path: root/parser.fun

functor Parser(P: PPC): PARSER = struct

  structure P = P
  structure T = P.T

  datatype unop =
    UnopPreInc |
    UnopPreDec |
    UnopAddr |
    UnopDeref |
    UnopPos |
    UnopNeg |
    UnopComp |
    UnopLogNeg |
    UnopCast of ctype |

    UnopPostInc |
    UnopPostDec

  and 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

  and expr =
    Enum |
    Eid of int |
    Estrlit of int |
    EmemberByV of int * exprAug |
    EmemberByP of int * 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

  and ctype =
    void_t |
    char_t |
    uchar_t |
    short_t |
    ushort_t |
    int_t |
    uint_t |
    long_t |
    ulong_t |
    longlong_t |
    ulonglong_t |
    float_t |
    double_t |

    pointer_t of int * ctype |
    function_t of ctype * ctype list |
    array_t of ctype

  val (ternaryOpPrio, ternaryOpLeftAssoc) = (2, false)

  datatype exprPart =
    EPexpr of exprAug |
    (* last two are prio and leftAssoc *)
    EPbinop of binop * P.tkPos * int * bool

  datatype storageSpec =
    SpecTypedef |
    SpecExtern |
    SpecStatic |
    SpecRegister

  datatype stmt = StmtCompound of exprAug list

  type declaredId = {
    id: int option,
    pos: P.tkPos,
    spec: storageSpec option,
    ctype: ctype,
    params: (int option * P.tkPos) list option
  }

  datatype def = Declaration of declaredId list |
    Definition of declaredId * stmt

  datatype token =
    Tk of T.token |
    TkParens of (token * P.tkPos) list |
    TkBrackets of (token * P.tkPos) list |
    TkBraces of (token * P.tkPos) list |
    TkTernary of (token * P.tkPos) list

  datatype declParts =
    Pointer of int |
    Id of int * P.tkPos |
    AbstructRoot of P.tkPos |
    FuncApp of (int option * P.tkPos * ctype) list |
    ArrayApplication

  datatype abstructPolicy = APpermitted | APenforced | APprohibited

  datatype specType = StorageSpec of storageSpec | TypeSpec of T.token

  val binopTable = [
    (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)
  ]

  fun pStorSpec s out =
    Printf out `(
      case s of
        SpecTypedef => "typedef"
      | SpecExtern => "extern"
      | SpecRegister => "register"
      | SpecStatic => "static"
    ) %

  val Pctype = fn z =>
  let
    fun pctype t out =
    let
      fun &s = Printf out `s %
    in
      case t of
        void_t => &"void"
      | char_t => &"char"
      | uchar_t => &"unsigned char"
      | short_t => &"short"
      | ushort_t => &"usigned short"
      | int_t => &"int"
      | uint_t => &"unsigned int"
      | long_t => &"long"
      | ulong_t => &"unsigned long"
      | longlong_t => &"long long"
      | ulonglong_t => &"unsigned long long"
      | float_t => &"float"
      | double_t => &"double"
      | pointer_t (plevel, t) =>
          Printf out `"{" I plevel `"} " A1 pctype t %
      | function_t (ret, params) => Printf out
        Plist pctype params (", ", true) `" -> " A1 pctype ret %
      | array_t el => Printf out `"[] -> " A1 pctype el %
    end
  in
    bind A1 pctype
  end z

  val typeSpecs = [
      T.kwVoid,
      T.kwChar,
      T.kwShort,
      T.kwInt,
      T.kwLong,
      T.kwFloat,
      T.kwDouble,
      T.kwSigned,
      T.kwUnsigned
  ]

  fun ts2idx ts =
  let
    fun find _ [] = raise Unreachable
      | find idx (ts' :: tss) =
        if ts = ts' then
          idx
        else
          find (idx + 1) tss
  in
    find 0 typeSpecs
  end

  fun idx2ts idx = List.nth (typeSpecs, idx)

  val tsMaxIdxP1 = length typeSpecs

  val prefixes = [
    (void_t, [[T.kwVoid]]),
    (char_t, [[T.kwChar], [T.kwChar, T.kwSigned]]),
    (uchar_t, [[T.kwUnsigned, T.kwChar]]),
    (short_t, [[T.kwShort], [T.kwSigned, T.kwShort], [T.kwSigned, T.kwInt],
      [T.kwSigned, T.kwShort, T.kwInt]]),
    (ushort_t, [[T.kwUnsigned, T.kwShort],
        [T.kwUnsigned, T.kwShort, T.kwInt]]),
    (int_t, [[T.kwInt], [T.kwSigned], [T.kwSigned, T.kwInt]]),
    (uint_t, [[T.kwUnsigned], [T.kwUnsigned, T.kwInt]]),
    (long_t, [[T.kwLong], [T.kwSigned, T.kwLong], [T.kwLong, T.kwInt],
      [T.kwSigned, T.kwLong, T.kwInt]]),
    (ulong_t, [[T.kwUnsigned, T.kwLong],
        [T.kwUnsigned, T.kwLong, T.kwInt]]),
    (longlong_t, [[T.kwLong, T.kwLong], [T.kwSigned, T.kwLong, T.kwLong],
        [T.kwLong, T.kwLong, T.kwInt],
        [T.kwSigned, T.kwLong, T.kwLong, T.kwInt]]),
    (ulonglong_t, [[T.kwUnsigned, T.kwLong, T.kwLong],
        [T.kwUnsigned, T.kwLong, T.kwLong, T.kwInt]]),
    (float_t, [[T.kwFloat]]),
    (double_t, [[T.kwDouble]])
  ]

  fun genReprChildren l =
  let
    open List
    fun genWithoutOne i =
      if i = length l then
        []
      else
        let
          val e = nth (l, i)
          val bef = take (l, i)
          val after = drop (l, i + 1)
        in
          (e, bef @ after) :: genWithoutOne (i + 1)
        end
    fun unique acc [] = acc
      | unique acc ((e, l) :: tail) =
        case List.find (fn (e', _) => e' = e) acc of
          NONE => unique ((e, l) :: acc) tail
        | SOME _ => unique acc tail
  in
    unique [] $ genWithoutOne 0
  end

  fun addRepr repr (P as (repr2id, _)) =
    case List.find (fn (repr', _) => repr' = repr) repr2id of
      SOME (_, id) => (id, P)
    | NONE =>
      let
        fun createId (repr2id, trs) =
        let
          val id = length repr2id
        in
          (id, ((repr, id) :: repr2id, trs))
        end
      in
        if length repr = 1 then
          let
            val (id, (repr2id, trs)) = createId P
          in
            (id, (repr2id, (0, ts2idx $ hd repr, id) :: trs))
          end
        else
          let
            val children = genReprChildren repr
            val (P, ids) = List.foldl (fn ((e, l), (P, ids)) =>
              let
                val (id, P) = addRepr l P
              in
                (P, (id, e) :: ids)
              end) (P, []) children

            val (id, (repr2id, trs)) = createId P
            val trs = List.foldl (fn ((id', e), trs) =>
                (id', ts2idx e, id) :: trs) trs ids
          in
            (id, (repr2id, trs))
          end
      end

  fun addTypeRepr ctype repr (repr2id, id2type, trs) =
  let
    val (id, (repr2id, trs)) = addRepr repr (repr2id, trs)
  in
    (repr2id, (id, ctype) :: id2type, trs)
  end

  fun prefixFsmPrint fsm repr2id =
  let
    fun findRepr id =
      case List.find (fn (_, id') => id' = id) repr2id of
        SOME (repr, _) => repr
      | NONE => raise Unreachable

    fun printRepr l out =
    let
      fun printRepr' [] _ = ()
        | printRepr' [tk] out = Printf out P.Ptk tk %
        | printRepr' (tk1 :: tk2 :: tail) out =
            Printf out P.Ptk tk1 `", " A1 printRepr' (tk2 :: tail) %
    in
      Printf out `"[" A1 printRepr' l `"]" %
    end

    open Array

    fun printRow i =
    let
      val (ctype, trs) = sub (fsm, i)
      fun printTrs () = appi (fn (j, id) =>
        if id = ~1 then
          ()
        else
          printf P.Ptk (idx2ts j) `" -> " I id `", " %
        ) trs
      fun printType out =
        case ctype of
          NONE => Printf out `"none" %
        | SOME ctype => Printf out Pctype ctype %
    in
      printf I i `" " A1 printRepr (findRepr i)
        `" |" A0 printType `"|: " %;
      printTrs ();
      printf `"\n" %
    end

    val i = ref 0
  in
    while !i < length fsm do (
        printRow $ !i;
        i := !i + 1
    )
  end

  fun buildPrefixFsm () =
  let
    val T = ([([], 0)], [], [])
    val (repr2id, id2type, trs) = List.foldl (fn ((t, rl), T) =>
        List.foldl (fn (r, T) => addTypeRepr t r T) T rl) T prefixes

    open Array

    fun fsmInit len =
    let
      val fsm = array (len, (NONE, array (tsMaxIdxP1, ~1)))
      val i = ref 1
    in
      while !i < len do (
        update (fsm, !i, (NONE, array (tsMaxIdxP1, ~1)));
        i := !i + 1
      );
      fsm
    end

    val fsm = fsmInit $ List.length repr2id

    val () = List.app (fn (id, ctype) =>
      let
        val (_, subarray) = sub (fsm, id)
      in
        update (fsm, id, (SOME ctype, subarray))
      end) id2type

    val () = List.app (fn (id', n, id) =>
      let
        val (_, subarray) = sub (fsm, id')
      in
        update (subarray, n, id)
      end) trs
  in
    (* prefixFsmPrint fsm repr2id; *)
    fsm
  end

  val prefixFsm = buildPrefixFsm ()

  fun advanceTypeRepr typeReprId (tk, pos) =
  let
    open Array
    val n = ts2idx tk
    val (_, subarray) = sub (prefixFsm, typeReprId)
    val id = sub (subarray, n)
  in
    if id = ~1 then
      P.error pos `"unexpected type specifier" %
    else
      id
  end

  fun typeRepr2type typeReprId =
    valOf o #1 o Array.sub $ (prefixFsm, typeReprId)

  fun pTokenL l out =
  let
    fun pToken (tk, _) out =
    let
      fun printList list opr cpr = Printf out `(opr ^ "| ")
        Plist pToken list (",", false) `(" |" ^ cpr) %
    in
      case tk of
        Tk tk => Printf out P.Ptk tk %
      | TkParens list => printList list "(" ")"
      | TkBrackets list => printList list "[" "]"
      | TkBraces list => printList list "{" "}"
      | TkTernary list => printList list "?" ":"
    end
  in
    Printf out Plist pToken l (",", false) %
  end

  type parseCtx = P.t * (token * P.tkPos) list list

  fun createParseCtx fname incDirs =
    (P.create { fname, incDirs, debugMode = false }, [])

  fun getTokenCtx (ppc, []) =
  let
    fun first T.RParen = "'('"
      | first T.RBracket = "'['"
      | first T.RBrace = "'{'"
      | first T.Colon = "'?'"
      | first _ = raise Unreachable

    fun newFrom start pos =
    let
      fun new con tkEnd = SOME (con, pos, tkEnd, [])
    in
      case start of
        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

    fun collect ppc (S as ((con, pos, tkEnd, list) :: tail)) =
    let
      val (tk, pos1, ppc) = P.getToken ppc
    in
      if tk = tkEnd then
        let
          val tk = con (rev $ (Tk T.EOS, pos1) :: list)
        in
          case tail of
            [] => (tk, pos, ppc)
          | ((con', pos', tkEnd, list) :: tail) =>
              collect ppc ((con', pos', tkEnd, (tk, pos) :: list) :: tail)
        end
      else
        collect ppc (
          case newFrom tk pos1 of
            SOME layer => (layer :: S)
          | NONE => (
            case tk of
              T.RParen | T.RBracket | T.RBrace | T.Colon =>
                P.error pos `"unmatched " `(first tkEnd) %
              | _ => (con, pos, tkEnd, (Tk tk, pos1) :: list) :: tail
          )
        )
    end
      | collect _ _ = raise Unreachable

    val (tk, pos, ppc) = P.getToken ppc
  in
    case newFrom tk pos of
      SOME layer =>
        (fn (tk, pos, ppc) => (tk, pos, (ppc, []))) $ collect ppc [layer]
    | NONE => (Tk tk, pos, (ppc, []))
  end
  | getTokenCtx (C as (_, [(Tk T.EOS, pos)] :: _)) =
    (Tk T.EOS, pos, C)
  | getTokenCtx (_, [_] :: _) = raise Unreachable
  | getTokenCtx (_, [] :: _) = raise Unreachable
  | getTokenCtx (ppc, ((tk, pos) :: tail) :: layers) =
    (tk, pos, (ppc, tail :: layers))

  fun ctxWithLayer (ppc, layers) list cl =
  let
    val ctx = (ppc, list :: layers)
    val (v, ctx) = cl ctx
  in
    (v, (fn (ppc, layers) => (ppc, tl layers)) ctx)
  end

  fun Punop unop out =
  let
    fun ~s = Printf out `s %
  in
    case unop of
      UnopPreInc | UnopPostInc => ~"++"
    | UnopPreDec | UnopPostDec => ~"--"
    | UnopPos => ~"+"
    | UnopNeg => ~"-"
    | UnopAddr => ~"&"
    | UnopDeref => ~"*"
    | UnopComp => ~"~"
    | UnopLogNeg => ~"!"
    | UnopCast ctype => Printf out Pctype ctype %
  end

  and Pbinop binop out =
    case List.find (fn (binop', _, _, _) => binop' = binop) binopTable
    of
      SOME (_, tk, _, _) => Printf out P.Ptk tk %
    | NONE => raise Unreachable

  and printExpr off ea out =
  let
    fun printExpr' off (EAug (e, pos)) out =
    let
      val P = fn z =>
      let
        fun Ppos out = Printf out `"| " P.PtkPos pos %
      in
        bind A0 Ppos
      end z

      fun member (member, ea) s = Printf out
        `"(" `s P.?member P `"\n" A2 printExpr' (off + 1) ea `")" %;
    in
      printf R off %;
      case e of
        Eid id => Printf out P.?id P %
      | Enum => Printf out `"num" P %
      | Estrlit s => Printf out P.?s P %
      | EmemberByV pair => member pair "."
      | EmemberByP pair => member pair "->"
      | EfuncCall (func, args) => (
        Printf out `"(fcall" P `"\n" A2 printExpr' (off + 1) func `"\n" %;
        app (fn arg =>
            (Printf out A2 printExpr' (off + 1) arg `"\n" %)) args;
        Printf out R off `")" %
      )
      | Eunop (unop, ea) => Printf out
        `"(" A1 Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" %
      | Ebinop (BR binop, left, right) =>
        let
          val binop =
            if binop = BrSubscript then
              "[]"
            else
              sprintf A1 Pbinop binop %
        in
          Printf out `"(" `binop P `"\n"
            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" %
  end

  and parseUnaryPrefix ctx acc =
  let
    val unopPreTable = [
      (T.DoublePlus, UnopPreInc),
      (T.DoubleMinus, UnopPreDec),
      (T.Plus, UnopPos),
      (T.Minus, UnopNeg),
      (T.Ampersand, UnopAddr),
      (T.Asterisk, UnopDeref),
      (T.Tilde, UnopComp),
      (T.ExclMark, UnopLogNeg)
    ]
    val (tk, pos, ctx') = getTokenCtx ctx
  in
    case tk of
      Tk tk => (
        case List.find (fn (tk', _) => tk' = tk) unopPreTable of
          SOME (_, unop) => parseUnaryPrefix ctx' ((unop, pos) :: acc)
        | _ => (acc, ctx)
      )
    | TkParens list =>
      if isTypeNameStart (#1 $ hd list) handle Empty => false then
        let
          val (ctype, ctx) = ctxWithLayer ctx' list
            (fn ctx => parseTypeName ctx)
        in
          parseUnaryPrefix ctx ((UnopCast ctype, pos) :: acc)
        end
      else
        (acc, ctx)
    | _ => (acc, ctx)
  end

  and parseBinop ctx endTk =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
  in
    case tk of
      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 (BR binop, pos, prio, leftAssoc), ctx)
          | NONE => P.clerror pos [P.Cbinop]
        )
    | _ => P.clerror pos [P.Cbinop]
  end

  and parseFuncCall ctx funcEa list pos =
  let
    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)
      | _ => collectArgs ctx (ea :: acc)
    end
    val (args, ctx) = ctxWithLayer ctx list (fn ctx => collectArgs ctx [])
  in
    (SOME $ EAug (EfuncCall (funcEa, args), pos), ctx)
  end

  and parseExprSuffix1 eAug ctx =
  let
    val (tk, pos1, ctx1) = getTokenCtx ctx

    fun formUnop1 unop = (SOME (EAug (Eunop (unop, eAug), pos1)), ctx1)
    fun formMemberOp unop =
    let
      val (tk, pos2, ctx2) = getTokenCtx ctx1
    in
      case tk of
        Tk (T.Id id) => (SOME (EAug (unop (id, eAug), pos1)), ctx2)
      | _ => 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
    | TkBrackets list =>
        let
          val (ea, ctx) =
            ctxWithLayer ctx1 list (fn ctx => parseExpr ctx NONE)
        in
          (SOME $ EAug (Ebinop (BR BrSubscript, eAug, ea), pos1), ctx)
        end
    | TkParens list => parseFuncCall ctx1 eAug list pos1
    | _ => (NONE, ctx)
  end

  and parseExprSuffix eAug ctx =
  let
    val (eAug', ctx) = parseExprSuffix1 eAug ctx
  in
    case eAug' of
      SOME eAug => parseExprSuffix eAug ctx
    | NONE => (eAug, ctx)
  end

  and parsePrimaryExpr ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
    fun wrap e = (EAug (e, pos), ctx)
  in
    case tk of
      Tk (T.Id id) => wrap $ Eid id
    | Tk (T.Strlit id) => wrap $ Estrlit id
    | Tk (T.CharConst _) => raise Unimplemented
    | Tk (T.Num _) => wrap Enum
    | TkParens list =>
        ctxWithLayer ctx list (fn (ctx: parseCtx) => parseExpr ctx NONE)
    | _ => P.clerror pos [P.Cid, P.Cconst]
  end

  and parseUnary ctx =
  let
    val (prefix, ctx) = parseUnaryPrefix ctx []
    val (eAug, ctx) = parsePrimaryExpr ctx
    val (eAug, ctx) = parseExprSuffix eAug ctx

    val eAug = List.foldl
        (fn ((unop, pos), e) => EAug (Eunop (unop, e), pos)) eAug prefix
  in
    (eAug, ctx)
  end

  and constructExpr parts =
  let
    fun shouldTakePrev _ [] = false
      | shouldTakePrev (_, _, p, assoc) ((_, _, p') :: _) =
        case Int.compare (p', p) of
          GREATER => true
        | EQUAL => assoc
        | LESS => false

    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 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 (applyTop vstack opstack)
      else
        (vstack, (binop, pos, p) :: opstack)

    fun finish ([ea], []) = ea
      | finish (_, []) = raise Unreachable
      | finish (vstack, opstack) = finish $ applyTop 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

  and parseExpr ctx endTk =
  let
    fun collect ctx expVal acc =
      if expVal then
        let
          val (unary, ctx) = parseUnary ctx
        in
          collect ctx (not expVal) (EPexpr unary :: acc)
        end
      else
          case parseBinop ctx endTk of
            SOME (binop, ctx) => collect ctx (not expVal) (binop :: acc)
          | NONE => (rev acc, ctx)

    val (parts, ctx) = collect ctx true []
    val expr = constructExpr parts
  in
    (expr, ctx)
  end

  and tryGetSpec ctx =
  let
    val (tk, pos, ctx') = getTokenCtx ctx

    val storageSpecs = [
        (T.kwTypedef, SpecTypedef),
        (T.kwExtern, SpecExtern),
        (T.kwStatic, SpecStatic),
        (T.kwRegister, SpecRegister)
    ]

    val cmp = (fn tk' => case tk of Tk tk => tk = tk' | _ => false)
    val cmp2 = (fn (tk', _) => case tk of Tk tk => tk = tk' | _ => false)
  in
    case List.find cmp typeSpecs of
      SOME tk => (SOME (TypeSpec tk, pos), ctx')
    | NONE => (
      case List.find cmp2 storageSpecs of
        SOME (_, spec) => (SOME (StorageSpec spec, pos), ctx')
      | NONE => (NONE, ctx)
    )
  end

  and parseDeclPrefix ctx =
  let
    fun collect ctx (storSpec, typeReprId) =
    let
      val (spec, ctx) = tryGetSpec ctx
    in
      case spec of
        NONE =>
            if typeReprId = 0 then
              let
                val (_, pos, _) = getTokenCtx ctx
                val ets = "expected type specifier"
                val etss = "expected type or storage specifier"
              in
                P.error pos `(if isSome storSpec then ets else etss) %
              end
            else
              ((storSpec, typeRepr2type typeReprId), ctx)
      | SOME (StorageSpec spec, pos) => (
          case storSpec of
            NONE => collect ctx (SOME spec, typeReprId)
          | SOME _ =>
              P.error pos `"storage specifier is already provided" %
      )
      | SOME (TypeSpec tk, pos) =>
          collect ctx (storSpec, advanceTypeRepr typeReprId (tk, pos))
    end
  in
    collect ctx (NONE, 0)
  end

  and Ppart part out =
    case part of
      Pointer plevel => Printf out `"[" I plevel `"] " %
    | Id _ => Printf out `"id" %
    | AbstructRoot _ => Printf out `":root" %
    | FuncApp _ => Printf out `"()" %
    | ArrayApplication => Printf out `"[]" %

  and isTypeNameStart tk =
    isSome $ List.find
      (fn tk' => case tk of Tk tk => tk = tk' | _ => false) typeSpecs

  and parseTypeName ctx =
  let
    val (prefix, ctx) = parseDeclPrefix ctx
    val (parts, ctx) = parseDeclarator (true, APenforced) [] ctx
    val declId = assembleDeclarator prefix parts
  in
    (#ctype declId, ctx)
  end

  and parseFuncParams ctx =
  let
    fun collect ctx acc =
    let
      val (prefix, ctx) = parseDeclPrefix ctx
      val (parts, ctx) = parseDeclarator (false, APpermitted) [] ctx
      val declaredId = assembleDeclarator prefix parts

      val (tk, pos, ctx) = getTokenCtx ctx
    in
      case tk of
        Tk T.EOS => (rev $ declaredId :: acc, ctx)
      | Tk T.Comma => collect ctx (declaredId :: acc)
      | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.RParen]
    end

    fun collect2 () =
    let
      val (tk, _, _) = getTokenCtx ctx
    in
      case tk of
        Tk T.EOS => ([], ctx)
      | _ => collect ctx []
    end

    val (params, ctx) = collect2 ()
    val params =
      map (fn { id, pos, ctype, ... } => (id, pos, ctype)) params
  in
    (FuncApp params, ctx)
  end

  and collectDDeclaratorTail parts untilEnd ctx =
  let
    val (tk, pos, ctx') = getTokenCtx ctx

    fun % ctx list f parts =
    let
      val (part, ctx) = ctxWithLayer ctx list (fn ctx => f ctx)
    in
      collectDDeclaratorTail (part :: parts) untilEnd ctx
    end
  in
    case tk of
      TkParens list => % ctx' list parseFuncParams parts
    | TkBrackets _ =>
        collectDDeclaratorTail (ArrayApplication :: parts) untilEnd ctx'
    | Tk T.EOS => (parts, ctx)
    | _ =>
      if untilEnd then
        P.clerror pos [P.Ctk T.LParen, P.Ctk T.RParen]
      else
        (parts, ctx)
  end

  and parseDDeclarator (untilEnd, absPolicy) ctx parts =
  let
    val (tk, pos, ctx') = getTokenCtx ctx

    fun isEOS tk = case tk of Tk T.EOS => true | _ => false

    val (parts, ctx) =
      case tk of
        Tk (T.Id id) =>
          if absPolicy = APenforced then
            P.error pos `"unexpected identifier in abstruct declarator" %
          else
            (Id (id, pos) :: parts, ctx')
      | TkParens list => ctxWithLayer ctx' list
                (fn ctx => parseDeclarator (true, absPolicy) parts ctx)
      | _ => (
          case absPolicy of
            APprohibited => P.clerror pos [P.Cid, P.Ctk T.LParen]
          | _ =>
            if untilEnd andalso not (isEOS tk) then
              P.error pos `"expected abstruct declarator end" %
            else
              (AbstructRoot pos :: parts, ctx)
      )
  in
    collectDDeclaratorTail parts untilEnd ctx
  end

  and parseDeclarator conf parts ctx =
  let
    fun collectPointer plevel ctx =
    let
      val (tk, pos, ctx') = getTokenCtx ctx
    in
      case tk of
        Tk T.Asterisk => collectPointer (plevel + 1) ctx'
      | Tk T.kwConst => P.error pos `"const is not supported" %
      | Tk T.kwVolatile => P.error pos `"volatile is not supported" %
      | _ => (plevel, ctx)
    end

    val (plevel, ctx) = collectPointer 0 ctx
    val (parts, ctx) = parseDDeclarator conf ctx parts
  in
    (if plevel > 0 then
      Pointer plevel :: parts
    else
      parts, ctx)
  end

  and checkParamUniqueness _ [] = ()
    | checkParamUniqueness acc ((SOME id, pos, _) :: ids) = (
      case List.find (fn id' => id' = id) acc of
        SOME _ => P.error pos `"parameter redefinition" %
      | NONE => checkParamUniqueness (id :: acc) ids
    )
    | checkParamUniqueness acc ((NONE, _, _) :: ids) =
        checkParamUniqueness acc ids

  and assembleDeclarator (storSpec, ctype) parts =
  let
    val parts = rev parts

    val (id, pos) =
      case hd parts of
        Id (id, pos) => (SOME id, pos)
      | AbstructRoot pos => (NONE, pos)
      | _ => raise Unreachable

    fun complete (Pointer plevel :: tail) =
        pointer_t (plevel, complete tail)
      | complete (FuncApp params :: tail) =
      let
        val () = checkParamUniqueness [] params
        val params = map (fn (_, _, ctype) => ctype) params
      in
        function_t (complete tail, params)
      end
      | complete (ArrayApplication :: tail) = array_t (complete tail)
      | complete [] = ctype
      | complete _ = raise Unreachable

    val params =
      case parts of
        _ :: FuncApp p :: _  => SOME $ map (fn (id, pos, _) => (id, pos)) p
      | _ => NONE

  in
    { id, pos, spec = storSpec, ctype = complete $ tl parts, params }
  end

  fun pDeclId ({ id, spec, ctype, params, ... }: declaredId) out = (
    Printf out Popt pStorSpec spec `" " Popt P.psid id `": "
        Pctype ctype `"\n" %;

    case params of
      NONE => ()
    | SOME params => Printf out
      `"params: " Plist (popt P.psid) (map #1 params) (", ", false) `"\n" %
  )

  datatype declaration =
    DeclIds of declaredId list |
    FuncDef of declaredId * (token * P.tkPos) list

  fun parseDeclaration ctx expectFdef =
  let
    val (prefix, ctx) = parseDeclPrefix ctx

    fun collectDeclarators acc ctx =
    let
      val (parts, ctx) = parseDeclarator (false, APprohibited) [] ctx
      val declaredId = assembleDeclarator prefix parts

      val (tk, pos, ctx) = getTokenCtx ctx
      fun first () = null acc

      fun die () = P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon]
      fun die2 () = P.clerror pos
        [P.Ctk T.Comma, P.Ctk T.Semicolon, P.Ctk T.LBrace]
    in
      case tk of
        Tk T.Comma => collectDeclarators (declaredId :: acc) ctx
      | Tk T.Semicolon => (DeclIds $ rev $ declaredId :: acc, ctx)
      | TkBraces list =>
          if expectFdef andalso first () then
            (FuncDef (declaredId, list), ctx)
          else
            die ()
      | _ =>
          if first () then
            die2 ()
          else
            die ()
    end
  in
    collectDeclarators [] ctx
  end

  fun parseStmtCompound ctx =
  let
    fun collect acc ctx =
    let
      val (tk, _, _) = getTokenCtx ctx
    in
      case tk of
        Tk T.EOS => (rev acc, ctx)
      | _ =>
          let
            val (ea, ctx) = parseExpr ctx (SOME T.Semicolon)
            val (tk, pos, ctx) = getTokenCtx ctx
          in
            case tk of
              Tk T.Semicolon => collect (ea :: acc) ctx
            | _ => P.clerror pos [P.Ctk T.Semicolon]
          end
    end

    val (eas, ctx) = collect [] ctx
  in
    (StmtCompound eas, ctx)
  end

  val Pstmt = fn z =>
  let
    fun Pstmt off (StmtCompound eas) out =
      Printf out R off `"{\n"
        Plist (printExpr (off + 1)) eas ("", false)
        R off `"}\n" %
  in
    bind A2 Pstmt
  end z

  fun parseFuncDefinition id ctx =
  let
    val (stmt, ctx) = parseStmtCompound ctx
  in
    (Definition (id, stmt), ctx)
  end

  fun printDef (Definition (id, stmt)) =
    printf `"Function: " A1 pDeclId id Pstmt 0 stmt %
  | printDef (Declaration ids) = printf Plist pDeclId ids ("", false) %

  fun parseDef ctx =
  let
    val (tk, _, _) = getTokenCtx ctx
  in
    case tk of
      Tk T.EOS => NONE
    | _ =>
      let
        val (toplev, ctx) = parseDeclaration ctx true
      in
        SOME (case toplev of
          DeclIds ids => (Declaration ids, ctx)
        | FuncDef (id, body) =>
            ctxWithLayer ctx body (fn ctx =>
              parseFuncDefinition id ctx))
      end

  end
end