1 module Pas2C where |
1 module Pas2C where |
2 |
2 |
3 import Text.PrettyPrint.HughesPJ |
3 import Text.PrettyPrint.HughesPJ |
4 import Data.Maybe |
4 import Data.Maybe |
5 import Data.Char |
5 import Data.Char |
6 import Text.Parsec.Prim |
6 import Text.Parsec.Prim hiding (State) |
7 import Control.Monad.State |
7 import Control.Monad.State |
8 import System.IO |
8 import System.IO |
9 import System.Directory |
9 import System.Directory |
10 import Control.Monad.IO.Class |
10 import Control.Monad.IO.Class |
11 import PascalPreprocessor |
11 import PascalPreprocessor |
12 import Control.Exception |
12 import Control.Exception |
13 import System.IO.Error |
13 import System.IO.Error |
14 import qualified Data.Map as Map |
14 import qualified Data.Map as Map |
15 import Control.Monad.Reader |
15 |
16 |
16 |
17 import PascalParser |
17 import PascalParser |
18 import PascalUnitSyntaxTree |
18 import PascalUnitSyntaxTree |
19 |
19 |
20 pas2C :: String -> IO () |
20 pas2C :: String -> IO () |
63 writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation |
63 writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation |
64 |
64 |
65 system :: [(String, String)] |
65 system :: [(String, String)] |
66 system = [] |
66 system = [] |
67 |
67 |
68 render2C = render . flip runReader system |
68 render2C = render . flip evalState system |
69 |
69 |
70 usesFiles :: PascalUnit -> [String] |
70 usesFiles :: PascalUnit -> [String] |
71 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
71 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
72 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
72 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
73 |
73 |
74 |
74 |
75 |
75 |
76 pascal2C :: PascalUnit -> Reader a Doc |
76 pascal2C :: PascalUnit -> State a Doc |
77 pascal2C (Unit _ interface implementation init fin) = |
77 pascal2C (Unit _ interface implementation init fin) = |
78 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
78 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
79 |
79 |
80 pascal2C (Program _ implementation mainFunction) = do |
80 pascal2C (Program _ implementation mainFunction) = do |
81 impl <- implementation2C implementation |
81 impl <- implementation2C implementation |
83 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
83 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
84 return $ impl $+$ main |
84 return $ impl $+$ main |
85 |
85 |
86 |
86 |
87 |
87 |
88 interface2C :: Interface -> Reader a Doc |
88 interface2C :: Interface -> State a Doc |
89 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
89 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
90 |
90 |
91 implementation2C :: Implementation -> Reader a Doc |
91 implementation2C :: Implementation -> State a Doc |
92 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
92 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
93 |
93 |
94 |
94 |
95 typesAndVars2C :: Bool -> TypesAndVars -> Reader a Doc |
95 typesAndVars2C :: Bool -> TypesAndVars -> State a Doc |
96 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
96 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
97 |
97 |
98 uses2C :: Uses -> Reader a Doc |
98 uses2C :: Uses -> State a Doc |
99 uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
99 uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
100 |
100 |
101 uses2List :: Uses -> [String] |
101 uses2List :: Uses -> [String] |
102 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
102 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
103 |
103 |
104 id2C :: Bool -> Identifier -> Reader a Doc |
104 id2C :: Bool -> Identifier -> State a Doc |
105 id2C isDecl (Identifier i _) = return $ text i |
105 id2C True (Identifier i _) = return $ text i |
106 |
106 |
107 tvar2C :: Bool -> TypeVarDeclaration -> Reader a Doc |
107 tvar2C :: Bool -> TypeVarDeclaration -> State a Doc |
108 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
108 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
109 t <- type2C returnType |
109 t <- type2C returnType |
110 p <- liftM hcat $ mapM (tvar2C False) params |
110 p <- liftM hcat $ mapM (tvar2C False) params |
111 n <- id2C True name |
111 n <- id2C True name |
112 return $ t <+> n <> parens p <> text ";" |
112 return $ t <+> n <> parens p <> text ";" |
143 initExpr Nothing = return $ empty |
143 initExpr Nothing = return $ empty |
144 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
144 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
145 tvar2C f (OperatorDeclaration op _ ret params body) = |
145 tvar2C f (OperatorDeclaration op _ ret params body) = |
146 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
146 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
147 |
147 |
148 initExpr2C :: InitExpression -> Reader a Doc |
148 initExpr2C :: InitExpression -> State a Doc |
149 initExpr2C (InitBinOp op expr1 expr2) = do |
149 initExpr2C (InitBinOp op expr1 expr2) = do |
150 e1 <- initExpr2C expr1 |
150 e1 <- initExpr2C expr1 |
151 e2 <- initExpr2C expr2 |
151 e2 <- initExpr2C expr2 |
152 o <- op2C op |
152 o <- op2C op |
153 return $ parens $ e1 <+> o <+> e2 |
153 return $ parens $ e1 <+> o <+> e2 |
157 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
157 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
158 initExpr2C (InitReference i) = id2C False i |
158 initExpr2C (InitReference i) = id2C False i |
159 initExpr2C _ = return $ text "<<expression>>" |
159 initExpr2C _ = return $ text "<<expression>>" |
160 |
160 |
161 |
161 |
162 type2C :: TypeDecl -> Reader a Doc |
162 type2C :: TypeDecl -> State a Doc |
163 type2C UnknownType = return $ text "void" |
163 type2C UnknownType = return $ text "void" |
164 type2C (String l) = return $ text $ "string" ++ show l |
164 type2C (String l) = return $ text $ "string" ++ show l |
165 type2C (SimpleType i) = id2C True i |
165 type2C (SimpleType i) = id2C True i |
166 type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
166 type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
167 type2C (RecordType tvs union) = do |
167 type2C (RecordType tvs union) = do |
171 type2C (Sequence ids) = return $ text "<<sequence type>>" |
171 type2C (Sequence ids) = return $ text "<<sequence type>>" |
172 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
172 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
173 type2C (Set t) = return $ text "<<set>>" |
173 type2C (Set t) = return $ text "<<set>>" |
174 type2C (FunctionType returnType params) = return $ text "<<function>>" |
174 type2C (FunctionType returnType params) = return $ text "<<function>>" |
175 |
175 |
176 phrase2C :: Phrase -> Reader a Doc |
176 phrase2C :: Phrase -> State a Doc |
177 phrase2C (Phrases p) = do |
177 phrase2C (Phrases p) = do |
178 ps <- mapM phrase2C p |
178 ps <- mapM phrase2C p |
179 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
179 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
180 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
180 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
181 phrase2C (ProcCall ref params) = do |
181 phrase2C (ProcCall ref params) = do |
204 e <- expr2C expr |
204 e <- expr2C expr |
205 cs <- mapM case2C cases |
205 cs <- mapM case2C cases |
206 return $ |
206 return $ |
207 text "switch" <> parens e <> text "of" $+$ (nest 4 . vcat) cs |
207 text "switch" <> parens e <> text "of" $+$ (nest 4 . vcat) cs |
208 where |
208 where |
209 case2C :: ([InitExpression], Phrase) -> Reader a Doc |
209 case2C :: ([InitExpression], Phrase) -> State a Doc |
210 case2C (e, p) = do |
210 case2C (e, p) = do |
211 ie <- mapM initExpr2C e |
211 ie <- mapM initExpr2C e |
212 ph <- phrase2C p |
212 ph <- phrase2C p |
213 return $ |
213 return $ |
214 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
214 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
234 |
234 |
235 wrapPhrase p@(Phrases _) = p |
235 wrapPhrase p@(Phrases _) = p |
236 wrapPhrase p = Phrases [p] |
236 wrapPhrase p = Phrases [p] |
237 |
237 |
238 |
238 |
239 expr2C :: Expression -> Reader a Doc |
239 expr2C :: Expression -> State a Doc |
240 expr2C (Expression s) = return $ text s |
240 expr2C (Expression s) = return $ text s |
241 expr2C (BinOp op expr1 expr2) = do |
241 expr2C (BinOp op expr1 expr2) = do |
242 e1 <- expr2C expr1 |
242 e1 <- expr2C expr1 |
243 e2 <- expr2C expr2 |
243 e2 <- expr2C expr2 |
244 o <- op2C op |
244 o <- op2C op |
256 return $ |
256 return $ |
257 r <> parens (hsep . punctuate (char ',') $ ps) |
257 r <> parens (hsep . punctuate (char ',') $ ps) |
258 expr2C _ = return $ text "<<expression>>" |
258 expr2C _ = return $ text "<<expression>>" |
259 |
259 |
260 |
260 |
261 ref2C :: Reference -> Reader a Doc |
261 ref2C :: Reference -> State a Doc |
262 ref2C (ArrayElement exprs ref) = do |
262 ref2C (ArrayElement exprs ref) = do |
263 r <- ref2C ref |
263 r <- ref2C ref |
264 es <- mapM expr2C exprs |
264 es <- mapM expr2C exprs |
265 return $ r <> (brackets . hcat) (punctuate comma es) |
265 return $ r <> (brackets . hcat) (punctuate comma es) |
266 ref2C (SimpleReference name) = id2C False name |
266 ref2C (SimpleReference name) = id2C False name |
288 e <- expr2C expr |
288 e <- expr2C expr |
289 return $ parens t <> e |
289 return $ parens t <> e |
290 ref2C (RefExpression expr) = expr2C expr |
290 ref2C (RefExpression expr) = expr2C expr |
291 |
291 |
292 |
292 |
293 op2C :: String -> Reader a Doc |
293 op2C :: String -> State a Doc |
294 op2C "or" = return $ text "|" |
294 op2C "or" = return $ text "|" |
295 op2C "and" = return $ text "&" |
295 op2C "and" = return $ text "&" |
296 op2C "not" = return $ text "!" |
296 op2C "not" = return $ text "!" |
297 op2C "xor" = return $ text "^" |
297 op2C "xor" = return $ text "^" |
298 op2C "div" = return $ text "/" |
298 op2C "div" = return $ text "/" |