path: root/parser.fun

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

  structure P = P
  structure T = P.T
  structure D = D

  type nid = int

  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 evalRes = ER of word * ctype

  and id = Lid of int | Gid of int * bool

  and expr =
    Eid of int * id option |
    Econst of int * cnum |
    Estrlit of int |
    EmemberByV of exprAug * int |
    EmemberByP of exprAug * int |
    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 * bool |
    array_t of Word64.word * ctype |
    struct_t of
     { name: nid, size: word, alignment: word,
        fields: (nid * word * ctype) list } |
    union_t of
     { name: nid, size: word, alignment: word,
        fields: (nid * word * ctype) list } |

    enum_t of nid * bool | (* is complete? *)
    remote_t of int

  val typeSizes = [
    (char_t, 1), (uchar_t, 1),
    (short_t, 2), (ushort_t, 2),
    (int_t, 4), (uint_t, 4),
    (long_t, 8), (ulong_t, 8),
    (longlong_t, 8), (longlong_t, 8)
  ]

  datatype under = UNone | USizeof | UAddr

  val pointerSize = Word64.fromInt 8

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

  val voidp = pointer_t (1, void_t)

  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 cini = CiniExpr of exprAug | CiniLayout of int

  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
  }

  datatype funcParam = FpParam of rawDecl | FpTripleDot

  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 * cini 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 option |
    StmtBreak |
    StmtNone |
    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 * cini * linkage

  type funcInfo = {
    name: int,
    pos: P.tkPos,
    t: ctype,
    paramNum: int,
    localVars: { name: nid, pos: P.tkPos, onStack: bool, t: ctype } vector,
    stmt: stmt
  }

  datatype def = Objects of objDef list | Definition of funcInfo

  type scope = (nid, int) Tree.t

  datatype tag = TagStruct | TagUnion | TagEnum

  datatype typeStatus = TsDefined of tag | TsIncomplete of tag | TsNotDefined

  (*
   * For structures and unions the type name (nid) is duplicated for the
   * ease of pctype function
   *)
  val types: { name: nid, pos: P.tkPos, t: ctype } D.t =
    D.create0 ()

  fun resolveType t =
  let
    fun resolve id =
    let
      val { t, ... } = D.get types id
    in
      case t of
        remote_t id => resolve id
      | t => t

    end
  in
    case t of
      remote_t id => resolve id
    | t => t
  end

  datatype taggedBody = EnumBody of (nid * P.tkPos * int) list
        | AggrBody of (nid * ctype) list

  type decl = P.tkPos * declClass * ctype * linkage

  datatype globalSym =
    GsDecl of decl |
    GsEnumConst of int |
    GsTypedef of int

  val localVars: { name: nid, pos: P.tkPos, onStack: bool, t: ctype } D.t
    = D.create0 ()

  val iniLayouts:
    (bool * word * { offset: word, t: ctype, value: word } list) D.t =
        D.create0 ()

  datatype ctx = Ctx of {
    aggrTypeNames: scope,

    localScopes: scope list,
    funcRetType: ctype option,

    globalSyms: (int, globalSym) Tree.t,

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

    loopLevel: int,
    paramNum: int option,

    defs: def list,
    strlits: int list
  }

  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 aggrTypeNames localScopes funcRetType globalSyms
      tokenBuf loopLevel paramNum defs strlits
    =
      { aggrTypeNames, localScopes, funcRetType, globalSyms,
        tokenBuf, loopLevel, paramNum, defs, strlits }

    fun to f { aggrTypeNames, localScopes, funcRetType, globalSyms,
        tokenBuf, loopLevel, paramNum, defs, strlits }
    =
      f aggrTypeNames localScopes funcRetType globalSyms tokenBuf
        loopLevel paramNum defs strlits
  in
    FRU.makeUpdate9 (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 bool * (int option * P.tkPos * ctype) list |
    ArrayApplication of Word64.word

  datatype abstructPolicy = APpermitted | APenforced | APprohibited

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

  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)
  ]

  datatype justConvArithResType = ResFromHigher | ResFromLeft | ResIsInt

  fun pctype short t out =
  let
    fun &(f, s) = Printf out `(if short then s else f) %

    fun ptagged (s, l) id out =
      if short then
        Printf out `s I id %
      else
        Printf out `l `" " P.? id %
  in
    case resolveType t of
      unknown_t => & ("unknown", "x")
    | 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, variadic) => Printf out `"{"
      Plist (pctype short) params (if short then "" else ", ", false, 2)
        `(if variadic then if short then "V" else " variadic" else "") `"}"
        `(if short then "" else " -> ") A2 pctype short ret %
    | array_t (n, el) =>
        Printf out `"[" W n `"]" A2 pctype short el %
    | struct_t { name, ... } => Printf out A2 ptagged ("r", "struct") name %
    | union_t { name, ... } => Printf out A2 ptagged ("u", "union") name %
    | enum_t (name, _) => Printf out A2 ptagged ("e", "enum") name %
    | remote_t _ => raise Unreachable
  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,

      T.kwStruct,
      T.kwUnion,
      T.kwEnum
  ]

  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

  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

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

    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, 2) `(" |" ^ 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, 2) %
  end
  *)

  fun isIntegral t =
    case resolveType t of
      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 resolveType t of
      (* float_t | double_t => true | *)
      _ => isIntegral t

  fun isSigned t =
    case resolveType t of
      char_t | short_t | int_t | long_t | longlong_t => true
    | _ => false

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

  fun isFunc t =
    case resolveType t of
      function_t _ => true
    | _ => false


  fun isPointer t =
    case resolveType t of
      (pointer_t _) => true
    | _ => false

  fun isIncomplete t =
    case resolveType t of
      (struct_t { fields, ... }) => null fields
    | (union_t { fields, ... }) => null fields
    | _ => false

  fun isObj t =
    case resolveType t of
      (void_t | function_t _) => false
    | _ => not $ isIncomplete t

  fun isPointerToObj t =
    case resolveType t of
      (pointer_t (n, t)) => if n > 1 then true else isObj t
    | _ => false

  fun isArray t =
    case resolveType t of
      array_t _ => true
    | _ => false

  fun isStruct t =
    case resolveType t of
      struct_t _ => true
    | _ => false

  fun isUnion t =
    case resolveType t of
      union_t _ => true
    | _ => false

  fun funcParts t =
    case resolveType t of
      (function_t (t, params, _)) => (t, params)
    | _ => raise Unreachable

  fun pointsTo t =
    case resolveType t of
      pointer_t (1, t) => t
    | pointer_t (n, t) =>
        if n < 2 then raise Unreachable else pointer_t (n - 1, t)
    | _ => raise Unreachable

  fun tryGetFields t =
    case resolveType t of
      (struct_t { fields, ... }) => fields
    | (union_t { fields, ... }) => fields
    | _ => raise Unreachable

  fun createCtx fname incDirs = Ctx {
    aggrTypeNames = Tree.empty,
    localScopes = [],
    funcRetType = NONE,
    globalSyms = Tree.empty,
    tokenBuf = (P.create { fname, incDirs, debugMode = false }, []),
    loopLevel = 0,
    paramNum = NONE,
    defs = [],
    strlits = []
  }

  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 (ea, id) 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, 2) %
    | 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 ctx (#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 isEmpty ctx =
      case #1 $ getTokenCtx ctx of
        Tk T.EOS => true
      | _ => false

    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) = if isEmpty ctx then ([], ctx) else 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 (eAug, id)) 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)) =>
        let
          val ctx = updateCtx ctx u#strlits (fn l => id :: l) %
        in
          (EA (Estrlit id, pos, true,
              array_t (Word64.fromInt size, char_t)), ctx)
        end
    | 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 UNone expr
  in
    ((eof, expr), ctx)
  end

  and convAggr under t lvalue =
    case under of
      UNone => (
        case t of
          function_t _ => (pointer_t (1, t), false)
        | array_t (_, el_t) => (pointer_t (1, el_t), false)
        | _ => (t, lvalue)
      )
    | _ => (t, lvalue)

  and reduceVarToStack id =
  let
    val ({ name, pos, onStack = _, t }) = D.get localVars id
  in
    D.set localVars id ({ name, pos, onStack = true, t })
  end

  and findId (Ctx ctx) pos under id =
  let
    fun findLocal [] = NONE
      | findLocal (scope :: scopes) =
      let
        val res = lookup scope id
      in
        case res of
          SOME lid =>
          let
            val t = #t $ D.get localVars lid

            val () =
              if under = UAddr then
                if lid < valOf (#paramNum ctx) then
                  P.error pos `"cannot take address of function argument" %
                else
                  reduceVarToStack lid
              else
                ()
            val (t, lvalue) = convAggr under t (not $ isFunc t)
          in
            SOME (Lid lid, lvalue, t, NONE)
          end
        | NONE => findLocal scopes
      end
  in
    case findLocal $ #localScopes ctx of
      SOME p => p
    | NONE =>
      let
        val res = lookup (#globalSyms ctx) id
      in
        case res of
          SOME (GsDecl (_, _, t, _)) =>
          let
            val (t', lvalue) = convAggr under t (not $ isFunc t)
          in
            (Gid (id, isFunc t), lvalue, t', NONE)
          end
        | SOME (GsEnumConst v) => (Gid (id, false), false, int_t, SOME v)
        | SOME (GsTypedef _) =>
            P.error pos `"type in place of an identifier" %
        | NONE => P.error pos `"unknown identifier" %
      end
  end

  and typeRank t =
    case resolveType 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
    | struct_t _ => 16
    | union_t _ => 17
    | unknown_t | remote_t _ | enum_t _ => raise Unreachable

  and convEA t (E as EA (_, pos, _, t')) =
    if t = t' then
      E
    else if t' = void_t then
      P.error pos `"unable to convert void" %
    else
      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 commonType t1 t2 =
  let
    val common = if typeRank t1 > typeRank t2 then t1 else t2
  in
    if typeRank common < typeRank int_t then int_t else common
  end

  and convArith (E1 as EA (_, pos1, _, t1)) (E2 as EA (_, pos2, _, t2)) =
  let
    val rank1 = typeRank t1
    val rank2 = typeRank t2

    val (higherType, pos, emax, emin, swapNeeded) =
      if rank1 > rank2 then
        (t1, pos1, E1, E2, false)
      else
        (t2, pos2, E2, E1, true)

    val () =
      if typeRank higherType > typeRank ulonglong_t then
        P.error pos `"expected arithmetic type" %
      else
        ()

    fun swap e1 e2 = if swapNeeded then (e2, e1) else (e1, e2)
  in
    if rank1 = rank2 then
      if rank1 >= typeRank int_t then
        (t1, (E1, E2))
      else
        (int_t, (promoteToInt E1, promoteToInt E2))
    else
      (higherType, swap emax (convEA higherType emin))
  end

  and isLvalue (EA (_, _, lvalue, _)) = lvalue
  and getT (EA (_, _, _, t)) = t
  and getPos (EA (_, pos, _, _)) = pos
  and setT (EA (binop, pos, lvalue, _)) t = EA (binop, pos, lvalue, t)

  and checkUnop check under (EA (Eunop (unop, oper), pos, _, t)) =
  let
    val under' =
      case unop of
        UnopSizeof => USizeof
      | UnopAddr => UAddr
      | _ => UNone
    val oper = check under' 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 =>
      if isScalar ot andalso isLvalue oper then
        EA (Eunop (unop, oper), pos, false, ot)
      else
        P.error (getPos oper)
          `"expected an arithmetic or a pointer lvalue expression" %
    | 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 (case under of UNone => ot | _ => T)
        | 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 justConvArith (EA (Ebinop (binop, left, right), pos, _, _))
      resultMode =
  let
    val (resT, (left, right)) = convArith left right
    val resT =
      case resultMode of
        ResIsInt => int_t
      | ResFromLeft => getT left
      | ResFromHigher => resT
  in
    EA (Ebinop (binop, left, right), pos, false, resT)
  end
   | justConvArith _ _ = raise Unreachable

  and checkRel (E as (EA (Ebinop (binop, left, right), pos, _, _))) =
  let
    val isEqCheck =
      case binop of BR BrEqual | BR BrNotEqual => true | _ => false

    val leftT = getT left
    val rightT = getT right
    val rightPos = getPos right
  in
    if isArith leftT andalso isArith rightT then
      justConvArith E ResIsInt
    else if isPointer leftT then
      if isPointer rightT then
        if pointsTo leftT = pointsTo rightT then
          setT E int_t
        else if isEqCheck andalso rightT = voidp then
          EA (Ebinop (binop, convEA voidp left, right), pos, false, int_t)
        else if isEqCheck andalso leftT = voidp then
          EA (Ebinop (binop, left, convEA voidp right), pos, false, int_t)
        else
          P.error rightPos `"pointer type does not match left sibling" %
      else
        P.error rightPos `"expected pointer" %
    else
      P.error (getPos left) `"expected arithmetic type or pointer" %
  end
    | checkRel _ = raise Unreachable

  and checkLogOp (E as EA (Ebinop (_, left, right), _, _, _)) =
  let
    fun error ea = P.error (getPos ea)`"expected value of scalar type" %
  in
      if isScalar (getT left) then
        if isScalar (getT right) then
          setT E int_t
        else
          error right
      else
        error left
  end
    | checkLogOp _ = raise Unreachable

  and checkSimpleArith (E as (EA (Ebinop (binop, left, right), _, _, _))) =
  let
    val leftT = getT left
    val rightT = getT right

    val leftPos = getPos left
    val rightPos = getPos right

    val isSub = case binop of BR BrSub => true | _ => false

    fun swap (EA (Ebinop (binop, left, right), pos, lvalue, t)) =
      EA (Ebinop (binop, right, left), pos, lvalue, t)
      | swap _ = raise Unreachable
  in
    if isArith leftT then
      if isArith rightT then
        justConvArith E ResFromHigher
      else if isPointerToObj rightT then
        swap $ setT E rightT
      else
        P.error rightPos `"expeced pointer" %
    else if isPointerToObj leftT then
      if isIntegral rightT then
        setT E leftT
      else if isSub andalso isPointer rightT then
        if leftT = rightT then
          setT E long_t
        else
          P.error rightPos `"value type does not match its left sibling" %
      else
        P.error rightPos `"expected value of an integral type" %
    else
      P.error leftPos `"expected value of an integral type or a pointer" %
  end
    | checkSimpleArith _ = raise Unreachable

  and checkSimpleAssignment
    (E as EA (Ebinop (binop, left, right), pos, lvalue, _))
  =
    if not $ isLvalue left then
      P.error (getPos left) `"expected lvalue" %
    else
    let
      val leftT = getT left
      val rightT = getT right
    in
      if isArith leftT andalso isArith rightT then
        EA (Ebinop (binop, left, convEA leftT right), pos, lvalue, leftT)
      else if isPointer leftT then
        if leftT = rightT then
          setT E leftT
        else if leftT = voidp orelse rightT = voidp then
          setT E leftT
        else
          P.error (getPos right)
            `"expression has a type incompatible with its sibling: "
             `"(" Pctype leftT `", >" Pctype rightT `")" %
      else
        P.error (getPos left)
          `"expected value of an arithmetic type or a pointer" %
    end
   | checkSimpleAssignment _ = raise Unreachable

  and checkCompoundAssignment maybePointer
    (E as EA (Ebinop (binop, left, right), pos, _, _))
  =
    if not $ isLvalue left then
      P.error (getPos left) `"expected lvalue" %
    else
    let
      val leftT = getT left
      val rightT = getT right
    in
      if isArith leftT andalso isArith rightT then
        if typeRank rightT < typeRank leftT then
          EA (Ebinop (binop, left, convEA leftT right), pos, false, leftT)
        else
          setT E leftT
      else if maybePointer andalso
        isPointer leftT andalso isIntegral rightT
      then
        setT E leftT
      else
        P.error pos `"unvalid operands of a compound assignment" %
    end
   | checkCompoundAssignment _ _ = raise Unreachable

  and checkComma (EA (Ebinop (binop, left, right), pos, _, _)) =
  let
    val left = convEA void_t left
  in
    EA (Ebinop (binop, left, right), pos, false, getT right)
  end
    | checkComma _ = raise Unreachable

  and checkSubscript (EA (Ebinop (_, left, right), pos, _, _)) =
  let
    val leftT = getT left
    val rightT = getT right

    val (left, right) =
      if isPointerToObj leftT andalso isIntegral rightT then
        (left, convEA long_t right)
      else if isIntegral leftT andalso isPointerToObj rightT then
        (right, convEA long_t left)
      else
        P.error pos `"expected pointer and integral pair" Pctype leftT %

    val resT = pointsTo $ getT left
  in
      EA (Ebinop(BR BrSubscript, left, right), pos, true, resT)
  end
   | checkSubscript _ = raise Unreachable

  and checkBinop check (EA (Ebinop (binop, left, right), pos, lvalue, t)) =
  let
    val E = EA (Ebinop (binop, check left, check right), pos, lvalue, t)
  in
    case binop of
      BR BrMul | BR BrDiv | BR BrMod => justConvArith E ResFromHigher
    | BR BrShiftLeft | BR BrShiftRight => justConvArith E ResFromLeft
    | BR BrLess | BR BrGreater | BR BrLessEqual | BR BrGreaterEqual =>
        checkRel E
    | BR BrEqual | BR BrNotEqual => checkRel E
    | BR BrBitAnd | BR BrBitOr | BR BrBitXor =>
        justConvArith E ResFromHigher
    | BR BrLogAnd | BR BrLogOr => checkLogOp E
    | BR BrSum | BR BrSub => checkSimpleArith E
    | BR BrAssign => checkSimpleAssignment E

    | BR BrSumAssign | BR BrSubAssign => checkCompoundAssignment true E

    | BR BrMulAssign | BR BrDivAssign | BR BrModAssign
    | BR BrLeftShiftAssign | BR BrRightShiftAssign
    | BR BrBitAndAssign | BR BrBitXorAssign | BR BrBitOrAssign =>
        checkCompoundAssignment false E

    | BR BrComma => checkComma E
    | BR BrSubscript => checkSubscript E

    | BinopTernaryIncomplete _ => raise Unreachable
  end
    | checkBinop _ _ = raise Unreachable

  and checkFuncCall check (EA (EfuncCall (func, args), pos, _, _)) =
  let
    fun checkArg arg =
    let
      val arg = check arg
    in
      if isObj $ getT arg then
        arg
      else
        P.error pos `"function argument is not of object type" %
    end

    val func = check func
    val args = List.map checkArg args

    fun convertArgs variadic (t :: ts) (arg :: args) =
      convEA t arg :: convertArgs variadic ts args
      | convertArgs _ [] [] = []
      | convertArgs false [] _ =
        P.error pos `"function called with too many arguments" %
      | convertArgs true [] (arg :: args) =
        promoteToInt arg :: convertArgs true [] args
      | convertArgs _ _ [] =
        P.error pos `"function called with too little arguments" %
  in
    case getT func of
      pointer_t (1, function_t (rt, argTypes, variadic)) =>
      let
        val args = convertArgs variadic argTypes args
      in
        EA (EfuncCall (func, args), pos, false, rt)
      end
    | _ => P.error pos `"expected pointer to function" %
  end
    | checkFuncCall _ _ = raise Unreachable

  and checkTernary check
    (E as (EA (Eternary (cond, thenPart, elsePart), pos, _, _)))
  =
  let
    val cond = check cond
    val thenPart = check thenPart
    val elsePart = check elsePart
  in
    if not $ isScalar $ getT cond then
      P.error (getPos cond) `"expected expression of scalar type" %
    else
    let
      val thenT = getT thenPart
      val elseT = getT elsePart
    in
      if isArith thenT andalso isArith elseT then
        let
          val (resT, (thenPart, elsePart)) = convArith thenPart elsePart
        in
          EA (Eternary (cond, thenPart, elsePart), pos, false, resT)
        end

      else if thenT = void_t andalso elseT = void_t then
        setT E void_t

      else if isPointer thenT then
        if thenT = elseT then
          setT E thenT
        else if elseT = voidp then
          setT E voidp
        else if isPointer elseT andalso thenT = voidp then
          setT E voidp
        else
          P.error (getPos elsePart)
            `"expression type is incompatible with its left sibling" %

      else
        P.error (getPos thenPart)
          `"expected expression of pointer or arithmetic type" %
    end
  end
    | checkTernary _ _ = raise Unreachable

  and getFieldInfo t field =
  let
    val fields = tryGetFields t
  in
    case List.find (fn (f, _, _) => f = field) fields of
      SOME (_, offset, fieldType) => SOME (offset, fieldType)
    | NONE => NONE
  end

  and checkMemberAccessByV check (EA (EmemberByV (ea, field), pos, _, _)) =
  let
    val ea = check ea
    val t = getT ea

    val t =
      if isStruct t orelse isUnion t then
        t
      else
        P.error (getPos ea) `"expected an aggregate" %
  in
    case getFieldInfo t field of
      NONE => P.error pos `"unknown field" %
    | SOME (_, ft) => EA (EmemberByV (ea, field), pos, true, ft)
  end
    | checkMemberAccessByV _ _ = raise Unreachable

  and checkMemberAccessByP check (EA (EmemberByP (ea, field), pos, _, _)) =
  let
    val ea = check ea
    val t = getT ea

    val t =
      if isPointer t then
        let
          val t = pointsTo t
        in
          if isStruct t orelse isUnion t then
            t
          else
            P.error (getPos ea) Pctype t `": "
                B (isUnion t) `": expected a pointer to an Aggregate" %
        end
      else
        P.error (getPos ea) `"expected a pointer to an aggregate" %
  in
    case getFieldInfo t field of
      NONE => P.error pos `"unknown field" %
    | SOME (_, ft) => EA (EmemberByP (ea, field), pos, true, ft)
  end
   | checkMemberAccessByP _ _ = raise Unreachable

  and checkStrlit under (EA (Estrlit id, pos, lvalue, t)) =
  let
    val (t, lvalue) = convAggr under t lvalue
  in
    EA (Estrlit id, pos, lvalue, t)
  end
    | checkStrlit _ _ = raise Unreachable

  and checkExpr ctx (under: under) (E as EA (e, pos, _, _)) =
  let
    val check = checkExpr ctx

    (* val () = printf `"Checking " A1 pea E `"\n" % *)
  in
    case e of
      Eid (id', _) =>
      let
        val (id, lvalue, t, const) = findId ctx pos under id'
      in
        case const of
          SOME v =>
            EA (Econst (id', Ninteger (Word.fromInt v)), pos, false, int_t)
        | _ => EA (Eid (id', SOME id), pos, lvalue, t)
      end
    | EsizeofType _ => checkSizeofType E
    | EfuncCall _ => checkFuncCall (check UNone) E
    | Ebinop (_, _, _) => checkBinop (check UNone) E
    | Eternary _ => checkTernary (check UNone) E
    | Eunop (_, _) => checkUnop check under E
    | EmemberByV _ => checkMemberAccessByV (check UNone) E
    | EmemberByP _ => checkMemberAccessByP (check UNone) E
    | Econst _ => E
    | Estrlit _ => checkStrlit under E
  end

  and tryGetTypedefName (Ctx ctx) id =
  let
    val res = lookup (#globalSyms ctx) id
  in
    case res of
      SOME (GsTypedef bufId) =>
      let
        val { t, ... } = D.get types bufId
      in
        SOME t
      end
    | _ => NONE
  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 =>
          case tk of
            Tk (T.Id id) => (
                case tryGetTypedefName ctx id of
                  NONE => (NONE, ctx)
                | SOME bufId => (SOME (TypeName bufId, pos), ctx')
            )
          | _ => (NONE, ctx)
    )
  end

  and findPrimTypeSize t =
    case List.find (fn (t', _) => t' = t) typeSizes of
      SOME (_, size) => Word64.fromInt size
    | _ => raise Unreachable

  and alignOfType t =
    case resolveType t of
      (pointer_t _) => pointerSize
    | (array_t (_, t)) => alignOfType t
    | (struct_t { alignment, ... } | union_t { alignment, ... }) =>
        alignment
    | t => findPrimTypeSize t

  and sizeOfType t =
    case resolveType t of
      (pointer_t _) => pointerSize
    | (array_t (n, t)) => n * sizeOfType t
    | (struct_t { size, ... } | union_t { size, ... }) => size
    | t => findPrimTypeSize t

  and sizeofWrapper t = Word64.toInt $ sizeOfType t

  and zeroExtend (ER (w, t)): word = extz w (sizeOfType t)

  and extz w fromSize =
  let
    val minus1 = Word64.notb (Word64.fromInt 0)
    val mask = Word64.>> (minus1, 0w64 - fromSize * 0w8)

    val res = Word64.andb (mask, w)
  in
    res
  end

  and getSignBit w sizeInBits: int =
  let
    open Word

    val shift = >> (w, sizeInBits - 0w1)
    val bit = andb (shift, 0w1)
  in
    toInt bit
  end

  and signExtend (ER (w, t)) = exts w (sizeOfType t)

  and exts w fromSize =
  let
    open Word

    val sizeInBits = fromSize * 0w8
    val signBit = getSignBit w sizeInBits
    val signExtMask = << (notb 0w0, sizeInBits)
  in
    if Int.compare (signBit, 0) = EQUAL then
      extz w fromSize
    else
      orb (signExtMask, w)
  end

  and evalUnop UnopPos _ arg = arg
    | evalUnop UnopNeg _ (R as (ER (_, t))) =
    let
      val w = zeroExtend R
    in
      ER (Word64.~ w, t)
    end
    | evalUnop UnopComp _ (ER (w, t)) =
    let
      val minus1 = Word64.notb $ Word64.fromInt 0
      val res as ER (w, _) = ER (Word64.xorb (minus1, w), t)
      val () = printf `"~ after: " W w `"\n" %
    in
      res
    end
    | evalUnop UnopCast (t', pos) (R as (ER (w, t))) =
    let
      val () =
        if not $ isArith t' then
          P.error pos `"not an arithmetic expression" %
        else
          ()
    in
      case Int.compare (sizeofWrapper t', sizeofWrapper t) of
        GREATER =>
          if isSigned t then
            ER (signExtend R, t')
          else
            ER (zeroExtend R, t')
      | EQUAL => ER (w, t')
      | LESS => ER (w, t')
    end
    | evalUnop _ (_, pos) _ =
      P.error pos `"invalid unop in constant expression" %

  and evalEqCheck eq left right =
  let
    val w1 = zeroExtend left
    val w2 = zeroExtend right

    val ` = Word64.fromInt
  in
    case (Word64.compare (w1, w2), eq) of
      (EQUAL, true) => `1
    | (EQUAL, false) => `0
    | (_, true) => `0
    | (_, false) => `1
  end

  and ebGetT (ER (_, t)) = t

  and ebIsNonzero arg =
  let
    val cleaned = zeroExtend arg
  in
    case Word64.compare (cleaned, Word64.fromInt 0) of
      EQUAL => false
    | _ => true
  end

  and ebIsNegative (ER (w, t)) =
    if isSigned t then
      if getSignBit w (0w8 * sizeOfType t) = 1 then
        true
      else
        false
    else
      false

  and w64FromBool true = Word64.fromInt 1
    | w64FromBool false = Word64.fromInt 0

  and ebDirect w64op (ER (w1, t)) (ER (w2, _)) = ER (w64op (w1, w2), t)

  and ebCompare left right convResult =
  let
    val (conv, comp) =
      if isSigned (ebGetT left) then
        (signExtend,
          fn (w1, w2) =>
            Int64.compare (word64Toint64 w1, word64Toint64 w2))
      else
        (zeroExtend, Word64.compare)
    val left' = conv left
    val right' = conv right

    val () = printf `"eval compare: " W left' `", " W right' `"\n" %
    val res = convResult $ comp (left', right')
  in
    ER (w64FromBool res, int_t)
  end

  and ebShiftLeft pos (ER (w1, t)) (right as ER (w2, _)) =
  let
    val count =
      if ebIsNegative right then
        P.error pos `"left shift count is negative" %
      else
        Word.fromLarge w2
  in
    ER (Word64.<< (w1, count), t)
  end

  and ebShiftRight pos left (right as ER (w, _)) =
  let
    val count =
      if ebIsNegative right then
        P.error pos `"right shift count is negative" %
      else
        Word.fromLarge w

    val (conv, w64op) =
      if isSigned (ebGetT left) then
        (signExtend, Word64.~>>)
      else
        (zeroExtend, Word64.>>)
  in
    ER (w64op (conv left, count), ebGetT left)
  end

  and ebHardArith (int32op, int64op, word64op) (left as ER (w1, t))
    (right as ER (w2, _))
  =
    if isSigned t then
      let
        val w = case sizeofWrapper t of
          4 => int32Toword64 $ int32op (word64Toint32 w1, word64Toint32 w2)
        | 8 => int64Toword64 $ int64op (word64Toint64 w1, word64Toint64 w2)
        | _ => raise Unreachable
      in
        ER (w, t)
      end
    else
      ebDirect word64op left right

  and evalBinop (BR BrSum) _ left right = ebDirect Word64.+ left right
    |  evalBinop (BR BrSub) _ left right = ebDirect Word64.- left right
    | evalBinop (BR BrBitAnd) _ left right =
        ebDirect Word64.andb left right
    | evalBinop (BR BrBitOr) _ left right = ebDirect Word64.orb left right
    | evalBinop (BR BrBitXor) _ left right =
        ebDirect Word64.xorb left right

    | evalBinop (BR BrMul) _ left right =
      ebHardArith (Int32.*, Int64.*, Word64.*) left right
    | evalBinop (BR BrDiv) _ left right =
      ebHardArith (Int32.div, Int64.div, Word64.div) left right
    | evalBinop (BR BrMod) _ left right =
      ebHardArith (Int32.mod, Int64.mod, Word64.mod) left right

    | evalBinop (BR BrEqual) _ left right =
        ER (evalEqCheck true left right, ebGetT left)
    | evalBinop (BR BrNotEqual) _ left right =
        ER (evalEqCheck false left right, ebGetT left)

    | evalBinop (BR BrLogAnd) _ left right =
      if ebIsNonzero left then
        ER (w64FromBool $ ebIsNonzero right, int_t)
      else
        ER (Word64.fromInt 0, int_t)
    | evalBinop (BR BrLogOr) _ left right =
      if ebIsNonzero left then
        ER (Word64.fromInt 1, int_t)
      else
        ER (w64FromBool $ ebIsNonzero right, int_t)

    | evalBinop (BR BrShiftLeft) pos left right =
        ebShiftLeft pos left right
    | evalBinop (BR BrShiftRight) pos left right =
        ebShiftRight pos left right

    | evalBinop (BR BrGreater) _ left right =
        ebCompare left right (fn GREATER => true | _ => false)
    | evalBinop (BR BrGreaterEqual) _ left right =
        ebCompare left right (fn GREATER | EQUAL => true | _ => false)
    | evalBinop (BR BrLess) _ left right =
        ebCompare left right (fn LESS => true | _ => false)
    | evalBinop (BR BrLessEqual) _ left right =
        ebCompare left right (fn LESS | EQUAL => true | _ => false)

    | evalBinop _ pos _ _ = P.error pos
      `"unsupported operator in constant expression" %

  and sizeofValue (EA (_, _, _, t)) = ER (sizeOfType t, ulong_t)

  and evalTernary cond left right =
    eval' (if ebIsNonzero $ eval' cond then left else right)

  and eval' (EA (e, pos, _, t)) =
    case e of
      Eid _ => P.error pos `"variable in constant expression" %
    | Econst (_, Ninteger w) =>
        (printf `"eval num: " W w `": " Pctype t `"\n" %;
            ER (w, t))
    | Econst _ => raise Unreachable
    | Estrlit _ => P.error pos `"string literal in constant expression" %
    | EmemberByV _ | EmemberByP _ =>
        P.error pos `"field access in constant expresssion" %
    | EfuncCall _ => P.error pos `"function call in constant expression" %
    | EsizeofType t' => ER (sizeOfType t', ulong_t)
    | Eunop (UnopSizeof, sub) => sizeofValue sub
    | Eunop (unop, sub) =>
        if isArith $ getT sub then
          evalUnop unop (t, pos) (eval' sub)
        else
          P.error pos `"not an arithmetic expression" %
    | Ebinop (binop, left, right) =>
        if isArith $ getT left then
          if isArith $ getT right then
            evalBinop binop pos (eval' left) (eval' right)
          else
            P.error pos `"not an arithmetic expression" %
        else
          P.error pos `"not an arithmetic expression" %
    | Eternary (cond, left, right) => evalTernary cond left right

  and eval (E as EA (_, pos, _, _)) t': word =
  let
    val e = Eunop (UnopCast, E)
    val res = eval' $ EA (e, pos, false, t')

    val ER (w, _) = res
    val () = printf `"eval: " W w `"\n" %
  in
    zeroExtend res
  end

  and convEnum t =
    case resolveType t of
      enum_t _ => int_t
    | _ => t

  and parseDeclPrefix ctx =
  let
    datatype state = TypeId of int | Type of ctype

    fun collect ctx (storSpec, typeReprId) =
    let
      val (spec, ctx) = tryGetSpec ctx

      fun handleTagged tag =
      let
        val (t, ctx) = processTagged tag ctx
      in
        ((storSpec, convEnum t), ctx)
      end
    in
      case (spec, typeReprId) of
        (NONE, TypeId 0) =>
          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

      | (NONE, TypeId id) => ((storSpec, typeRepr2type id), ctx)
      | (NONE, Type t) => ((storSpec, convEnum t), 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 T.kwStruct, _), TypeId 0) =>
          handleTagged TagStruct
      | (SOME (TypeSpec T.kwUnion, _), TypeId 0) => handleTagged TagUnion
      | (SOME (TypeSpec T.kwEnum, _), TypeId 0) => handleTagged TagEnum
      | (SOME (TypeSpec (T.kwStruct | T.kwUnion | T.kwEnum), pos), _) =>
          P.error pos `"invalid type specifier" %
      | (SOME (TypeSpec tk, pos), TypeId id) =>
          collect ctx (storSpec, TypeId $ advanceTypeRepr id (tk, pos))
      | (SOME (TypeSpec _, pos), _) =>
          P.error pos `"invalid type specifier" %
      | (SOME (TypeName t, _), TypeId 0) => ((storSpec, t), ctx)
      | (SOME (TypeName _, pos), _) =>
          P.error pos `"unexpected typedef'ed name" %
    end
  in
    collect ctx (NONE, TypeId 0)
  end

  and getTaggedName ctx =
  let
    val (tk, pos, ctx) = getTokenCtx ctx
  in
    case tk of
      Tk (T.Id id) => (id, pos, ctx)
    | TkBrackets _ =>
        P.error pos `"anonymous aggregates are not supported" %
    | _ => P.error pos `"expected aggregate name" %
  end

  and parseAggrDeclaration ctx =
  let
    val (prefix, ctx) = parseDeclPrefix ctx

    fun convToField ({ pos, spec = SOME _, ... }) =
      P.error pos `"aggregate field with storage specifier" %
      | convToField ({ id, pos, spec = NONE, t, ... }) =
        if isFunc t then
          P.error pos `"field of function type" %
        else if isIncomplete t then
          P.error pos `"field of incomplete type" %
        else
          (valOf id, pos, t)

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

      val field = convToField declaredId
      val acc = field :: acc

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

  and tryGetAggrBody pos ctx: taggedBody option * ctx =
  let
    val (tk, _, ctx') = getTokenCtx ctx

    fun checkFieldUniqueness ((id, _, _) :: fs) = (
      case List.find (fn (id', _, _) => id' = id) fs of
        SOME (_, pos, _) => P.error pos `"field name is reused" %
      | NONE => checkFieldUniqueness fs
    )
      | checkFieldUniqueness [] = ()

    fun collectFields acc ctx =
    let
       val (tk, _, _) = getTokenCtx ctx
    in
      case tk of
        Tk T.EOS =>
        let
          val acc = rev acc
        in
          if null acc then
            P.error pos `"empty aggregates are not supported" %
          else (
            checkFieldUniqueness acc;
            (SOME $ AggrBody $ map (fn (id, _, t) => (id, t)) acc, ctx)
          )
        end
      | _ =>
        let
          val (fields, ctx) = parseAggrDeclaration ctx
        in
          collectFields (List.revAppend (fields, acc)) ctx
        end
    end
  in
    case tk of
      TkBraces list => ctxWithLayer ctx' list (collectFields [])
    | _ => (NONE, ctx)
  end

  and addEnumConstant (Ctx ctx) (id, pos, v) =
  let
    fun f NONE = ((), SOME $ GsEnumConst v)
      | f (SOME (GsDecl _)) =
        P.error pos `"symbol already denotes a declaration" %
      | f (SOME (GsEnumConst _)) =
        P.error pos `"symbol already denotes a enum constast" %
      | f (SOME (GsTypedef _)) =
        P.error pos `"symbol is already typedef'ed" %

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

  and tryGetEnumBody ctx =
  let
    val (tk, _, ctx') = getTokenCtx ctx

    fun collect defVal acc ctx =
    let
      fun getValue ctx =
      let
        val ((status, ea), ctx) = parseExpr [T.Comma] ctx

        val w = eval ea int_t
        val value = word64Toint32 w
      in
        (status, value, ctx)
      end

      val (tk, idPos, ctx) = getTokenCtx ctx
      val id =
        case tk of
          Tk (T.Id id) => id
        | _ => P.clerror idPos [P.Cid]

      val (tk, pos, ctx) = getTokenCtx ctx

      fun fin v ctx =
      let
        val ctx = addEnumConstant ctx (id, idPos, v)
      in
        (SOME $ EnumBody $ rev $ (id, idPos, v) :: acc, ctx)
      end
      fun cont v ctx =
      let
        val ctx = addEnumConstant ctx (id, idPos, v)
      in
        collect (v + 1) ((id, idPos, v) :: acc) ctx
      end
    in
      case tk of
        Tk T.EOS => fin defVal ctx
      | Tk T.Comma => cont defVal ctx
      | Tk T.EqualSign =>
        let
          val (continue, v, ctx) = getValue ctx
        in
          if continue = 1 then
            cont v ctx
          else
            fin v ctx
        end
      | _ => P.clerror pos [P.Ctk T.EqualSign, P.Ctk T.RBrace]
    end
  in
    case tk of
      TkBraces list => ctxWithLayer ctx' list (collect 0 [])
    | _ => (NONE, ctx)
  end

  and getTaggedStatus id (Ctx { aggrTypeNames, ... }) =
  let
    val bufId = lookup aggrTypeNames id

    (* val () = printf `"Searching for " P.? id `"\n" % *)
  in
    case bufId of
      NONE => TsNotDefined
    | SOME id =>
      case resolveType $ #t $ D.get types id of
        struct_t { fields, ... } =>
          (if null fields then TsIncomplete else TsDefined) TagStruct
      | union_t { fields, ... } =>
          (if null fields then TsIncomplete else TsDefined) TagUnion
      | enum_t (_, isComplete) =>
          (if isComplete then TsDefined else TsIncomplete) TagEnum
      | _ => raise Unreachable
  end

  and getTypeIdFromName id (Ctx { aggrTypeNames, ... }) =
    valOf $ lookup aggrTypeNames id

  and ctFromTag TagStruct = struct_t
    | ctFromTag TagUnion = union_t
    | ctFromTag TagEnum = raise Unreachable

  and sFromTag TagStruct = "struct"
    | sFromTag TagUnion = "union"
    | sFromTag TagEnum = "enum"

  and calcAggr tag id [] =
    ctFromTag tag $ { name = id, size = 0w0, alignment = 0w0, fields = [] }
    | calcAggr tag id fields =
  let

    fun max l f =
      List.foldl (fn ((_, t), m) =>
        let
          val fa = f t
        in
          if fa > m then fa else m
        end) 0w0 l

    val alignment: word = max fields alignOfType

    fun align v align =
      if v mod align = 0w0 then v else v + align - v mod align

    fun calcStructSize size [] offsets =
      if size mod alignment = 0w0 then
        (size, rev offsets)
      else
        (align size alignment, rev offsets)
      | calcStructSize size ((_, t) :: fields) offsets =
      let
        val fieldOffset = align size (alignOfType t)
        val size = fieldOffset + sizeOfType t

        val () = printf `"foffset : " W fieldOffset `"\n" %
      in
        calcStructSize size fields (fieldOffset :: offsets)
      end

    fun calcUnionSize fields =
    let
      val offsets = List.tabulate (length fields, fn _ => 0w0)
      val size = max fields sizeOfType
      val size = align size alignment
    in
      (size, offsets)
    end

    val (size, offsets) =
      case tag of
        TagStruct =>
            calcStructSize
                ((sizeOfType o #2 o hd) fields) (tl fields) [0w0]
      | TagUnion => calcUnionSize fields
      | TagEnum => raise Unreachable

    fun zipOffsets (off :: offs) ((id, t) :: fs) =
      (id, off, t) :: zipOffsets offs fs
      | zipOffsets [] [] = []
      | zipOffsets _ _ = raise Unreachable
  in
    ctFromTag tag $ { name = id, size, alignment,
        fields = zipOffsets offsets fields }
  end

  and Ptagged z =
  let
    fun p [] _ = ()
      | p ((id, offset, t) :: fields) out =
        Printf out `"\t" W offset `": " P.? id `": "
                Pctype t `"\n" A1 p fields %

    fun f (struct_t info | union_t info) out =
      Printf out `"{ size = " W (#size info) `", alignment = "
        W (#alignment info) `"\n" A1 p (#fields info) `"}\n" %
      | f (enum_t _) _ = ()
      | f _ _ = raise Unreachable
  in
    bind A1 f
  end z

  and checkTags pos nTag tag =
    if nTag <> tag then
      P.error pos `"aggregate with same name but different tag exists" %
    else
      ()


  and registerDefault id pos ctx (nTag, tag) =
  let
    val () = checkTags pos nTag tag
  in
    (getTypeIdFromName id ctx, ctx)
  end

  and prepareInfo ctx id pos TagEnum NONE =
    ({ name = id, pos, t = enum_t (id, false) }, ctx)
    | prepareInfo ctx id pos TagEnum (SOME (EnumBody vals)) =
    let
      fun print ((id, _, v) :: vs) out =
        Printf out `"\t" P.? id `" = " I v `"\n" A1 print vs %
        | print [] _ = ()

      val () = printf `"enum constants:\n" A1 print vals %
    in
      ({ name = id, pos, t = enum_t (id, true) }, ctx)
    end
    | prepareInfo ctx id pos tag body =
    let
      val body =
        if isSome body then
          case valOf body of
            EnumBody _ => raise Unreachable
          | AggrBody body => body
        else
          []
    in
        ({ name = id, pos, t = calcAggr tag id body }, ctx)
    end

  and registerTagged id pos nTag (TsIncomplete tag | TsDefined tag) NONE ctx
  =
      registerDefault id pos ctx (nTag, tag)

    | registerTagged id pos nTag TsNotDefined (body: taggedBody option)
      (C as Ctx { aggrTypeNames, ... })
    =
    let
      val newBufId = D.length types
      val (_, aggrTypeNames) = Tree.insert intCompare aggrTypeNames id newBufId

      val status = if isSome body then "complete" else "incomplete"

      val (newInfo, C) = prepareInfo C id pos nTag body
    in
      D.push types newInfo;
      printf `"new " `status `" " `(sFromTag nTag) `": "
        P.? id `":" I id `"\n" Ptagged (#t newInfo) %;
      (newBufId, updateCtx C s#aggrTypeNames aggrTypeNames %)
    end

    | registerTagged id pos nTag (TsIncomplete tag) (SOME body)
      (C as Ctx { aggrTypeNames, ... })
    =
    let
      val () = checkTags pos nTag tag

      val bufId = valOf $ lookup aggrTypeNames id
      val (newInfo, C) = prepareInfo C id pos nTag (SOME body)
    in
      D.set types bufId newInfo;
      printf `"completing " `(sFromTag nTag) `": "
        P.? id `":" I id `"\n" Ptagged (#t newInfo) %;
      (bufId, C)
    end
    | registerTagged _ pos _ (TsDefined _) (SOME _) _ =
      P.error pos `"aggregate redefinition" %

  and processTagged tag ctx =
  let
    val (id, pos, ctx) = getTaggedName ctx

    val curStatus = getTaggedStatus id ctx

    (* TODO *)

    val (body, ctx) =
      case tag of
        TagEnum => tryGetEnumBody ctx
      | _ => tryGetAggrBody pos ctx

    val (bufTypeId, ctx) = registerTagged id pos tag curStatus body ctx
  in
    (remote_t bufTypeId, ctx)
  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 ctx tk =
    case List.find (fn tk' => case tk of Tk tk => tk = tk' | _ => false)
      typeSpecs of
      SOME _ => true
    | NONE => (
      case tk of
        Tk (T.Id id) => isSome $ tryGetTypedefName ctx id
      | _ => false
    )

  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 parseParam ctx =
  let
    val (tk, _, ctx') = getTokenCtx ctx
  in
    case tk of
      Tk T.TripleDot => (FpTripleDot, ctx')
    | _ =>
      let
        val (prefix, ctx) = parseDeclPrefix ctx
        val (parts, ctx) = parseDeclarator (false, APpermitted) [] ctx
        val declaredId = assembleDeclarator prefix parts

        val () = checkParamStorSpec declaredId
      in
        (FpParam declaredId, ctx)
      end
  end

  and parseFuncParams ctx =
  let
    fun collect ctx acc =
    let
      val (param, ctx) = parseParam ctx
      val isTd =
        case param of
          FpTripleDot => true
        | _ => false
      fun getP (FpParam p) = p
        | getP _ = raise Unreachable

      val (tk, pos, ctx) = getTokenCtx ctx
    in
      case (isTd, tk) of
        (true, Tk T.EOS) => (true, rev acc, ctx)
      | (false, Tk T.EOS) => (false, rev $ (getP param) :: acc, ctx)
      | (true, Tk T.Comma) => P.clerror pos [P.Ctk T.RParen]
      | (false, Tk T.Comma) => collect ctx (getP param :: acc)
      | (true, _) => P.clerror pos [P.Ctk T.RParen]
      | (false, _) => 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 => (false, [], ctx)
      | _ => collect ctx []
    end

    val (variadic, params, ctx) = collect2 ()
    val params =
      map (fn { id, pos, t, ... } => (id, pos, t)) params
  in
    (FuncApp (variadic, 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 list =>
      let
        val ((_, ea), ctx) = ctxWithLayer ctx' list $ parseExpr []
        val w: word = eval ea ulong_t
      in
        collectDDeclaratorTail (ArrayApplication w :: parts) untilEnd ctx
      end
    | 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 ctx list =
    case (#1 $ hd list) of
      Tk T.EOS => true
    | tk => isTypeNameStart ctx 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 ctx 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 (variadic, params) :: tail) =
      let
        val () = checkParamUniqueness [] params
        val params = map (fn (_, _, ctype) => ctype) params
      in
        function_t (complete tail, params, variadic)
      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 }: rawDecl)
  end

  fun printIni _ (CiniExpr ea) out = Printf out A1 pea ea %
    | printIni off (CiniLayout id) out =
    let
      val (_, _, layout) = D.get iniLayouts id
      fun pentry ({ offset, t, value }) out =
        Printf out R off `"\t" W offset `": "
                Pctype t `": " W value `"\n" %
    in
      Printf out `"{\n" Plist pentry layout ("", false, 0) R off `"}\n" %
    end

  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, T.EOS] ctx
    in
      if status = 0 orelse status = 2 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

        val () = printf `"Status: " I status %
      in
        if status = 0 then
          dieExpTerms pos terms
        else
          (status, ini, ctx)
      end
    | _ =>
      let
        val ((status, ea), ctx) = parseExpr terms ctx
        fun isToplev [T.Comma, T.Semicolon] = 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, pos, ... } =
    let
      val prevLinkage =
        case lookup (#globalSyms ctx) (valOf id) of
          NONE => NONE
        | SOME (GsDecl (_, _, _, linkage)) => SOME linkage
        | SOME (GsEnumConst _) =>
            P.error pos `"symbol is already defined as a enum costant" %
        | SOME (GsTypedef _) =>
            P.error pos `"symbol is already typedef'ed" %
    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 (GsDecl  (pos, class, t, linkage)))
      | f (SOME (GsDecl (_, 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 (GsDecl (pos, newClass, t, linkage)))
        end
      | f (SOME (GsEnumConst _)) =
        P.error pos `"enum constant with such name is already defined" %
      | f (SOME (GsTypedef _)) =
        P.error pos `"symbol is already typedef'ed" %

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

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

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

  datatype layout = LcScalar of ctype | LcAggr of layoutAux list
    and layoutAux = LcAux of word * layout

  fun computeTLayout t =
  let
    val t = resolveType t
  in
    if isScalar t then
      LcScalar t
    else
      case t of
        struct_t { fields, ... } =>
          let
            fun comp ((_, offset, t) :: fs) acc =
            let
              val layout = computeTLayout t
            in
              comp fs (LcAux (offset, layout) :: acc)
            end
              | comp [] acc = rev acc
          in
            LcAggr $ comp fields []
          end
     | union_t { fields, ... } => computeTLayout (#3 $ hd fields)
     | array_t (n, t) =>
         LcAggr $ List.tabulate (Word.toInt n, fn n =>
         let
           val l = computeTLayout t
           val lx = LcAux (Word.fromInt n * sizeOfType t, l)
         in
           lx
         end)

     | _ => raise Unreachable
  end

  fun printOffsets (LcAux (offset, l)) out =
  let
    val () = Printf out W offset `":" %
  in
    case l of
      LcScalar t => Printf out `"[" Pctype t `"]" %
    | LcAggr lxs => Printf out Plist printOffsets lxs (", ", true, 1) %
  end

  fun calcOffsets offset (LcAux (off, l)) =
    case l of
      LcScalar t => LcAux (offset + off, LcScalar t)
    | LcAggr lxs =>
      let
        val lxs = List.map (calcOffsets $ offset + off) lxs
      in
        LcAux (offset + off, LcAggr lxs)
      end

  fun extractFirstScalar (LcAux (off, l)) =
  let
    fun restore [] = NONE
      | restore (first :: tail) =
      let
        fun rest [] (buf: layoutAux) = buf
          | rest (LcAux (off, LcAggr lcxs) :: tail) buf =
            rest tail (LcAux (off, LcAggr (buf :: lcxs)))
          | rest _ _ = raise Unreachable
      in
        SOME $ rest tail first
      end

    fun extractFirst acc (LcAux (off, l)) =
      case l of
        LcScalar t => ((off, t), restore acc)
      | LcAggr (lcxs) =>
        let
          val acc =
            if length lcxs = 1 then
              acc
            else
              LcAux (off, LcAggr (tl lcxs)) :: acc
        in
          extractFirst acc (hd lcxs)
        end
  in
    case l of
      LcScalar t => ((off, t), NONE)
    | L => extractFirst [] (LcAux (off, L))
  end

  fun getOneIni _ (IniExpr _) = raise Unreachable
    | getOneIni pos (I as IniCompound []) =
      (IniExpr (EA (Econst (0, Ninteger 0w0), pos, false, int_t)), I)
    | getOneIni _ (IniCompound (ini :: inis)) = (ini, IniCompound inis)

  fun reachedImplicitZeros (IniCompound []) = true
    | reachedImplicitZeros (IniCompound _) = false
    | reachedImplicitZeros _ = raise Unreachable

  fun matchInitializer _ (LcAux (offset, LcScalar t)) (IniExpr ea) acc =
  let
    val value = eval ea t
  in
    (NONE, ({ offset, t, value } :: acc))
  end
    | matchInitializer pos (LcAux (_, LcScalar _)) _ _ =
        P.error pos `"cannot match scalar with compound initializer" %
    | matchInitializer _ (L as LcAux (_, LcAggr _)) (IniExpr ea) acc =
    let
      val ((offset, t), tail) = extractFirstScalar L

      val value = eval ea t
    in
      (tail: layoutAux option, { offset, t, value } :: acc)
    end
    | matchInitializer pos (LcAux (_, LcAggr lcxs))
        (Ini as IniCompound _) acc
    =
    let
      fun matchOne acc lcx inis =
      let
        val (ini, inis) = getOneIni pos inis
        val (tail, acc) = matchInitializer pos lcx ini acc
      in
        case tail of
          NONE => (acc, inis)
        | SOME lcx => matchOne acc lcx inis
      end

      fun matchAll acc [] ini =
        if reachedImplicitZeros ini then
          acc
        else
          P.error pos `"extra initializer components" %
       | matchAll acc (lcx :: lcxs) ini =
       let
         val (acc, ini) =  matchOne acc lcx ini
       in
         matchAll acc lcxs ini
       end

      val acc = matchAll acc lcxs Ini
    in
      (NONE, acc)
    end

  fun flattenIni pos lcx ini =
  let
    val (res, acc) = matchInitializer pos lcx ini []
    val () =
      case res of
        NONE => ()
      | SOME _ => raise Unreachable
  in
    rev acc
  end

  fun getCharArrayLen t =
    case resolveType t of
      array_t (n, t) => if resolveType t = char_t then SOME n else NONE
    | _ => NONE

  fun convStrlitIni pos t ini =
  let
    fun convStrlit2ini n id =
    let
      open List

      fun min a b = if a < b then a else b

      val chars = P.T.strlit2charList $ P.?? id
      val chars = take (chars, min n (length chars))
      val bytes =
        map (fn c => Econst(id, Ninteger (Word.fromInt $ ord c))) chars
    in
      IniCompound
        (map (fn b => IniExpr (EA (b, pos, false, char_t))) bytes)
    end
  in
    case getCharArrayLen t of
      NONE => ini
    | SOME len => (
      case ini of
        IniExpr (EA (Estrlit id, _, _, _))
      | IniCompound ([IniExpr (EA (Estrlit id, _, _, _))]) =>
          convStrlit2ini (Word.toInt len) id
      | _ => ini
    )
  end

  fun registerLayout layout t toplev =
    D.pushAndGetId iniLayouts (toplev, sizeOfType t, layout)

  fun getLayoutSize id = #2 $ D.get iniLayouts id

  fun canonExprIni toplev t ea =
    if toplev then
      let
        val () = printf `"Here\n" %
        val value = eval ea t
        val layout = [{ offset = 0w0, t, value }]
      in
        CiniLayout (registerLayout layout t toplev)
      end
    else
      CiniExpr $ convEA t ea

  fun canonIni toplev pos t ini =
  let
    val ini = convStrlitIni pos t ini
  in
    if isScalar t then
      case ini of
        IniExpr ea | IniCompound [IniExpr ea] => canonExprIni toplev t ea
      | _ => P.error pos `"compound initializer with scalar variable" %
    else
      case ini of
         IniExpr _ =>
           P.error pos
             `"cannot initialize aggregate with scalar initializer" %
      | _ =>
        let
          val layout = calcOffsets 0w0 $ LcAux (0w0, computeTLayout t)
          val layout = flattenIni pos layout ini

          val id = registerLayout layout t toplev
        in
          CiniLayout id
        end
  end

  fun handleToplevDecl ctx rawDecl =
  let
    val (class, D as (id, pos, t, linkage), ini) =
        getToplevDeclKind ctx rawDecl

    val () =
      if isIncomplete t then
        P.error pos `"toplev declaration of incomplete type" %
      else
        ()
    val ctx = addDeclaration ctx D class
  in
    if class = DeclDefined then
      let
        val ini = canonIni true pos t (valOf ini)
      in
        (SOME $ ToplevId (id, pos, t, ini, linkage), ctx)
      end
    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 if isIncomplete t then
      P.error pos `"variable with incomplete 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 = D.length localVars

          val () = D.push localVars
            ({ name = id, pos, t, onStack = not $ isScalar t })

          val (_, scope) = Tree.insert intCompare scope id varId
        in
          (varId, id, updateCtx (Ctx ctx)
            u#localScopes (fn scs => scope :: tl scs) %)
        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" %;

    (SOME $ LocalId (varId, ini), ctx)
  end

  fun handleTypedef (C as Ctx ctx) ({ pos, t, id, ini, ... }: rawDecl) =
  let
    val () =
      if isSome ini then
        P.error pos `"typedef with initializer" %
      else
        ()

    val id = valOf id
    val info = { name = id, pos, t }
    val bufId = D.length types

    fun f NONE = ((), SOME (GsTypedef bufId))
      | f (SOME (GsTypedef _)) =
        P.error pos `"symbol is already typedef'ed" %
      | f (SOME (GsDecl _)) =
        P.error pos `"there is a already a declaration with such name" %
      | f (SOME (GsEnumConst _)) =
        P.error pos `"there is already an enum constant with such name" %

    val ((), globalSyms) = lookup2 (#globalSyms ctx) id f
    val () = D.push types info

    val () = printfn `"new typedef'ed name: " P.? id %
  in
    (NONE, updateCtx C s#globalSyms globalSyms %)
  end

  fun handleRawDecl ctx (D as { spec, pos, ... }: rawDecl) =
    case spec of
      SOME SpecTypedef =>
        if isGlobalScope ctx then
          handleTypedef ctx D
        else
          P.error pos `"typedef in local scope is not supported\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 =
      if toplev then
        ObjDefs $ map (fn ToplevId v => v | _ => raise Unreachable) acc
      else
        LocalVarInits $ map (fn LocalId v => v | _ => raise Unreachable)
          (rev acc)

    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

    val (tk, _, ctx') = getTokenCtx ctx
  in
    case tk of
      Tk T.Semicolon => (finishNormal [], ctx')
    | _ => 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
    | Tk T.Semicolon => (StmtNone, #3 $ getTokenCtx 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 getReturnExpr ctx =
  let
    val (tk, _, ctx') = getTokenCtx ctx
  in
    case tk of
      Tk T.Semicolon => (NONE, 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
          (SOME ea, ctx)
      end
  end

  and parseReturn ctx =
  let
    val (_, pos, ctx) = getTokenCtx ctx

    val (ea, ctx) = getReturnExpr ctx

    val Ctx ctx' = ctx
    val rt = valOf $ #funcRetType ctx'

    fun ret () = (StmtReturn $ Option.map (convEA rt) ea, ctx)
  in
    case ea of
      NONE =>
        if rt = void_t then
          ret ()
        else
          P.error pos `"empty return in non-void function" %
    | SOME _ =>
        if rt = void_t then
          P.error pos `"attempt to return value in void function" %
        else
          ret ()
  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 handleLocalIni (id, NONE) =
    if #onStack $ D.get localVars id then
      SOME (id, NONE)
    else
      NONE
    | handleLocalIni (id, SOME ini) =
    let
      val (pos, t) = (fn ({pos, t, ... }) => (pos, t)) $
          D.get localVars id

      val ini = canonIni false pos t ini
    in
      SOME (id, SOME ini)
    end

  and processLocalInis inis =
  let
    fun loop [] acc = rev acc
      | loop (ini :: inis) acc =
        case handleLocalIni ini of
          NONE => loop inis acc
        | SOME v => loop inis (v :: acc)
  in
    loop inis []
  end

  and parseStmtCompound isFuncBody ctx =
  let
    fun collectDecls acc ctx =
    let
      val (tk, _, _) = getTokenCtx ctx
    in
      if isTypeNameStart ctx tk then
        let
          val (res, ctx) = parseDeclaration ctx
          val varInits =
            case res of
              LocalVarInits l => l (* handleInis ctx l *)
            | _ => raise Unreachable
        in
          collectDecls (List.revAppend (varInits, 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
          val acc =
            case stmt of
              StmtNone => acc
            | _ => stmt :: acc
        in
          collectStmts 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 inits = processLocalInis inits

    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 off) ini `"\n" %

  fun pstmt' off (StmtCompound (inits, stmts)) out =
    Printf out `"{\n"
      Plist (pinit (off + 1)) inits ("", false, 2)
      Plist (pstmt (off + 1)) stmts ("\n", false, 2)
      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 " Popt pea ea `";" %
    | pstmt' _ StmtBreak out = Printf out `"break;" %
    | pstmt' _ StmtContinue out = Printf out `"continue;" %
    | pstmt' _ StmtNone out =  Printf out `";" %

  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

    fun checkParamTypes (arg :: args) =
      if not $ isScalar arg then
        P.error pos `"function has parameter with non-scalar type" %
      else
        checkParamTypes args
      | checkParamTypes [] = ()

    val (rt, args) =
      case t of
        function_t (t, args, variadic) =>
          if variadic then
            P.error pos `"variadic function definition is not supported" %
          else
            (t, args)
      | _ => raise Unreachable

    val () =
      if isScalar rt orelse rt = void_t then
        ()
      else
        P.error pos `"function return type is not scalar or void" %
  in
    checkParams $ valOf params;
    checkParamTypes args
  end

  fun ctxPrepareForFunc ctx t params =
  let
    val (rt, paramTypes) = funcParts t

    fun createLocalVars scope _ [] [] = scope
      | createLocalVars scope curVarId (t :: ts)
        ((SOME id, pos) :: params)
    =
      let
        val localVar = { name = id, pos, t, onStack = false }
        val (_, scope) = Tree.insert intCompare scope id curVarId
      in
        D.push localVars localVar;
        createLocalVars scope (curVarId + 1) ts params
      end
      | createLocalVars _ _ _ _ = raise Unreachable

    val scope = createLocalVars Tree.empty 0 paramTypes params
  in
    updateCtx ctx s#localScopes [scope] s#funcRetType (SOME rt)
        s#paramNum (SOME $ length params) %
  end

  fun worldPrepareForFunc () = D.reset localVars

  fun finishLocalVars () = D.toVec localVars

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

    val () = worldPrepareForFunc ()
    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 ()

    val ctx = updateCtx ctx s#paramNum NONE %
  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 = #t $ 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, variadic) =
      case t of
        function_t (ret, _, v) => (ret, v)
      | _ => raise Unreachable
  in
    printf P.?name `" " Plist printParam params (", ", true, 2)
        `(if variadic then " variadic" else "")
        `" -> " 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
        `" = " A2 printIni 0 ini `"\n" %
    end
  in
    printf Plist pobj objs ("", false, 2) %
  end
  | printDef (Definition (D as { stmt, localVars, ... })) =
  let
    fun pLocalVar i ({ name, t, onStack, ... }) out =
      Printf out `"%" I i `"(" P.?name `"): "
        `(if onStack then "& " else "") Pctype t `"\n" %
  in
    printFuncHeader D;
    printf Pstmt 0 stmt %;
    Vector.appi (fn (i, var) => printf A2 pLocalVar i var %) localVars
  end

  type decl = P.tkPos * declClass * ctype * linkage

  fun ctxAddDef ctx def = updateCtx ctx u#defs (fn l => def :: l) %

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

  fun finalize (C as Ctx { globalSyms, ... }) =
  let
    fun f id (GsDecl (pos, DeclTentative, t, linkage)) acc =
      (id, pos, t, CiniLayout (~1), linkage) :: acc
      | f _ _ acc = acc

    fun ch (GsDecl (pos, DeclTentative, t, linkage)) =
      (GsDecl (pos, DeclDefined, t, linkage))
      | ch v = v

    val promoted = Tree.traverse globalSyms f []
    val globalSyms = Tree.changeV globalSyms ch
  in
    updateCtx C u#defs (fn l => Objects promoted :: rev l)
        s#globalSyms globalSyms %
  end

  type progInfo =  {
    ext: nid list,
    glob: nid list,
    objsZI: objDef list,
    objs: objDef list,
    funcs: funcInfo list,
    strlits: int list
  }

  fun explode (Ctx { globalSyms, defs, strlits, ... }) =
  let
    fun findExtAndGlob id (GsDecl (_, declType, _, LinkExternal))
      (ext, glob)
    = (
      case declType of
        DeclRegular => (id :: ext, glob)
      | DeclDefined => (ext, id :: glob)
      | DeclTentative => raise Unreachable
    )
    | findExtAndGlob _ _ acc = acc

    val (ext, glob) = Tree.traverse globalSyms findExtAndGlob ([], [])
    val objsZI =
      case hd defs of
        Objects objs => objs
      | _ => raise Unreachable

    fun partition (objs, funcDefs) (Objects obj :: tail) =
      partition (List.revAppend (obj, objs), funcDefs) tail
      | partition (objs, funcDefs) (Definition fi :: tail) =
        partition (objs, fi :: funcDefs) tail
      | partition (objs, funcDefs) [] = (rev objs, rev funcDefs)

    val (objs, funcs) = partition ([], []) (tl defs)
  in
    { ext, glob, objsZI, objs, funcs, strlits }
  end

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