69 escapeStr :: String -> String |
69 escapeStr :: String -> String |
70 escapeStr = foldr escapeChar [] |
70 escapeStr = foldr escapeChar [] |
71 |
71 |
72 escapeChar :: Char -> ShowS |
72 escapeChar :: Char -> ShowS |
73 escapeChar '"' s = "\\\"" ++ s |
73 escapeChar '"' s = "\\\"" ++ s |
|
74 escapeChar '\\' s = "\\\\" ++ s |
74 escapeChar a s = a : s |
75 escapeChar a s = a : s |
75 |
76 |
76 strInit :: String -> Doc |
77 strInit :: String -> Doc |
77 strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a)) |
78 strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a)) |
78 |
79 |
79 renderStringConsts :: State RenderState Doc |
80 renderStringConsts :: State RenderState Doc |
80 renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi)) |
81 renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi)) |
81 $ gets stringConsts |
82 $ gets stringConsts |
82 |
83 |
83 docToLower :: Doc -> Doc |
84 docToLower :: Doc -> Doc |
84 docToLower = text . map toLower . render |
85 docToLower = text . map toLower . render |
85 |
86 |
130 toNamespace nss (System tvs) = |
131 toNamespace nss (System tvs) = |
131 currentScope $ execState f (emptyState nss) |
132 currentScope $ execState f (emptyState nss) |
132 where |
133 where |
133 f = do |
134 f = do |
134 checkDuplicateFunDecls tvs |
135 checkDuplicateFunDecls tvs |
135 mapM_ (tvar2C True) tvs |
136 mapM_ (tvar2C True False True False) tvs |
|
137 toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them |
|
138 currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"} |
|
139 where |
|
140 f = do |
|
141 checkDuplicateFunDecls tvs |
|
142 mapM_ (tvar2C True False True False) tvs |
136 toNamespace _ (Program {}) = Map.empty |
143 toNamespace _ (Program {}) = Map.empty |
137 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
144 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
138 currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"} |
145 currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"} |
139 |
146 |
140 |
147 |
141 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
148 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
142 withState' f sf = do |
149 withState' f sf = do |
143 st <- liftM f get |
150 st <- liftM f get |
163 records = Map.fromList $ map (\(a, b) -> (map toLower a, [(prefix ++ a, b)])) recs |
169 records = Map.fromList $ map (\(a, b) -> (map toLower a, [(prefix ++ a, b)])) recs |
164 un [a] b = a : b |
170 un [a] b = a : b |
165 |
171 |
166 toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO () |
172 toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO () |
167 toCFiles _ (_, System _) = return () |
173 toCFiles _ (_, System _) = return () |
|
174 toCFiles _ (_, Redo _) = return () |
168 toCFiles ns p@(fn, pu) = do |
175 toCFiles ns p@(fn, pu) = do |
169 hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." |
176 hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." |
170 toCFiles' p |
177 toCFiles' p |
171 where |
178 where |
172 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
179 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
173 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
180 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
174 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState{currentUnit = map toLower i ++ "_"} |
181 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
|
182 (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
175 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
183 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
176 writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
184 writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation |
177 initialState = emptyState ns |
185 initialState = emptyState ns |
178 |
186 |
179 render2C :: RenderState -> State RenderState Doc -> String |
187 render2C :: RenderState -> State RenderState Doc -> String |
180 render2C a = render . ($+$ empty) . flip evalState a |
188 render2C a = render . ($+$ empty) . flip evalState a |
181 |
189 |
|
190 |
182 usesFiles :: PascalUnit -> [String] |
191 usesFiles :: PascalUnit -> [String] |
183 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
192 usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses |
184 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
193 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2 |
185 usesFiles (System {}) = [] |
194 usesFiles (System {}) = [] |
186 |
195 usesFiles (Redo {}) = [] |
187 |
196 |
188 pascal2C :: PascalUnit -> State RenderState Doc |
197 pascal2C :: PascalUnit -> State RenderState Doc |
189 pascal2C (Unit _ interface implementation init fin) = |
198 pascal2C (Unit _ interface implementation init fin) = |
190 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
199 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
191 |
200 |
192 pascal2C (Program _ implementation mainFunction) = do |
201 pascal2C (Program _ implementation mainFunction) = do |
193 impl <- implementation2C implementation |
202 impl <- implementation2C implementation |
194 [main] <- tvar2C True |
203 [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction))) |
195 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
|
196 return $ impl $+$ main |
204 return $ impl $+$ main |
197 |
205 |
198 |
206 |
199 |
207 -- the second bool indicates whether do normal interface translation or generate variable declarations |
200 interface2C :: Interface -> State RenderState Doc |
208 -- that will be inserted into implementation files |
201 interface2C (Interface uses tvars) = do |
209 interface2C :: Interface -> Bool -> State RenderState Doc |
|
210 interface2C (Interface uses tvars) True = do |
202 u <- uses2C uses |
211 u <- uses2C uses |
203 tv <- typesAndVars2C True tvars |
212 tv <- typesAndVars2C True True True tvars |
204 r <- renderStringConsts |
213 r <- renderStringConsts |
205 return (u $+$ r $+$ tv) |
214 return (u $+$ r $+$ tv) |
|
215 interface2C (Interface uses tvars) False = do |
|
216 u <- uses2C uses |
|
217 tv <- typesAndVars2C True False False tvars |
|
218 r <- renderStringConsts |
|
219 return tv |
206 |
220 |
207 implementation2C :: Implementation -> State RenderState Doc |
221 implementation2C :: Implementation -> State RenderState Doc |
208 implementation2C (Implementation uses tvars) = do |
222 implementation2C (Implementation uses tvars) = do |
209 u <- uses2C uses |
223 u <- uses2C uses |
210 tv <- typesAndVars2C True tvars |
224 tv <- typesAndVars2C True False True tvars |
211 r <- renderStringConsts |
225 r <- renderStringConsts |
212 return (u $+$ r $+$ tv) |
226 return (u $+$ r $+$ tv) |
213 |
227 |
214 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () |
228 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () |
215 checkDuplicateFunDecls tvs = |
229 checkDuplicateFunDecls tvs = |
218 initMap = Map.empty |
232 initMap = Map.empty |
219 --initMap = Map.fromList [("reset", 2)] |
233 --initMap = Map.fromList [("reset", 2)] |
220 ins (FunctionDeclaration (Identifier i _) _ _ _) m = Map.insertWith (+) (map toLower i) 1 m |
234 ins (FunctionDeclaration (Identifier i _) _ _ _) m = Map.insertWith (+) (map toLower i) 1 m |
221 ins _ m = m |
235 ins _ m = m |
222 |
236 |
223 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
237 -- the second bool indicates whether declare variable as extern or not |
224 typesAndVars2C b (TypesAndVars ts) = do |
238 -- the third bool indicates whether include types or not |
|
239 |
|
240 typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc |
|
241 typesAndVars2C b externVar includeType(TypesAndVars ts) = do |
225 checkDuplicateFunDecls ts |
242 checkDuplicateFunDecls ts |
226 liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts |
243 liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts |
227 |
244 |
228 setBaseType :: BaseType -> Identifier -> Identifier |
245 setBaseType :: BaseType -> Identifier -> Identifier |
229 setBaseType bt (Identifier i _) = Identifier i bt |
246 setBaseType bt (Identifier i _) = Identifier i bt |
230 |
247 |
231 uses2C :: Uses -> State RenderState Doc |
248 uses2C :: Uses -> State RenderState Doc |
232 uses2C uses@(Uses unitIds) = do |
249 uses2C uses@(Uses unitIds) = do |
|
250 |
233 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
251 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
|
252 mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds) |
234 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
253 mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds |
235 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
254 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
236 where |
255 where |
237 injectNamespace (Identifier i _) = do |
256 injectNamespace (Identifier i _) = do |
238 getNS <- gets (flip Map.lookup . namespaces) |
257 getNS <- gets (flip Map.lookup . namespaces) |
441 hasVars = hasPassByReference params |
464 hasVars = hasPassByReference params |
442 |
465 |
443 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
466 fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
444 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
467 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
445 |
468 |
446 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc] |
469 -- the second bool indicates whether declare variable as extern or not |
447 tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) = |
470 -- the third bool indicates whether include types or not |
448 fun2C b name f |
471 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
449 tvar2C _ td@(TypeDeclaration i' t) = do |
472 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
|
473 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _) = do |
|
474 t <- fun2C b name f |
|
475 if includeType then return t else return [] |
|
476 tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do |
450 i <- id2CTyped t i' |
477 i <- id2CTyped t i' |
451 tp <- type2C t |
478 tp <- type2C t |
452 return [text "typedef" <+> tp i] |
479 return $ if includeType then [text "typedef" <+> tp i] else [] |
453 |
480 |
454 tvar2C _ (VarDeclaration True _ (ids, t) Nothing) = do |
481 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
455 t' <- liftM ((empty <+>) . ) $ type2C t |
482 t' <- liftM ((empty <+>) . ) $ type2C t |
456 liftM (map(\i -> t' i)) $ mapM (id2CTyped (VarParamType t)) ids |
483 liftM (map(\i -> t' i)) $ mapM (id2CTyped (VarParamType t)) ids |
457 |
484 |
458 tvar2C _ (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
485 tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
459 t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t |
486 t' <- liftM (((if isConst then text "static const" else if externVar |
|
487 then text "extern" |
|
488 else empty) |
|
489 <+>) . ) $ type2C t |
460 ie <- initExpr mInitExpr |
490 ie <- initExpr mInitExpr |
461 lt <- gets lastType |
491 lt <- gets lastType |
462 case (isConst, lt, ids, mInitExpr) of |
492 case (isConst, lt, ids, mInitExpr) of |
463 (True, BTInt, [i], Just _) -> do |
493 (True, BTInt, [i], Just _) -> do |
464 i' <- id2CTyped t i |
494 i' <- id2CTyped t i |
465 return [text "enum" <> braces (i' <+> ie)] |
495 return $ if includeType then [text "enum" <> braces (i' <+> ie)] else [] |
466 (True, BTFloat, [i], Just e) -> do |
496 (True, BTFloat, [i], Just e) -> do |
467 i' <- id2CTyped t i |
497 i' <- id2CTyped t i |
468 ie <- initExpr2C e |
498 ie <- initExpr2C e |
469 return [text "#define" <+> i' <+> parens ie <> text "\n"] |
499 return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else [] |
470 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids |
500 (_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids |
471 _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids |
501 (_, BTArray r _ _, [i], _) -> do |
|
502 i' <- id2CTyped t i |
|
503 ie' <- return $ case (r, mInitExpr, ignoreInit) of |
|
504 (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all |
|
505 (_, _, _) -> ie |
|
506 result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids |
|
507 case (r, ignoreInit) of |
|
508 (RangeInfinite, False) -> |
|
509 -- if the array is dynamic, add dimension info to it |
|
510 return $ [dimDecl] ++ result |
|
511 where |
|
512 arrayDimStr = show $ arrayDimension t |
|
513 arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}") |
|
514 dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp |
|
515 |
|
516 (_, _) -> return result |
|
517 |
|
518 _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped t) ids |
472 where |
519 where |
473 initExpr Nothing = return $ empty |
520 initExpr Nothing = return $ empty |
474 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
521 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
475 |
522 varDeclDecision True True varStr expStr = varStr <+> expStr |
476 tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do |
523 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
|
524 varDeclDecision False False varStr expStr = varStr <+> expStr |
|
525 varDeclDecision True False varStr expStr = empty |
|
526 arrayDimension a = case a of |
|
527 ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t |
|
528 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." |
|
529 _ -> 0 |
|
530 |
|
531 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) ret params body) = do |
477 r <- op2CTyped op (extractTypes params) |
532 r <- op2CTyped op (extractTypes params) |
478 fun2C f i (FunctionDeclaration r ret params body) |
533 fun2C f i (FunctionDeclaration r ret params body) |
479 |
534 |
480 |
535 |
481 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
536 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
589 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
645 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
590 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
646 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
591 _ -> return $ \a -> i' <+> text "*" <+> a |
647 _ -> return $ \a -> i' <+> text "*" <+> a |
592 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
648 type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t |
593 type2C' (RecordType tvs union) = do |
649 type2C' (RecordType tvs union) = do |
594 t <- withState' f $ mapM (tvar2C False) tvs |
650 t <- withState' f $ mapM (tvar2C False False True False) tvs |
595 u <- unions |
651 u <- unions |
596 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i |
652 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i |
597 where |
653 where |
598 f s = s{currentUnit = ""} |
654 f s = s{currentUnit = ""} |
599 unions = case union of |
655 unions = case union of |
600 Nothing -> return empty |
656 Nothing -> return empty |
601 Just a -> do |
657 Just a -> do |
602 structs <- mapM struct2C a |
658 structs <- mapM struct2C a |
603 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
659 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
604 struct2C tvs = do |
660 struct2C tvs = do |
605 t <- withState' f $ mapM (tvar2C False) tvs |
661 t <- withState' f $ mapM (tvar2C False False True False) tvs |
606 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi |
662 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi |
607 type2C' (RangeType r) = return (text "int" <+>) |
663 type2C' (RangeType r) = return (text "int" <+>) |
608 type2C' (Sequence ids) = do |
664 type2C' (Sequence ids) = do |
609 is <- mapM (id2C IOInsert . setBaseType bt) ids |
665 is <- mapM (id2C IOInsert . setBaseType bt) ids |
610 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
666 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
673 return $ r <+> text "=" <+> e <> semi |
729 return $ r <+> text "=" <+> e <> semi |
674 BTString -> do |
730 BTString -> do |
675 e <- expr2C expr |
731 e <- expr2C expr |
676 return $ r <+> text "=" <+> e <> semi |
732 return $ r <+> text "=" <+> e <> semi |
677 _ -> error $ "Assignment to string from " ++ show lt |
733 _ -> error $ "Assignment to string from " ++ show lt |
678 (BTArray _ _ _, _) -> phrase2C $ |
734 (BTArray _ _ _, _) -> do |
679 ProcCall (FunCall |
735 case expr of |
680 [ |
736 Reference er -> do |
681 Reference $ Address ref |
737 exprRef <- ref2C er |
682 , Reference $ Address $ RefExpression expr |
738 exprT <- gets lastType |
683 , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown)) |
739 case exprT of |
684 ] |
740 BTArray RangeInfinite _ _ -> |
685 (SimpleReference (Identifier "memcpy" BTUnknown)) |
741 return $ text "FIXME: assign a dynamic array to an array" |
686 ) [] |
742 BTArray _ _ _ -> phrase2C $ |
|
743 ProcCall (FunCall |
|
744 [ |
|
745 Reference $ ref |
|
746 , Reference $ RefExpression expr |
|
747 , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown)) |
|
748 ] |
|
749 (SimpleReference (Identifier "memcpy" BTUnknown)) |
|
750 ) [] |
|
751 _ -> return $ text "FIXME: assign a non-specific value to an array" |
|
752 |
|
753 _ -> return $ text "FIXME: dynamic array assignment 2" |
687 _ -> do |
754 _ -> do |
688 e <- expr2C expr |
755 e <- expr2C expr |
689 return $ r <+> text "=" <+> e <> semi |
756 return $ r <+> text "=" <+> e <> semi |
690 phrase2C (WhileCycle expr phrase) = do |
757 phrase2C (WhileCycle expr phrase) = do |
691 e <- expr2C expr |
758 e <- expr2C expr |
714 t <- gets lastType |
781 t <- gets lastType |
715 case t of |
782 case t of |
716 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
783 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
717 a -> do |
784 a -> do |
718 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
785 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
719 phrase2C (ForCycle i' e1' e2' p) = do |
786 phrase2C (ForCycle i' e1' e2' p up) = do |
720 i <- id2C IOLookup i' |
787 i <- id2C IOLookup i' |
721 e1 <- expr2C e1' |
788 e1 <- expr2C e1' |
722 e2 <- expr2C e2' |
789 e2 <- expr2C e2' |
723 ph <- phrase2C (wrapPhrase p) |
790 ph <- phrase2C (wrapPhrase p) |
|
791 cmp <- return $ if up == True then "<=" else ">=" |
|
792 inc <- return $ if up == True then "++" else "--" |
724 return $ |
793 return $ |
725 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i]) |
794 text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> parens e1, i <+> text cmp <+> parens e2, text inc <> i]) |
726 $$ |
795 $$ |
727 ph |
796 ph |
728 phrase2C (RepeatCycle e' p') = do |
797 phrase2C (RepeatCycle e' p') = do |
729 e <- expr2C e' |
798 e <- expr2C e' |
730 p <- phrase2C (Phrases p') |
799 p <- phrase2C (Phrases p') |
775 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
844 ref2C $ FunCall [expr1, expr2] (SimpleReference i) |
776 ("in", _, _) -> |
845 ("in", _, _) -> |
777 case expr2 of |
846 case expr2 of |
778 SetExpression set -> do |
847 SetExpression set -> do |
779 ids <- mapM (id2C IOLookup) set |
848 ids <- mapM (id2C IOLookup) set |
|
849 modify(\s -> s{lastType = BTBool}) |
780 return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids |
850 return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids |
781 _ -> error "'in' against not set expression" |
851 _ -> error "'in' against not set expression" |
782 (o, _, _) | o `elem` boolOps -> do |
852 (o, _, _) | o `elem` boolOps -> do |
783 modify(\s -> s{lastType = BTBool}) |
853 modify(\s -> s{lastType = BTBool}) |
784 return $ parens e1 <+> text o <+> parens e2 |
854 return $ parens e1 <+> text o <+> parens e2 |
785 | otherwise -> return $ parens e1 <+> text o <+> parens e2 |
855 | otherwise -> do |
|
856 o' <- return $ case o of |
|
857 "/(float)" -> text "/(float)" -- pascal returns real value |
|
858 _ -> text o |
|
859 e1' <- return $ case (o, t1, t2) of |
|
860 ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1 |
|
861 _ -> parens e1 |
|
862 e2' <- return $ case (o, t1, t2) of |
|
863 ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2 |
|
864 _ -> parens e2 |
|
865 return $ e1' <+> o' <+> e2' |
786 where |
866 where |
787 boolOps = ["==", "!=", "<", ">", "<=", ">="] |
867 boolOps = ["==", "!=", "<", ">", "<=", ">="] |
788 expr2C (NumberLiteral s) = do |
868 expr2C (NumberLiteral s) = do |
789 modify(\s -> s{lastType = BTInt}) |
869 modify(\s -> s{lastType = BTInt}) |
790 return $ text s |
870 return $ text s |
833 BTString -> return $ int 255 |
918 BTString -> return $ int 255 |
834 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n |
919 BTArray (RangeFromTo _ n) _ _ -> initExpr2C n |
835 _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt |
920 _ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt |
836 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
921 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e |
837 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
922 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e |
838 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e |
923 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e |
839 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do |
924 expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do |
840 e' <- expr2C e |
925 e' <- expr2C e |
841 lt <- gets lastType |
926 lt <- gets lastType |
842 modify (\s -> s{lastType = BTInt}) |
927 modify (\s -> s{lastType = BTInt}) |
843 case lt of |
928 case lt of |
844 BTString -> return $ text "Length" <> parens e' |
929 BTString -> return $ text "fpcrtl_Length" <> parens e' |
845 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' |
930 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e' |
846 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n]) |
931 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n]) |
847 _ -> error $ "length() called on " ++ show lt |
932 _ -> error $ "length() called on " ++ show lt |
848 expr2C (BuiltInFunCall params ref) = do |
933 expr2C (BuiltInFunCall params ref) = do |
849 r <- ref2C ref |
934 r <- ref2C ref |