diff options
| -rw-r--r-- | parser.fun | 212 |
1 files changed, 122 insertions, 90 deletions
@@ -16,77 +16,77 @@ functor Parser(P: PPC): PARSER = struct UnopPostInc | UnopPostDec - datatype binop = - BinopSubscript | - - BinopMul | - BinopDiv | - BinopMod | - BinopSum | - BinopSub | - BinopShiftLeft | - BinopShiftRight | - BinopGreater | - BinopLess | - BinopLessEqual | - BinopGreaterEqual | - BinopEqual | - BinopNotEqual | - BinopBitAnd | - BinopBitXor | - BinopBitOr | - BinopLogAnd | - BinopLogOr | - - BinopAssign | - BinopMulAssign | - BinopDivAssign | - BinopModAssign | - BinopSumAssign | - BinopSubAssign | - BinopLeftShiftAssign | - BinopRightShiftAssign | - BinopBitAndAssign | - BinopBitXorAssign | - BinopBitOrAssign | - - BinopComma + datatype binopReg = + BrSubscript | + + BrMul | + BrDiv | + BrMod | + BrSum | + BrSub | + BrShiftLeft | + BrShiftRight | + BrGreater | + BrLess | + BrLessEqual | + BrGreaterEqual | + BrEqual | + BrNotEqual | + BrBitAnd | + BrBitXor | + BrBitOr | + BrLogAnd | + BrLogOr | + + BrAssign | + BrMulAssign | + BrDivAssign | + BrModAssign | + BrSumAssign | + BrSubAssign | + BrLeftShiftAssign | + BrRightShiftAssign | + BrBitAndAssign | + BrBitXorAssign | + BrBitOrAssign | + + BrComma val binopTable = [ - (BinopSubscript, T.Invalid, 0, false), - - (BinopMul, T.Asterisk, 13, true), - (BinopDiv, T.Slash, 13, true), - (BinopMod, T.Percent, 13, true), - (BinopSum, T.Plus, 12, true), - (BinopSub, T.Minus, 12, true), - (BinopShiftLeft, T.DoubleLess, 11, true), - (BinopShiftRight, T.DoubleGreater, 11, true), - (BinopGreater, T.Greater, 10, true), - (BinopLess, T.Less, 10, true), - (BinopLessEqual, T.LessEqualSign, 10, true), - (BinopGreaterEqual, T.GreaterEqualSign, 10, true), - (BinopEqual, T.DoubleEqualSign, 9, true), - (BinopNotEqual, T.ExclMarkEqualSign, 9, true), - (BinopBitAnd, T.Ampersand, 8, true), - (BinopBitXor, T.Cap, 7, true), - (BinopBitOr, T.VerticalBar, 6, true), - (BinopLogAnd, T.DoubleAmpersand, 5, true), - (BinopLogOr, T.DoubleVerticalBar, 4, true), - - (BinopAssign, T.EqualSign, 2, false), - (BinopMulAssign, T.AmpersandEqualSign, 2, false), - (BinopDivAssign, T.SlashEqualSign, 2, false), - (BinopModAssign, T.PercentEqualSign, 2, false), - (BinopSumAssign, T.PlusEqualSign, 2, false), - (BinopSubAssign, T.MinusEqualSign, 2, false), - (BinopLeftShiftAssign, T.DoubleLessEqualSign, 2, false), - (BinopRightShiftAssign, T.DoubleGreaterEqualSign, 2, false), - (BinopBitAndAssign, T.AmpersandEqualSign, 2, false), - (BinopBitXorAssign, T.CapEqualSign, 2, false), - (BinopBitOrAssign, T.VerticalBarEqualSign, 2, false), - - (BinopComma, T.Comma, 1, true) + (BrSubscript, T.Invalid, 0, false), + + (BrMul, T.Asterisk, 13, true), + (BrDiv, T.Slash, 13, true), + (BrMod, T.Percent, 13, true), + (BrSum, T.Plus, 12, true), + (BrSub, T.Minus, 12, true), + (BrShiftLeft, T.DoubleLess, 11, true), + (BrShiftRight, T.DoubleGreater, 11, true), + (BrGreater, T.Greater, 10, true), + (BrLess, T.Less, 10, true), + (BrLessEqual, T.LessEqualSign, 10, true), + (BrGreaterEqual, T.GreaterEqualSign, 10, true), + (BrEqual, T.DoubleEqualSign, 9, true), + (BrNotEqual, T.ExclMarkEqualSign, 9, true), + (BrBitAnd, T.Ampersand, 8, true), + (BrBitXor, T.Cap, 7, true), + (BrBitOr, T.VerticalBar, 6, true), + (BrLogAnd, T.DoubleAmpersand, 5, true), + (BrLogOr, T.DoubleVerticalBar, 4, true), + + (BrAssign, T.EqualSign, 2, false), + (BrMulAssign, T.AmpersandEqualSign, 2, false), + (BrDivAssign, T.SlashEqualSign, 2, false), + (BrModAssign, T.PercentEqualSign, 2, false), + (BrSumAssign, T.PlusEqualSign, 2, false), + (BrSubAssign, T.MinusEqualSign, 2, false), + (BrLeftShiftAssign, T.DoubleLessEqualSign, 2, false), + (BrRightShiftAssign, T.DoubleGreaterEqualSign, 2, false), + (BrBitAndAssign, T.AmpersandEqualSign, 2, false), + (BrBitXorAssign, T.CapEqualSign, 2, false), + (BrBitOrAssign, T.VerticalBarEqualSign, 2, false), + + (BrComma, T.Comma, 1, true) ] datatype expr = @@ -96,11 +96,16 @@ functor Parser(P: PPC): PARSER = struct EmemberByV of string * exprAug | EmemberByP of string * exprAug | EfuncCall of exprAug * exprAug list | + ETernary of exprAug * exprAug * exprAug | Eunop of unop * exprAug | Ebinop of binop * exprAug * exprAug and exprAug = EAug of expr * P.tkPos + and binop = BR of binopReg | BinopTernaryIncomplete of exprAug + + val (ternaryOpPrio, ternaryOpLeftAssoc) = (2, false) + datatype exprPart = EPexpr of exprAug | (* last two are prio and leftAssoc *) @@ -112,7 +117,8 @@ functor Parser(P: PPC): PARSER = struct Tk of T.token | TkParens of (token * P.tkPos) list | TkBrackets of (token * P.tkPos) list | - TkBraces of (token * P.tkPos) list + TkBraces of (token * P.tkPos) list | + TkTernary of (token * P.tkPos) list fun PtokenL (_, []) = () | PtokenL (out, head :: tail) = @@ -126,6 +132,7 @@ functor Parser(P: PPC): PARSER = struct | TkParens list => printL list "(" ")" | TkBrackets list => printL list "[" "]" | TkBraces list => printL list "{" "}" + | TkTernary list => printL list "?" ":" end type parseCtx = P.t * (token * P.tkPos) list list @@ -138,6 +145,7 @@ functor Parser(P: PPC): PARSER = struct fun first T.RParen = "'('" | first T.RBracket = "'['" | first T.RBrace = "'{'" + | first T.Colon = "'?'" | first _ = raise Unreachable fun newFrom start pos = @@ -148,6 +156,7 @@ functor Parser(P: PPC): PARSER = struct T.LParen => new TkParens T.RParen | T.LBracket => new TkBrackets T.RBracket | T.LBrace => new TkBraces T.RBrace + | T.QuestionMark => new TkTernary T.Colon | _ => NONE end @@ -170,7 +179,7 @@ functor Parser(P: PPC): PARSER = struct SOME layer => (layer :: S) | NONE => ( case tk of - T.RParen | T.RBracket | T.RBrace => + T.RParen | T.RBracket | T.RBrace | T.Colon => P.error pos `"unmatched " `(first tkEnd) % | _ => (con, pos, tkEnd, (Tk tk, pos1) :: list) :: tail ) @@ -256,10 +265,10 @@ functor Parser(P: PPC): PARSER = struct ) | Eunop (unop, ea) => Printf out `"(" Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" % - | Ebinop (binop, left, right) => + | Ebinop (BR binop, left, right) => let val binop = - if binop = BinopSubscript then + if binop = BrSubscript then "[]" else sprintf Pbinop binop % @@ -268,6 +277,12 @@ functor Parser(P: PPC): PARSER = struct A2 printExpr (off + 1) left A2 printExpr' (off + 1) right `")" % end + | Ebinop(BinopTernaryIncomplete _, _, _) => raise Unreachable + | ETernary (cond, trueBody, falseBody) => + Printf out `"(?:" P `"\n" + A2 printExpr (off + 1) cond + A2 printExpr (off + 1) trueBody + A2 printExpr' (off + 1) falseBody `")" % end in Printf out A2 printExpr' off ea `"\n" % @@ -279,7 +294,11 @@ functor Parser(P: PPC): PARSER = struct (T.DoublePlus, UnopPreInc), (T.DoubleMinus, UnopPreDec), (T.Plus, UnopPos), - (T.Minus, UnopNeg) + (T.Minus, UnopNeg), + (T.Ampersand, UnopAddr), + (T.Asterisk, UnopDeref), + (T.Tilde, UnopComp), + (T.ExclMark, UnopLogNeg) ] val (tk, pos, ctx') = getTokenCtx ctx in @@ -295,34 +314,43 @@ functor Parser(P: PPC): PARSER = struct fun parseBinop ctx endTk = let val (tk, pos, ctx) = getTokenCtx ctx + in case tk of - Tk tk => + TkTernary list => + let + val (ea, ctx) = ctxWithLayer ctx list + (fn ctx => parseExpr ctx NONE) + in + SOME (EPbinop (BinopTernaryIncomplete ea, pos, + ternaryOpPrio, ternaryOpLeftAssoc), ctx) + end + | Tk tk => if tk = T.EOS orelse (isSome endTk andalso tk = valOf endTk) then NONE else ( case List.find (fn (_, tk', _, _) => tk' = tk) binopTable of SOME (binop, _, prio, leftAssoc) => - SOME (EPbinop (binop, pos, prio, leftAssoc), ctx) + SOME (EPbinop (BR binop, pos, prio, leftAssoc), ctx) | NONE => P.clerror pos [P.Cbinop] ) | _ => P.clerror pos [P.Cbinop] end - fun parseFuncArgs ctx ea list pos = + and parseFuncCall ctx funcEa list pos = let - fun collect ctx acc = + fun collectArgs ctx acc = let val (ea, ctx) = parseExpr ctx (SOME T.Comma) val (tk, _, ctx) = getTokenCtx ctx in case tk of Tk T.EOS => (rev $ ea :: acc, ctx) - | _ => collect ctx (ea :: acc) + | _ => collectArgs ctx (ea :: acc) end - val (acc, ctx) = ctxWithLayer ctx list (fn ctx => collect ctx []) + val (args, ctx) = ctxWithLayer ctx list (fn ctx => collectArgs ctx []) in - (SOME $ EAug (EfuncCall (ea, acc), pos), ctx) + (SOME $ EAug (EfuncCall (funcEa, args), pos), ctx) end and parseExprSuffix1 eAug ctx = @@ -349,9 +377,9 @@ functor Parser(P: PPC): PARSER = struct val (ea, ctx) = ctxWithLayer ctx1 list (fn ctx => parseExpr ctx NONE) in - (SOME $ EAug (Ebinop (BinopSubscript, eAug, ea), pos1), ctx) + (SOME $ EAug (Ebinop (BR BrSubscript, eAug, ea), pos1), ctx) end - | TkParens list => parseFuncArgs ctx1 eAug list pos1 + | TkParens list => parseFuncCall ctx1 eAug list pos1 | _ => (NONE, ctx) end @@ -388,7 +416,7 @@ functor Parser(P: PPC): PARSER = struct val eAug = List.foldl (fn ((unop, pos), e) => EAug (Eunop (unop, e), pos)) eAug prefix in - (EPexpr eAug, ctx) + (eAug, ctx) end and constructExpr parts = @@ -400,27 +428,31 @@ functor Parser(P: PPC): PARSER = struct | EQUAL => assoc | LESS => false - fun moveHead vstack opstack = + fun applyTop vstack opstack = let fun take2 (x :: y :: tl) = (x, y, tl) | take2 _ = raise Unreachable val (right, left, vstack) = take2 vstack - val (binop', pos, _) = hd opstack + val (binop, pos, _) = hd opstack - val head = EAug (Ebinop (binop', left, right), pos) + val head = EAug ( + case binop of + BR binop => Ebinop (BR binop, left, right) + | BinopTernaryIncomplete trueBody => + ETernary(left, trueBody, right), pos) in (head :: vstack, tl opstack) end fun insert (Q as (binop, pos, p, _)) (vstack, opstack) = if shouldTakePrev Q opstack then - insert Q (moveHead vstack opstack) + insert Q (applyTop vstack opstack) else (vstack, (binop, pos, p) :: opstack) fun finish ([ea], []) = ea | finish (_, []) = raise Unreachable - | finish (vstack, opstack) = finish $ moveHead vstack opstack + | finish (vstack, opstack) = finish $ applyTop vstack opstack fun construct (vstack, opstack) (EPexpr ea :: acc) = construct (ea :: vstack, opstack) acc @@ -438,7 +470,7 @@ functor Parser(P: PPC): PARSER = struct let val (unary, ctx) = parseUnary ctx in - collect ctx (not expVal) (unary :: acc) + collect ctx (not expVal) (EPexpr unary :: acc) end else case parseBinop ctx endTk of |