diff -r 55b49cc1f33a -r fcf13e40d6b6 tools/PascalParser.hs --- a/tools/PascalParser.hs Wed Jul 25 10:56:14 2012 -0400 +++ b/tools/PascalParser.hs Wed Jul 25 10:57:00 2012 -0400 @@ -19,7 +19,7 @@ pascalUnit = do comments - u <- choice [program, unit, systemUnit] + u <- choice [program, unit, systemUnit, redoUnit] comments return u @@ -348,36 +348,46 @@ comments return $ Implementation u (TypesAndVars tv) -expression = buildExpressionParser table term "expression" +expression = do + buildExpressionParser table term "expression" where term = comments >> choice [ builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown)) , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e) , brackets pas (commaSep pas iD) >>= return . SetExpression - , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i + , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i , float pas >>= return . FloatLiteral . show - , natural pas >>= return . NumberLiteral . show + , try $ integer pas >>= return . NumberLiteral . show , try (string "_S" >> stringLiteral pas) >>= return . StringLiteral , try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral , stringLiteral pas >>= return . strOrChar , try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c) , char '#' >> many digit >>= \c -> comments >> return (CharCode c) , char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h) - , char '-' >> expression >>= return . PrefixOp "-" + --, char '-' >> expression >>= return . PrefixOp "-" + , char '-' >> reference >>= return . PrefixOp "-" . Reference + , try $ string "not" >> error "unexpected not in term" , try $ string "nil" >> return Null - , try $ string "not" >> expression >>= return . PrefixOp "not" , reference >>= return . Reference ] "simple expression" - table = [ + table = [ + [ Prefix (try (string "not") >> return (PrefixOp "not")) + , Prefix (try (char '-') >> return (PrefixOp "-"))] + , [ Infix (char '*' >> return (BinOp "*")) AssocLeft , Infix (char '/' >> return (BinOp "/")) AssocLeft , Infix (try (string "div") >> return (BinOp "div")) AssocLeft , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft , Infix (try (string "in") >> return (BinOp "in")) AssocNone + , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft + , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft + , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft ] , [ Infix (char '+' >> return (BinOp "+")) AssocLeft , Infix (char '-' >> return (BinOp "-")) AssocLeft + , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft + , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft ] , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone @@ -385,13 +395,13 @@ , Infix (char '<' >> return (BinOp "<")) AssocNone , Infix (char '>' >> return (BinOp ">")) AssocNone ] - , [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone - , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone + {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone + , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone ] - , [ Infix (try $ string "and" >> return (BinOp "and")) AssocLeft - , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft + , [ + Infix (try $ string "or" >> return (BinOp "or")) AssocLeft , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft - ] + ]-} , [ Infix (char '=' >> return (BinOp "=")) AssocNone ] @@ -415,7 +425,7 @@ , switchCase , withBlock , forCycle - , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r + , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown)) , procCall , char ';' >> comments >> return NOP @@ -480,7 +490,12 @@ comments e1 <- expression comments - choice [string "to", string "downto"] + up <- liftM (== Just "to") $ + optionMaybe $ choice [ + try $ string "to" + , try $ string "downto" + ] + --choice [string "to", string "downto"] comments e2 <- expression comments @@ -488,7 +503,7 @@ comments p <- phrase comments - return $ ForCycle i e1 e2 p + return $ ForCycle i e1 e2 p up switchCase = do try $ string "case" @@ -573,14 +588,20 @@ table = [ [ Prefix (char '-' >> return (InitPrefixOp "-")) + ,Prefix (try (string "not") >> return (InitPrefixOp "not")) ] , [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft , Infix (char '/' >> return (InitBinOp "/")) AssocLeft , Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft , Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft + , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft + , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone + , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone ] , [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft , Infix (char '-' >> return (InitBinOp "-")) AssocLeft + , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft + , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft ] , [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone , Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone @@ -589,14 +610,14 @@ , Infix (char '>' >> return (InitBinOp ">")) AssocNone , Infix (char '=' >> return (InitBinOp "=")) AssocNone ] - , [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft + {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft ] , [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone - ] - , [Prefix (try (string "not") >> return (InitPrefixOp "not"))] + ]--} + --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))] ] itypeCast = do @@ -621,3 +642,14 @@ string "var" v <- varsDecl True return $ System (t ++ v) + +redoUnit = do + string "redo;" + comments + string "type" + comments + t <- typesDecl + string "var" + v <- varsDecl True + return $ Redo (t ++ v) +