50 modify (Map.insert fileName a) |
50 modify (Map.insert fileName a) |
51 mapM_ f (usesFiles a) |
51 mapM_ f (usesFiles a) |
52 |
52 |
53 toCFiles :: (String, PascalUnit) -> IO () |
53 toCFiles :: (String, PascalUnit) -> IO () |
54 toCFiles (_, System) = return () |
54 toCFiles (_, System) = return () |
55 toCFiles (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render . pascal2C) p |
55 toCFiles p@(fn, pu) = do |
56 toCFiles (fn, (Unit _ interface implementation _ _)) = do |
56 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
57 writeFile (fn ++ ".h") $ (render . interface2C) interface |
57 toCFiles' p |
58 writeFile (fn ++ ".c") $ (render . implementation2C) implementation |
58 where |
|
59 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render . pascal2C) p |
|
60 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
|
61 writeFile (fn ++ ".h") $ (render . interface2C) interface |
|
62 writeFile (fn ++ ".c") $ (render . implementation2C) implementation |
59 |
63 |
60 usesFiles :: PascalUnit -> [String] |
64 usesFiles :: PascalUnit -> [String] |
61 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
65 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
62 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
66 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
63 |
67 |
69 $+$ |
73 $+$ |
70 implementation2C implementation |
74 implementation2C implementation |
71 pascal2C (Program _ implementation mainFunction) = |
75 pascal2C (Program _ implementation mainFunction) = |
72 implementation2C implementation |
76 implementation2C implementation |
73 $+$ |
77 $+$ |
74 tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") [] (Just (TypesAndVars [], mainFunction))) |
78 tvar2C True (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") [] (Just (TypesAndVars [], mainFunction))) |
75 |
79 |
76 |
80 |
77 interface2C :: Interface -> Doc |
81 interface2C :: Interface -> Doc |
78 interface2C (Interface uses tvars) = uses2C uses $+$ typesAndVars2C tvars |
82 interface2C (Interface uses tvars) = uses2C uses $+$ typesAndVars2C True tvars |
79 |
83 |
80 implementation2C :: Implementation -> Doc |
84 implementation2C :: Implementation -> Doc |
81 implementation2C (Implementation uses tvars) = uses2C uses $+$ typesAndVars2C tvars |
85 implementation2C (Implementation uses tvars) = uses2C uses $+$ typesAndVars2C True tvars |
82 |
86 |
83 |
87 |
84 typesAndVars2C :: TypesAndVars -> Doc |
88 typesAndVars2C :: Bool -> TypesAndVars -> Doc |
85 typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts |
89 typesAndVars2C b (TypesAndVars ts) = vcat $ map (tvar2C b) ts |
86 |
90 |
87 uses2C :: Uses -> Doc |
91 uses2C :: Uses -> Doc |
88 uses2C uses = vcat $ map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
92 uses2C uses = vcat $ map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
89 |
93 |
90 uses2List :: Uses -> [String] |
94 uses2List :: Uses -> [String] |
91 uses2List (Uses ids) = map (\(Identifier i) -> i) ids |
95 uses2List (Uses ids) = map (\(Identifier i) -> i) ids |
92 |
96 |
93 tvar2C :: TypeVarDeclaration -> Doc |
97 tvar2C :: Bool -> TypeVarDeclaration -> Doc |
94 tvar2C (FunctionDeclaration (Identifier name) returnType params Nothing) = |
98 tvar2C _ (FunctionDeclaration (Identifier name) returnType params Nothing) = |
95 type2C returnType <+> text name <> parens (hcat $ map tvar2C params) <> text ";" |
99 type2C returnType <+> text name <> parens (hcat $ map (tvar2C False) params) <> text ";" |
96 tvar2C (FunctionDeclaration (Identifier name) returnType params (Just (tvars, phrase))) = |
100 tvar2C True (FunctionDeclaration (Identifier name) returnType params (Just (tvars, phrase))) = |
97 type2C returnType <+> text name <> parens (hcat $ map tvar2C params) |
101 type2C returnType <+> text name <> parens (hcat $ map (tvar2C False) params) |
98 $+$ |
102 $+$ |
99 text "{" |
103 text "{" |
100 $+$ nest 4 ( |
104 $+$ nest 4 ( |
101 typesAndVars2C tvars |
105 typesAndVars2C False tvars |
102 $+$ |
106 $+$ |
103 phrase2C' phrase |
107 phrase2C' phrase |
104 ) |
108 ) |
105 $+$ |
109 $+$ |
106 text "}" |
110 text "}" |
107 where |
111 where |
108 phrase2C' (Phrases p) = vcat $ map phrase2C p |
112 phrase2C' (Phrases p) = vcat $ map phrase2C p |
109 phrase2C' p = phrase2C p |
113 phrase2C' p = phrase2C p |
110 tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";" |
114 tvar2C False (FunctionDeclaration (Identifier name) _ _ _) = error $ "nested functions not allowed: " ++ name |
111 tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = |
115 tvar2C _ (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";" |
|
116 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = |
112 if isConst then text "const" else empty |
117 if isConst then text "const" else empty |
113 <+> |
118 <+> |
114 type2C t |
119 type2C t |
115 <+> |
120 <+> |
116 (hsep . punctuate (char ',') . map (\(Identifier i) -> text i) $ ids) |
121 (hsep . punctuate (char ',') . map (\(Identifier i) -> text i) $ ids) |
119 <> |
124 <> |
120 text ";" |
125 text ";" |
121 where |
126 where |
122 initExpr Nothing = empty |
127 initExpr Nothing = empty |
123 initExpr (Just e) = text "=" <+> initExpr2C e |
128 initExpr (Just e) = text "=" <+> initExpr2C e |
124 tvar2C (OperatorDeclaration op _ ret params body) = |
129 tvar2C f (OperatorDeclaration op _ ret params body) = |
125 tvar2C (FunctionDeclaration (Identifier "<op>") ret params body) |
130 tvar2C f (FunctionDeclaration (Identifier $ "<op " ++ op ++ ">") ret params body) |
126 |
131 |
127 initExpr2C :: InitExpression -> Doc |
132 initExpr2C :: InitExpression -> Doc |
128 initExpr2C (InitBinOp op expr1 expr2) = parens $ (initExpr2C expr1) <+> op2C op <+> (initExpr2C expr2) |
133 initExpr2C (InitBinOp op expr1 expr2) = parens $ (initExpr2C expr1) <+> op2C op <+> (initExpr2C expr2) |
129 initExpr2C (InitNumber s) = text s |
134 initExpr2C (InitNumber s) = text s |
130 initExpr2C (InitFloat s) = text s |
135 initExpr2C (InitFloat s) = text s |
138 type2C :: TypeDecl -> Doc |
143 type2C :: TypeDecl -> Doc |
139 type2C UnknownType = text "void" |
144 type2C UnknownType = text "void" |
140 type2C (String l) = text $ "string" ++ show l |
145 type2C (String l) = text $ "string" ++ show l |
141 type2C (SimpleType (Identifier i)) = text i |
146 type2C (SimpleType (Identifier i)) = text i |
142 type2C (PointerTo t) = type2C t <> text "*" |
147 type2C (PointerTo t) = type2C t <> text "*" |
143 type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}" |
148 type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map (tvar2C False) $ tvs) $+$ text "}" |
144 type2C (RangeType r) = text "<<range type>>" |
149 type2C (RangeType r) = text "<<range type>>" |
145 type2C (Sequence ids) = text "<<sequence type>>" |
150 type2C (Sequence ids) = text "<<sequence type>>" |
146 type2C (ArrayDecl r t) = text "<<array type>>" |
151 type2C (ArrayDecl r t) = text "<<array type>>" |
147 type2C (Set t) = text "<<set>>" |
152 type2C (Set t) = text "<<set>>" |
148 type2C (FunctionType returnType params) = text "<<function>>" |
153 type2C (FunctionType returnType params) = text "<<function>>" |