path: root/parser.fun

functor Parser(structure Tree: TREE; structure P: PPC): PARSER = struct

  structure P = P
  structure T = P.T

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

    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 cnum =
      Ninteger of Word64.word
    | Nfloat of Real32.real
    | Ndouble of Real64.real

  and id = Lid of int | Gid of int

  and expr =
    Eid of int * id option |
    Econst of int * cnum |
    Estrlit of int |
    EmemberByV of int * exprAug |
    EmemberByP of int * exprAug |
    EfuncCall of exprAug * exprAug list |
    Eternary of exprAug * exprAug * exprAug |
    EsizeofType of ctype |
    Eunop of unop * exprAug |
    Ebinop of binop * exprAug * exprAug

  and exprAug = EA of expr * P.tkPos * bool * ctype

  and binop = BR of binopReg | BinopTernaryIncomplete of exprAug

  and ctype =
    unknown_t |
    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 Word64.word * ctype

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

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

  type unopList = (unop * P.tkPos * ctype) list

  datatype exprPrefix =
    NormalPrefix of unopList |
    SizeofType of unopList * ctype * P.tkPos * ctype

  datatype ini = IniExpr of exprAug | IniCompound of ini list

  datatype storageSpec =
    SpecTypedef |
    SpecExtern |
    SpecStatic |
    SpecRegister

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

  val updateRD = fn z =>
  let
    fun from id pos spec t ini params = { id, pos, spec, t, ini, params }
    fun to f { id, pos, spec, t, ini, params } = f id pos spec t ini params
  in
    FRU.makeUpdate6 (from, from, to)
  end z

  datatype stmt =
    StmtExpr of exprAug |
    StmtCompound of (int * ini option) list * stmt list |
    StmtIf of exprAug * stmt * stmt option |
    StmtFor of exprAug option * exprAug option * exprAug option * stmt |
    StmtWhile of exprAug * stmt |
    StmtDoWhile of stmt * exprAug |
    StmtReturn of exprAug |
    StmtBreak |
    StmtContinue

  datatype parseBinopRes = BRbinop of exprPart | BRfinish of int

  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 linkage = LinkInternal | LinkExternal
  datatype declClass = DeclRegular | DeclTentative | DeclDefined

  type objDef = int * P.tkPos * ctype * ini * linkage

  type funcInfo = {
    name: int,
    pos: P.tkPos,
    t: ctype,
    paramNum: int,
    localVars: (int * P.tkPos * ctype) vector,
    stmt: stmt
  }

  datatype def = Objects of objDef list | Definition of funcInfo

  type nid = int

  type scope = (nid, int) Tree.t

  datatype ctx = Ctx of {
    localScopes: scope list,

    localVars: (int * P.tkPos * ctype) list,
    globalDecls: (int, P.tkPos * declClass * ctype * linkage) Tree.t,

    tokenBuf: P.t * (token * P.tkPos) list list,

    loopLevel: int
  }

  val intCompare = fn a => fn b => Int.compare (a, b)
  val lookup = fn z => Tree.lookup intCompare z
  val lookup2 = fn z => Tree.lookup2 intCompare z

  fun updateCtx (Ctx ctx) = fn z =>
  let
    fun from localScopes localVars globalDecls tokenBuf loopLevel =
      { localScopes, localVars, globalDecls, tokenBuf, loopLevel }
    fun to f { localScopes, localVars, globalDecls, tokenBuf, loopLevel } =
      f localScopes localVars globalDecls tokenBuf loopLevel
  in
    FRU.makeUpdate5 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f))
  end

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

  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 pctype short t out =
  let
    fun &(f, s) = Printf out `(if short then s else f) %
  in
    case t of
      unknown_t => & ("unknown", "u")
    | void_t => & ("void", "v")
    | char_t => & ("char", "c")
    | uchar_t => & ("unsigned char", "C")
    | short_t => & ("short", "s")
    | ushort_t => & ("usigned short", "S")
    | int_t => & ("int", "i")
    | uint_t => & ("unsigned int", "I")
    | long_t => & ("long", "l")
    | ulong_t => & ("unsigned long", "L")
    | longlong_t => & ("long long", "w")
    | ulonglong_t => & ("unsigned long long", "W")
    (*
    | float_t => & ("float", "f")
    | double_t => & ("double", "d")
    *)
    | pointer_t (plevel, t) =>
        if short then
          Printf out I plevel A2 pctype true t %
        else
          Printf out `"{" I plevel `"} " A2 pctype false t %
    | function_t (ret, params) => Printf out `"{"
      Plist (pctype short) params (if short then "" else ", ", false)
        `"}" `(if short then "" else " -> ") A2 pctype short ret %
    | array_t (n, el) =>
        Printf out `"[" `(Word64.toString n) `"]" A2 pctype short el %
  end

  val Pctype = fn z => bind A1 (pctype false) 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

  val isIntegral = fn
      char_t | uchar_t | short_t | ushort_t | int_t | uint_t
    | long_t | ulong_t | longlong_t | ulonglong_t => true
    | _ => false

  fun isArith t =
    case t of
      (* float_t | double_t => true | *)
      _ => isIntegral t

  fun isScalar t =
    case t of
      pointer_t _ => true
    | t => isArith t

  val isFunc = fn
      function_t _ => true
    | _ => false

  val isPointer = fn
      pointer_t _ => true
    | _ => false

  fun createCtx fname incDirs = Ctx {
    localScopes = [],
    localVars = [],
    globalDecls = Tree.empty,
    tokenBuf = (P.create { fname, incDirs, debugMode = false }, []),
    loopLevel = 0
  }

  fun loopWrapper ctx f =
  let
    val ctx = updateCtx ctx u#loopLevel (fn l => l + 1) %
    val (r, ctx) = f ctx
    val ctx = updateCtx ctx u#loopLevel (fn l => l - 1) %
  in
    (r, ctx)
  end

  fun isInLoop (Ctx ctx) = #loopLevel ctx > 0

  fun getToken (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
  | getToken (C as (_, [(Tk T.EOS, pos)] :: _)) =
    (Tk T.EOS, pos, C)
  | getToken (_, [_] :: _) = raise Unreachable
  | getToken (_, [] :: _) = raise Unreachable
  | getToken (ppc, ((tk, pos) :: tail) :: layers) =
    (tk, pos, (ppc, tail :: layers))

  fun getTokenCtx (C as Ctx { tokenBuf, ... }) =
  let
    val (tk, pos, tokenBuf) = getToken tokenBuf
  in
    (tk, pos, updateCtx C s#tokenBuf tokenBuf %)
  end

  fun isGlobalScope (Ctx { localScopes, ... }) = null localScopes

  fun ctxWithLayer (C as Ctx { tokenBuf = (ppc, layers), ... }) list cl =
  let
    val ctx = updateCtx C s#tokenBuf (ppc, list :: layers) %
    val (v, ctx) = cl ctx
    val restore = fn (ppc, layers) => (ppc, tl layers)
  in
    (v, updateCtx ctx u#tokenBuf restore %)
  end

  fun Punop unop out =
  let
    fun ~s = Printf out `s %
  in
    case unop of
      UnopPreInc | UnopPostInc => ~"++"
    | UnopPreDec | UnopPostDec => ~"--"
    | UnopSizeof => ~"sizeof"
    | UnopPos => ~"+"
    | UnopNeg => ~"-"
    | UnopAddr => ~"&"
    | UnopDeref => ~"*"
    | UnopComp => ~"~"
    | UnopLogNeg => ~"!"
    | UnopCast => raise Unreachable
  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 pid (Lid id) out = Printf out `"l" I id %
    | pid (Gid _) out = Printf out `"gl" %

  and pexpr e out =
  let
    fun mem (id, ea) s = Printf out A1 pea ea `s P.? id %
  in
    case e of
      Eid (nid, id) => Printf out P.? nid `"{" A3 poptN "none" pid id `"}" %
    | Econst (id, n) => (
        case n of
          Ninteger _ => Printf out P.? id %
        | Nfloat _ => Printf out P.? id `":float" %
        | Ndouble _ => Printf out P.? id `":double" %
    )
    | Estrlit id => Printf out P.? id %
    | EmemberByV p => mem p "."
    | EmemberByP p => mem p "->"
    | EsizeofType ctype => Printf out `"sizeof(" Pctype ctype `")" %
    | EfuncCall (func, args) =>
        Printf out `"fcall " A1 pea func `", " Plist pea args (", ", false) %
    | Eternary (cond, ifB, elseB) =>
        Printf out A1 pea cond `"?" A1 pea ifB `":" A1 pea elseB %
    | Ebinop(BinopTernaryIncomplete _, _, _) => raise Unreachable
    | Ebinop(BR binop, left, right) =>
    let
      val binop =
        if binop = BrSubscript then "[]" else sprintf A1 Pbinop binop %
    in
      Printf out A1 pea left `" " `binop `" " A1 pea right %
    end
    | Eunop (UnopCast, _) => raise Unreachable
    | Eunop (unop, ea) => Printf out A1 Punop unop `" " A1 pea ea %
  end

  and pea (EA (e, _, _, t)) out =
  let
    fun pType out = Printf out A2 pctype true t %
    fun exprPrinter e out =
      case e of
        Eid _ | Econst _ | Estrlit _ =>
          Printf out A1 pexpr e `":" A0 pType %
      | Eunop (UnopCast, ea) =>
        Printf out A1 pea ea `"@" A0 pType %
      | _ => Printf out `"(" A1 pexpr e `"):" A0 pType %
  in
    Printf out A1 exprPrinter e %
  end

  and parseTypeInParens tk ctx =
    case tk of
      TkParens list =>
        if isTypeNameStart (#1 $ hd list) then
          let
            val (ctype, ctx) = ctxWithLayer ctx list parseTypeName
          in
            SOME (ctype, ctx)
          end
        else
          NONE
    | _ => NONE

  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),
      (T.kwSizeof, UnopSizeof)
    ]
    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, unknown_t) :: acc)
        | _ => (NormalPrefix acc, ctx)
      )
    | _ => (
      case parseTypeInParens tk ctx' of
        SOME (ctype, ctx) =>
          if #1 (hd acc) = UnopSizeof handle Empty => false then
            (SizeofType (tl acc, ctype, #2 $ hd acc, ulong_t), ctx)
          else
            parseUnaryPrefix ctx ((UnopCast, pos, ctype) :: acc)
      | NONE => (NormalPrefix acc, ctx)
    )
  end

  and oneOfEndTks tk terms =
  let
    fun f idx tk (tk' :: tks) =
      if tk = tk' then idx else f (idx + 1) tk tks
      | f _ _ [] = 0
  in
    case tk of
      Tk tk => f 1 tk terms
    | _ => 0
  end

  and parseBinop ctx endTks =
  let
    val (tk', pos, ctx) = getTokenCtx ctx
  in
    case tk' of
      TkTernary list =>
      let
        val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr [])
      in
        (BRbinop $ EPbinop (BinopTernaryIncomplete ea, pos,
            ternaryOpPrio, ternaryOpLeftAssoc), ctx)
      end
    | Tk tk =>
      if tk = T.EOS then
        (BRfinish 0, ctx)
      else
        let
          val status = oneOfEndTks tk' endTks
        in
          if status > 0 then
            (BRfinish status, ctx)
          else
            case List.find (fn (_, tk', _, _) => tk' = tk) binopTable of
              SOME (binop, _, prio, leftAssoc) =>
                (BRbinop $ EPbinop (BR binop, pos, prio, leftAssoc), ctx)
            | NONE => P.clerror pos [P.Cbinop]
        end
    | _ => P.clerror pos [P.Cbinop]
  end

  and makeEA e pos = EA (e, pos, false, unknown_t)

  and parseFuncCall funcEa pos ctx =
  let
    fun collectArgs acc ctx =
    let
      val ((status, ea), ctx) = parseExpr [T.Comma] ctx
    in
      if status = 0 then
        (rev $ ea :: acc, ctx)
      else
        collectArgs (ea :: acc) ctx
    end
    val (args, ctx) = collectArgs [] ctx
  in
    (SOME $ makeEA (EfuncCall (funcEa, args)) pos, ctx)
  end

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

    fun formUnop1 unop = (SOME $ makeEA (Eunop (unop, eAug)) pos1, ctx1)
    fun formMemberOp unop =
    let
      val (tk, pos2, ctx2) = getTokenCtx ctx1
    in
      case tk of
        Tk (T.Id id) => (SOME $ makeEA (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 (parseExpr [])
          val ea = makeEA (Ebinop (BR BrSubscript, eAug, ea)) pos1
        in
          (SOME ea, ctx)
        end
    | TkParens list => ctxWithLayer ctx1 list (parseFuncCall eAug 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 determineMinNumType candidates acc =
  let
    open IntInf
    fun p n = pow (fromInt 2, n)

    val limits = [
        (int_t, p 31),
        (uint_t, p 32),
        (long_t, p 63),
        (ulong_t, p 64)
    ]

    fun findLimit longlong_t = p 63
      | findLimit ulonglong_t = p 64
      | findLimit ctype =
        case List.find (fn (t, _) => t = ctype) limits of
          NONE => raise Unreachable
        | SOME (_, limit) => limit

    fun find [] = (ulonglong_t, Word64.fromLargeInt acc)
      | find (t :: tail) =
        if acc < (findLimit t) then
          (t, Word64.fromLargeInt acc)
        else
          find tail
  in
    find candidates
  end

  and getSuffix pos repr =
  let

    fun suffixChar c =
    let
      val c = Char.toLower c
    in
      c = #"u" orelse c = #"l"
    end

    fun findBorder idx =
      if suffixChar $ String.sub (repr, idx) then
        findBorder (idx - 1)
      else
        idx + 1

    val startIdx = findBorder $ String.size repr - 1
    val suffix = String.extract (repr, startIdx, NONE)

    val suffixCode =
      case suffix of
        "" => 0
      | "u" | "U" => 1
      | "l" | "L" => 2
      | "ul" | "uL" | "Ul" | "UL" | "lu" | "lU" | "Lu" | "LU" => 3
      | "ll" | "LL" => 4
      | "ull" | "uLL" | "Ull" | "ULL" | "llu" | "llU" | "LLu" | "LLU" => 5
      | _ => P.error pos `"unknown integer constant suffix" %
  in
    (String.substring (repr, 0, startIdx), suffixCode)
  end

  and determiteIntNumType isDec (acc, suffix) =
  let
    val candidates = [
     ([int_t, long_t, longlong_t], [int_t, uint_t, long_t, ulong_t,
        longlong_t]),
     ([uint_t, ulong_t], [uint_t, ulong_t]),
     ([long_t, longlong_t], [long_t, ulong_t, longlong_t]),
     ([ulong_t], [ulong_t]),
     ([longlong_t], [longlong_t]),
     ([], [])
    ]

    val candArray = Array.fromList candidates
    val (dec, other) = Array.sub (candArray, suffix)
  in
    determineMinNumType (if isDec then dec else other) acc
  end

  and parseNumGeneric (pos, conv) (idx, s) acc radix =
    if idx = String.size s then
      acc
    else
      let
        val d =
          case conv $ String.sub (s, idx) of
            NONE => P.error pos `"invalid integer constant" %
          | SOME v => IntInf.fromInt v
        val idx = idx + 1
        open IntInf
      in
        parseNumGeneric (pos, conv) (idx, s)
            (acc * radix + d) radix
      end

  and collectNum pos num =
  let
    fun hexDigit c =
      if Char.isDigit c then
        SOME $ ord c - ord #"0"
      else if Char.isHexDigit c then
        SOME $ ord c - ord #"a" + 10
      else
        NONE

    fun octDigit c =
      if ord c >= ord #"0" andalso ord c < ord #"8" then
        SOME $ ord c - ord #"0"
      else
        NONE

    fun decDigit c =
      if Char.isDigit c then
        SOME $ ord c - ord #"0"
      else
        NONE
  in
    if String.sub (num, 0) = #"0" then
      (if String.size num > 1 andalso
        Char.toLower (String.sub (num, 1)) = #"x"
      then
        parseNumGeneric (pos, hexDigit) (2, num) 0 16
      else
        parseNumGeneric (pos, octDigit) (1, num) 0 8, false)
    else
      (parseNumGeneric (pos, decDigit) (0, num) 0 10, true)
  end

  and parseInteger pos s =
  let
    val (num, suffix) = getSuffix pos s
    val (acc, isDec) = collectNum pos num
    val (t, v) = determiteIntNumType isDec (acc, suffix)
  in
    (t, Ninteger v)
  end

  and isFPconst s =
  let
    open String
    fun find idx =
      if idx = size s then
        false
      else
        case sub (s, idx) of
          #"." | #"e" | #"E" => true
        | c =>
          if Char.isDigit c then
            find (idx + 1)
          else
            false
  in
    find 0
  end

  (*
  and parseFP pos s =
  let
    val lastC = String.sub (s, String.size s - 1)
    fun handleStatus (status, v) =
      case status of
        0 => v
      | 1 => P.error pos `"floating-point constant overflow" %
      | ~1 => P.error pos `"floating-point constant underflow" %
      | 2 => P.error pos `"invalid floating-point constant" %
      | _ => raise Unreachable
  in
    case Char.toLower lastC of
      #"f" =>
      let
        val repr = String.substring (s, 0, String.size s - 1)
      in
        (float_t, Nfloat o handleStatus o parseFloat $ repr)
      end
    | #"L" => P.error pos `"long double is not supported" %
    | _ => (double_t, Ndouble o handleStatus o parseDouble $ s)
  end
  *)

  and parseNumber pos s =
    (if isFPconst s then
      P.error pos `"floating-point numbers are not implemented" %
        else parseInteger) pos s

  and parsePrimaryExpr ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
    fun wrap e = (makeEA e pos, ctx)
    fun wrapNum id (t, v) = (EA (Econst (id, v), pos, false, t), ctx)
  in
    case tk of
      Tk (T.Id id) => wrap $ Eid (id, NONE)
    | Tk (T.Strlit (id, size)) =>
        (EA (Estrlit id, pos, false,
            array_t (Word64.fromInt size, char_t)), ctx)
    | Tk (T.CharConst (id, v)) => wrapNum id (int_t, Ninteger v)
    | Tk (T.Num id) => wrapNum id $ parseNumber pos $ P.?? id
    | TkParens list =>
      let
        val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr [])
      in
        (ea, ctx)
      end
    | _ => P.clerror pos [P.Cid, P.Cconst, P.Cstrlit]
  end

  and parseUnary ctx =
  let
    val (prefix, ctx) = parseUnaryPrefix ctx []
    fun applyPrefix prefix ea =
        List.foldl (fn ((unop, pos, t), e) =>
            EA (Eunop (unop, e), pos, false, t)) ea prefix
  in
    case prefix of
      NormalPrefix unopList =>
      let
        val (ea, ctx) = parsePrimaryExpr ctx
        val (ea, ctx) = parseExprSuffix ea ctx
      in
       (applyPrefix unopList ea, ctx)
      end
    | SizeofType (unopList, ctype, pos, resType) =>
      (applyPrefix unopList
        (EA (EsizeofType ctype, pos, false, resType)), 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 =
        case binop of
          BR binop => Ebinop (BR binop, left, right)
        | BinopTernaryIncomplete trueBody =>
            Eternary(left, trueBody, right)
    in
      (makeEA head pos :: 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 endTks ctx =
  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 endTks of
            (BRbinop binop, ctx) => collect ctx (not expVal) (binop :: acc)
          | (BRfinish status, ctx) => (status, rev acc, ctx)

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

  and convAggr sizeofOrAddr t =
    if sizeofOrAddr then
      t
    else
      case t of
        function_t _ => pointer_t (1, t)
      | array_t (_, el_t) => pointer_t (1, el_t)
      | _ => t

  and findId (Ctx ctx) pos sizeofOrAddr id =
  let
    fun findLocal [] = NONE
      | findLocal (scope :: scopes) =
      let
        val res = lookup scope id
      in
        case res of
          SOME lid =>
          let
            val locals = rev o #localVars $ ctx
            val t = #3 $ List.nth (locals, lid)
          in
            SOME (Lid lid, true, t)
          end
        | NONE => findLocal scopes
      end
  in
    case findLocal $ #localScopes ctx of
      SOME p => p
    | NONE =>
      let
        val res = lookup (#globalDecls ctx) id
      in
        case res of
          SOME (_, _, t, _) => (Gid id, false, convAggr sizeofOrAddr t)
        | NONE => P.error pos `"unknown identifier" %
      end
  end

  and typeRank t =
    case t of
      char_t => 0
    | uchar_t => 1
    | short_t => 2
    | ushort_t => 3
    | int_t => 4
    | uint_t => 5
    | long_t => 6
    | ulong_t => 7
    | longlong_t => 8
    | ulonglong_t => 9
    | void_t => 12
    | pointer_t _ => 13
    | array_t _ => 14
    | function_t _ => 15
    | unknown_t => raise Unreachable

  and convEA t (E as EA (_, pos, _, _)) =
    EA (Eunop (UnopCast, E), pos, false, t)

  and promoteToInt (E as EA (_, _, _, t)) =
    if typeRank t < typeRank int_t then
      convEA int_t E
    else
      E

  and isLvalue (EA (_, _, lvalue, _)) = lvalue

  and getT ea = case ea of EA (_, _, _, t) => t

  and checkUnop check sizeofOrAddr (EA (Eunop (unop, oper), pos, _, t)) =
  let
    val oper = check (unop = UnopSizeof orelse unop = UnopAddr) oper
    fun finish lvalue t = EA (Eunop (unop, oper), pos, lvalue, t)

    val ot = getT oper

    fun toInt () =
    let
      val oper = promoteToInt oper
    in
      EA (Eunop (unop, oper), pos, false, getT oper)
    end
  in
    case unop of
      UnopPostInc | UnopPostDec | UnopPreInc | UnopPreDec =>
        raise Unimplemented
    | UnopPos | UnopNeg =>
        if isArith ot then
          toInt ()
        else
          P.error pos `"operand of not arithmetic type" %
    | UnopComp =>
        if isIntegral ot then
          toInt ()
        else
          P.error pos `"operand of not integral type" %
    | UnopLogNeg =>
        if isScalar ot then
          finish false int_t
        else
          P.error pos `"operand of not scalar type" %
    | UnopSizeof =>
        if isFunc ot then
          P.error pos `"sizeof argument has function type" %
        else
          finish false ulong_t
    | UnopAddr =>
        if isFunc ot orelse isLvalue oper then
          EA (Eunop (unop, oper), pos, false, pointer_t (1, getT oper))
        else
          P.error pos `"expected function designator or lvalue operand" %
    | UnopDeref => (
        case ot of
          pointer_t (1, T as function_t _) =>
            finish false (if sizeofOrAddr then T else ot)
        | pointer_t (1, t) => finish true t
        | pointer_t (n, t) => finish true (pointer_t (n-1, t))
        | _ => P.error pos `"operand of not pointer type" %
    )
    | UnopCast =>
        if t <> void_t andalso not (isScalar t) then
          P.error pos `": cast to not scalar type or void" %
        else if not (isScalar ot) then
          P.error pos `"operand of not scalar type" %
        else
          finish false t
  end
   | checkUnop _ _ _ = raise Unreachable

  and checkSizeofType (EA (E as EsizeofType t, pos, _, _)) =
    if isFunc t then
      P.error pos `"operand of function type" %
    else
      EA (E, pos, false, ulong_t)
    | checkSizeofType _ = raise Unreachable

  and checkBinop check (EA (Ebinop (binop, left, right), pos, _, t)) =
    EA (Ebinop (binop, check left, check right), pos, false, t)
    | checkBinop _ _ = raise Unreachable

  and checkFuncCall check (EA (EfuncCall (func, args), pos, _, _)) =
  let
    (* TODO: check arguments *)
    val func = check func
  in
    case getT func of
      pointer_t (1, function_t (rt, _)) =>
        EA (EfuncCall (func, args), pos, false, rt)
    | _ => P.error pos `"expected pointer to function" %
  end
    | checkFuncCall _ _ = raise Unreachable

  and checkExpr ctx sizeofOrAddr (E as EA (e, pos, _, _)) =
  let
    val check = checkExpr ctx
  in
    case e of
      Eid (id', _) =>
      let
        val (id, lvalue, t) = findId ctx pos sizeofOrAddr id'
      in
        EA (Eid (id', SOME id), pos, lvalue, t)
      end
    | EsizeofType _ => checkSizeofType E
    | EfuncCall _ => checkFuncCall (check false) E
    | Ebinop (_, _, _) => checkBinop (check false) E
    | Eunop (_, _) => checkUnop check sizeofOrAddr E
    | _ => E
  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
    (#t declId, ctx)
  end

  and checkParamStorSpec ({ spec = spec, pos, ... }: rawDecl) =
    case spec of
      SOME SpecRegister =>
        P.warning pos `"declaration with register storage specifier" %
    | SOME _ => P.error pos `"parameter with invalid storage specifier" %
    | _ => ()

  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 () = checkParamStorSpec declaredId
      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, t, ... } => (id, pos, t)) 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 0w0 :: 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 isParams list =
    case (#1 $ hd list) of
      Tk T.EOS => true
    | tk => isTypeNameStart tk

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

    val isEOS = fn Tk T.EOS => true | _ => false
    val consAbstruct = fn () => (AbstructRoot pos :: parts, ctx)

    val (parts, ctx) =
      case (tk, absPolicy) of
        (Tk (T.Id _), APenforced) =>
            P.error pos `"unexpected identifier in abstract declarator" %
      | (Tk (T.Id id), _) => (Id (id, pos) :: parts, ctx')
      | (TkParens list, _) => (
          case (isParams list, absPolicy) of
            (true, APprohibited) =>
              P.clerror (#2 $ hd list) [P.Cid, P.Ctk T.Asterisk]
          | (true, _) => consAbstruct ()
          | (false, _) => ctxWithLayer ctx' list
            (parseDeclarator (true, absPolicy) parts)
      )
      | (TkBrackets _, APenforced) | (TkBrackets _, APpermitted) =>
          consAbstruct ()
      | (_, 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
          consAbstruct ()
  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) =
    let
      val t = complete tail
    in
      case t of
        pointer_t (plevel', t) => pointer_t (plevel' + plevel, t)
      | _ => pointer_t (plevel, t)
    end
      | complete (FuncApp params :: tail) =
      let
        val () = checkParamUniqueness [] params
        val params = map (fn (_, _, ctype) => ctype) params
      in
        function_t (complete tail, params)
      end
      | complete (ArrayApplication n :: tail) = array_t (n, 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, t = complete $ tl parts,
        ini = NONE, params }
  end

  fun printIni (IniExpr ea) out = Printf out A1 pea ea %
    | printIni (IniCompound inis) out = Printf out
        `"{" Plist (printIni) inis (", ", false) `"}" %

  fun dieExpTerms pos terms = P.clerror pos $ map P.Ctk terms

  fun parseCompoundInitializer ctx =
  let
    fun collect ctx acc =
    let
      val (status, ini, ctx) = parseInitializer [T.Comma] ctx
    in
      if status = 0 then
        (rev $ ini :: acc, ctx)
      else
        collect ctx (ini :: acc)
    end

    val (inis, ctx) = collect ctx []
  in
    (IniCompound inis, ctx)
  end

  and parseInitializer terms ctx =
  let
    val (tk, _, ctx') = getTokenCtx ctx
  in
    case tk of
      TkBraces list =>
      let
        val (ini, ctx) = ctxWithLayer ctx' list parseCompoundInitializer
        val (tk, pos, ctx) = getTokenCtx ctx
        val status = oneOfEndTks tk terms
      in
        if status = 0 then
          dieExpTerms pos terms
        else
          (status, ini, ctx)
      end
    | _ =>
      let
        val ((status, ea), ctx) = parseExpr terms ctx
        fun isToplev [_, _] = true
          | isToplev _ = false
      in
        if status = 0 andalso isToplev terms then
          dieExpTerms (#2 $ getTokenCtx ctx) terms
        else
          (status, IniExpr ea, ctx)
      end
  end

  fun tryParseInitializer ctx rawId =
  let
    val (status, ini, ctx) = parseInitializer [T.Comma, T.Semicolon] ctx
  in
    (status, updateRD rawId s#ini (SOME ini) %, ctx)
  end

  fun getLinkage ctx (D as { spec = NONE, t, ... }) =
    if isFunc t then
      getLinkage ctx (updateRD D s#spec (SOME SpecExtern) %)
    else
      LinkExternal
    | getLinkage _ { spec = SOME SpecStatic, ... } = LinkInternal
    | getLinkage (Ctx ctx) { spec = SOME SpecExtern, id, ... } =
    let
      val prevLinkage =
        case lookup (#globalDecls ctx) (valOf id) of
          NONE => NONE
        | SOME (_, _, _, linkage) => SOME linkage
    in
      case prevLinkage of
        SOME linkage => linkage
      | NONE => LinkExternal
    end
   | getLinkage _ { pos, ... } =
      P.error pos `"declaration with invalid storage specifier" %

  fun getToplevFuncDeclKind ctx (D as { id, pos, t, ... }: rawDecl) =
  let
    val linkage = getLinkage ctx D
  in
    (DeclRegular, (valOf id, pos, t, linkage), NONE)
  end

  fun getToplevObjDeclKind ctx
    (D as { ini, id, pos, t, spec, ... }: rawDecl) =
  let
    val linkage = getLinkage ctx D
    val decl = (valOf id, pos, t, linkage)
  in
    case ini of
      SOME _ => (DeclDefined, decl, ini)
    | NONE =>
      let
        val class =
          case spec of
            SOME SpecExtern => DeclRegular
          | NONE | SOME SpecStatic =>
              if isFunc t then DeclRegular else DeclTentative
          | _ => raise Unreachable
      in
        (class, decl, ini)
      end
  end

  fun getToplevDeclKind ctx (id as { t, ... }: rawDecl) =
    (if isFunc t then getToplevFuncDeclKind else getToplevObjDeclKind)
        ctx id

  fun link2str LinkInternal = "internal"
    | link2str LinkExternal = "external"

  fun class2str DeclRegular = "regular"
    | class2str DeclTentative = "tentative"
    | class2str DeclDefined = "definition"

  fun addDeclaration (Ctx ctx) (id, pos, t, linkage) class =
  let
    fun f NONE = ((), SOME (pos, class, t, linkage))
      | f (SOME (_, class', t', linkage')) =
      if linkage' <> linkage then
        P.error pos `"declaration linkage conflict" %
      else if t <> t' then
        P.error pos `"declaration type conflict" %
      else
        let
          val newClass =
            case (class, class') of
              (DeclRegular, DeclRegular) => DeclRegular
            | (DeclRegular, DeclTentative) | (DeclTentative, DeclRegular) |
              (DeclTentative, DeclTentative) => DeclTentative
            | (DeclDefined, DeclDefined) =>
                P.error pos `"redefinition" %
            | _ => DeclDefined
        in
          ((), SOME (pos, newClass, t, linkage))
        end

    val () = printf `(class2str class) `" decl "
      `(link2str linkage) `" " P.?id `": " Pctype t `"\n" %

    val ((), tree) = lookup2 (#globalDecls ctx) id f
  in
    updateCtx (Ctx ctx) s#globalDecls tree %
  end

  datatype idData = ToplevId of objDef | LocalId of int * ini option

  fun handleToplevDecl ctx rawDecl =
  let
    val (class, D as (id, pos, t, linkage), ini) =
        getToplevDeclKind ctx rawDecl
    val ctx = addDeclaration ctx D class
  in
    if class = DeclDefined then
      (SOME $ ToplevId (id, pos, t, valOf ini, linkage), ctx)
    else
      (NONE, ctx)
  end

  fun warnRegister pos (SOME SpecRegister) =
    P.warning pos `"register storage specifier" %
    | warnRegister _ _ = ()

  fun checkLocalVarType pos t =
    if isFunc t then
      P.error pos `"variable with function type" %
    else
      ()

  fun insertLocalVar (Ctx ctx) ({ id, pos, t, ... }: rawDecl) =
  let
    val id = valOf id
    val scope = hd $ #localScopes ctx
    val oldVal = lookup scope id
  in
    case oldVal of
      SOME _ => P.error pos `"local variable redefinition" %
    | NONE =>
        let
          val varId = length $ #localVars ctx
          val localVars = (id, pos, t) :: #localVars ctx
          val (_, scope) = Tree.insert intCompare scope id varId
        in
          (varId, id, updateCtx (Ctx ctx)
            u#localScopes (fn scs => scope :: tl scs)
            s#localVars localVars %)
        end
  end

  fun handleLocalVar ctx (D as { spec, pos, t, ini, ... }: rawDecl) =
  let
    val () = warnRegister pos spec
    val () = checkLocalVarType pos t
    val (varId, nid, ctx) = insertLocalVar ctx D

    val offset = case ctx of Ctx v => length $ #localScopes v
  in
    printf R offset
        `"local var " P.?nid `"(" I varId `"): " Pctype t `"\n" %;

    if isSome ini orelse not $ isScalar t then
      (SOME $ LocalId (varId, ini), ctx)
    else
      (NONE, ctx)
  end

  fun handleRawDecl ctx (D as { spec, pos, ... }: rawDecl) =
    case spec of
      SOME SpecTypedef => P.error pos `"typedef is not supported yet\n" %
    | _ =>
      (if isGlobalScope ctx then handleToplevDecl else handleLocalVar)
        ctx D

  datatype fdecRes =
    FDnormal of (bool * idData option) |
    FDFuncDef of rawDecl * (token * P.tkPos) list

  fun finishDeclarator rawId expectFdef ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
    fun ret continue rawId ctx =
    let
      val (def, ctx) = handleRawDecl ctx rawId
    in
      (FDnormal (continue, def), ctx)
    end
  in
    case tk of
      Tk T.Comma => ret true rawId ctx
    | Tk T.Semicolon => ret false rawId ctx
    | Tk T.EqualSign =>
      let
        val (status, rawId, ctx) = tryParseInitializer ctx rawId
      in
        ret (status = 1) rawId ctx
      end
    | _ =>
      if expectFdef then
        case tk of
          TkBraces list => (FDFuncDef (rawId, list), ctx)
        | _ => P.clerror pos
            [P.Ctk T.Comma, P.Ctk T.Semicolon, P.Ctk T.LBrace]
      else
        P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon]
  end

  datatype toplev =
    ObjDefs of objDef list |
    LocalVarInits of (int * ini option) list |
    FuncDef of rawDecl * (token * P.tkPos) list

  fun parseDeclaration ctx =
  let
    val toplev = isGlobalScope ctx
    val (prefix, ctx) = parseDeclPrefix ctx

    fun finishNormal acc =
    let
      val acc = rev acc
    in
      if toplev then
        ObjDefs $ map (fn ToplevId v => v | _ => raise Unreachable) acc
      else
        LocalVarInits $ map (fn LocalId v => v | _ => raise Unreachable)
          acc
    end

    fun collectDeclarators acc ctx =
    let
      fun add (SOME v) = v :: acc
        | add NONE = acc

      val (parts, ctx) = parseDeclarator (false, APprohibited) [] ctx
      val declIdRaw = assembleDeclarator prefix parts
      val (res, ctx) = finishDeclarator declIdRaw
            (toplev andalso null acc) ctx
    in
      case res of
        FDFuncDef fd => (FuncDef fd, ctx)
      | FDnormal (continue, toplevMaybe) =>
        if continue then
          collectDeclarators (add toplevMaybe) ctx
        else
          (finishNormal $ add toplevMaybe, ctx)
    end
  in
    collectDeclarators [] ctx
  end

  fun skipExpected expectedTk ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
    fun die () = P.clerror pos [P.Ctk expectedTk]
  in
    case tk of
      Tk tk =>
        if tk = expectedTk then
          ctx
        else
          die ()
    | _ => die ()
  end

  fun parseJmp (ctx, pos) stmt =
  let
    val () =
      if not $ isInLoop ctx then
        P.error pos `"loop jump outside of loop" %
      else
        ()
    val ctx' = skipExpected T.Semicolon ctx
  in
    (stmt, ctx')
  end

  fun parseStmt ctx =
  let
    val (tk, pos, ctx') = getTokenCtx ctx
    val loopWrapper = loopWrapper ctx'
    val parseJmp = parseJmp (ctx', pos)
  in
    case tk of
      TkBraces list => ctxWithLayer ctx' list (parseStmtCompound false)
    | Tk T.kwIf => parseIf ctx'
    | Tk T.kwFor => loopWrapper parseFor
    | Tk T.kwWhile => loopWrapper parseWhile
    | Tk T.kwDo => loopWrapper parseDoWhile
    | Tk T.kwBreak => parseJmp StmtBreak
    | Tk T.kwContinue => parseJmp StmtContinue
    | Tk T.kwReturn => parseReturn ctx'
    | _ => parseStmtExpr ctx
  end

  and getParenInsides ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
  in
    case tk of
      TkParens list => (list, ctx)
    | _ => P.clerror pos [P.Ctk T.LParen]
  end

  and parseReturn ctx =
  let
    val ((status, ea), ctx) = parseExpr [T.Semicolon] ctx
  in
    if status = 0 then
      P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.Semicolon]
    else
      (StmtReturn ea, ctx)
  end

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

    val notlastExp = [P.Ctk T.Semicolon, P.Cexpr]
    val lastExp = [P.Ctk T.RParen, P.Cexpr]
  in
    case tk of
      Tk tk =>
        if (last andalso tk = T.EOS) orelse
            (not last andalso tk = T.Semicolon)
        then
          (NONE, ctx')
        else
          let
            val ((status, ea), ctx) = parseExpr [T.Semicolon] ctx
          in
            if status = 0 andalso not last then
              P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.Semicolon]
            else if status <> 0 andalso last then
              P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.RParen]
            else
              (SOME ea, ctx)
          end
    | _ => P.clerror pos (if last then lastExp else notlastExp)
  end

  and parseFor ctx =
  let
    fun parseHeader ctx =
    let
      val (pre, ctx) = parseExprFor false ctx
      val (cord, ctx) = parseExprFor false ctx
      val (post, ctx) = parseExprFor true ctx
    in
      ((pre, cord, post), ctx)
    end

    val (list, ctx) = getParenInsides ctx
    val ((pre, cord, post), ctx) = ctxWithLayer ctx list parseHeader
    val (body, ctx) = parseStmt ctx
  in
    (StmtFor (pre, cord, post, body), ctx)
  end

  and parseExprInParens ctx =
  let
    val (list, ctx) = getParenInsides ctx
    val ((_, ea), ctx) = ctxWithLayer ctx list (parseExpr [])
  in
    (ea, ctx)
  end

  and parseIf ctx =
  let
    val (cond, ctx) = parseExprInParens ctx
    val (stmt, ctx) = parseStmt ctx

    val (tk, _, ctx') = getTokenCtx ctx
    val (elseBody, ctx) =
      case tk of
        Tk T.kwElse => (fn (a, b) => (SOME a, b)) $ parseStmt ctx'
      | _ => (NONE, ctx)
  in
    (StmtIf (cond, stmt, elseBody), ctx)
  end

  and parseWhile ctx =
  let
    val (cond, ctx) = parseExprInParens ctx
    val (stmt, ctx) = parseStmt ctx
  in
    (StmtWhile (cond, stmt), ctx)
  end

  and parseDoWhile ctx =
  let
    val (stmt, ctx) = parseStmt ctx
    val ctx = skipExpected T.kwWhile ctx
    val (cond, ctx) = parseExprInParens ctx
    val ctx = skipExpected T.Semicolon ctx
  in
    (StmtDoWhile (stmt, cond), ctx)
  end

  and parseStmtExpr ctx =
  let
    val ((status, ea), ctx) = parseExpr [T.Semicolon] ctx
  in
    if status = 0 then
      P.clerror (#2 $ getTokenCtx ctx) [P.Ctk T.Semicolon]
    else
      (StmtExpr ea, ctx)
  end

  and parseStmtCompound isFuncBody ctx =
  let
    fun collectDecls acc ctx =
    let
      val (tk, _, _) = getTokenCtx ctx
    in
      if isTypeNameStart tk then
        let
          val (res , ctx) = parseDeclaration ctx
          val inits =
            case res of
              LocalVarInits l => l
            | _ => raise Unreachable
        in
          collectDecls (List.revAppend (inits, acc)) ctx
        end
      else
        (rev acc, ctx)
    end

    fun collectStmts acc ctx =
    let
      val (tk, _, _) = getTokenCtx ctx
    in
      case tk of
        Tk T.EOS => (rev acc, ctx)
      | _ =>
        let
          val (stmt, ctx) = parseStmt ctx
        in
          collectStmts (stmt :: acc) ctx
        end
    end

    val ctx =
      if isFuncBody then
        ctx
      else
        updateCtx ctx u#localScopes (fn scs => Tree.empty :: scs) %

    val (inits, ctx) = collectDecls [] ctx
    val (stmts, ctx) = collectStmts [] ctx

    val ctx = updateCtx ctx u#localScopes tl %
  in
    (StmtCompound (inits, stmts), ctx)
  end

  fun pinit off (id, ini) out =
    Printf out R off
        `"%" I id `" <- " A3 poptN "alloc" printIni ini `"\n" %

  fun pstmt' off (StmtCompound (inits, stmts)) out =
    Printf out `"{\n"
      Plist (pinit (off + 1)) inits ("", false)
      Plist (pstmt (off + 1)) stmts ("\n", false)
      R off `"}" %

    | pstmt' _ (StmtExpr ea) out = Printf out A1 pea ea `";" %

    | pstmt' off (StmtIf (cond, ifBody, elseBody)) out =
      Printf out `"if " A1 pea cond `" " A2 pCompBody (off + 1) ifBody
      Popt (fn stmt => fn out =>
        Printf out R off `"else " A2 pCompBody (off + 1) stmt %) elseBody %

    | pstmt' off (StmtFor (pre, cond, post, body)) out =
      Printf out
        `"for " Popt pea pre `"; " Popt pea cond `"; " Popt pea post
        A2 pCompBody (off + 1) body %

    | pstmt' off (StmtWhile (cond, body)) out =
      Printf out `"while " A1 pea cond `" "
        A2 pCompBody (off + 1) body %

    | pstmt' off (StmtDoWhile (body, cond)) out =
      Printf out `"do " A2 pCompBody (off + 1) body
        `" " A1 pea cond `";" %
    | pstmt' _ (StmtReturn ea) out =
        Printf out `"return " A1 pea ea `";" %
    | pstmt' _ StmtBreak out = Printf out `"break;" %
    | pstmt' _ StmtContinue out = Printf out `"continue;" %

  and pCompBody off (S as (StmtCompound _)) out =
    Printf out A2 pstmt' (off - 1) S %
    | pCompBody (off:int) stmt out = Printf out `"\n" A2 pstmt off stmt %

  and pstmt off stmt out = Printf out R off A2 pstmt' off stmt `"\n" %

  val Pstmt = fn z => bind A2 pstmt z

  fun validateFuncHeader ({ t, pos, params, ... }: rawDecl) =
  let
    val () =
      if not $ isFunc t then
        P.error pos `"identifier not of function type\n" %
      else
        ()
    fun checkParams [] = ()
      | checkParams ((id, pos) :: tail) =
        case id of
          NONE => P.error pos `"expected parameter name\n" %
        | SOME _ => checkParams tail
  in
    checkParams $ valOf params
  end

  fun ctxPrepareForFunc ctx t params =
  let
    val paramTypes =
      case t of function_t (_, ts) => ts | _ => raise Unreachable

    fun createLocalVars (acc, scope) [] [] = (acc, scope)
      | createLocalVars (acc, scope) (t :: ts) ((SOME id, pos) :: params) =
      let
        val localVar = (id, pos, t)
        val (_, scope) = Tree.insert intCompare scope id $ length acc
      in
        createLocalVars (localVar :: acc, scope) ts params
      end
      | createLocalVars _ _ _ = raise Unreachable

    val (localVars, scope) =
      createLocalVars ([], Tree.empty) paramTypes params
  in
    updateCtx ctx s#localVars localVars s#localScopes [scope] %
  end

  fun finishLocalVars (Ctx ctx) = Vector.fromList o rev o #localVars $ ctx

  fun parseFuncDefinition (D as { id, pos, t, params, ... }: rawDecl) ctx =
  let
    val () = validateFuncHeader D
    val (id, params) = (valOf id, valOf params)

    val ctx = ctxPrepareForFunc ctx t params

    val linkage = getLinkage ctx D
    val ctx = addDeclaration ctx (id, pos, t, linkage) DeclDefined

    val (stmt, ctx) = parseStmtCompound true ctx
    val localVars = finishLocalVars ctx
  in
    (Definition {
        name = id,
        pos,
        t,
        paramNum = length params,
        localVars,
        stmt },
    ctx)
  end

  fun printFuncHeader ({ name, localVars, paramNum, t, ... }: funcInfo) =
  let
    fun getParams acc idx =
      if idx = paramNum then
        rev acc
      else
        let
          val param = #3 $ Vector.sub (localVars, idx)
        in
          getParams ((idx, param) :: acc) (idx + 1)
        end

    val params = getParams [] 0
    fun printParam (id, t) out = Printf out `"%" I id `": " Pctype t %
    val ret = case t of function_t (ret, _) => ret | _ => raise Unreachable
  in
    printf P.?name Plist printParam params (", ", true)
        `" -> " Pctype ret `"\n" %
  end

  fun printDef (Objects objs) =
  let
    fun pobj (id, _, t, ini, linkage) out =
    let
      val link = if linkage = LinkInternal then "static" else "global"
    in
      Printf out `link `" " P.?id `":" Pctype t
        `" = " A1 printIni ini `"\n" %
    end
  in
    printf Plist pobj objs ("", false) %
  end
  | printDef (Definition (D as { stmt, localVars, ... })) =
  let
    fun pLocalVar i (id, _, t) out =
      Printf out `"%" I i `"(" P.?id `"): " Pctype t `"\n" %
  in
    printFuncHeader D;
    printf Pstmt 0 stmt %;
    Vector.appi (fn (i, var) => printf A2 pLocalVar i var %) localVars
  end

  fun parseDef ctx =
  let
    val (tk, _, _) = getTokenCtx ctx
  in
    case tk of
      Tk T.EOS => NONE
    | _ =>
      let
        val (toplev, ctx) = parseDeclaration ctx
      in
        SOME (case toplev of
          ObjDefs objDefList => (Objects objDefList, ctx)
        | FuncDef (id, body) =>
            ctxWithLayer ctx body (parseFuncDefinition id)
        | LocalVarInits _ => raise Unreachable)
      end
  end
end