62 renderCFiles units = do |
62 renderCFiles units = do |
63 let u = Map.toList units |
63 let u = Map.toList units |
64 let ns = Map.map toNamespace units |
64 let ns = Map.map toNamespace units |
65 mapM_ (toCFiles ns) u |
65 mapM_ (toCFiles ns) u |
66 where |
66 where |
67 toNamespace :: PascalUnit -> [(String, String)] |
67 toNamespace :: PascalUnit -> [(String, String)] |
68 toNamespace = concatMap tv2id . extractTVs |
68 toNamespace = concatMap tv2id . extractTVs |
69 extractTVs (System tv) = tv |
69 |
70 extractTVs (Program {}) = [] |
70 extractTVs (System tv) = tv |
71 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
71 extractTVs (Program {}) = [] |
72 tv2id :: TypeVarDeclaration -> [(String, String)] |
72 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
73 tv2id (TypeDeclaration (Identifier i _) _) = [(map toLower i, i)] |
73 |
74 tv2id (VarDeclaration _ (ids, _) _) = map (\(Identifier i _) -> (map toLower i, i)) ids |
74 tv2id :: TypeVarDeclaration -> [(String, String)] |
75 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [(map toLower i, i)] |
75 tv2id (TypeDeclaration (Identifier i _) _) = [(map toLower i, i)] |
76 tv2id (OperatorDeclaration i _ _ _ _) = [(map toLower i, i)] |
76 tv2id (VarDeclaration _ (ids, _) _) = map (\(Identifier i _) -> (map toLower i, i)) ids |
|
77 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [(map toLower i, i)] |
|
78 tv2id (OperatorDeclaration i _ _ _ _) = [(map toLower i, i)] |
77 |
79 |
78 |
80 |
79 toCFiles :: Map.Map String [(String, String)] -> (String, PascalUnit) -> IO () |
81 toCFiles :: Map.Map String [(String, String)] -> (String, PascalUnit) -> IO () |
80 toCFiles _ (_, System _) = return () |
82 toCFiles _ (_, System _) = return () |
81 toCFiles ns p@(fn, pu) = do |
83 toCFiles ns p@(fn, pu) = do |
122 uses2C :: Uses -> State RenderState Doc |
124 uses2C :: Uses -> State RenderState Doc |
123 uses2C uses@(Uses unitIds) = do |
125 uses2C uses@(Uses unitIds) = do |
124 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
126 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
125 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
127 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
126 where |
128 where |
127 injectNamespace (Identifier i _) = do |
129 injectNamespace (Identifier i _) = do |
128 getNS <- gets (flip Map.lookup . namespaces) |
130 getNS <- gets (flip Map.lookup . namespaces) |
129 let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
131 let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
130 modify (\s -> s{currentScope = f $ currentScope s}) |
132 modify (\s -> s{currentScope = f $ currentScope s}) |
131 |
133 |
132 uses2List :: Uses -> [String] |
134 uses2List :: Uses -> [String] |
151 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
153 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
152 t <- type2C returnType |
154 t <- type2C returnType |
153 p <- liftM hcat $ mapM (tvar2C False) params |
155 p <- liftM hcat $ mapM (tvar2C False) params |
154 n <- id2C True name |
156 n <- id2C True name |
155 return $ t <+> n <> parens p <> text ";" |
157 return $ t <+> n <> parens p <> text ";" |
|
158 |
156 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
159 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
157 t <- type2C returnType |
160 t <- type2C returnType |
158 p <- liftM hcat $ mapM (tvar2C False) params |
161 p <- liftM hcat $ mapM (tvar2C False) params |
159 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
162 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
160 n <- id2C True name |
163 n <- id2C True name |
167 $+$ |
170 $+$ |
168 text "}" |
171 text "}" |
169 where |
172 where |
170 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
173 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
171 phrase2C' p = phrase2C p |
174 phrase2C' p = phrase2C p |
|
175 |
172 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
176 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
173 tvar2C _ (TypeDeclaration i' t) = do |
177 tvar2C _ (TypeDeclaration i' t) = do |
174 tp <- type2C t |
178 tp <- type2C t |
175 i <- id2C True i' |
179 i <- id2C True i' |
176 return $ text "type" <+> i <+> tp <> text ";" |
180 return $ text "type" <+> i <+> tp <> text ";" |
|
181 |
177 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
182 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
178 t' <- type2C t |
183 t' <- type2C t |
179 i <- mapM (id2C True) ids |
184 i <- mapM (id2C True) ids |
180 ie <- initExpr mInitExpr |
185 ie <- initExpr mInitExpr |
181 return $ if isConst then text "const" else empty |
186 return $ if isConst then text "const" else empty |
184 <+> ie |
189 <+> ie |
185 <> text ";" |
190 <> text ";" |
186 where |
191 where |
187 initExpr Nothing = return $ empty |
192 initExpr Nothing = return $ empty |
188 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
193 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
|
194 |
189 tvar2C f (OperatorDeclaration op _ ret params body) = |
195 tvar2C f (OperatorDeclaration op _ ret params body) = |
190 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
196 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
191 |
197 |
|
198 |
192 initExpr2C :: InitExpression -> State RenderState Doc |
199 initExpr2C :: InitExpression -> State RenderState Doc |
193 initExpr2C (InitBinOp op expr1 expr2) = do |
200 initExpr2C (InitBinOp op expr1 expr2) = do |
194 e1 <- initExpr2C expr1 |
201 e1 <- initExpr2C expr1 |
195 e2 <- initExpr2C expr2 |
202 e2 <- initExpr2C expr2 |
196 o <- op2C op |
203 o <- op2C op |