29 currentScope :: [Record], |
29 currentScope :: [Record], |
30 lastIdentifier :: String, |
30 lastIdentifier :: String, |
31 lastType :: BaseType, |
31 lastType :: BaseType, |
32 namespaces :: Map.Map String [Record] |
32 namespaces :: Map.Map String [Record] |
33 } |
33 } |
|
34 |
|
35 emptyState = RenderState [] "" BTUnknown |
34 |
36 |
35 docToLower :: Doc -> Doc |
37 docToLower :: Doc -> Doc |
36 docToLower = text . map toLower . render |
38 docToLower = text . map toLower . render |
37 |
39 |
38 pas2C :: String -> IO () |
40 pas2C :: String -> IO () |
76 let nss = Map.map (toNamespace nss) units |
78 let nss = Map.map (toNamespace nss) units |
77 mapM_ (toCFiles nss) u |
79 mapM_ (toCFiles nss) u |
78 where |
80 where |
79 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
81 toNamespace :: Map.Map String [Record] -> PascalUnit -> [Record] |
80 toNamespace nss (System tvs) = |
82 toNamespace nss (System tvs) = |
81 currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] "" BTUnknown nss) |
83 currentScope $ execState (mapM_ (tvar2C True) tvs) (emptyState nss) |
82 toNamespace _ (Program {}) = [] |
84 toNamespace _ (Program {}) = [] |
83 toNamespace nss (Unit _ interface _ _ _) = |
85 toNamespace nss (Unit _ interface _ _ _) = |
84 currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss) |
86 currentScope $ execState (interface2C interface) (emptyState nss) |
85 |
87 |
86 |
88 |
87 withState' :: (a -> a) -> State a b -> State a b |
89 withState' :: (a -> a) -> State a b -> State a b |
88 withState' f s = do |
90 withState' f s = do |
89 st <- gets id |
91 st <- liftM f get |
90 return $ evalState s (f st) |
92 return $ evalState s st |
91 |
93 |
92 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
94 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
93 withLastIdNamespace f = do |
95 withLastIdNamespace f = do |
94 li <- gets lastIdentifier |
96 li <- gets lastIdentifier |
95 nss <- gets namespaces |
97 nss <- gets namespaces |
110 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
112 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
111 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
113 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
112 let (a, s) = runState (interface2C interface) initialState |
114 let (a, s) = runState (interface2C interface) initialState |
113 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
115 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
114 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
116 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
115 initialState = RenderState [] "" BTUnknown ns |
117 initialState = emptyState ns |
116 |
118 |
117 render2C :: RenderState -> State RenderState Doc -> String |
119 render2C :: RenderState -> State RenderState Doc -> String |
118 render2C a = render . flip evalState a |
120 render2C a = render . flip evalState a |
119 |
121 |
120 usesFiles :: PascalUnit -> [String] |
122 usesFiles :: PascalUnit -> [String] |
163 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
165 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
164 |
166 |
165 |
167 |
166 id2C :: InsertOption -> Identifier -> State RenderState Doc |
168 id2C :: InsertOption -> Identifier -> State RenderState Doc |
167 id2C IOInsert (Identifier i t) = do |
169 id2C IOInsert (Identifier i t) = do |
168 modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
170 modify (\s -> s{currentScope = (n, (i, t)) : currentScope s, lastIdentifier = n}) |
169 return $ text i |
171 return $ text i |
|
172 where |
|
173 n = map toLower i |
170 id2C IOLookup (Identifier i t) = do |
174 id2C IOLookup (Identifier i t) = do |
171 let i' = map toLower i |
175 let i' = map toLower i |
172 v <- gets $ find (\(a, _) -> a == i') . currentScope |
176 v <- gets $ find (\(a, _) -> a == i') . currentScope |
173 ns <- gets currentScope |
177 ns <- gets currentScope |
174 if isNothing v then |
178 if isNothing v then |
256 t <- type2C returnType |
260 t <- type2C returnType |
257 p <- liftM hcat $ mapM (tvar2C False) params |
261 p <- liftM hcat $ mapM (tvar2C False) params |
258 n <- id2C IOInsert name |
262 n <- id2C IOInsert name |
259 return $ t <+> n <> parens p <> text ";" |
263 return $ t <+> n <> parens p <> text ";" |
260 |
264 |
261 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
265 tvar2C True (FunctionDeclaration (Identifier i _) returnType params (Just (tvars, phrase))) = do |
262 t <- type2C returnType |
266 t <- type2C returnType |
263 (p, ph) <- withState' id $ do |
267 t'<- gets lastType |
|
268 n <- id2C IOInsert (Identifier i (BTFunction t')) |
|
269 (p, ph) <- withState' (\st -> st{currentScope = (lastIdentifier st, (lastIdentifier st ++ "_result", t')) : currentScope st}) $ do |
264 p <- liftM hcat $ mapM (tvar2C False) params |
270 p <- liftM hcat $ mapM (tvar2C False) params |
265 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
271 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
266 return (p, ph) |
272 return (p, ph) |
267 n <- id2C IOInsert name |
|
268 let res = docToLower $ n <> text "_result" |
273 let res = docToLower $ n <> text "_result" |
269 let phrasesBlock = case returnType of |
274 let phrasesBlock = case returnType of |
270 VoidType -> ph |
275 VoidType -> ph |
271 _ -> t <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
276 _ -> t <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi |
272 return $ |
277 return $ |
299 <> text ";" |
304 <> text ";" |
300 where |
305 where |
301 initExpr Nothing = return $ empty |
306 initExpr Nothing = return $ empty |
302 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
307 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
303 |
308 |
304 tvar2C f (OperatorDeclaration op _ ret params body) = |
309 tvar2C f (OperatorDeclaration op i ret params body) = |
305 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") BTUnknown) ret params body) |
310 tvar2C f (FunctionDeclaration i ret params body) |
306 |
311 |
307 |
312 |
308 initExpr2C :: InitExpression -> State RenderState Doc |
313 initExpr2C :: InitExpression -> State RenderState Doc |
309 initExpr2C (InitBinOp op expr1 expr2) = do |
314 initExpr2C (InitBinOp op expr1 expr2) = do |
310 e1 <- initExpr2C expr1 |
315 e1 <- initExpr2C expr1 |