15 import Data.List (find) |
15 import Data.List (find) |
16 |
16 |
17 import PascalParser |
17 import PascalParser |
18 import PascalUnitSyntaxTree |
18 import PascalUnitSyntaxTree |
19 |
19 |
|
20 |
|
21 data InsertOption = |
|
22 IOInsert |
|
23 | IOLookup |
|
24 | IODeferred |
20 |
25 |
21 type Record = (String, (String, BaseType)) |
26 type Record = (String, (String, BaseType)) |
22 data RenderState = RenderState |
27 data RenderState = RenderState |
23 { |
28 { |
24 currentScope :: [Record], |
29 currentScope :: [Record], |
120 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
125 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
121 |
126 |
122 uses2C :: Uses -> State RenderState Doc |
127 uses2C :: Uses -> State RenderState Doc |
123 uses2C uses@(Uses unitIds) = do |
128 uses2C uses@(Uses unitIds) = do |
124 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
129 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
125 mapM_ (id2C True) unitIds |
130 mapM_ (id2C IOInsert) unitIds |
126 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
131 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
127 where |
132 where |
128 injectNamespace (Identifier i _) = do |
133 injectNamespace (Identifier i _) = do |
129 getNS <- gets (flip Map.lookup . namespaces) |
134 getNS <- gets (flip Map.lookup . namespaces) |
130 let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
135 let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
132 |
137 |
133 uses2List :: Uses -> [String] |
138 uses2List :: Uses -> [String] |
134 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
139 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
135 |
140 |
136 |
141 |
137 id2C :: Bool -> Identifier -> State RenderState Doc |
142 id2C :: InsertOption -> Identifier -> State RenderState Doc |
138 id2C True (Identifier i t) = do |
143 id2C IOInsert (Identifier i t) = do |
139 modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
144 modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
140 return $ text i |
145 return $ text i |
141 id2C False (Identifier i t) = do |
146 id2C IOLookup (Identifier i t) = do |
142 let i' = map toLower i |
147 let i' = map toLower i |
143 v <- gets $ find (\(a, _) -> a == i') . currentScope |
148 v <- gets $ find (\(a, _) -> a == i') . currentScope |
144 ns <- gets currentScope |
149 ns <- gets currentScope |
145 modify (\s -> s{lastType = t}) |
150 modify (\s -> s{lastType = t}) |
146 if isNothing v then |
151 if isNothing v then |
147 error $ "Not defined: '" ++ i' ++ "'\n" ++ show ns |
152 error $ "Not defined: '" ++ i' ++ "'\n" -- ++ show ns |
148 else |
153 else |
|
154 return . text . fst . snd . fromJust $ v |
|
155 id2C IODeferred (Identifier i t) = do |
|
156 let i' = map toLower i |
|
157 v <- gets $ find (\(a, _) -> a == i') . currentScope |
|
158 if (isNothing v) then |
|
159 do |
|
160 modify (\s -> s{currentScope = (i', (i, t)) : currentScope s}) |
|
161 return $ text i |
|
162 else |
149 return . text . fst . snd . fromJust $ v |
163 return . text . fst . snd . fromJust $ v |
150 |
164 |
151 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
165 id2CTyped :: TypeDecl -> Identifier -> State RenderState Doc |
152 id2CTyped t (Identifier i _) = do |
166 id2CTyped t (Identifier i _) = do |
153 tb <- resolveType t |
167 tb <- resolveType t |
154 id2C True (Identifier i tb) |
168 case tb of |
155 {--id2CTyped BTUnknown i = do |
169 BTUnknown -> do |
156 ns <- gets currentScope |
170 ns <- gets currentScope |
157 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\n" ++ show ns |
171 error $ "id2CTyped: type BTUnknown for " ++ show i ++ "\ntype: " ++ show t ++ "\nnamespace: " ++ show ns |
158 id2CTyped bt (Identifier i _) = id2C True (Identifier i bt)--} |
172 _ -> id2C IOInsert (Identifier i tb) |
159 |
173 |
160 |
174 |
161 resolveType :: TypeDecl -> State RenderState BaseType |
175 resolveType :: TypeDecl -> State RenderState BaseType |
162 resolveType st@(SimpleType (Identifier i _)) = do |
176 resolveType st@(SimpleType (Identifier i _)) = do |
163 let i' = map toLower i |
177 let i' = map toLower i |
192 |
206 |
193 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
207 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
194 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
208 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
195 t <- type2C returnType |
209 t <- type2C returnType |
196 p <- liftM hcat $ mapM (tvar2C False) params |
210 p <- liftM hcat $ mapM (tvar2C False) params |
197 n <- id2C True name |
211 n <- id2C IOInsert name |
198 return $ t <+> n <> parens p <> text ";" |
212 return $ t <+> n <> parens p <> text ";" |
199 |
213 |
200 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
214 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
201 t <- type2C returnType |
215 t <- type2C returnType |
202 p <- liftM hcat $ mapM (tvar2C False) params |
216 p <- liftM hcat $ mapM (tvar2C False) params |
203 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
217 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
204 n <- id2C True name |
218 n <- id2C IOInsert name |
205 return $ |
219 return $ |
206 t <+> n <> parens p |
220 t <+> n <> parens p |
207 $+$ |
221 $+$ |
208 text "{" |
222 text "{" |
209 $+$ |
223 $+$ |
246 return $ parens $ e1 <+> o <+> e2 |
260 return $ parens $ e1 <+> o <+> e2 |
247 initExpr2C (InitNumber s) = return $ text s |
261 initExpr2C (InitNumber s) = return $ text s |
248 initExpr2C (InitFloat s) = return $ text s |
262 initExpr2C (InitFloat s) = return $ text s |
249 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
263 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
250 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
264 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
251 initExpr2C (InitReference i) = id2C False i |
265 initExpr2C (InitReference i) = id2C IOLookup i |
252 initExpr2C _ = return $ text "<<expression>>" |
266 initExpr2C _ = return $ text "<<expression>>" |
253 |
267 |
254 |
268 |
255 type2C :: TypeDecl -> State RenderState Doc |
269 type2C :: TypeDecl -> State RenderState Doc |
256 type2C UnknownType = return $ text "void" |
270 type2C UnknownType = return $ text "void" |
257 type2C (String l) = return $ text $ "string" ++ show l |
271 type2C (String l) = return $ text $ "string" ++ show l |
258 type2C (SimpleType i) = id2C False i |
272 type2C (SimpleType i) = id2C IOLookup i |
259 type2C (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C True i |
273 type2C (PointerTo (SimpleType i)) = liftM (<> text "*") $ id2C IODeferred i |
260 type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
274 type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
261 type2C (RecordType tvs union) = do |
275 type2C (RecordType tvs union) = do |
262 t <- mapM (tvar2C False) tvs |
276 t <- mapM (tvar2C False) tvs |
263 return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
277 return $ text "{" $+$ (nest 4 . vcat $ t) $+$ text "}" |
264 type2C (RangeType r) = return $ text "<<range type>>" |
278 type2C (RangeType r) = return $ text "<<range type>>" |
265 type2C (Sequence ids) = do |
279 type2C (Sequence ids) = do |
266 mapM_ (id2C True) ids |
280 mapM_ (id2C IOInsert) ids |
267 return $ text "<<sequence type>>" |
281 return $ text "<<sequence type>>" |
268 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
282 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
269 type2C (Set t) = return $ text "<<set>>" |
283 type2C (Set t) = return $ text "<<set>>" |
270 type2C (FunctionType returnType params) = return $ text "<<function>>" |
284 type2C (FunctionType returnType params) = return $ text "<<function>>" |
271 type2C (DeriveType _) = return $ text "<<type derived from constant literal>>" |
285 type2C (DeriveType _) = return $ text "<<type derived from constant literal>>" |
312 phrase2C (WithBlock ref p) = do |
326 phrase2C (WithBlock ref p) = do |
313 r <- ref2C ref |
327 r <- ref2C ref |
314 ph <- phrase2C $ wrapPhrase p |
328 ph <- phrase2C $ wrapPhrase p |
315 return $ text "namespace" <> parens r $$ ph |
329 return $ text "namespace" <> parens r $$ ph |
316 phrase2C (ForCycle i' e1' e2' p) = do |
330 phrase2C (ForCycle i' e1' e2' p) = do |
317 i <- id2C False i' |
331 i <- id2C IOLookup i' |
318 e1 <- expr2C e1' |
332 e1 <- expr2C e1' |
319 e2 <- expr2C e2' |
333 e2 <- expr2C e2' |
320 ph <- phrase2C (wrapPhrase p) |
334 ph <- phrase2C (wrapPhrase p) |
321 return $ |
335 return $ |
322 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
336 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
358 ref2C :: Reference -> State RenderState Doc |
372 ref2C :: Reference -> State RenderState Doc |
359 ref2C (ArrayElement exprs ref) = do |
373 ref2C (ArrayElement exprs ref) = do |
360 r <- ref2C ref |
374 r <- ref2C ref |
361 es <- mapM expr2C exprs |
375 es <- mapM expr2C exprs |
362 return $ r <> (brackets . hcat) (punctuate comma es) |
376 return $ r <> (brackets . hcat) (punctuate comma es) |
363 ref2C (SimpleReference name) = id2C False name |
377 ref2C (SimpleReference name) = id2C IOLookup name |
364 ref2C (RecordField (Dereference ref1) ref2) = do |
378 ref2C (RecordField (Dereference ref1) ref2) = do |
365 r1 <- ref2C ref1 |
379 r1 <- ref2C ref1 |
366 r2 <- ref2C ref2 |
380 r2 <- ref2C ref2 |
367 return $ |
381 return $ |
368 r1 <> text "->" <> r2 |
382 r1 <> text "->" <> r2 |
383 r <> parens (hsep . punctuate (char ',') $ ps) |
397 r <> parens (hsep . punctuate (char ',') $ ps) |
384 ref2C (Address ref) = do |
398 ref2C (Address ref) = do |
385 r <- ref2C ref |
399 r <- ref2C ref |
386 return $ text "&" <> parens r |
400 return $ text "&" <> parens r |
387 ref2C (TypeCast t' expr) = do |
401 ref2C (TypeCast t' expr) = do |
388 t <- id2C False t' |
402 t <- id2C IOLookup t' |
389 e <- expr2C expr |
403 e <- expr2C expr |
390 return $ parens t <> e |
404 return $ parens t <> e |
391 ref2C (RefExpression expr) = expr2C expr |
405 ref2C (RefExpression expr) = expr2C expr |
392 |
406 |
393 |
407 |