34 lastIdentifier :: String, |
34 lastIdentifier :: String, |
35 lastType :: BaseType, |
35 lastType :: BaseType, |
36 stringConsts :: [(String, String)], |
36 stringConsts :: [(String, String)], |
37 uniqCounter :: Int, |
37 uniqCounter :: Int, |
38 toMangle :: Set.Set String, |
38 toMangle :: Set.Set String, |
|
39 currentUnit :: String, |
39 namespaces :: Map.Map String Records |
40 namespaces :: Map.Map String Records |
40 } |
41 } |
41 |
42 |
42 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty |
43 emptyState = RenderState Map.empty "" BTUnknown [] 0 Set.empty "" |
43 |
44 |
44 getUniq :: State RenderState Int |
45 getUniq :: State RenderState Int |
45 getUniq = do |
46 getUniq = do |
46 i <- gets uniqCounter |
47 i <- gets uniqCounter |
47 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
48 modify(\s -> s{uniqCounter = uniqCounter s + 1}) |
124 where |
125 where |
125 toNamespace :: Map.Map String Records -> PascalUnit -> Records |
126 toNamespace :: Map.Map String Records -> PascalUnit -> Records |
126 toNamespace nss (System tvs) = |
127 toNamespace nss (System tvs) = |
127 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
128 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
128 toNamespace _ (Program {}) = Map.empty |
129 toNamespace _ (Program {}) = Map.empty |
129 toNamespace nss (Unit _ interface _ _ _) = |
130 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
130 currentScope $ execState (interface2C interface) (emptyState nss) |
131 currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"} |
131 |
132 |
132 |
133 |
133 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
134 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
134 withState' f sf = do |
135 withState' f sf = do |
135 st <- liftM f get |
136 st <- liftM f get |
160 toCFiles ns p@(fn, pu) = do |
161 toCFiles ns p@(fn, pu) = do |
161 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
162 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
162 toCFiles' p |
163 toCFiles' p |
163 where |
164 where |
164 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
165 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
165 toCFiles' (fn, (Unit unitId interface implementation _ _)) = do |
166 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
166 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState |
167 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState{currentUnit = map toLower i ++ "_"} |
167 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
168 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
168 writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
169 writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
169 initialState = emptyState ns |
170 initialState = emptyState ns |
170 |
171 |
171 render2C :: RenderState -> State RenderState Doc -> String |
172 render2C :: RenderState -> State RenderState Doc -> String |
234 |
235 |
235 id2C :: InsertOption -> Identifier -> State RenderState Doc |
236 id2C :: InsertOption -> Identifier -> State RenderState Doc |
236 id2C IOInsert (Identifier i t) = do |
237 id2C IOInsert (Identifier i t) = do |
237 ns <- gets currentScope |
238 ns <- gets currentScope |
238 tom <- gets (Set.member n . toMangle) |
239 tom <- gets (Set.member n . toMangle) |
|
240 cu <- gets currentUnit |
239 let i' = case (t, tom) of |
241 let i' = case (t, tom) of |
240 (BTFunction p _, True) -> i ++ ('_' : show p) |
242 (BTFunction p _, True) -> cu ++ i ++ ('_' : show p) |
|
243 (BTFunction _ _, _) -> cu ++ i |
241 _ -> i |
244 _ -> i |
242 modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t)] (currentScope s), lastIdentifier = n}) |
245 modify (\s -> s{currentScope = Map.insertWith (++) n [(i', t)] (currentScope s), lastIdentifier = n}) |
243 return $ text i' |
246 return $ text i' |
244 where |
247 where |
245 n = map toLower i |
248 n = map toLower i |
730 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
733 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
731 r1 <- ref2C ref1 |
734 r1 <- ref2C ref1 |
732 t <- fromPointer (show ref1) =<< gets lastType |
735 t <- fromPointer (show ref1) =<< gets lastType |
733 r2 <- case t of |
736 r2 <- case t of |
734 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
737 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
735 BTUnit -> withLastIdNamespace $ ref2C ref2 |
738 BTUnit -> withLastIdNamespace $ ref2CF ref2 |
736 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
739 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
737 return $ |
740 return $ |
738 r1 <> text "->" <> r2 |
741 r1 <> text "->" <> r2 |
739 ref2C rf@(RecordField ref1 ref2) = do |
742 ref2C rf@(RecordField ref1 ref2) = do |
740 r1 <- ref2C ref1 |
743 r1 <- ref2C ref1 |
741 t <- gets lastType |
744 t <- gets lastType |
742 r2 <- case t of |
745 case t of |
743 -- BTFunctionReturn s (BTRecord rs) -> withRecordNamespace "" rs $ ref2C ref2 |
746 BTRecord rs -> do |
744 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
747 r2 <- withRecordNamespace "" rs $ ref2C ref2 |
745 BTUnit -> withLastIdNamespace $ ref2C ref2 |
748 return $ r1 <> text "." <> r2 |
|
749 BTUnit -> withLastIdNamespace $ ref2CF ref2 |
746 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
750 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf |
747 return $ |
|
748 r1 <> text "." <> r2 |
|
749 ref2C d@(Dereference ref) = do |
751 ref2C d@(Dereference ref) = do |
750 r <- ref2C ref |
752 r <- ref2C ref |
751 t <- fromPointer (show d) =<< gets lastType |
753 t <- fromPointer (show d) =<< gets lastType |
752 modify (\st -> st{lastType = t}) |
754 modify (\st -> st{lastType = t}) |
753 return $ (parens $ text "*" <> r) |
755 return $ (parens $ text "*" <> r) |