25 deriving Show |
25 deriving Show |
26 data TypesAndVars = TypesAndVars [TypeVarDeclaration] |
26 data TypesAndVars = TypesAndVars [TypeVarDeclaration] |
27 deriving Show |
27 deriving Show |
28 data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl |
28 data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl |
29 | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe InitExpression) |
29 | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe InitExpression) |
30 | FunctionDeclaration Identifier TypeDecl (Maybe (TypesAndVars, Phrase)) |
30 | FunctionDeclaration Identifier TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase)) |
31 deriving Show |
31 deriving Show |
32 data TypeDecl = SimpleType Identifier |
32 data TypeDecl = SimpleType Identifier |
33 | RangeType Range |
33 | RangeType Range |
34 | Sequence [Identifier] |
34 | Sequence [Identifier] |
35 | ArrayDecl Range TypeDecl |
35 | ArrayDecl (Maybe Range) TypeDecl |
36 | RecordType [TypeVarDeclaration] |
36 | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]]) |
37 | PointerTo TypeDecl |
37 | PointerTo TypeDecl |
38 | String Integer |
38 | String Integer |
|
39 | Set TypeDecl |
|
40 | FunctionType TypeDecl [TypeVarDeclaration] |
39 | UnknownType |
41 | UnknownType |
40 deriving Show |
42 deriving Show |
41 data Range = Range Identifier |
43 data Range = Range Identifier |
42 | RangeFromTo InitExpression InitExpression |
44 | RangeFromTo InitExpression InitExpression |
43 deriving Show |
45 deriving Show |
124 |
126 |
125 table = [ |
127 table = [ |
126 [Infix (try (char '.' >> notFollowedBy (char '.')) >> return RecordField) AssocLeft] |
128 [Infix (try (char '.' >> notFollowedBy (char '.')) >> return RecordField) AssocLeft] |
127 ] |
129 ] |
128 |
130 |
129 postfixes r = many postfix >>= return . foldl fp r |
131 postfixes r = many postfix >>= return . foldl (flip ($)) r |
130 postfix = choice [ |
132 postfix = choice [ |
131 parens pas (option [] parameters) >>= return . FunCall |
133 parens pas (option [] parameters) >>= return . FunCall |
132 , char '^' >> return Dereference |
134 , char '^' >> return Dereference |
133 , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement |
135 , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement |
134 ] |
136 ] |
135 fp r f = f r |
|
136 |
137 |
137 |
138 |
138 varsDecl1 = varsParser sepEndBy1 |
139 varsDecl1 = varsParser sepEndBy1 |
139 varsDecl = varsParser sepEndBy |
140 varsDecl = varsParser sepEndBy |
140 varsParser m endsWithSemi = do |
141 varsParser m endsWithSemi = do |
141 vs <- m (aVarDecl endsWithSemi) (semi pas) |
142 vs <- m (aVarDecl endsWithSemi) (semi pas) |
142 return vs |
143 return vs |
143 |
144 |
144 aVarDecl endsWithSemi = do |
145 aVarDecl endsWithSemi = do |
145 when (not endsWithSemi) $ |
146 unless endsWithSemi $ |
146 optional $ choice [ |
147 optional $ choice [ |
147 try $ string "var" |
148 try $ string "var" |
148 , try $ string "const" |
149 , try $ string "const" |
149 , try $ string "out" |
150 , try $ string "out" |
150 ] |
151 ] |
188 char '^' >> typeDecl >>= return . PointerTo |
190 char '^' >> typeDecl >>= return . PointerTo |
189 , try (string "shortstring") >> return (String 255) |
191 , try (string "shortstring") >> return (String 255) |
190 , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255 |
192 , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255 |
191 , arrayDecl |
193 , arrayDecl |
192 , recordDecl |
194 , recordDecl |
|
195 , setDecl |
|
196 , functionType |
193 , sequenceDecl >>= return . Sequence |
197 , sequenceDecl >>= return . Sequence |
194 , try (identifier pas) >>= return . SimpleType . Identifier |
198 , try (identifier pas) >>= return . SimpleType . Identifier |
195 , rangeDecl >>= return . RangeType |
199 , rangeDecl >>= return . RangeType |
196 ] <?> "type declaration" |
200 ] <?> "type declaration" |
197 where |
201 where |
198 arrayDecl = do |
202 arrayDecl = do |
199 try $ string "array" |
203 try $ do |
200 comments |
204 optional $ (try $ string "packed") >> comments |
201 char '[' |
205 string "array" |
202 r <- rangeDecl |
206 comments |
203 char ']' |
207 r <- optionMaybe $ do |
204 comments |
208 char '[' |
|
209 r <- rangeDecl |
|
210 char ']' |
|
211 comments |
|
212 return r |
205 string "of" |
213 string "of" |
206 comments |
214 comments |
207 t <- typeDecl |
215 t <- typeDecl |
208 return $ ArrayDecl r t |
216 return $ ArrayDecl r t |
209 recordDecl = do |
217 recordDecl = do |
210 optional $ (try $ string "packed") >> comments |
218 try $ do |
211 try $ string "record" |
219 optional $ (try $ string "packed") >> comments |
|
220 string "record" |
212 comments |
221 comments |
213 vs <- varsDecl True |
222 vs <- varsDecl True |
|
223 union <- optionMaybe $ do |
|
224 string "case" |
|
225 comments |
|
226 iD |
|
227 comments |
|
228 string "of" |
|
229 comments |
|
230 many unionCase |
214 string "end" |
231 string "end" |
215 return $ RecordType vs |
232 return $ RecordType vs union |
216 sequenceDecl = (parens pas) $ (commaSep pas) iD |
233 setDecl = do |
|
234 try $ string "set" >> space |
|
235 comments |
|
236 string "of" |
|
237 comments |
|
238 liftM Set typeDecl |
|
239 unionCase = do |
|
240 try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ()) |
|
241 char ':' |
|
242 comments |
|
243 u <- parens pas $ varsDecl True |
|
244 char ';' |
|
245 comments |
|
246 return u |
|
247 sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char '=' >> spaces >> integer pas) >> return i) |
|
248 functionType = do |
|
249 fp <- try (string "function") <|> try (string "procedure") |
|
250 comments |
|
251 vs <- option [] $ parens pas $ varsDecl False |
|
252 comments |
|
253 ret <- if (fp == "function") then do |
|
254 char ':' |
|
255 comments |
|
256 ret <- typeDecl |
|
257 comments |
|
258 return ret |
|
259 else |
|
260 return UnknownType |
|
261 optional $ try $ char ';' >> comments >> string "cdecl" |
|
262 comments |
|
263 return $ FunctionType ret vs |
217 |
264 |
218 typesDecl = many (aTypeDecl >>= \t -> comments >> return t) |
265 typesDecl = many (aTypeDecl >>= \t -> comments >> return t) |
219 where |
266 where |
220 aTypeDecl = do |
267 aTypeDecl = do |
221 i <- try $ do |
268 i <- try $ do |
268 comments |
314 comments |
269 t <- typesDecl |
315 t <- typesDecl |
270 comments |
316 comments |
271 return t |
317 return t |
272 |
318 |
273 procDecl = do |
319 funcDecl = do |
274 try $ string "procedure" |
320 fp <- try (string "function") <|> try (string "procedure") |
275 comments |
321 comments |
276 i <- iD |
322 i <- iD |
277 optional $ parens pas $ varsDecl False |
323 vs <- option [] $ parens pas $ varsDecl False |
278 comments |
324 comments |
|
325 ret <- if (fp == "function") then do |
|
326 char ':' |
|
327 comments |
|
328 ret <- typeDecl |
|
329 comments |
|
330 return ret |
|
331 else |
|
332 return UnknownType |
279 char ';' |
333 char ';' |
280 comments |
334 comments |
281 forward <- liftM isJust $ optionMaybe ((try $ string "forward;") >> comments) |
335 forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments) |
|
336 many functionDecorator |
282 b <- if isImpl && (not forward) then |
337 b <- if isImpl && (not forward) then |
283 liftM Just functionBody |
338 liftM Just functionBody |
284 else |
339 else |
285 return Nothing |
340 return Nothing |
286 -- comments |
341 return $ [FunctionDeclaration i ret vs b] |
287 return $ [FunctionDeclaration i UnknownType b] |
342 functionDecorator = choice [ |
288 |
343 try $ string "inline;" |
289 funcDecl = do |
344 , try $ string "cdecl;" |
290 try $ string "function" |
345 , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";" |
291 comments |
346 ] >> comments |
292 i <- iD |
|
293 optional $ parens pas $ varsDecl False |
|
294 comments |
|
295 char ':' |
|
296 comments |
|
297 ret <- typeDecl |
|
298 comments |
|
299 char ';' |
|
300 comments |
|
301 forward <- liftM isJust $ optionMaybe ((try $ string "forward;") >> comments) |
|
302 b <- if isImpl && (not forward) then |
|
303 liftM Just functionBody |
|
304 else |
|
305 return Nothing |
|
306 return $ [FunctionDeclaration i ret b] |
|
307 |
|
308 program = do |
347 program = do |
309 string "program" |
348 string "program" |
310 comments |
349 comments |
311 name <- iD |
350 name <- iD |
312 (char ';') |
351 (char ';') |
364 , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft |
403 , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft |
365 ] |
404 ] |
366 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
405 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
367 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
406 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
368 ] |
407 ] |
|
408 , [Prefix (try (string "not") >> return (PrefixOp "not"))] |
369 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
409 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
370 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
410 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
371 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
411 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
372 , Infix (char '<' >> return (BinOp "<")) AssocNone |
412 , Infix (char '<' >> return (BinOp "<")) AssocNone |
373 , Infix (char '>' >> return (BinOp ">")) AssocNone |
413 , Infix (char '>' >> return (BinOp ">")) AssocNone |
378 , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft |
418 , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft |
379 ] |
419 ] |
380 , [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone |
420 , [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone |
381 , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone |
421 , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone |
382 ] |
422 ] |
383 , [Prefix (try (string "not") >> return (PrefixOp "not"))] |
|
384 ] |
423 ] |
385 |
424 |
386 phrasesBlock = do |
425 phrasesBlock = do |
387 try $ string "begin" |
426 try $ string "begin" |
388 comments |
427 comments |
432 comments |
471 comments |
433 o <- phrase |
472 o <- phrase |
434 return $ WhileCycle e o |
473 return $ WhileCycle e o |
435 |
474 |
436 withBlock = do |
475 withBlock = do |
437 try $ string "with" |
476 try $ string "with" >> space |
438 comments |
477 comments |
439 rs <- (commaSep1 pas) reference |
478 rs <- (commaSep1 pas) reference |
440 comments |
479 comments |
441 string "do" |
480 string "do" |
442 comments |
481 comments |
443 o <- phrase |
482 o <- phrase |
444 return $ foldr WithBlock o rs |
483 return $ foldr WithBlock o rs |
445 |
484 |
446 repeatCycle = do |
485 repeatCycle = do |
447 try $ string "repeat" |
486 try $ string "repeat" >> space |
448 comments |
487 comments |
449 o <- many phrase |
488 o <- many phrase |
450 string "until" |
489 string "until" |
451 comments |
490 comments |
452 e <- expression |
491 e <- expression |
453 comments |
492 comments |
454 return $ RepeatCycle e o |
493 return $ RepeatCycle e o |
455 |
494 |
456 forCycle = do |
495 forCycle = do |
457 try $ string "for" |
496 try $ string "for" >> space |
458 comments |
497 comments |
459 i <- iD |
498 i <- iD |
460 comments |
499 comments |
461 string ":=" |
500 string ":=" |
462 comments |
501 comments |