Expression parsing

1 files changed, 348 insertions, 0 deletions

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