--
-- Copyright (c)2007 Chris Pressey, Cat's Eye Technologies.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
--
-- 1. Redistributions of source code must retain the above copyright
-- notices, this list of conditions and the following disclaimer.
-- 2. Redistributions in binary form must reproduce the above copyright
-- notices, this list of conditions, and the following disclaimer in
-- the documentation and/or other materials provided with the
-- distribution.
-- 3. Neither the names of the copyright holders nor the names of their
-- contributors may be used to endorse or promote products derived
-- from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-- COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
--
-----------------------------------------------------------------------
-- ============================== Parser =========================== --
-----------------------------------------------------------------------
module Parser where
import Scanner
import Primitive
import AST
--
-- Utility
--
expect [] l = l
expect (x:xs) (y:ys)
| x == y =
expect xs ys
--
-- Statement ::= "if" BoolExpr "then" Statement "else" Statement
-- | "while" BoolExpr "do" Statement
-- | "begin" Statement {";" Statement} "end"
-- | "var" VarName "in" Statement
-- | "print" NumExpr
-- | VarName ":=" NumExpr
--
parseStatement (IfToken:tokens) =
let
(tokens2, be) = parseBoolExpr tokens
tokens3 = expect [ThenToken] tokens2
(tokens4, s1) = parseStatement tokens3
tokens5 = expect [ElseToken] tokens4
(tokens6, s2) = parseStatement tokens5
in
(tokens6, IfStmt be s1 s2)
parseStatement (VarToken:tokens) =
let
((Ident ident):tokens2) = tokens
v = VarName ident
tokens3 = expect [InToken] tokens2
(tokens4, s) = parseStatement tokens3
in
(tokens4, Var v s)
parseStatement (WhileToken:tokens) =
let
(tokens2, be) = parseBoolExpr tokens
tokens3 = expect [DoToken] tokens2
(tokens4, s) = parseStatement tokens3
in
(tokens4, While be s)
parseStatement (PrintToken:tokens) =
let
(tokens2, ne) = parseNumExpr tokens
in
(tokens2, Print ne)
parseStatement ((Ident s):tokens) =
let
v = VarName s
tokens2 = expect [BecomesToken] tokens
(tokens3, ne) = parseNumExpr tokens2
in
(tokens3, Assign v ne)
parseStatement (BeginToken:tokens) =
let
(tokens2, stmtList) = parseStmtList tokens []
in
(tokens2, Block (reverse stmtList))
parseStmtList tokens acc =
let
(tokens2, s) = parseStatement tokens
in
case tokens2 of
(StmtSepToken:rest) ->
parseStmtList rest (s : acc)
(EndToken:rest) ->
(rest, (s:acc))
--
-- NumExpr ::= AddExpr.
--
parseNumExpr tokens = parseAddExpr tokens
--
-- AddExpr ::= MulExpr {("+" | "-") MulExpr}.
--
parseAddExpr tokens =
let
(tokens2, lhs) = parseMulExpr tokens
in
parseAddExprTail tokens2 lhs
parseAddExprTail (AddToken:tokens) lhs =
let
(tokens2, rhs) = parseMulExpr tokens
newLhs = NumOp Add lhs rhs
in
parseAddExprTail tokens2 newLhs
parseAddExprTail (SubtractToken:tokens) lhs =
let
(tokens2, rhs) = parseMulExpr tokens
newLhs = NumOp Subtract lhs rhs
in
parseAddExprTail tokens2 newLhs
parseAddExprTail tokens e = (tokens, e)
--
-- MulExpr ::= Primitive {("*" | "/") Primitive}.
--
parseMulExpr tokens =
let
(tokens2, lhs) = parsePrimitive tokens
in
parseMulExprTail tokens2 lhs
parseMulExprTail (MultiplyToken:tokens) lhs =
let
(tokens2, rhs) = parsePrimitive tokens
newLhs = NumOp Multiply lhs rhs
in
parseMulExprTail tokens2 newLhs
parseMulExprTail (DivideToken:tokens) lhs =
let
(tokens2, rhs) = parsePrimitive tokens
newLhs = NumOp Divide lhs rhs
in
parseMulExprTail tokens2 newLhs
parseMulExprTail tokens e = (tokens, e)
--
-- Primitive ::= "(" NumExpr ")"
-- | "if" BoolExpr "then" NumExpr "else" NumExpr
-- | "let" VarName "=" NumExpr "in" NumExpr
-- | "valueof" VarName "in" Statement
-- | "loop" NumExpr
-- | "repeat"
-- | "input" VarName "in" NumExpr
-- | VarName
-- | NumConst.
--
parsePrimitive (OpenParenToken:tokens) =
let
(tokens2, ne) = parseNumExpr tokens
tokens3 = expect [CloseParenToken] tokens2
in
(tokens3, ne)
parsePrimitive (IfToken:tokens) =
let
(tokens2, be) = parseBoolExpr tokens
tokens3 = expect [ThenToken] tokens2
(tokens4, e1) = parseNumExpr tokens3
tokens5 = expect [ElseToken] tokens4
(tokens6, e2) = parseNumExpr tokens5
in
(tokens6, IfExpr be e1 e2)
parsePrimitive (LetToken:tokens) =
let
((Ident ident):tokens2) = tokens
v = VarName ident
tokens3 = expect [EqualToken] tokens2
(tokens4, e1) = parseNumExpr tokens3
tokens5 = expect [InToken] tokens4
(tokens6, e2) = parseNumExpr tokens5
in
(tokens6, Let v e1 e2)
parsePrimitive (ValueOfToken:tokens) =
let
((Ident ident):tokens2) = tokens
v = VarName ident
tokens3 = expect [InToken] tokens2
(tokens4, s) = parseStatement tokens3
in
(tokens4, ValueOf v s)
parsePrimitive (LoopToken:tokens) =
let
(tokens2, e) = parseNumExpr tokens
in
(tokens2, Loop e)
parsePrimitive (RepeatToken:tokens) = (tokens, Repeat)
parsePrimitive (InputToken:tokens) =
let
((Ident ident):tokens2) = tokens
v = VarName ident
tokens3 = expect [InToken] tokens2
(tokens4, ne) = parseNumExpr tokens3
in
(tokens4, Input v ne)
parsePrimitive ((IntLit i):tokens) = (tokens, NumConst i)
parsePrimitive ((Ident s):tokens) = (tokens, (VarRef (VarName s)))
--
-- BoolExpr ::= RelExpr {("&" | "|") RelExpr}
-- | "not" BoolExpr
-- | "(" BoolExpr ")".
--
parseBoolExpr (NotToken:tokens) =
let
(tokens2, be) = parseBoolExpr tokens
in
(tokens2, Not be)
parseBoolExpr (OpenParenToken:tokens) =
let
(tokens2, be) = parseBoolExpr tokens
tokens3 = expect [CloseParenToken] tokens2
in
(tokens3, be)
parseBoolExpr tokens =
let
(tokens2, lhs) = parseRelExpr tokens
in
parseBoolExprTail tokens2 lhs
parseBoolExprTail (AndToken:tokens) lhs =
let
(tokens2, rhs) = parseRelExpr tokens
newLhs = BoolOp And lhs rhs
in
parseBoolExprTail tokens2 newLhs
parseBoolExprTail (OrToken:tokens) lhs =
let
(tokens2, rhs) = parseRelExpr tokens
newLhs = BoolOp Or lhs rhs
in
parseBoolExprTail tokens2 newLhs
parseBoolExprTail tokens be = (tokens, be)
--
-- RelExpr ::= NumExpr (">" | "<" | ">=" | "<=" | "=" | "/=") NumExpr.
--
parseRelExpr tokens =
let
(tokens2, lhs) = parseNumExpr tokens
(tokens3, relOp) = relOpForSym tokens2
(tokens4, rhs) = parseNumExpr tokens3
in
(tokens4, RelOp relOp lhs rhs)
relOpForSym (GreaterThanToken:tokens) = (tokens, GreaterThan)
relOpForSym (GreaterThanOrEqualToken:tokens) = (tokens, GreaterThanOrEqual)
relOpForSym (EqualToken:tokens) = (tokens, Equal)
relOpForSym (NotEqualToken:tokens) = (tokens, NotEqual)
relOpForSym (LessThanToken:tokens) = (tokens, LessThan)
relOpForSym (LessThanOrEqualToken:tokens) = (tokens, LessThanOrEqual)
--
-- Driver
--
parse string = parseStatement (tokenize string)