From d9c809a5550b2fe23b2fd1e66672b503730d55f1 Mon Sep 17 00:00:00 2001 From: Vladimir Azarov Date: Sun, 25 May 2025 19:59:56 +0200 Subject: Expression parsing --- parser.fun | 348 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 348 insertions(+) create mode 100644 parser.fun (limited to 'parser.fun') diff --git a/parser.fun b/parser.fun new file mode 100644 index 0000000..ccd467e --- /dev/null +++ b/parser.fun @@ -0,0 +1,348 @@ +functor Parser(P: PPC): PARSER = struct + + structure P = P + structure T = P.T + + type parseCtx = P.t + + datatype unop = + UnopPreInc | + UnopPreDec | + UnopAddr | + UnopDeref | + UnopPos | + UnopNeg | + UnopComp | + UnopLogNeg | + + UnopPostInc | + UnopPostDec + + datatype binop = + 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 + + val binopTable = [ + (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, 3, false), + (BinopMulAssign, T.AmpersandEqualSign, 3, false), + (BinopDivAssign, T.SlashEqualSign, 3, false), + (BinopModAssign, T.PercentEqualSign, 3, false), + (BinopSumAssign, T.PlusEqualSign, 3, false), + (BinopSubAssign, T.MinusEqualSign, 3, false), + (BinopLeftShiftAssign, T.DoubleLessEqualSign, 3, false), + (BinopRightShiftAssign, T.DoubleGreaterEqualSign, 3, false), + (BinopBitAndAssign, T.AmpersandEqualSign, 3, false), + (BinopBitXorAssign, T.CapEqualSign, 3, false), + (BinopBitOrAssign, T.VerticalBarEqualSign, 3, false) + ] + + datatype expr = + Enum | + Eid of string | + Estrlit of string | + EmemberByV of string * exprAug | + EmemberByP of string * exprAug | + Eunop of unop * exprAug | + Ebinop of binop * exprAug * exprAug + + and exprAug = EAug of expr * P.tkPos + + datatype exprPart = + EPexpr of exprAug | + (* last two are prio and leftAssoc *) + EPbinop of binop * P.tkPos * int * bool + + type def = expr + + datatype token = + Tk of T.token | + TkParens of (token * P.tkPos) list | + TkBrackets of (token * P.tkPos) list | + TkBraces of (token * P.tkPos) list + + fun createParseCtx fname incDirs = + P.create { fname, incDirs, debugMode = false } + + fun getToken ppc = + let + val (tk, pos, ppc) = P.getToken ppc + in + case tk of + T.LParen | T.LBracket | T.LBrace => raise Unimplemented + | _ => (Tk tk, pos, ppc) + end + + val Punop = fn z => + let + fun Punop (out, unop) = + Printf out `(case unop of + UnopPreInc | UnopPostInc => "++" + | UnopPreDec | UnopPostDec => "--" + | UnopPos => "+" + | UnopNeg => "-" + | UnopAddr => "&" + | UnopDeref => "*" + | UnopComp => "~" + | UnopLogNeg => "!") % + in + bind A1 Punop + end z + + val Pbinop = fn z => + let + fun Pbinop (out, binop) = + case List.find (fn (binop', _, _, _) => binop' = binop) binopTable + of + SOME (_, tk, _, _) => Printf out T.Ptk tk% + | NONE => raise Unreachable + in + bind A1 Pbinop + end z + + fun printExpr off ea = + let + fun printExpr' off (EAug (e, pos)) = + let + fun Pprintf g = printf R off (fn (a, _) => + g (a, fn (_, out) => Printf out `"| " P.PtkPos pos %)) + + fun member (member, ea) s = ( + Pprintf `"(" `s `member %; + printf `"\n" %; + printExpr' (off + 1) ea; + printf `")" % + ) + in + case e of + Eid id => Pprintf `id % + | Enum => Pprintf `"num" % + | Estrlit s => Pprintf `"\"" `s `"\"" % + | EmemberByV pair => member pair "." + | EmemberByP pair => member pair "->" + | Eunop (unop, ea) => ( + Pprintf `"(" Punop unop %; + printf `"\n" %; + printExpr' (off + 1) ea; + printf `")" % + ) + | Ebinop (binop, left, right) => ( + Pprintf `"(" Pbinop binop %; + printf `"\n" %; + printExpr (off + 1) left; + printExpr' (off + 1) right; + printf `")" % + ) + end + in + printExpr' off ea; + printf `"\n" % + end + + fun parseUnaryPrefix ppc acc = + let + val unopPreTable = [ + (T.DoublePlus, UnopPreInc), + (T.DoubleMinus, UnopPreDec), + (T.Plus, UnopPos), + (T.Minus, UnopNeg) + ] + val (tk, pos, ppc') = getToken ppc + in + case tk of + Tk tk => ( + case List.find (fn (tk', _) => tk' = tk) unopPreTable of + SOME (_, unop) => parseUnaryPrefix ppc' ((unop, pos) :: acc) + | _ => (acc, ppc) + ) + | _ => (acc, ppc) + end + + fun parsePrimaryExpr ppc = + let + val (tk, pos, ppc) = getToken ppc + in + (fn e => (EAug (e, pos), ppc)) + (case tk of + Tk (T.Id id) => Eid id + | Tk (T.StringConst s) => Estrlit s + | Tk (T.CharConst _) => raise Unimplemented + | Tk (T.Num _) => Enum + | _ => P.clerror pos [P.Cid, P.Cconst]) + end + + fun parseExprSuffix1 eAug ppc = + let + val (tk, pos1, ppc1) = getToken ppc + + fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ppc1) + fun formMemberOp unop = + let + val (tk, pos2, ppc2) = getToken ppc1 + in + case tk of + Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ppc2) + | _ => P.clerror pos2 [P.Cid] + end + in + case tk of + Tk T.DoublePlus => formUnop1 UnopPostInc + | Tk T.DoubleMinus => formUnop1 UnopPostDec + | Tk T.Dot => formMemberOp EmemberByV + | Tk T.Arrow => formMemberOp EmemberByP + | _ => (NONE, ppc) + end + + fun parseExprSuffix eAug ppc = + let + val (eAug', ppc) = parseExprSuffix1 eAug ppc + in + case eAug' of + SOME eAug => parseExprSuffix eAug ppc + | NONE => (eAug, ppc) + end + + fun parseUnary ppc = + let + val (prefix, ppc) = parseUnaryPrefix ppc [] + val (eAug, ppc) = parsePrimaryExpr ppc + val (eAug, ppc) = parseExprSuffix eAug ppc + + val eAug = List.foldl + (fn ((unop, pos), e) => EAug (Eunop (unop, e), pos)) eAug prefix + in + (EPexpr eAug, ppc) + end + + fun parseBinop ppc = + let + val (tk, pos, ppc) = getToken ppc + in + case tk of + Tk tk => ( + case List.find (fn (_, tk', _, _) => tk' = tk) binopTable of + SOME (binop, _, prio, leftAssoc) => + SOME (EPbinop (binop, pos, prio, leftAssoc), ppc) + | NONE => + if tk = T.EOS then + NONE + else + P.clerror pos [P.Cbinop] + ) + | _ => P.clerror pos [P.Cbinop] + end + + fun constructExpr parts = + let + fun shouldTakePrev _ [] = false + | shouldTakePrev (_, _, p, assoc) ((_, _, p') :: _) = + case Int.compare (p', p) of + GREATER => true + | EQUAL => assoc + | LESS => false + + fun moveHead 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 head = EAug (Ebinop (binop', left, 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) + else + (vstack, (binop, pos, p) :: opstack) + + fun finish ([ea], []) = ea + | finish (_, []) = raise Unreachable + | finish (vstack, opstack) = finish $ moveHead vstack opstack + + fun construct (vstack, opstack) (EPexpr ea :: acc) = + construct (ea :: vstack, opstack) acc + | construct stacks (EPbinop Q :: acc) = + construct (insert Q stacks) acc + | construct stacks [] = finish stacks + in + construct ([], []) parts + end + + fun parseExpr ppc = + let + fun collect ppc expVal acc = + if expVal then + let + val (unary, ppc) = parseUnary ppc + in + collect ppc (not expVal) (unary :: acc) + end + else + case parseBinop ppc of + SOME (binop, ppc) => collect ppc (not expVal) (binop :: acc) + | NONE => (rev acc, ppc) + + val (parts, ppc) = collect ppc true [] + val expr = constructExpr parts + in + (expr, ppc) + end + + fun parseDef ppc = + let + val (expr, ppc) = parseExpr ppc + val () = printExpr 0 expr + in + (raise Unimplemented, ppc) + end +end -- cgit v1.2.3