2 |
2 |
3 import PascalParser |
3 import PascalParser |
4 import Text.PrettyPrint.HughesPJ |
4 import Text.PrettyPrint.HughesPJ |
5 import Data.Maybe |
5 import Data.Maybe |
6 import Data.Char |
6 import Data.Char |
|
7 import Text.Parsec.String |
7 |
8 |
|
9 |
|
10 pas2C :: String -> IO String |
|
11 pas2C fileName = do |
|
12 ptree <- parseFromFile pascalUnit fileName |
|
13 case ptree of |
|
14 (Left a) -> return (show a) |
|
15 (Right a) -> (return . render . pascal2C) a |
8 |
16 |
9 pascal2C :: PascalUnit -> Doc |
17 pascal2C :: PascalUnit -> Doc |
10 pascal2C (Unit unitName interface implementation init fin) = implementation2C implementation |
18 pascal2C (Unit unitName interface implementation init fin) = implementation2C implementation |
11 |
19 |
12 |
20 |
19 |
27 |
20 |
28 |
21 tvar2C :: TypeVarDeclaration -> Doc |
29 tvar2C :: TypeVarDeclaration -> Doc |
22 tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = |
30 tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = |
23 type2C returnType <+> text (name ++ "();") |
31 type2C returnType <+> text (name ++ "();") |
24 |
|
25 |
|
26 tvar2C (FunctionDeclaration (Identifier name) returnType (Just phrase)) = |
32 tvar2C (FunctionDeclaration (Identifier name) returnType (Just phrase)) = |
27 type2C returnType <+> text (name ++ "()") |
33 type2C returnType <+> text (name ++ "()") |
28 $$ |
34 $$ |
29 phrase2C phrase |
35 phrase2C phrase |
30 tvar2C _ = empty |
36 tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";" |
|
37 tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = |
|
38 if isConst then text "const" else empty |
|
39 <+> |
|
40 type2C t |
|
41 <+> |
|
42 (hsep . punctuate (char ',') . map (\(Identifier i) -> text i) $ ids) |
|
43 <+> |
|
44 initExpr mInitExpr |
|
45 <> |
|
46 text ";" |
|
47 where |
|
48 initExpr Nothing = empty |
|
49 initExpr (Just e) = text "=" <+> initExpr2C e |
|
50 |
|
51 initExpr2C :: InitExpression -> Doc |
|
52 initExpr2C _ = text "<<expression>>" |
31 |
53 |
32 type2C :: TypeDecl -> Doc |
54 type2C :: TypeDecl -> Doc |
33 type2C UnknownType = text "void" |
55 type2C UnknownType = text "void" |
34 type2C _ = text "<<type>>" |
56 type2C String = text "string" |
|
57 type2C (SimpleType (Identifier i)) = text i |
|
58 type2C (PointerTo t) = type2C t <> text "*" |
|
59 type2C (RecordType tvs) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}" |
|
60 type2C (RangeType r) = text "<<range type>>" |
|
61 type2C (Sequence ids) = text "<<sequence type>>" |
|
62 type2C (ArrayDecl r t) = text "<<array type>>" |
|
63 |
35 |
64 |
36 phrase2C :: Phrase -> Doc |
65 phrase2C :: Phrase -> Doc |
37 phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}" |
66 phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}" |
38 phrase2C (ProcCall (Identifier name) params) = text name <> parens (hsep . punctuate (char ',') . map expr2C $ params) <> semi |
67 phrase2C (ProcCall (Identifier name) params) = text name <> parens (hsep . punctuate (char ',') . map expr2C $ params) <> semi |
39 phrase2C (IfThenElse (expr) phrase1 mphrase2) = text "if" <> parens (expr2C expr) $+$ (phrase2C . wrapPhrase) phrase1 $+$ elsePart |
68 phrase2C (IfThenElse (expr) phrase1 mphrase2) = text "if" <> parens (expr2C expr) $+$ (phrase2C . wrapPhrase) phrase1 $+$ elsePart |
44 phrase2C (WhileCycle expr phrase) = text "while" <> parens (expr2C expr) $$ (phrase2C $ wrapPhrase phrase) |
73 phrase2C (WhileCycle expr phrase) = text "while" <> parens (expr2C expr) $$ (phrase2C $ wrapPhrase phrase) |
45 phrase2C (SwitchCase expr cases mphrase) = text "switch" <> parens (expr2C expr) <> text "of" $+$ (nest 4 . vcat . map case2C) cases |
74 phrase2C (SwitchCase expr cases mphrase) = text "switch" <> parens (expr2C expr) <> text "of" $+$ (nest 4 . vcat . map case2C) cases |
46 where |
75 where |
47 case2C :: (Expression, Phrase) -> Doc |
76 case2C :: (Expression, Phrase) -> Doc |
48 case2C (e, p) = text "case" <+> parens (expr2C e) <> char ':' <> nest 4 (phrase2C p $+$ text "break;") |
77 case2C (e, p) = text "case" <+> parens (expr2C e) <> char ':' <> nest 4 (phrase2C p $+$ text "break;") |
49 {- |
78 phrase2C (WithBlock ref p) = text "namespace" <> parens (ref2C ref) $$ (phrase2C $ wrapPhrase p) |
50 | RepeatCycle Expression Phrase |
79 phrase2C (ForCycle (Identifier i) e1 e2 p) = |
51 | ForCycle |
80 text "for" <> (parens . hsep . punctuate (char ';') $ [text i <+> text "=" <+> expr2C e1, text i <+> text "<=" <+> expr2C e2, text "++" <> text i]) |
52 -} |
81 $$ |
53 phrase2C _ = empty |
82 phrase2C (wrapPhrase p) |
|
83 phrase2C (RepeatCycle e p) = text "do" <+> phrase2C (Phrases p) <+> text "while" <> parens (text "!" <> parens (expr2C e)) |
|
84 |
54 |
85 |
55 wrapPhrase p@(Phrases _) = p |
86 wrapPhrase p@(Phrases _) = p |
56 wrapPhrase p = Phrases [p] |
87 wrapPhrase p = Phrases [p] |
|
88 |
57 |
89 |
58 expr2C :: Expression -> Doc |
90 expr2C :: Expression -> Doc |
59 expr2C (Expression s) = text s |
91 expr2C (Expression s) = text s |
60 expr2C (BinOp op expr1 expr2) = parens $ (expr2C expr1) <+> op2C op <+> (expr2C expr2) |
92 expr2C (BinOp op expr1 expr2) = parens $ (expr2C expr1) <+> op2C op <+> (expr2C expr2) |
61 expr2C (NumberLiteral s) = text s |
93 expr2C (NumberLiteral s) = text s |
77 ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2 |
109 ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2 |
78 ref2C (Dereference ref) = parens $ text "*" <> ref2C ref |
110 ref2C (Dereference ref) = parens $ text "*" <> ref2C ref |
79 ref2C (FunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params) |
111 ref2C (FunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params) |
80 ref2C (Address ref) = text "&" <> ref2C ref |
112 ref2C (Address ref) = text "&" <> ref2C ref |
81 |
113 |
|
114 |
82 op2C "or" = text "|" |
115 op2C "or" = text "|" |
83 op2C "and" = text "&" |
116 op2C "and" = text "&" |
84 op2C "not" = text "!" |
117 op2C "not" = text "!" |
85 op2C "xor" = text "^" |
118 op2C "xor" = text "^" |
86 op2C "div" = text "/" |
119 op2C "div" = text "/" |