10 import Text.Parsec.String |
10 import Text.Parsec.String |
11 import Control.Monad |
11 import Control.Monad |
12 import Data.Maybe |
12 import Data.Maybe |
13 |
13 |
14 import PascalBasics |
14 import PascalBasics |
15 |
15 import PascalUnitSyntaxTree |
16 data PascalUnit = |
|
17 Program Identifier Implementation Phrase |
|
18 | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize) |
|
19 | System |
|
20 deriving Show |
|
21 data Interface = Interface Uses TypesAndVars |
|
22 deriving Show |
|
23 data Implementation = Implementation Uses TypesAndVars |
|
24 deriving Show |
|
25 data Identifier = Identifier String |
|
26 deriving Show |
|
27 data TypesAndVars = TypesAndVars [TypeVarDeclaration] |
|
28 deriving Show |
|
29 data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl |
|
30 | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe InitExpression) |
|
31 | FunctionDeclaration Identifier TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) |
|
32 | OperatorDeclaration String Identifier TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) |
|
33 deriving Show |
|
34 data TypeDecl = SimpleType Identifier |
|
35 | RangeType Range |
|
36 | Sequence [Identifier] |
|
37 | ArrayDecl (Maybe Range) TypeDecl |
|
38 | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]]) |
|
39 | PointerTo TypeDecl |
|
40 | String Integer |
|
41 | Set TypeDecl |
|
42 | FunctionType TypeDecl [TypeVarDeclaration] |
|
43 | UnknownType |
|
44 deriving Show |
|
45 data Range = Range Identifier |
|
46 | RangeFromTo InitExpression InitExpression |
|
47 deriving Show |
|
48 data Initialize = Initialize String |
|
49 deriving Show |
|
50 data Finalize = Finalize String |
|
51 deriving Show |
|
52 data Uses = Uses [Identifier] |
|
53 deriving Show |
|
54 data Phrase = ProcCall Reference [Expression] |
|
55 | IfThenElse Expression Phrase (Maybe Phrase) |
|
56 | WhileCycle Expression Phrase |
|
57 | RepeatCycle Expression [Phrase] |
|
58 | ForCycle Identifier Expression Expression Phrase |
|
59 | WithBlock Reference Phrase |
|
60 | Phrases [Phrase] |
|
61 | SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase]) |
|
62 | Assignment Reference Expression |
|
63 | NOP |
|
64 deriving Show |
|
65 data Expression = Expression String |
|
66 | BuiltInFunCall [Expression] Reference |
|
67 | PrefixOp String Expression |
|
68 | PostfixOp String Expression |
|
69 | BinOp String Expression Expression |
|
70 | StringLiteral String |
|
71 | CharCode String |
|
72 | HexCharCode String |
|
73 | NumberLiteral String |
|
74 | FloatLiteral String |
|
75 | HexNumber String |
|
76 | Reference Reference |
|
77 | SetExpression [Identifier] |
|
78 | Null |
|
79 deriving Show |
|
80 data Reference = ArrayElement [Expression] Reference |
|
81 | FunCall [Expression] Reference |
|
82 | TypeCast Identifier Expression |
|
83 | SimpleReference Identifier |
|
84 | Dereference Reference |
|
85 | RecordField Reference Reference |
|
86 | Address Reference |
|
87 | RefExpression Expression |
|
88 deriving Show |
|
89 data InitExpression = InitBinOp String InitExpression InitExpression |
|
90 | InitPrefixOp String InitExpression |
|
91 | InitReference Identifier |
|
92 | InitArray [InitExpression] |
|
93 | InitRecord [(Identifier, InitExpression)] |
|
94 | InitFloat String |
|
95 | InitNumber String |
|
96 | InitHexNumber String |
|
97 | InitString String |
|
98 | InitChar String |
|
99 | BuiltInFunction String [InitExpression] |
|
100 | InitSet [InitExpression] |
|
101 | InitAddress InitExpression |
|
102 | InitNull |
|
103 | InitRange Range |
|
104 | InitTypeCast Identifier InitExpression |
|
105 deriving Show |
|
106 |
16 |
107 knownTypes = ["shortstring", "char", "byte"] |
17 knownTypes = ["shortstring", "char", "byte"] |
108 |
18 |
109 pascalUnit = do |
19 pascalUnit = do |
110 comments |
20 comments |
143 postfixes r = many postfix >>= return . foldl (flip ($)) r |
53 postfixes r = many postfix >>= return . foldl (flip ($)) r |
144 postfix = choice [ |
54 postfix = choice [ |
145 parens pas (option [] parameters) >>= return . FunCall |
55 parens pas (option [] parameters) >>= return . FunCall |
146 , char '^' >> return Dereference |
56 , char '^' >> return Dereference |
147 , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement |
57 , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement |
148 , (char '.' >> notFollowedBy (char '.')) >> liftM RecordField reference |
58 , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference |
149 ] |
59 ] |
150 |
60 |
151 typeCast = do |
61 typeCast = do |
152 t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes |
62 t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes |
153 e <- parens pas expression |
63 e <- parens pas expression |
448 , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c) |
358 , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c) |
449 , char '#' >> many digit >>= \c -> comments >> return (CharCode c) |
359 , char '#' >> many digit >>= \c -> comments >> return (CharCode c) |
450 , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h) |
360 , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h) |
451 , char '-' >> expression >>= return . PrefixOp "-" |
361 , char '-' >> expression >>= return . PrefixOp "-" |
452 , try $ string "nil" >> return Null |
362 , try $ string "nil" >> return Null |
|
363 , try $ string "not" >> expression >>= return . PrefixOp "not" |
453 , reference >>= return . Reference |
364 , reference >>= return . Reference |
454 ] <?> "simple expression" |
365 ] <?> "simple expression" |
455 |
366 |
456 table = [ |
367 table = [ |
457 [ Infix (char '*' >> return (BinOp "*")) AssocLeft |
368 [ Infix (char '*' >> return (BinOp "*")) AssocLeft |
461 , Infix (try (string "in") >> return (BinOp "in")) AssocNone |
372 , Infix (try (string "in") >> return (BinOp "in")) AssocNone |
462 ] |
373 ] |
463 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
374 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
464 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
375 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
465 ] |
376 ] |
466 , [Prefix (try (string "not") >> return (PrefixOp "not"))] |
|
467 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
377 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
468 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
378 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
469 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
379 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
470 , Infix (char '<' >> return (BinOp "<")) AssocNone |
380 , Infix (char '<' >> return (BinOp "<")) AssocNone |
471 , Infix (char '>' >> return (BinOp ">")) AssocNone |
381 , Infix (char '>' >> return (BinOp ">")) AssocNone |