11 import PascalPreprocessor |
11 import PascalPreprocessor |
12 import Control.Exception |
12 import Control.Exception |
13 import System.IO.Error |
13 import System.IO.Error |
14 import qualified Data.Map as Map |
14 import qualified Data.Map as Map |
15 import qualified Data.Set as Set |
15 import qualified Data.Set as Set |
16 import Data.List (find) |
16 import Data.List (find, stripPrefix) |
17 import Numeric |
17 import Numeric |
18 |
18 |
19 import PascalParser |
19 import PascalParser |
20 import PascalUnitSyntaxTree |
20 import PascalUnitSyntaxTree |
21 |
21 |
143 toNamespace nss (System tvs) = |
143 toNamespace nss (System tvs) = |
144 currentScope $ execState f (emptyState nss) |
144 currentScope $ execState f (emptyState nss) |
145 where |
145 where |
146 f = do |
146 f = do |
147 checkDuplicateFunDecls tvs |
147 checkDuplicateFunDecls tvs |
148 mapM_ (tvar2C True False True False) tvs |
148 mapM_ (tvar2C True False True False False) tvs |
149 toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them |
149 toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them |
150 currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"} |
150 currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"} |
151 where |
151 where |
152 f = do |
152 f = do |
153 checkDuplicateFunDecls tvs |
153 checkDuplicateFunDecls tvs |
154 mapM_ (tvar2C True False True False) tvs |
154 mapM_ (tvar2C True False True False False) tvs |
155 toNamespace _ (Program {}) = Map.empty |
155 toNamespace _ (Program {}) = Map.empty |
156 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
156 toNamespace nss (Unit (Identifier i _) interface _ _ _) = |
157 currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"} |
157 currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"} |
158 |
158 |
159 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
159 withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a |
237 pascal2C (Unit _ interface implementation _ _) = |
237 pascal2C (Unit _ interface implementation _ _) = |
238 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
238 liftM2 ($+$) (interface2C interface True) (implementation2C implementation) |
239 |
239 |
240 pascal2C (Program _ implementation mainFunction) = do |
240 pascal2C (Program _ implementation mainFunction) = do |
241 impl <- implementation2C implementation |
241 impl <- implementation2C implementation |
242 main <- liftM head $ tvar2C True False True True |
242 main <- liftM head $ tvar2C True False True True False |
243 (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) |
243 (FunctionDeclaration (Identifier "main" (BTInt True)) False False False (SimpleType $ Identifier "int" (BTInt True)) |
244 [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing |
244 [VarDeclaration False False ([Identifier "argc" (BTInt True)], SimpleType (Identifier "Integer" (BTInt True))) Nothing |
245 , VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] |
245 , VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] |
246 (Just (TypesAndVars [], Phrases [mainResultInit, mainFunction]))) |
246 (Just (TypesAndVars [], Phrases [mainResultInit, mainFunction]))) |
247 |
247 |
252 -- the second bool indicates whether do normal interface translation or generate variable declarations |
252 -- the second bool indicates whether do normal interface translation or generate variable declarations |
253 -- that will be inserted into implementation files |
253 -- that will be inserted into implementation files |
254 interface2C :: Interface -> Bool -> State RenderState Doc |
254 interface2C :: Interface -> Bool -> State RenderState Doc |
255 interface2C (Interface uses tvars) True = do |
255 interface2C (Interface uses tvars) True = do |
256 u <- uses2C uses |
256 u <- uses2C uses |
257 tv <- typesAndVars2C True True True tvars |
257 tv <- typesAndVars2C True True True False tvars |
258 r <- renderStringConsts |
258 r <- renderStringConsts |
259 return (u $+$ r $+$ tv) |
259 return (u $+$ r $+$ tv) |
260 interface2C (Interface uses tvars) False = do |
260 interface2C (Interface uses tvars) False = do |
261 void $ uses2C uses |
261 void $ uses2C uses |
262 tv <- typesAndVars2C True False False tvars |
262 tv <- typesAndVars2C True False False False tvars |
263 void $ renderStringConsts |
263 void $ renderStringConsts |
264 return tv |
264 return tv |
265 |
265 |
266 implementation2C :: Implementation -> State RenderState Doc |
266 implementation2C :: Implementation -> State RenderState Doc |
267 implementation2C (Implementation uses tvars) = do |
267 implementation2C (Implementation uses tvars) = do |
268 u <- uses2C uses |
268 u <- uses2C uses |
269 tv <- typesAndVars2C True False True tvars |
269 tv <- typesAndVars2C True False True True tvars |
270 r <- renderStringConsts |
270 r <- renderStringConsts |
271 return (u $+$ r $+$ tv) |
271 return (u $+$ r $+$ tv) |
272 |
272 |
273 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () |
273 checkDuplicateFunDecls :: [TypeVarDeclaration] -> State RenderState () |
274 checkDuplicateFunDecls tvs = |
274 checkDuplicateFunDecls tvs = |
281 ins _ m = m |
281 ins _ m = m |
282 |
282 |
283 -- the second bool indicates whether declare variable as extern or not |
283 -- the second bool indicates whether declare variable as extern or not |
284 -- the third bool indicates whether include types or not |
284 -- the third bool indicates whether include types or not |
285 |
285 |
286 typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc |
286 typesAndVars2C :: Bool -> Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc |
287 typesAndVars2C b externVar includeType(TypesAndVars ts) = do |
287 typesAndVars2C b externVar includeType static (TypesAndVars ts) = do |
288 checkDuplicateFunDecls ts |
288 checkDuplicateFunDecls ts |
289 liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts |
289 liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False static) ts |
290 |
290 |
291 setBaseType :: BaseType -> Identifier -> Identifier |
291 setBaseType :: BaseType -> Identifier -> Identifier |
292 setBaseType bt (Identifier i _) = Identifier i bt |
292 setBaseType bt (Identifier i _) = Identifier i bt |
293 |
293 |
294 uses2C :: Uses -> State RenderState Doc |
294 uses2C :: Uses -> State RenderState Doc |
457 fromPointer s t = do |
457 fromPointer s t = do |
458 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
458 error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s |
459 |
459 |
460 |
460 |
461 functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc |
461 functionParams2C :: [TypeVarDeclaration] -> State RenderState Doc |
462 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params |
462 functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True False) params |
463 |
463 |
464 numberOfDeclarations :: [TypeVarDeclaration] -> Int |
464 numberOfDeclarations :: [TypeVarDeclaration] -> Int |
465 numberOfDeclarations = sum . map cnt |
465 numberOfDeclarations = sum . map cnt |
466 where |
466 where |
467 cnt (VarDeclaration _ _ (ids, _) _) = length ids |
467 cnt (VarDeclaration _ _ (ids, _) _) = length ids |
516 else (render res) |
516 else (render res) |
517 |
517 |
518 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else t') empty] $ currentScope st |
518 (p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [Record resultId (if isVoid then (BTFunction hasVars False bts t') else t') empty] $ currentScope st |
519 , currentFunctionResult = if isVoid then [] else render res}) $ do |
519 , currentFunctionResult = if isVoid then [] else render res}) $ do |
520 p <- functionParams2C params |
520 p <- functionParams2C params |
521 ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase) |
521 ph <- liftM2 ($+$) (typesAndVars2C False False True False tvars) (phrase2C' phrase) |
522 return (p, ph) |
522 return (p, ph) |
523 |
523 |
524 let isTrivialReturn = case phrase of |
524 let isTrivialReturn = case phrase of |
525 (Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True |
525 (Phrases (BuiltInFunctionCall _ (SimpleReference (Identifier "exit" BTUnknown)) : _)) -> True |
526 _ -> False |
526 _ -> False |
553 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
553 fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv |
554 |
554 |
555 -- the second bool indicates whether declare variable as extern or not |
555 -- the second bool indicates whether declare variable as extern or not |
556 -- the third bool indicates whether include types or not |
556 -- the third bool indicates whether include types or not |
557 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
557 -- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params) |
558 tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
558 tvar2C :: Bool -> Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc] |
559 tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = do |
559 tvar2C b _ includeType _ _ f@(FunctionDeclaration (Identifier name _) _ _ _ _ _ _) = do |
560 t <- fun2C b name f |
560 t <- fun2C b name f |
561 if includeType then return t else return [] |
561 if includeType then return t else return [] |
562 tvar2C _ _ includeType _ (TypeDeclaration i' t) = do |
562 tvar2C _ _ includeType _ _ (TypeDeclaration i' t) = do |
563 i <- id2CTyped t i' |
563 i <- id2CTyped t i' |
564 tp <- type2C t |
564 tp <- type2C t |
565 let res = if includeType then [text "typedef" <+> tp i] else [] |
565 let res = if includeType then [text "typedef" <+> tp i] else [] |
566 case t of |
566 case t of |
567 (Sequence ids) -> do |
567 (Sequence ids) -> do |
568 modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s}) |
568 modify(\s -> s{enums = (render i, map (\(Identifier id' _) -> id') ids) : enums s}) |
569 return res |
569 return res |
570 _ -> return res |
570 _ -> return res |
571 |
571 |
572 tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
572 tvar2C _ _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do |
573 t' <- liftM ((empty <+>) . ) $ type2C t |
573 t' <- liftM ((empty <+>) . ) $ type2C t |
574 liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids |
574 liftM (map(\i -> t' i)) $ mapM (id2CTyped2 (Just $ t' empty) (VarParamType t)) ids |
575 |
575 |
576 tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
576 tvar2C _ externVar includeType ignoreInit static (VarDeclaration _ isConst (ids, t) mInitExpr) = do |
577 t' <- liftM ((declDetails <+>) . ) $ type2C t |
577 t' <- liftM ((declDetails <+>) . ) $ type2C t |
578 ie <- initExpr mInitExpr |
578 ie <- initExpr mInitExpr |
579 lt <- gets lastType |
579 lt <- gets lastType |
580 case (isConst, lt, ids, mInitExpr) of |
580 case (isConst, lt, ids, mInitExpr) of |
581 (True, BTInt _, [i], Just _) -> do |
581 (True, BTInt _, [i], Just _) -> do |
605 |
605 |
606 _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids |
606 _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped2 (Just $ t' empty) t) ids |
607 where |
607 where |
608 declDetails = if isConst then text "static const" else if externVar |
608 declDetails = if isConst then text "static const" else if externVar |
609 then text "extern" |
609 then text "extern" |
610 else empty |
610 else if static then text "static" else empty |
611 initExpr Nothing = return $ empty |
611 initExpr Nothing = return $ empty |
612 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
612 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
613 varDeclDecision True True varStr expStr = varStr <+> expStr |
613 varDeclDecision True True varStr expStr = varStr <+> expStr |
614 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
614 varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr |
615 varDeclDecision False False varStr expStr = varStr <+> expStr |
615 varDeclDecision False False varStr expStr = varStr <+> expStr |
618 ArrayDecl Nothing t' -> let a' = arrayDimension t' in |
618 ArrayDecl Nothing t' -> let a' = arrayDimension t' in |
619 if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' |
619 if a' > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + a' |
620 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." |
620 ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported." |
621 _ -> 0 |
621 _ -> 0 |
622 |
622 |
623 tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do |
623 tvar2C f _ _ _ _ (OperatorDeclaration op (Identifier i _) inline ret params body) = do |
624 r <- op2CTyped op (extractTypes params) |
624 r <- op2CTyped op (extractTypes params) |
625 fun2C f i (FunctionDeclaration r inline False False ret params body) |
625 fun2C f i (FunctionDeclaration r inline False False ret params body) |
626 |
626 |
627 |
627 |
628 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
628 op2CTyped :: String -> [TypeDecl] -> State RenderState Identifier |
752 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
752 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
753 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
753 BTUnknown -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a |
754 _ -> return $ \a -> i' <+> text "*" <+> a |
754 _ -> return $ \a -> i' <+> text "*" <+> a |
755 type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t |
755 type2C' (PointerTo t) = liftM (\tx a -> tx (parens $ text "*" <> a)) $ type2C t |
756 type2C' (RecordType tvs union) = do |
756 type2C' (RecordType tvs union) = do |
757 t' <- withState' f $ mapM (tvar2C False False True False) tvs |
757 t' <- withState' f $ mapM (tvar2C False False True False False) tvs |
758 u <- unions |
758 u <- unions |
759 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i |
759 return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t') $$ u) $+$ rbrace <+> i |
760 where |
760 where |
761 f s = s{currentUnit = ""} |
761 f s = s{currentUnit = ""} |
762 unions = case union of |
762 unions = case union of |
763 Nothing -> return empty |
763 Nothing -> return empty |
764 Just a -> do |
764 Just a -> do |
765 structs <- mapM struct2C a |
765 structs <- mapM struct2C a |
766 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
766 return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi |
767 struct2C stvs = do |
767 struct2C stvs = do |
768 txts <- withState' f $ mapM (tvar2C False False True False) stvs |
768 txts <- withState' f $ mapM (tvar2C False False True False False) stvs |
769 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi |
769 return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ txts)) <> semi |
770 type2C' (RangeType r) = return (text "int" <+>) |
770 type2C' (RangeType r) = return (text "int" <+>) |
771 type2C' (Sequence ids) = do |
771 type2C' (Sequence ids) = do |
772 is <- mapM (id2C IOInsert . setBaseType bt) ids |
772 is <- mapM (id2C IOInsert . setBaseType bt) ids |
773 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
773 return (text "enum" <+> (braces . vcat . punctuate comma . map (\(a, b) -> a <+> equals <+> text "0x" <> text (showHex b "")) $ zip is [0..]) <+>) |
918 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p |
918 (BTRecord _ rs) -> withRecordNamespace (render r ++ ".") (rec2Records rs) $ phrase2C $ wrapPhrase p |
919 a -> do |
919 a -> do |
920 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
920 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb |
921 phrase2C (ForCycle i' e1' e2' p up) = do |
921 phrase2C (ForCycle i' e1' e2' p up) = do |
922 i <- id2C IOLookup i' |
922 i <- id2C IOLookup i' |
923 iType <- gets lastIdTypeDecl |
923 -- hackishly strip 'static' from type declaration to workaround the use of global variables in 'for' cycles in uLandGenMaze |
|
924 iType <- liftM (text . maybeStripPrefix "static " . show) $ gets lastIdTypeDecl |
924 e1 <- expr2C e1' |
925 e1 <- expr2C e1' |
925 e2 <- expr2C e2' |
926 e2 <- expr2C e2' |
926 let iEnd = i <> text "__end__" |
927 let iEnd = i <> text "__end__" |
927 ph <- phrase2C $ wrapPhrase p |
928 ph <- phrase2C $ wrapPhrase p |
928 return . braces $ |
929 return . braces $ |
933 text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> |
934 text "if" <+> (parens $ i <+> text (if up then "<=" else ">=") <+> iEnd) <+> text "do" <+> ph <+> |
934 text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi |
935 text "while" <> parens (i <> text (if up then "++" else "--") <+> text "!=" <+> iEnd) <> semi |
935 where |
936 where |
936 appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] |
937 appendPhrase p (Phrases ps) = Phrases $ ps ++ [p] |
937 appendPhrase _ _ = error "illegal appendPhrase call" |
938 appendPhrase _ _ = error "illegal appendPhrase call" |
|
939 maybeStripPrefix prefix a = fromMaybe a $ stripPrefix prefix a |
938 phrase2C (RepeatCycle e' p') = do |
940 phrase2C (RepeatCycle e' p') = do |
939 e <- expr2C e' |
941 e <- expr2C e' |
940 p <- phrase2C (Phrases p') |
942 p <- phrase2C (Phrases p') |
941 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
943 return $ text "do" <+> p <+> text "while" <> parens (text "!" <> parens e) <> semi |
942 |
944 |