1 module PascalParser where |
1 module PascalParser where |
2 |
2 |
3 import Text.Parsec.Expr |
3 import Text.Parsec |
4 import Text.Parsec.Char |
4 import Text.Parsec.Char |
5 import Text.Parsec.Token |
5 import Text.Parsec.Token |
6 import Text.Parsec.Language |
6 import Text.Parsec.Language |
|
7 import Text.Parsec.Expr |
7 import Text.Parsec.Prim |
8 import Text.Parsec.Prim |
8 import Text.Parsec.Combinator |
9 import Text.Parsec.Combinator |
9 import Text.Parsec.String |
10 import Text.Parsec.String |
10 import Control.Monad |
11 import Control.Monad |
|
12 import Data.Maybe |
11 import Data.Char |
13 import Data.Char |
12 |
14 |
13 data PascalUnit = |
15 import PascalBasics |
14 Program Identifier Implementation |
16 import PascalUnitSyntaxTree |
15 | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize) |
17 |
16 deriving Show |
18 knownTypes = ["shortstring", "ansistring", "char", "byte"] |
17 data Interface = Interface Uses TypesAndVars |
|
18 deriving Show |
|
19 data Implementation = Implementation Uses TypesAndVars |
|
20 deriving Show |
|
21 data Identifier = Identifier String |
|
22 deriving Show |
|
23 data TypesAndVars = TypesAndVars [TypeVarDeclaration] |
|
24 deriving Show |
|
25 data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl |
|
26 | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe Expression) |
|
27 | FunctionDeclaration Identifier TypeDecl (Maybe Phrase) |
|
28 deriving Show |
|
29 data TypeDecl = SimpleType Identifier |
|
30 | RangeType Range |
|
31 | Sequence [Identifier] |
|
32 | ArrayDecl Range TypeDecl |
|
33 | RecordType [TypeVarDeclaration] |
|
34 | PointerTo TypeDecl |
|
35 | String |
|
36 | UnknownType |
|
37 deriving Show |
|
38 data Range = Range Identifier |
|
39 | RangeFromTo Expression Expression |
|
40 deriving Show |
|
41 data Initialize = Initialize String |
|
42 deriving Show |
|
43 data Finalize = Finalize String |
|
44 deriving Show |
|
45 data Uses = Uses [Identifier] |
|
46 deriving Show |
|
47 data Phrase = ProcCall Identifier [Expression] |
|
48 | IfThenElse Expression Phrase (Maybe Phrase) |
|
49 | WhileCycle Expression Phrase |
|
50 | RepeatCycle Expression [Phrase] |
|
51 | ForCycle Identifier Expression Expression Phrase |
|
52 | WithBlock Expression Phrase |
|
53 | Phrases [Phrase] |
|
54 | SwitchCase Expression [(Expression, Phrase)] (Maybe Phrase) |
|
55 | Assignment Reference Expression |
|
56 deriving Show |
|
57 data Expression = Expression String |
|
58 | PrefixOp String Expression |
|
59 | PostfixOp String Expression |
|
60 | BinOp String Expression Expression |
|
61 | StringLiteral String |
|
62 | CharCode String |
|
63 | NumberLiteral String |
|
64 | HexNumber String |
|
65 | Reference Reference |
|
66 | Null |
|
67 deriving Show |
|
68 data Reference = ArrayElement [Expression] Reference |
|
69 | FunCall [Expression] Reference |
|
70 | SimpleReference Identifier |
|
71 | Dereference Reference |
|
72 | RecordField Reference Reference |
|
73 | Address Reference |
|
74 deriving Show |
|
75 |
|
76 pascalLanguageDef |
|
77 = emptyDef |
|
78 { commentStart = "(*" |
|
79 , commentEnd = "*)" |
|
80 , commentLine = "//" |
|
81 , nestedComments = False |
|
82 , identStart = letter <|> oneOf "_" |
|
83 , identLetter = alphaNum <|> oneOf "_." |
|
84 , reservedNames = [ |
|
85 "begin", "end", "program", "unit", "interface" |
|
86 , "implementation", "and", "or", "xor", "shl" |
|
87 , "shr", "while", "do", "repeat", "until", "case", "of" |
|
88 , "type", "var", "const", "out", "array", "packed" |
|
89 , "procedure", "function", "with", "for", "to" |
|
90 , "downto", "div", "mod", "record", "set", "nil" |
|
91 , "string", "shortstring" |
|
92 ] |
|
93 , reservedOpNames= [] |
|
94 , caseSensitive = False |
|
95 } |
|
96 |
|
97 pas = patch $ makeTokenParser pascalLanguageDef |
|
98 where |
|
99 patch tp = tp {stringLiteral = sl} |
|
100 sl = do |
|
101 (char '\'') |
|
102 s <- (many $ noneOf "'") |
|
103 (char '\'') |
|
104 ss <- many $ do |
|
105 (char '\'') |
|
106 s' <- (many $ noneOf "'") |
|
107 (char '\'') |
|
108 return $ '\'' : s' |
|
109 comments |
|
110 return $ concat (s:ss) |
|
111 |
|
112 comments = do |
|
113 spaces |
|
114 skipMany $ do |
|
115 comment |
|
116 spaces |
|
117 |
19 |
118 pascalUnit = do |
20 pascalUnit = do |
119 comments |
21 comments |
120 u <- choice [program, unit] |
22 u <- choice [program, unit, systemUnit, redoUnit] |
121 comments |
23 comments |
122 return u |
24 return u |
123 |
25 |
124 comment = choice [ |
|
125 char '{' >> manyTill anyChar (try $ char '}') |
|
126 , (try $ string "(*") >> manyTill anyChar (try $ string "*)") |
|
127 , (try $ string "//") >> manyTill anyChar (try newline) |
|
128 ] |
|
129 |
|
130 iD = do |
26 iD = do |
131 i <- liftM Identifier (identifier pas) |
27 i <- liftM (flip Identifier BTUnknown) (identifier pas) |
132 comments |
28 comments |
133 return i |
29 return i |
134 |
30 |
135 unit = do |
31 unit = do |
136 string "unit" >> comments |
32 string "unit" >> comments |
137 name <- iD |
33 name <- iD |
138 semi pas |
34 semi pas |
139 comments |
35 comments |
140 int <- interface |
36 int <- interface |
141 impl <- implementation |
37 impl <- implementation |
142 comments |
38 comments |
143 return $ Unit name int impl Nothing Nothing |
39 return $ Unit name int impl Nothing Nothing |
144 |
40 |
145 |
41 |
146 reference = buildExpressionParser table term <?> "reference" |
42 reference = buildExpressionParser table term <?> "reference" |
147 where |
43 where |
148 term = comments >> choice [ |
44 term = comments >> choice [ |
149 parens pas reference |
45 parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes |
150 , char '@' >> reference >>= return . Address |
46 , try $ typeCast >>= postfixes |
151 , iD >>= return . SimpleReference |
47 , char '@' >> liftM Address reference >>= postfixes |
|
48 , liftM SimpleReference iD >>= postfixes |
152 ] <?> "simple reference" |
49 ] <?> "simple reference" |
153 |
50 |
154 table = [ |
51 table = [ |
155 [Postfix $ (parens pas) (option [] parameters) >>= return . FunCall] |
|
156 , [Postfix (char '^' >> return Dereference)] |
|
157 , [Postfix $ (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement] |
|
158 , [Infix (try (char '.' >> notFollowedBy (char '.')) >> return RecordField) AssocLeft] |
|
159 ] |
52 ] |
160 |
53 |
161 |
54 postfixes r = many postfix >>= return . foldl (flip ($)) r |
162 varsDecl1 = varsParser sepEndBy1 |
55 postfix = choice [ |
|
56 parens pas (option [] parameters) >>= return . FunCall |
|
57 , char '^' >> return Dereference |
|
58 , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement |
|
59 , (char '.' >> notFollowedBy (char '.')) >> liftM (flip RecordField) reference |
|
60 ] |
|
61 |
|
62 typeCast = do |
|
63 t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes |
|
64 e <- parens pas expression |
|
65 comments |
|
66 return $ TypeCast (Identifier t BTUnknown) e |
|
67 |
|
68 varsDecl1 = varsParser sepEndBy1 |
163 varsDecl = varsParser sepEndBy |
69 varsDecl = varsParser sepEndBy |
164 varsParser m endsWithSemi = do |
70 varsParser m endsWithSemi = do |
165 vs <- m (aVarDecl endsWithSemi) (semi pas) |
71 vs <- m (aVarDecl endsWithSemi) (semi pas) |
166 return vs |
72 return vs |
167 |
73 |
168 aVarDecl endsWithSemi = do |
74 aVarDecl endsWithSemi = do |
169 when (not endsWithSemi) $ |
75 isVar <- liftM (== Just "var") $ |
170 optional $ choice [ |
76 if not endsWithSemi then |
171 try $ string "var" |
77 optionMaybe $ choice [ |
172 , try $ string "const" |
78 try $ string "var" |
173 , try $ string "out" |
79 , try $ string "const" |
174 ] |
80 , try $ string "out" |
|
81 ] |
|
82 else |
|
83 return Nothing |
175 comments |
84 comments |
176 ids <- do |
85 ids <- do |
177 i <- (commaSep1 pas) $ (try iD <?> "variable declaration") |
86 i <- (commaSep1 pas) $ (try iD <?> "variable declaration") |
178 char ':' |
87 char ':' |
179 return i |
88 return i |
181 t <- typeDecl <?> "variable type declaration" |
90 t <- typeDecl <?> "variable type declaration" |
182 comments |
91 comments |
183 init <- option Nothing $ do |
92 init <- option Nothing $ do |
184 char '=' |
93 char '=' |
185 comments |
94 comments |
186 e <- expression |
95 e <- initExpression |
187 comments |
96 comments |
188 return (Just e) |
97 return (Just e) |
189 return $ VarDeclaration False (ids, t) init |
98 return $ VarDeclaration isVar False (ids, t) init |
190 |
99 |
191 |
100 |
192 constsDecl = do |
101 constsDecl = do |
193 vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i) |
102 vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i) |
194 comments |
103 comments |
195 return vs |
104 return vs |
196 where |
105 where |
197 aConstDecl = do |
106 aConstDecl = do |
198 comments |
107 comments |
199 i <- iD <?> "const declaration" |
108 i <- iD |
200 optional $ do |
109 t <- optionMaybe $ do |
201 char ':' |
110 char ':' |
202 comments |
111 comments |
203 t <- typeDecl |
112 t <- typeDecl |
204 return () |
113 comments |
|
114 return t |
205 char '=' |
115 char '=' |
206 comments |
116 comments |
207 e <- expression |
117 e <- initExpression |
208 comments |
118 comments |
209 return $ VarDeclaration False ([i], UnknownType) (Just e) |
119 return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e) |
210 |
120 |
211 typeDecl = choice [ |
121 typeDecl = choice [ |
212 char '^' >> typeDecl >>= return . PointerTo |
122 char '^' >> typeDecl >>= return . PointerTo |
213 , try (string "shortstring") >> return String |
123 , try (string "shortstring") >> return (String 255) |
|
124 , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255 |
|
125 , try (string "ansistring") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255 |
214 , arrayDecl |
126 , arrayDecl |
215 , recordDecl |
127 , recordDecl |
|
128 , setDecl |
|
129 , functionType |
|
130 , sequenceDecl >>= return . Sequence |
|
131 , try iD >>= return . SimpleType |
216 , rangeDecl >>= return . RangeType |
132 , rangeDecl >>= return . RangeType |
217 , sequenceDecl >>= return . Sequence |
|
218 , identifier pas >>= return . SimpleType . Identifier |
|
219 ] <?> "type declaration" |
133 ] <?> "type declaration" |
220 where |
134 where |
221 arrayDecl = do |
135 arrayDecl = do |
222 try $ string "array" |
136 try $ do |
223 comments |
137 optional $ (try $ string "packed") >> comments |
224 char '[' |
138 string "array" |
225 r <- rangeDecl |
139 comments |
226 char ']' |
140 r <- option [] $ do |
227 comments |
141 char '[' |
|
142 r <- commaSep pas rangeDecl |
|
143 char ']' |
|
144 comments |
|
145 return r |
228 string "of" |
146 string "of" |
229 comments |
147 comments |
230 t <- typeDecl |
148 t <- typeDecl |
231 return $ ArrayDecl r t |
149 if null r then |
|
150 return $ ArrayDecl Nothing t |
|
151 else |
|
152 return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r) |
232 recordDecl = do |
153 recordDecl = do |
233 optional $ (try $ string "packed") >> comments |
154 try $ do |
234 try $ string "record" |
155 optional $ (try $ string "packed") >> comments |
|
156 string "record" |
235 comments |
157 comments |
236 vs <- varsDecl True |
158 vs <- varsDecl True |
|
159 union <- optionMaybe $ do |
|
160 string "case" |
|
161 comments |
|
162 iD |
|
163 comments |
|
164 string "of" |
|
165 comments |
|
166 many unionCase |
237 string "end" |
167 string "end" |
238 return $ RecordType vs |
168 return $ RecordType vs union |
239 sequenceDecl = (parens pas) $ (commaSep pas) iD |
169 setDecl = do |
|
170 try $ string "set" >> space |
|
171 comments |
|
172 string "of" |
|
173 comments |
|
174 liftM Set typeDecl |
|
175 unionCase = do |
|
176 try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ()) |
|
177 char ':' |
|
178 comments |
|
179 u <- parens pas $ varsDecl True |
|
180 char ';' |
|
181 comments |
|
182 return u |
|
183 sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i) |
|
184 functionType = do |
|
185 fp <- try (string "function") <|> try (string "procedure") |
|
186 comments |
|
187 vs <- option [] $ parens pas $ varsDecl False |
|
188 comments |
|
189 ret <- if (fp == "function") then do |
|
190 char ':' |
|
191 comments |
|
192 ret <- typeDecl |
|
193 comments |
|
194 return ret |
|
195 else |
|
196 return VoidType |
|
197 optional $ try $ char ';' >> comments >> string "cdecl" |
|
198 comments |
|
199 return $ FunctionType ret vs |
240 |
200 |
241 typesDecl = many (aTypeDecl >>= \t -> comments >> return t) |
201 typesDecl = many (aTypeDecl >>= \t -> comments >> return t) |
242 where |
202 where |
243 aTypeDecl = do |
203 aTypeDecl = do |
244 i <- try $ do |
204 i <- try $ do |
250 t <- typeDecl |
210 t <- typeDecl |
251 comments |
211 comments |
252 semi pas |
212 semi pas |
253 comments |
213 comments |
254 return $ TypeDeclaration i t |
214 return $ TypeDeclaration i t |
255 |
215 |
256 rangeDecl = choice [ |
216 rangeDecl = choice [ |
257 try $ rangeft |
217 try $ rangeft |
258 , iD >>= return . Range |
218 , iD >>= return . Range |
259 ] <?> "range declaration" |
219 ] <?> "range declaration" |
260 where |
220 where |
261 rangeft = do |
221 rangeft = do |
262 e1 <- expression |
222 e1 <- initExpression |
263 string ".." |
223 string ".." |
264 e2 <- expression |
224 e2 <- initExpression |
265 return $ RangeFromTo e1 e2 |
225 return $ RangeFromTo e1 e2 |
266 |
226 |
267 typeVarDeclaration isImpl = (liftM concat . many . choice) [ |
227 typeVarDeclaration isImpl = (liftM concat . many . choice) [ |
268 varSection, |
228 varSection, |
269 constSection, |
229 constSection, |
270 typeSection, |
230 typeSection, |
271 funcDecl, |
231 funcDecl, |
272 procDecl |
232 operatorDecl |
273 ] |
233 ] |
274 where |
234 where |
275 varSection = do |
235 varSection = do |
276 try $ string "var" |
236 try $ string "var" |
277 comments |
237 comments |
278 v <- varsDecl1 True |
238 v <- varsDecl1 True <?> "variable declaration" |
279 comments |
239 comments |
280 return v |
240 return v |
281 |
241 |
282 constSection = do |
242 constSection = do |
283 try $ string "const" |
243 try $ string "const" |
284 comments |
244 comments |
285 c <- constsDecl |
245 c <- constsDecl <?> "const declaration" |
286 comments |
246 comments |
287 return c |
247 return c |
288 |
248 |
289 typeSection = do |
249 typeSection = do |
290 try $ string "type" |
250 try $ string "type" |
291 comments |
251 comments |
292 t <- typesDecl |
252 t <- typesDecl <?> "type declaration" |
293 comments |
253 comments |
294 return t |
254 return t |
295 |
255 |
296 procDecl = do |
256 operatorDecl = do |
297 try $ string "procedure" |
257 try $ string "operator" |
298 comments |
258 comments |
299 i <- iD |
259 i <- manyTill anyChar space |
300 optional $ do |
260 comments |
301 char '(' |
261 vs <- parens pas $ varsDecl False |
302 varsDecl False |
262 comments |
303 char ')' |
263 rid <- iD |
304 comments |
264 comments |
|
265 char ':' |
|
266 comments |
|
267 ret <- typeDecl |
|
268 comments |
|
269 return ret |
305 char ';' |
270 char ';' |
306 b <- if isImpl then |
271 comments |
307 do |
272 forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments) |
308 comments |
273 inline <- liftM (any (== "inline;")) $ many functionDecorator |
309 optional $ typeVarDeclaration True |
274 b <- if isImpl && (not forward) then |
310 comments |
|
311 liftM Just functionBody |
275 liftM Just functionBody |
312 else |
276 else |
313 return Nothing |
277 return Nothing |
314 comments |
278 return $ [OperatorDeclaration i rid inline ret vs b] |
315 return $ [FunctionDeclaration i UnknownType b] |
279 |
316 |
280 |
317 funcDecl = do |
281 funcDecl = do |
318 try $ string "function" |
282 fp <- try (string "function") <|> try (string "procedure") |
319 comments |
283 comments |
320 i <- iD |
284 i <- iD |
321 optional $ do |
285 vs <- option [] $ parens pas $ varsDecl False |
322 char '(' |
286 comments |
323 varsDecl False |
287 ret <- if (fp == "function") then do |
324 char ')' |
288 char ':' |
325 comments |
289 comments |
326 char ':' |
290 ret <- typeDecl |
327 comments |
291 comments |
328 ret <- typeDecl |
292 return ret |
329 comments |
293 else |
|
294 return VoidType |
330 char ';' |
295 char ';' |
331 comments |
296 comments |
332 b <- if isImpl then |
297 forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments) |
333 do |
298 inline <- liftM (any (== "inline;")) $ many functionDecorator |
334 optional $ typeVarDeclaration True |
299 b <- if isImpl && (not forward) then |
335 comments |
|
336 liftM Just functionBody |
300 liftM Just functionBody |
337 else |
301 else |
338 return Nothing |
302 return Nothing |
339 return $ [FunctionDeclaration i ret Nothing] |
303 return $ [FunctionDeclaration i inline ret vs b] |
|
304 |
|
305 functionDecorator = do |
|
306 d <- choice [ |
|
307 try $ string "inline;" |
|
308 , try $ caseInsensitiveString "cdecl;" |
|
309 , try $ string "overload;" |
|
310 , try $ string "export;" |
|
311 , try $ string "varargs;" |
|
312 , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";" |
|
313 ] |
|
314 comments |
|
315 return d |
|
316 |
340 |
317 |
341 program = do |
318 program = do |
342 string "program" |
319 string "program" |
343 comments |
320 comments |
344 name <- iD |
321 name <- iD |
345 (char ';') |
322 (char ';') |
346 comments |
323 comments |
347 impl <- implementation |
324 comments |
348 comments |
325 u <- uses |
349 return $ Program name impl |
326 comments |
|
327 tv <- typeVarDeclaration True |
|
328 comments |
|
329 p <- phrase |
|
330 comments |
|
331 char '.' |
|
332 comments |
|
333 return $ Program name (Implementation u (TypesAndVars tv)) p |
350 |
334 |
351 interface = do |
335 interface = do |
352 string "interface" |
336 string "interface" |
353 comments |
337 comments |
354 u <- uses |
338 u <- uses |
365 tv <- typeVarDeclaration True |
349 tv <- typeVarDeclaration True |
366 string "end." |
350 string "end." |
367 comments |
351 comments |
368 return $ Implementation u (TypesAndVars tv) |
352 return $ Implementation u (TypesAndVars tv) |
369 |
353 |
370 expression = buildExpressionParser table term <?> "expression" |
354 expression = do |
|
355 buildExpressionParser table term <?> "expression" |
371 where |
356 where |
372 term = comments >> choice [ |
357 term = comments >> choice [ |
373 parens pas $ expression |
358 builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown)) |
|
359 , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e) |
|
360 , brackets pas (commaSep pas iD) >>= return . SetExpression |
|
361 , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i |
|
362 , float pas >>= return . FloatLiteral . show |
374 , try $ integer pas >>= return . NumberLiteral . show |
363 , try $ integer pas >>= return . NumberLiteral . show |
375 , stringLiteral pas >>= return . StringLiteral |
364 , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral |
376 , char '#' >> many digit >>= return . CharCode |
365 , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral |
377 , char '$' >> many hexDigit >>= return . HexNumber |
366 , stringLiteral pas >>= return . strOrChar |
|
367 , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c) |
|
368 , char '#' >> many digit >>= \c -> comments >> return (CharCode c) |
|
369 , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h) |
|
370 --, char '-' >> expression >>= return . PrefixOp "-" |
|
371 , char '-' >> reference >>= return . PrefixOp "-" . Reference |
|
372 , (try $ string "not" >> notFollowedBy comments) >> unexpected "'not'" |
378 , try $ string "nil" >> return Null |
373 , try $ string "nil" >> return Null |
379 , reference >>= return . Reference |
374 , reference >>= return . Reference |
380 ] <?> "simple expression" |
375 ] <?> "simple expression" |
381 |
376 |
382 table = [ |
377 table = [ |
|
378 [ Prefix (try (string "not") >> return (PrefixOp "not")) |
|
379 , Prefix (try (char '-') >> return (PrefixOp "-"))] |
|
380 , |
383 [ Infix (char '*' >> return (BinOp "*")) AssocLeft |
381 [ Infix (char '*' >> return (BinOp "*")) AssocLeft |
384 , Infix (char '/' >> return (BinOp "/")) AssocLeft |
382 , Infix (char '/' >> return (BinOp "/")) AssocLeft |
385 , Infix (try (string "div") >> return (BinOp "div")) AssocLeft |
383 , Infix (try (string "div") >> return (BinOp "div")) AssocLeft |
386 , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft |
384 , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft |
|
385 , Infix (try (string "in") >> return (BinOp "in")) AssocNone |
|
386 , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft |
|
387 , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft |
|
388 , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft |
387 ] |
389 ] |
388 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
390 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
389 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
391 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
390 , Prefix (char '-' >> return (PrefixOp "-")) |
392 , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft |
|
393 , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft |
391 ] |
394 ] |
392 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
395 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
393 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
396 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
394 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
397 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
395 , Infix (char '<' >> return (BinOp "<")) AssocNone |
398 , Infix (char '<' >> return (BinOp "<")) AssocNone |
396 , Infix (char '>' >> return (BinOp ">")) AssocNone |
399 , Infix (char '>' >> return (BinOp ">")) AssocNone |
397 , Infix (char '=' >> return (BinOp "=")) AssocNone |
400 ] |
398 ] |
401 {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone |
399 , [ Infix (try $ string "and" >> return (BinOp "and")) AssocLeft |
402 , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone |
400 , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft |
403 ] |
|
404 , [ |
|
405 Infix (try $ string "or" >> return (BinOp "or")) AssocLeft |
401 , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft |
406 , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft |
402 ] |
407 ]-} |
403 , [ Infix (try $ string "shl" >> return (BinOp "and")) AssocNone |
408 , [ |
404 , Infix (try $ string "shr" >> return (BinOp "or")) AssocNone |
409 Infix (char '=' >> return (BinOp "=")) AssocNone |
405 ] |
410 ] |
406 , [Prefix (try (string "not") >> return (PrefixOp "not"))] |
|
407 ] |
411 ] |
408 |
412 strOrChar [a] = CharCode . show . ord $ a |
|
413 strOrChar a = StringLiteral a |
|
414 |
409 phrasesBlock = do |
415 phrasesBlock = do |
410 try $ string "begin" |
416 try $ string "begin" |
411 comments |
417 comments |
412 p <- manyTill phrase (try $ string "end") |
418 p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum) |
413 comments |
419 comments |
414 return $ Phrases p |
420 return $ Phrases p |
415 |
421 |
416 phrase = do |
422 phrase = do |
417 o <- choice [ |
423 o <- choice [ |
418 phrasesBlock |
424 phrasesBlock |
419 , ifBlock |
425 , ifBlock |
420 , whileCycle |
426 , whileCycle |
421 , repeatCycle |
427 , repeatCycle |
422 , switchCase |
428 , switchCase |
423 , withBlock |
429 , withBlock |
424 , forCycle |
430 , forCycle |
425 , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r |
431 , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r |
|
432 , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown)) |
426 , procCall |
433 , procCall |
|
434 , char ';' >> comments >> return NOP |
427 ] |
435 ] |
428 optional $ char ';' |
436 optional $ char ';' |
429 comments |
437 comments |
430 return o |
438 return o |
431 |
439 |
432 ifBlock = do |
440 ifBlock = do |
433 try $ string "if" |
441 try $ string "if" >> notFollowedBy (alphaNum <|> char '_') |
434 comments |
442 comments |
435 e <- expression |
443 e <- expression |
436 comments |
444 comments |
437 string "then" |
445 string "then" |
438 comments |
446 comments |
439 o1 <- phrase |
447 o1 <- phrase |
440 comments |
448 comments |
441 o2 <- optionMaybe $ do |
449 o2 <- optionMaybe $ do |
442 try $ string "else" |
450 try $ string "else" >> space |
443 comments |
451 comments |
444 o <- phrase |
452 o <- option NOP phrase |
445 comments |
453 comments |
446 return o |
454 return o |
447 return $ IfThenElse e o1 o2 |
455 return $ IfThenElse e o1 o2 |
448 |
456 |
449 whileCycle = do |
457 whileCycle = do |
455 comments |
463 comments |
456 o <- phrase |
464 o <- phrase |
457 return $ WhileCycle e o |
465 return $ WhileCycle e o |
458 |
466 |
459 withBlock = do |
467 withBlock = do |
460 try $ string "with" |
468 try $ string "with" >> space |
461 comments |
469 comments |
462 e <- expression |
470 rs <- (commaSep1 pas) reference |
463 comments |
471 comments |
464 string "do" |
472 string "do" |
465 comments |
473 comments |
466 o <- phrase |
474 o <- phrase |
467 return $ WithBlock e o |
475 return $ foldr WithBlock o rs |
468 |
476 |
469 repeatCycle = do |
477 repeatCycle = do |
470 try $ string "repeat" |
478 try $ string "repeat" >> space |
471 comments |
479 comments |
472 o <- many phrase |
480 o <- many phrase |
473 string "until" |
481 string "until" |
474 comments |
482 comments |
475 e <- expression |
483 e <- expression |
476 comments |
484 comments |
477 return $ RepeatCycle e o |
485 return $ RepeatCycle e o |
478 |
486 |
479 forCycle = do |
487 forCycle = do |
480 try $ string "for" |
488 try $ string "for" >> space |
481 comments |
489 comments |
482 i <- iD |
490 i <- iD |
483 comments |
491 comments |
484 string ":=" |
492 string ":=" |
485 comments |
493 comments |
486 e1 <- expression |
494 e1 <- expression |
487 comments |
495 comments |
488 choice [string "to", string "downto"] |
496 up <- liftM (== Just "to") $ |
|
497 optionMaybe $ choice [ |
|
498 try $ string "to" |
|
499 , try $ string "downto" |
|
500 ] |
|
501 --choice [string "to", string "downto"] |
489 comments |
502 comments |
490 e2 <- expression |
503 e2 <- expression |
491 comments |
504 comments |
492 string "do" |
505 string "do" |
493 comments |
506 comments |
494 p <- phrase |
507 p <- phrase |
495 comments |
508 comments |
496 return $ ForCycle i e1 e2 p |
509 return $ ForCycle i e1 e2 p up |
497 |
510 |
498 switchCase = do |
511 switchCase = do |
499 try $ string "case" |
512 try $ string "case" |
500 comments |
513 comments |
501 e <- expression |
514 e <- expression |
502 comments |
515 comments |
503 string "of" |
516 string "of" |
504 comments |
517 comments |
505 cs <- many1 aCase |
518 cs <- many1 aCase |
506 o2 <- optionMaybe $ do |
519 o2 <- optionMaybe $ do |
507 try $ string "else" |
520 try $ string "else" >> notFollowedBy alphaNum |
508 comments |
521 comments |
509 o <- phrase |
522 o <- many phrase |
510 comments |
523 comments |
511 return o |
524 return o |
512 string "end" |
525 string "end" |
|
526 comments |
513 return $ SwitchCase e cs o2 |
527 return $ SwitchCase e cs o2 |
514 where |
528 where |
515 aCase = do |
529 aCase = do |
516 e <- expression |
530 e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression) |
517 comments |
531 comments |
518 char ':' |
532 char ':' |
519 comments |
533 comments |
520 p <- phrase |
534 p <- phrase |
521 comments |
535 comments |
522 return (e, p) |
536 return (e, p) |
523 |
537 |
524 procCall = do |
538 procCall = do |
525 i <- iD |
539 r <- reference |
526 p <- option [] $ (parens pas) parameters |
540 p <- option [] $ (parens pas) parameters |
527 return $ ProcCall i p |
541 return $ ProcCall r p |
528 |
542 |
529 parameters = (commaSep pas) expression <?> "parameters" |
543 parameters = (commaSep pas) expression <?> "parameters" |
530 |
544 |
531 functionBody = do |
545 functionBody = do |
|
546 tv <- typeVarDeclaration True |
|
547 comments |
532 p <- phrasesBlock |
548 p <- phrasesBlock |
533 char ';' |
549 char ';' |
534 comments |
550 comments |
535 return p |
551 return (TypesAndVars tv, p) |
536 |
552 |
537 uses = liftM Uses (option [] u) |
553 uses = liftM Uses (option [] u) |
538 where |
554 where |
539 u = do |
555 u = do |
540 string "uses" |
556 string "uses" |
541 comments |
557 comments |
542 u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments) |
558 u <- (iD >>= \i -> comments >> return i) `sepBy1` (char ',' >> comments) |
543 char ';' |
559 char ';' |
544 comments |
560 comments |
545 return u |
561 return u |
|
562 |
|
563 initExpression = buildExpressionParser table term <?> "initialization expression" |
|
564 where |
|
565 term = comments >> choice [ |
|
566 liftM (uncurry BuiltInFunction) $ builtInFunction initExpression |
|
567 , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet |
|
568 , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when (null $ tail ia) mzero >> return (InitArray ia) |
|
569 , try $ parens pas (sepEndBy recField (char ';' >> comments)) >>= return . InitRecord |
|
570 , parens pas initExpression |
|
571 , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . InitNumber . show) i |
|
572 , try $ float pas >>= return . InitFloat . show |
|
573 , try $ integer pas >>= return . InitNumber . show |
|
574 , stringLiteral pas >>= return . InitString |
|
575 , char '#' >> many digit >>= \c -> comments >> return (InitChar c) |
|
576 , char '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h) |
|
577 , char '@' >> initExpression >>= \c -> comments >> return (InitAddress c) |
|
578 , try $ string "nil" >> return InitNull |
|
579 , itypeCast |
|
580 , iD >>= return . InitReference |
|
581 ] |
|
582 |
|
583 recField = do |
|
584 i <- iD |
|
585 spaces |
|
586 char ':' |
|
587 spaces |
|
588 e <- initExpression |
|
589 spaces |
|
590 return (i ,e) |
|
591 |
|
592 table = [ |
|
593 [ |
|
594 Prefix (char '-' >> return (InitPrefixOp "-")) |
|
595 ,Prefix (try (string "not") >> return (InitPrefixOp "not")) |
|
596 ] |
|
597 , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft |
|
598 , Infix (char '/' >> return (InitBinOp "/")) AssocLeft |
|
599 , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft |
|
600 , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft |
|
601 , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft |
|
602 , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone |
|
603 , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone |
|
604 ] |
|
605 , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft |
|
606 , Infix (char '-' >> return (InitBinOp "-")) AssocLeft |
|
607 , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft |
|
608 , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft |
|
609 ] |
|
610 , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone |
|
611 , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone |
|
612 , Infix (try (string ">=") >> return (InitBinOp ">=")) AssocNone |
|
613 , Infix (char '<' >> return (InitBinOp "<")) AssocNone |
|
614 , Infix (char '>' >> return (InitBinOp ">")) AssocNone |
|
615 , Infix (char '=' >> return (InitBinOp "=")) AssocNone |
|
616 ] |
|
617 {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft |
|
618 , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft |
|
619 , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft |
|
620 ] |
|
621 , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone |
|
622 , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone |
|
623 ]--} |
|
624 --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))] |
|
625 ] |
|
626 |
|
627 itypeCast = do |
|
628 t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes |
|
629 i <- parens pas initExpression |
|
630 comments |
|
631 return $ InitTypeCast (Identifier t BTUnknown) i |
|
632 |
|
633 builtInFunction e = do |
|
634 name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin |
|
635 spaces |
|
636 exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e |
|
637 spaces |
|
638 return (name, exprs) |
|
639 |
|
640 systemUnit = do |
|
641 string "system;" |
|
642 comments |
|
643 string "type" |
|
644 comments |
|
645 t <- typesDecl |
|
646 string "var" |
|
647 v <- varsDecl True |
|
648 return $ System (t ++ v) |
|
649 |
|
650 redoUnit = do |
|
651 string "redo;" |
|
652 comments |
|
653 string "type" |
|
654 comments |
|
655 t <- typesDecl |
|
656 string "var" |
|
657 v <- varsDecl True |
|
658 return $ Redo (t ++ v) |
|
659 |