78 currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] "" BTUnknown nss) |
78 currentScope $ execState (mapM_ (tvar2C True) tvs) (RenderState [] "" BTUnknown nss) |
79 toNamespace _ (Program {}) = [] |
79 toNamespace _ (Program {}) = [] |
80 toNamespace nss (Unit _ interface _ _ _) = |
80 toNamespace nss (Unit _ interface _ _ _) = |
81 currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss) |
81 currentScope $ execState (interface2C interface) (RenderState [] "" BTUnknown nss) |
82 |
82 |
83 |
83 |
|
84 withState' :: (a -> a) -> State a b -> State a b |
|
85 withState' f s = do |
|
86 st <- gets id |
|
87 return $ evalState s (f st) |
|
88 |
84 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
89 withLastIdNamespace :: State RenderState Doc -> State RenderState Doc |
85 withLastIdNamespace f = do |
90 withLastIdNamespace f = do |
86 li <- gets lastIdentifier |
91 li <- gets lastIdentifier |
87 nss <- gets namespaces |
92 nss <- gets namespaces |
88 st <- gets id |
93 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
89 error $ show $ Map.keys nss |
94 |
90 return $ evalState f st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)} |
95 withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
|
96 withRecordNamespace recs = withState' f |
|
97 where |
|
98 f st = st{currentScope = records ++ currentScope st} |
|
99 records = map (\(a, b) -> (map toLower a, (a, b))) recs |
91 |
100 |
92 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
101 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
93 toCFiles _ (_, System _) = return () |
102 toCFiles _ (_, System _) = return () |
94 toCFiles ns p@(fn, pu) = do |
103 toCFiles ns p@(fn, pu) = do |
95 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
104 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
194 f "boolean" = BTBool |
203 f "boolean" = BTBool |
195 f "float" = BTFloat |
204 f "float" = BTFloat |
196 f "char" = BTChar |
205 f "char" = BTChar |
197 f "string" = BTString |
206 f "string" = BTString |
198 f _ = error $ "Unknown system type: " ++ show st |
207 f _ = error $ "Unknown system type: " ++ show st |
199 resolveType (PointerTo t) = return $ BTPointerTo BTUnknown -- can't resolveType for t here |
208 resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i) |
|
209 resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t |
200 resolveType (RecordType tv mtvs) = do |
210 resolveType (RecordType tv mtvs) = do |
201 li <- gets lastIdentifier |
211 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs) |
202 tvs <- liftM concat $ mapM f (concat $ tv : fromMaybe [] mtvs) |
212 return . BTRecord . concat $ tvs |
203 modify (\s -> s{namespaces = Map.insert li tvs (namespaces s)}) |
213 where |
204 return BTRecord |
214 f :: TypeVarDeclaration -> State RenderState [(String, BaseType)] |
205 where |
215 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM ((,) i) $ resolveType td) ids |
206 f :: TypeVarDeclaration -> State RenderState [Record] |
|
207 f (VarDeclaration _ (ids, td) _) = mapM (\(Identifier i _) -> liftM (\t -> (map toLower i, (i, t))) $ resolveType td) ids |
|
208 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
216 resolveType (ArrayDecl (Just _) t) = liftM (BTArray BTInt) $ resolveType t |
209 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
217 resolveType (ArrayDecl Nothing t) = liftM (BTArray BTInt) $ resolveType t |
210 resolveType (FunctionType t _) = liftM BTFunction $ resolveType t |
218 resolveType (FunctionType t _) = liftM BTFunction $ resolveType t |
211 resolveType (DeriveType _) = return BTInt |
219 resolveType (DeriveType _) = return BTInt |
212 resolveType (String _) = return BTString |
220 resolveType (String _) = return BTString |
225 n <- id2C IOInsert name |
233 n <- id2C IOInsert name |
226 return $ t <+> n <> parens p <> text ";" |
234 return $ t <+> n <> parens p <> text ";" |
227 |
235 |
228 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
236 tvar2C True (FunctionDeclaration name returnType params (Just (tvars, phrase))) = do |
229 t <- type2C returnType |
237 t <- type2C returnType |
230 p <- liftM hcat $ mapM (tvar2C False) params |
238 (p, ph) <- withState' id $ do |
231 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
239 p <- liftM hcat $ mapM (tvar2C False) params |
|
240 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
|
241 return (p, ph) |
232 n <- id2C IOInsert name |
242 n <- id2C IOInsert name |
233 return $ |
243 return $ |
234 t <+> n <> parens p |
244 t <+> n <> parens p |
235 $+$ |
245 $+$ |
236 text "{" |
246 text "{" |
382 r <> parens (hsep . punctuate (char ',') $ ps) |
392 r <> parens (hsep . punctuate (char ',') $ ps) |
383 expr2C _ = return $ text "<<expression>>" |
393 expr2C _ = return $ text "<<expression>>" |
384 |
394 |
385 |
395 |
386 ref2C :: Reference -> State RenderState Doc |
396 ref2C :: Reference -> State RenderState Doc |
387 ref2C (ArrayElement exprs ref) = do |
397 ref2C ae@(ArrayElement exprs ref) = do |
388 r <- ref2C ref |
398 r <- ref2C ref |
|
399 t <- gets lastType |
|
400 case t of |
|
401 (BTArray _ t') -> modify (\st -> st{lastType = t'}) |
|
402 a -> error $ show a ++ "\n" ++ show ae |
389 es <- mapM expr2C exprs |
403 es <- mapM expr2C exprs |
390 return $ r <> (brackets . hcat) (punctuate comma es) |
404 return $ r <> (brackets . hcat) (punctuate comma es) |
391 ref2C (SimpleReference name) = id2C IOLookup name |
405 ref2C (SimpleReference name) = id2C IOLookup name |
392 ref2C (RecordField (Dereference ref1) ref2) = do |
406 ref2C (RecordField (Dereference ref1) ref2) = do |
393 r1 <- ref2C ref1 |
407 r1 <- ref2C ref1 |
396 r1 <> text "->" <> r2 |
410 r1 <> text "->" <> r2 |
397 ref2C rf@(RecordField ref1 ref2) = do |
411 ref2C rf@(RecordField ref1 ref2) = do |
398 r1 <- ref2C ref1 |
412 r1 <- ref2C ref1 |
399 t <- gets lastType |
413 t <- gets lastType |
400 r2 <- case t of |
414 r2 <- case t of |
401 BTRecord -> withLastIdNamespace $ ref2C ref2 |
415 BTRecord rs -> withRecordNamespace rs $ ref2C ref2 |
402 BTUnit -> withLastIdNamespace $ ref2C ref2 |
416 BTUnit -> withLastIdNamespace $ ref2C ref2 |
403 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
417 a -> error $ "dereferencing from " ++ show a ++ " - " ++ show rf |
404 return $ |
418 return $ |
405 r1 <> text "." <> r2 |
419 r1 <> text "." <> r2 |
406 ref2C (Dereference ref) = liftM ((parens $ text "*") <>) $ ref2C ref |
420 ref2C (Dereference ref) = do |
|
421 r <- ref2C ref |
|
422 t <- gets lastType |
|
423 case t of |
|
424 (BTPointerTo t') -> modify (\st -> st{lastType = t'}) |
|
425 a -> error $ "Dereferencing from non-pointer type " ++ show a |
|
426 return $ (parens $ text "*") <> r |
407 ref2C (FunCall params ref) = do |
427 ref2C (FunCall params ref) = do |
408 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
428 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
409 r <- ref2C ref |
429 r <- ref2C ref |
410 t <- gets lastType |
430 t <- gets lastType |
411 case t of |
431 case t of |