Cast operator

2 files changed, 450 insertions, 360 deletions

diff --git a/ccross.mlb b/ccross.mlb
index 3bd2ca6..3aea79a 100644
--- a/ccross.mlb
+++ b/ccross.mlb
@@ -5,8 +5,11 @@ ann
 in
 	$(SML_LIB)/basis/basis.mlb
     $(SML_LIB)/basis/mlton.mlb
+
     common.sml
 
+    exn_handler.sig exn_handler.sml
+
     stream.sig stream.sml
     hashtable.sig hashtable.sml
     tree.sig tree.sml
@@ -16,7 +19,6 @@ in
     ppc.sig ppc.fun
     parser.sig parser.fun
 
-    exn_handler.sig exn_handler.sml
     driver.sig driver.fun
 
     ccross.sig ccross.sml
diff --git a/parser.fun b/parser.fun
index db44c9a..9f66fc3 100644
--- a/parser.fun
+++ b/parser.fun
@@ -12,11 +12,12 @@ functor Parser(P: PPC): PARSER = struct
     UnopNeg |
     UnopComp |
     UnopLogNeg |
+    UnopCast of ctype |
 
     UnopPostInc |
     UnopPostDec
 
-  datatype binopReg =
+  and binopReg =
     BrSubscript |
 
     BrMul |
@@ -52,44 +53,7 @@ functor Parser(P: PPC): PARSER = struct
 
     BrComma
 
-  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 expr =
+  and expr =
     Enum |
     Eid of int |
     Estrlit of int |
@@ -104,20 +68,7 @@ functor Parser(P: PPC): PARSER = struct
 
   and binop = BR of binopReg | BinopTernaryIncomplete of exprAug
 
-  val (ternaryOpPrio, ternaryOpLeftAssoc) = (2, false)
-
-  datatype exprPart =
-    EPexpr of exprAug |
-    (* last two are prio and leftAssoc *)
-    EPbinop of binop * P.tkPos * int * bool
-
-  datatype storageSpec =
-    SpecTypedef |
-    SpecExtern |
-    SpecStatic |
-    SpecRegister
-
-  datatype ctype =
+  and ctype =
     void_t |
     char_t |
     uchar_t |
@@ -136,7 +87,31 @@ functor Parser(P: PPC): PARSER = struct
     function_t of ctype * ctype list |
     array_t of ctype
 
-  type def = expr
+  val (ternaryOpPrio, ternaryOpLeftAssoc) = (2, false)
+
+  datatype exprPart =
+    EPexpr of exprAug |
+    (* last two are prio and leftAssoc *)
+    EPbinop of binop * P.tkPos * int * bool
+
+  datatype storageSpec =
+    SpecTypedef |
+    SpecExtern |
+    SpecStatic |
+    SpecRegister
+
+  datatype stmt = StmtCompound of exprAug
+
+  type declaredId = {
+    id: int option,
+    pos: P.tkPos,
+    spec: storageSpec option,
+    ctype: ctype,
+    params: (int option * P.tkPos) list option
+  }
+
+  datatype def = Declaration of declaredId list |
+    Definition of declaredId * stmt
 
   datatype token =
     Tk of T.token |
@@ -145,6 +120,54 @@ functor Parser(P: PPC): PARSER = struct
     TkBraces of (token * P.tkPos) list |
     TkTernary of (token * P.tkPos) list
 
+  datatype declParts =
+    Pointer of int |
+    Id of int * P.tkPos |
+    AbstructRoot of P.tkPos |
+    FuncApp of (int option * P.tkPos * ctype) list |
+    ArrayApplication
+
+  datatype abstructPolicy = APpermitted | APenforced | APprohibited
+
+  datatype specType = StorageSpec of storageSpec | TypeSpec of T.token
+
+  val binopTable = [
+    (BrSubscript, T.Invalid, 0, false),
+
+    (BrMul, T.Asterisk, 13, true),
+    (BrDiv, T.Slash, 13, true),
+    (BrMod, T.Percent, 13, true),
+    (BrSum, T.Plus, 12, true),
+    (BrSub, T.Minus, 12, true),
+    (BrShiftLeft, T.DoubleLess, 11, true),
+    (BrShiftRight, T.DoubleGreater, 11, true),
+    (BrGreater, T.Greater, 10, true),
+    (BrLess, T.Less, 10, true),
+    (BrLessEqual, T.LessEqualSign, 10, true),
+    (BrGreaterEqual, T.GreaterEqualSign, 10, true),
+    (BrEqual, T.DoubleEqualSign, 9, true),
+    (BrNotEqual, T.ExclMarkEqualSign, 9, true),
+    (BrBitAnd, T.Ampersand, 8, true),
+    (BrBitXor, T.Cap, 7, true),
+    (BrBitOr, T.VerticalBar, 6, true),
+    (BrLogAnd, T.DoubleAmpersand, 5, true),
+    (BrLogOr, T.DoubleVerticalBar, 4, true),
+
+    (BrAssign, T.EqualSign, 2, false),
+    (BrMulAssign, T.AmpersandEqualSign, 2, false),
+    (BrDivAssign, T.SlashEqualSign, 2, false),
+    (BrModAssign, T.PercentEqualSign, 2, false),
+    (BrSumAssign, T.PlusEqualSign, 2, false),
+    (BrSubAssign, T.MinusEqualSign, 2, false),
+    (BrLeftShiftAssign, T.DoubleLessEqualSign, 2, false),
+    (BrRightShiftAssign, T.DoubleGreaterEqualSign, 2, false),
+    (BrBitAndAssign, T.AmpersandEqualSign, 2, false),
+    (BrBitXorAssign, T.CapEqualSign, 2, false),
+    (BrBitOrAssign, T.VerticalBarEqualSign, 2, false),
+
+    (BrComma, T.Comma, 1, true)
+  ]
+
   val PstorSpec = fn z =>
   let
     fun f (out, s) =
@@ -196,6 +219,228 @@ functor Parser(P: PPC): PARSER = struct
     bind A1 Pctype
   end z
 
+  val typeSpecs = [
+      T.kwVoid,
+      T.kwChar,
+      T.kwShort,
+      T.kwInt,
+      T.kwLong,
+      T.kwFloat,
+      T.kwDouble,
+      T.kwSigned,
+      T.kwUnsigned
+  ]
+
+  fun ts2idx ts =
+  let
+    fun find _ [] = raise Unreachable
+      | find idx (ts' :: tss) =
+        if ts = ts' then
+          idx
+        else
+          find (idx + 1) tss
+  in
+    find 0 typeSpecs
+  end
+
+  fun idx2ts idx = List.nth (typeSpecs, idx)
+
+  val tsMaxIdxP1 = length typeSpecs
+
+  val prefixes = [
+    (void_t, [[T.kwVoid]]),
+    (char_t, [[T.kwChar], [T.kwChar, T.kwSigned]]),
+    (uchar_t, [[T.kwUnsigned, T.kwChar]]),
+    (short_t, [[T.kwShort], [T.kwSigned, T.kwShort], [T.kwSigned, T.kwInt],
+      [T.kwSigned, T.kwShort, T.kwInt]]),
+    (ushort_t, [[T.kwUnsigned, T.kwShort],
+        [T.kwUnsigned, T.kwShort, T.kwInt]]),
+    (int_t, [[T.kwInt], [T.kwSigned], [T.kwSigned, T.kwInt]]),
+    (uint_t, [[T.kwUnsigned], [T.kwUnsigned, T.kwInt]]),
+    (long_t, [[T.kwLong], [T.kwSigned, T.kwLong], [T.kwLong, T.kwInt],
+      [T.kwSigned, T.kwLong, T.kwInt]]),
+    (ulong_t, [[T.kwUnsigned, T.kwLong],
+        [T.kwUnsigned, T.kwLong, T.kwInt]]),
+    (longlong_t, [[T.kwLong, T.kwLong], [T.kwSigned, T.kwLong, T.kwLong],
+        [T.kwLong, T.kwLong, T.kwInt],
+        [T.kwSigned, T.kwLong, T.kwLong, T.kwInt]]),
+    (ulonglong_t, [[T.kwUnsigned, T.kwLong, T.kwLong],
+        [T.kwUnsigned, T.kwLong, T.kwLong, T.kwInt]]),
+    (float_t, [[T.kwFloat]]),
+    (double_t, [[T.kwDouble]])
+  ]
+
+  fun genReprChildren l =
+  let
+    open List
+    fun genWithoutOne i =
+      if i = length l then
+        []
+      else
+        let
+          val e = nth (l, i)
+          val bef = take (l, i)
+          val after = drop (l, i + 1)
+        in
+          (e, bef @ after) :: genWithoutOne (i + 1)
+        end
+    fun unique acc [] = acc
+      | unique acc ((e, l) :: tail) =
+        case List.find (fn (e', _) => e' = e) acc of
+          NONE => unique ((e, l) :: acc) tail
+        | SOME _ => unique acc tail
+  in
+    unique [] $ genWithoutOne 0
+  end
+
+  fun addRepr repr (P as (repr2id, _)) =
+    case List.find (fn (repr', _) => repr' = repr) repr2id of
+      SOME (_, id) => (id, P)
+    | NONE =>
+      let
+        fun createId (repr2id, trs) =
+        let
+          val id = length repr2id
+        in
+          (id, ((repr, id) :: repr2id, trs))
+        end
+      in
+        if length repr = 1 then
+          let
+            val (id, (repr2id, trs)) = createId P
+          in
+            (id, (repr2id, (0, ts2idx $ hd repr, id) :: trs))
+          end
+        else
+          let
+            val children = genReprChildren repr
+            val (P, ids) = List.foldl (fn ((e, l), (P, ids)) =>
+              let
+                val (id, P) = addRepr l P
+              in
+                (P, (id, e) :: ids)
+              end) (P, []) children
+
+            val (id, (repr2id, trs)) = createId P
+            val trs = List.foldl (fn ((id', e), trs) =>
+                (id', ts2idx e, id) :: trs) trs ids
+          in
+            (id, (repr2id, trs))
+          end
+      end
+
+  fun addTypeRepr ctype repr (repr2id, id2type, trs) =
+  let
+    val (id, (repr2id, trs)) = addRepr repr (repr2id, trs)
+  in
+    (repr2id, (id, ctype) :: id2type, trs)
+  end
+
+  fun prefixFsmPrint fsm repr2id =
+  let
+    fun findRepr id =
+      case List.find (fn (_, id') => id' = id) repr2id of
+        SOME (repr, _) => repr
+      | NONE => raise Unreachable
+
+    fun printRepr (out, l) =
+    let
+      fun printRepr' (_, []) = ()
+        | printRepr' (out, [tk]) = Printf out P.Ptk tk %
+        | printRepr' (out, tk1 :: tk2 :: tail) =
+            Printf out P.Ptk tk1 `", " A1 printRepr' (tk2 :: tail) %
+    in
+      Printf out `"[" A1 printRepr' l `"]" %
+    end
+
+    open Array
+
+    fun printRow i =
+    let
+      val (ctype, trs) = sub (fsm, i)
+      fun printTrs () = appi (fn (j, id) =>
+        if id = ~1 then
+          ()
+        else
+          printf P.Ptk (idx2ts j) `" -> " I id `", " %
+        ) trs
+      fun printType out =
+        case ctype of
+          NONE => Printf out `"none" %
+        | SOME ctype => Printf out Pctype ctype %
+    in
+      printf I i `" " A1 printRepr (findRepr i)
+        `" |" A0 printType `"|: " %;
+      printTrs ();
+      printf `"\n" %
+    end
+
+    val i = ref 0
+  in
+    while !i < length fsm do (
+        printRow $ !i;
+        i := !i + 1
+    )
+  end
+
+  fun buildPrefixFsm () =
+  let
+    val T = ([([], 0)], [], [])
+    val (repr2id, id2type, trs) = List.foldl (fn ((t, rl), T) =>
+        List.foldl (fn (r, T) => addTypeRepr t r T) T rl) T prefixes
+
+    open Array
+
+    fun fsmInit len =
+    let
+      val fsm = array (len, (NONE, array (tsMaxIdxP1, ~1)))
+      val i = ref 1
+    in
+      while !i < len do (
+        update (fsm, !i, (NONE, array (tsMaxIdxP1, ~1)));
+        i := !i + 1
+      );
+      fsm
+    end
+
+    val fsm = fsmInit $ List.length repr2id
+
+    val () = List.app (fn (id, ctype) =>
+      let
+        val (_, subarray) = sub (fsm, id)
+      in
+        update (fsm, id, (SOME ctype, subarray))
+      end) id2type
+
+    val () = List.app (fn (id', n, id) =>
+      let
+        val (_, subarray) = sub (fsm, id')
+      in
+        update (subarray, n, id)
+      end) trs
+  in
+    (* prefixFsmPrint fsm repr2id; *)
+    fsm
+  end
+
+  val prefixFsm = buildPrefixFsm ()
+
+  fun advanceTypeRepr typeReprId (tk, pos) =
+  let
+    open Array
+    val n = ts2idx tk
+    val (_, subarray) = sub (prefixFsm, typeReprId)
+    val id = sub (subarray, n)
+  in
+    if id = ~1 then
+      P.error pos `"unexpected type specifier" %
+    else
+      id
+  end
+
+  fun typeRepr2type typeReprId =
+    valOf o #1 o Array.sub $ (prefixFsm, typeReprId)
+
   fun PtokenL (_, []) = ()
     | PtokenL (out, head :: tail) =
     let
@@ -285,34 +530,29 @@ functor Parser(P: PPC): PARSER = struct
     (v, (fn (ppc, layers) => (ppc, tl layers)) ctx)
   end
 
-  val Punop = fn z =>
+  fun Punop (out, unop) =
   let
-    fun Punop (out, unop) =
-      Printf out `(case unop of
-        UnopPreInc | UnopPostInc => "++"
-      | UnopPreDec | UnopPostDec => "--"
-      | UnopPos => "+"
-      | UnopNeg => "-"
-      | UnopAddr => "&"
-      | UnopDeref => "*"
-      | UnopComp => "~"
-      | UnopLogNeg => "!") %
+    fun ~s = Printf out `s %
   in
-    bind A1 Punop
-  end z
+    case unop of
+      UnopPreInc | UnopPostInc => ~"++"
+    | UnopPreDec | UnopPostDec => ~"--"
+    | UnopPos => ~"+"
+    | UnopNeg => ~"-"
+    | UnopAddr => ~"&"
+    | UnopDeref => ~"*"
+    | UnopComp => ~"~"
+    | UnopLogNeg => ~"!"
+    | UnopCast ctype => Printf out Pctype ctype %
+  end
 
-  val Pbinop = fn z =>
-  let
-    fun Pbinop (out, binop) =
-      case List.find (fn (binop', _, _, _) => binop' = binop) binopTable
-      of
-        SOME (_, tk, _, _) => Printf out P.Ptk tk %
-      | NONE => raise Unreachable
-  in
-    bind A1 Pbinop
-  end z
+  and Pbinop (out, binop) =
+    case List.find (fn (binop', _, _, _) => binop' = binop) binopTable
+    of
+      SOME (_, tk, _, _) => Printf out P.Ptk tk %
+    | NONE => raise Unreachable
 
-  fun printExpr (out, off, ea) =
+  and printExpr (out, off, ea) =
   let
     fun printExpr' (out, off, EAug (e, pos)) =
     let
@@ -340,14 +580,14 @@ functor Parser(P: PPC): PARSER = struct
         Printf out R off `")" %
       )
       | Eunop (unop, ea) => Printf out
-        `"(" Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" %
+        `"(" A1 Punop unop P `"\n" A2 printExpr' (off + 1) ea `")" %
       | Ebinop (BR binop, left, right) =>
         let
           val binop =
             if binop = BrSubscript then
               "[]"
             else
-              sprintf Pbinop binop %
+              sprintf A1 Pbinop binop %
         in
           Printf out `"(" `binop P `"\n"
             A2 printExpr (off + 1) left
@@ -364,7 +604,7 @@ functor Parser(P: PPC): PARSER = struct
     Printf out A2 printExpr' off ea `"\n" %
   end
 
-  fun parseUnaryPrefix ctx acc =
+  and parseUnaryPrefix ctx acc =
   let
     val unopPreTable = [
       (T.DoublePlus, UnopPreInc),
@@ -384,13 +624,22 @@ functor Parser(P: PPC): PARSER = struct
           SOME (_, unop) => parseUnaryPrefix ctx' ((unop, pos) :: acc)
         | _ => (acc, ctx)
       )
+    | TkParens list =>
+      if isTypeNameStart (#1 $ hd list) handle Empty => false then
+        let
+          val (ctype, ctx) = ctxWithLayer ctx' list
+            (fn ctx => parseTypeName ctx)
+        in
+          parseUnaryPrefix ctx ((UnopCast ctype, pos) :: acc)
+        end
+      else
+        (acc, ctx)
     | _ => (acc, ctx)
   end
 
-  fun parseBinop ctx endTk =
+  and parseBinop ctx endTk =
   let
     val (tk, pos, ctx) = getTokenCtx ctx
-
   in
     case tk of
       TkTernary list =>
@@ -559,231 +808,7 @@ functor Parser(P: PPC): PARSER = struct
     (expr, ctx)
   end
 
-  val typeSpecs = [
-      T.kwVoid,
-      T.kwChar,
-      T.kwShort,
-      T.kwInt,
-      T.kwLong,
-      T.kwFloat,
-      T.kwDouble,
-      T.kwSigned,
-      T.kwUnsigned
-  ]
-
-  fun ts2idx ts =
-  let
-    fun find _ [] = raise Unreachable
-      | find idx (ts' :: tss) =
-        if ts = ts' then
-          idx
-        else
-          find (idx + 1) tss
-  in
-    find 0 typeSpecs
-  end
-
-  fun idx2ts idx = List.nth (typeSpecs, idx)
-
-  val tsMaxIdxP1 = length typeSpecs
-
-  val prefixes = [
-    (void_t, [[T.kwVoid]]),
-    (char_t, [[T.kwChar], [T.kwChar, T.kwSigned]]),
-    (uchar_t, [[T.kwUnsigned, T.kwChar]]),
-    (short_t, [[T.kwShort], [T.kwSigned, T.kwShort], [T.kwSigned, T.kwInt],
-      [T.kwSigned, T.kwShort, T.kwInt]]),
-    (ushort_t, [[T.kwUnsigned, T.kwShort],
-        [T.kwUnsigned, T.kwShort, T.kwInt]]),
-    (int_t, [[T.kwInt], [T.kwSigned], [T.kwSigned, T.kwInt]]),
-    (uint_t, [[T.kwUnsigned], [T.kwUnsigned, T.kwInt]]),
-    (long_t, [[T.kwLong], [T.kwSigned, T.kwLong], [T.kwLong, T.kwInt],
-      [T.kwSigned, T.kwLong, T.kwInt]]),
-    (ulong_t, [[T.kwUnsigned, T.kwLong],
-        [T.kwUnsigned, T.kwLong, T.kwInt]]),
-    (longlong_t, [[T.kwLong, T.kwLong], [T.kwSigned, T.kwLong, T.kwLong],
-        [T.kwLong, T.kwLong, T.kwInt],
-        [T.kwSigned, T.kwLong, T.kwLong, T.kwInt]]),
-    (ulonglong_t, [[T.kwUnsigned, T.kwLong, T.kwLong],
-        [T.kwUnsigned, T.kwLong, T.kwLong, T.kwInt]]),
-    (float_t, [[T.kwFloat]]),
-    (double_t, [[T.kwDouble]])
-  ]
-
-  fun genReprChildren l =
-  let
-    open List
-    fun genWithoutOne i =
-      if i = length l then
-        []
-      else
-        let
-          val e = nth (l, i)
-          val bef = take (l, i)
-          val after = drop (l, i + 1)
-        in
-          (e, bef @ after) :: genWithoutOne (i + 1)
-        end
-    fun unique acc [] = acc
-      | unique acc ((e, l) :: tail) =
-        case List.find (fn (e', _) => e' = e) acc of
-          NONE => unique ((e, l) :: acc) tail
-        | SOME _ => unique acc tail
-  in
-    unique [] $ genWithoutOne 0
-  end
-
-  fun addRepr repr (P as (repr2id, _)) =
-    case List.find (fn (repr', _) => repr' = repr) repr2id of
-      SOME (_, id) => (id, P)
-    | NONE =>
-      let
-        fun createId (repr2id, trs) =
-        let
-          val id = length repr2id
-        in
-          (id, ((repr, id) :: repr2id, trs))
-        end
-      in
-        if length repr = 1 then
-          let
-            val (id, (repr2id, trs)) = createId P
-          in
-            (id, (repr2id, (0, ts2idx $ hd repr, id) :: trs))
-          end
-        else
-          let
-            val children = genReprChildren repr
-            val (P, ids) = List.foldl (fn ((e, l), (P, ids)) =>
-              let
-                val (id, P) = addRepr l P
-              in
-                (P, (id, e) :: ids)
-              end) (P, []) children
-
-            val (id, (repr2id, trs)) = createId P
-            val trs = List.foldl (fn ((id', e), trs) =>
-                (id', ts2idx e, id) :: trs) trs ids 
-          in
-            (id, (repr2id, trs))
-          end
-      end
-
-  fun addTypeRepr ctype repr (repr2id, id2type, trs) =
-  let
-    val (id, (repr2id, trs)) = addRepr repr (repr2id, trs)
-  in
-    (repr2id, (id, ctype) :: id2type, trs)
-  end
-
-  fun prefixFsmPrint fsm repr2id =
-  let
-    fun findRepr id =
-      case List.find (fn (_, id') => id' = id) repr2id of
-        SOME (repr, _) => repr
-      | NONE => raise Unreachable
-
-    fun printRepr (out, l) =
-    let
-      fun printRepr' (_, []) = ()
-        | printRepr' (out, [tk]) = Printf out P.Ptk tk %
-        | printRepr' (out, tk1 :: tk2 :: tail) =
-            Printf out P.Ptk tk1 `", " A1 printRepr' (tk2 :: tail) %
-    in
-      Printf out `"[" A1 printRepr' l `"]" %
-    end
-
-    open Array
-
-    fun printRow i =
-    let
-      val (ctype, trs) = sub (fsm, i)
-      fun printTrs () = appi (fn (j, id) =>
-        if id = ~1 then
-          ()
-        else
-          printf P.Ptk (idx2ts j) `" -> " I id `", " %
-        ) trs
-      fun printType out =
-        case ctype of
-          NONE => Printf out `"none" %
-        | SOME ctype => Printf out Pctype ctype %
-    in
-      printf I i `" " A1 printRepr (findRepr i)
-        `" |" A0 printType `"|: " %;
-      printTrs ();
-      printf `"\n" %
-    end
-
-    val i = ref 0
-  in
-    while !i < length fsm do (
-        printRow $ !i;
-        i := !i + 1
-    )
-  end
-
-  fun buildPrefixFsm () =
-  let
-    val T = ([([], 0)], [], [])
-    val (repr2id, id2type, trs) = List.foldl (fn ((t, rl), T) =>
-        List.foldl (fn (r, T) => addTypeRepr t r T) T rl) T prefixes
-
-    open Array
-
-    fun fsmInit len =
-    let
-      val fsm = array (len, (NONE, array (tsMaxIdxP1, ~1)))
-      val i = ref 1
-    in
-      while !i < len do (
-        update (fsm, !i, (NONE, array (tsMaxIdxP1, ~1)));
-        i := !i + 1
-      );
-      fsm
-    end
-
-    val fsm = fsmInit $ List.length repr2id
-
-    val () = List.app (fn (id, ctype) =>
-      let
-        val (_, subarray) = sub (fsm, id)
-      in
-        update (fsm, id, (SOME ctype, subarray))
-      end) id2type
-
-    val () = List.app (fn (id', n, id) =>
-      let
-        val (_, subarray) = sub (fsm, id')
-      in
-        update (subarray, n, id)
-      end) trs
-  in
-    (* prefixFsmPrint fsm repr2id; *)
-    fsm
-  end
-
-  val prefixFsm = buildPrefixFsm ()
-
-  fun advanceTypeRepr typeReprId (tk, pos) =
-  let
-    open Array
-    val n = ts2idx tk
-    val (_, subarray) = sub (prefixFsm, typeReprId)
-    val id = sub (subarray, n)
-  in
-    if id = ~1 then
-      P.error pos `"unexpected type specifier" %
-    else
-      id
-  end
-
-  fun typeRepr2type typeReprId =
-    valOf o #1 o Array.sub $ (prefixFsm, typeReprId)
-
-  datatype specType = StorageSpec of storageSpec | TypeSpec of T.token
-
-  fun tryGetSpec ctx =
+  and tryGetSpec ctx =
   let
     val (tk, pos, ctx') = getTokenCtx ctx
 
@@ -806,7 +831,7 @@ functor Parser(P: PPC): PARSER = struct
     )
   end
 
-  fun parseDeclPrefix ctx =
+  and parseDeclPrefix ctx =
   let
     fun collect ctx (storSpec, typeReprId) =
     let
@@ -835,25 +860,34 @@ functor Parser(P: PPC): PARSER = struct
     collect ctx (NONE, 0)
   end
 
-  datatype declParts =
-    Pointer of int |
-    Id of int * P.tkPos |
-    FuncApp of (int option * P.tkPos * ctype) list |
-    ArrayApplication
-
-  fun Ppart (out, part) =
+  and Ppart (out, part) =
     case part of
       Pointer plevel => Printf out `"[" I plevel `"] " %
     | Id _ => Printf out `"id" %
+    | AbstructRoot _ => Printf out `":root" %
     | FuncApp _ => Printf out `"()" %
     | ArrayApplication => Printf out `"[]" %
 
-  fun parseFuncParams ctx =
+  and isTypeNameStart tk =
+    isSome $ List.find
+      (fn tk' => case tk of Tk tk => tk = tk' | _ => false) typeSpecs
+
+
+  and parseTypeName ctx =
+  let
+    val (prefix, ctx) = parseDeclPrefix ctx
+    val (parts, ctx) = parseDeclarator (true, APenforced) [] ctx
+    val declId = assembleDeclarator prefix parts
+  in
+    (#ctype declId, ctx)
+  end
+
+  and parseFuncParams ctx =
   let
     fun collect ctx acc =
     let
       val (prefix, ctx) = parseDeclPrefix ctx
-      val (parts, ctx) = parseDeclarator (false, true) [] ctx
+      val (parts, ctx) = parseDeclarator (false, APpermitted) [] ctx
       val declaredId = assembleDeclarator prefix parts
 
       val (tk, pos, ctx) = getTokenCtx ctx
@@ -875,45 +909,60 @@ functor Parser(P: PPC): PARSER = struct
 
     val (params, ctx) = collect2 ()
     val params =
-      map (fn ((id, pos), _, ctype, _) => (id, pos, ctype)) params
+      map (fn { id, pos, ctype, ... } => (id, pos, ctype)) params
   in
     (FuncApp params, ctx)
   end
 
-  and parseDDeclarator (untilEnd, abstractOk) ctx parts =
+  and collectDDeclaratorTail parts untilEnd ctx =
   let
-    val (tk, pos, ctx) = getTokenCtx ctx
-
-    val (parts, ctx) =
-      case tk of
-        Tk (T.Id id) => (Id (id, pos) :: parts, ctx)
-      | TkParens list => ctxWithLayer ctx list
-                (fn ctx => parseDeclarator (true, abstractOk) parts ctx)
-      | _ => P.clerror pos [P.Cid, P.Ctk T.LParen]
+    val (tk, pos, ctx') = getTokenCtx ctx
 
-    fun collectTail parts ctx =
+    fun % ctx list f parts =
     let
-      val (tk, pos, ctx') = getTokenCtx ctx
-
-      fun % ctx list f parts =
-      let
-        val (part, ctx) = ctxWithLayer ctx list (fn ctx => f ctx)
-      in
-        collectTail (part :: parts) ctx
-      end
+      val (part, ctx) = ctxWithLayer ctx list (fn ctx => f ctx)
     in
-      case tk of
-        TkParens list => % ctx' list parseFuncParams parts
-      | TkBrackets _ => collectTail (ArrayApplication :: parts) ctx'
-      | Tk T.EOS => (parts, ctx)
-      | _ =>
-        if untilEnd then
-          P.clerror pos [P.Ctk T.LParen, P.Ctk T.RParen]
-        else
-          (parts, ctx)
+      collectDDeclaratorTail (part :: parts) untilEnd ctx
     end
   in
-    collectTail parts ctx
+    case tk of
+      TkParens list => % ctx' list parseFuncParams parts
+    | TkBrackets _ =>
+        collectDDeclaratorTail (ArrayApplication :: parts) untilEnd ctx'
+    | Tk T.EOS => (parts, ctx)
+    | _ =>
+      if untilEnd then
+        P.clerror pos [P.Ctk T.LParen, P.Ctk T.RParen]
+      else
+        (parts, ctx)
+  end
+
+  and parseDDeclarator (untilEnd, absPolicy) ctx parts =
+  let
+    val (tk, pos, ctx') = getTokenCtx ctx
+
+    fun isEOS tk = case tk of Tk T.EOS => true | _ => false
+
+    val (parts, ctx) =
+      case tk of
+        Tk (T.Id id) =>
+          if absPolicy = APenforced then
+            P.error pos `"unexpected identifier in abstruct declarator" %
+          else
+            (Id (id, pos) :: parts, ctx')
+      | TkParens list => ctxWithLayer ctx' list
+                (fn ctx => parseDeclarator (true, absPolicy) parts ctx)
+      | _ => (
+          case absPolicy of
+            APprohibited => P.clerror pos [P.Cid, P.Ctk T.LParen]
+          | _ =>
+            if untilEnd andalso not (isEOS tk) then
+              P.error pos `"expected abstruct declarator end" %
+            else
+              (AbstructRoot pos :: parts, ctx)
+      )
+  in
+    collectDDeclaratorTail parts untilEnd ctx
   end
 
   and parseDeclarator conf parts ctx =
@@ -944,7 +993,8 @@ functor Parser(P: PPC): PARSER = struct
 
     val (id, pos) =
       case hd parts of
-        Id (id, pos) => (id, pos)
+        Id (id, pos) => (SOME id, pos)
+      | AbstructRoot pos => (NONE, pos)
       | _ => raise Unreachable
 
     fun complete (Pointer plevel :: tail) =
@@ -965,17 +1015,16 @@ functor Parser(P: PPC): PARSER = struct
         _ :: FuncApp p :: _  => SOME $ map (fn (id, pos, _) => (id, pos)) p
       | _ => NONE
 
-    val idType = complete $ tl parts
   in
-    ((SOME id, pos), storSpec, idType, params)
+    { id, pos, spec = storSpec, ctype = complete $ tl parts, params }
   end
 
-  fun printDeclaredId ((id, _), storSpec, ctype, params) =
+  fun printDeclId ({ id, spec, ctype, params, ... }: declaredId) =
   let
     fun Pstor (_, NONE) = ()
       | Pstor (out, SOME s) = Printf out PstorSpec s %
   in
-    printf A1 Pstor storSpec Popt P.? id `": " Pctype ctype `"\n" %;
+    printf A1 Pstor spec Popt P.? id `": " Pctype ctype `"\n" %;
     case params of
       NONE => ()
     | SOME params => (
@@ -985,31 +1034,70 @@ functor Parser(P: PPC): PARSER = struct
     )
   end
 
-  fun parseDeclaration ctx =
+  datatype declaration =
+    DeclIds of declaredId list |
+    FuncDef of declaredId * (token * P.tkPos) list
+
+  fun parseDeclaration ctx expectFdef =
   let
     val (prefix, ctx) = parseDeclPrefix ctx
 
     fun collectDeclarators acc ctx =
     let
-      val (parts, ctx) = parseDeclarator (false, false) [] ctx
+      val (parts, ctx) = parseDeclarator (false, APprohibited) [] ctx
       val declaredId = assembleDeclarator prefix parts
 
       val (tk, pos, ctx) = getTokenCtx ctx
+      fun first () = null acc
+
+      fun die () = P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon]
+      fun die2 () = P.clerror pos
+        [P.Ctk T.Comma, P.Ctk T.Semicolon, P.Ctk T.LBrace]
     in
       case tk of
         Tk T.Comma => collectDeclarators (declaredId :: acc) ctx
-      | Tk T.Semicolon => (rev $ declaredId :: acc, ctx)
-      | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.Semicolon]
+      | Tk T.Semicolon => (DeclIds $ rev $ declaredId :: acc, ctx)
+      | TkBraces list =>
+          if expectFdef andalso first () then
+            (FuncDef (declaredId, list), ctx)
+          else
+            die ()
+      | _ =>
+          if first () then
+            die2 ()
+          else
+            die ()
     end
   in
     collectDeclarators [] ctx
   end
 
+  fun parseStmtCompound ctx =
+  let
+    val (ea, ctx) = parseExpr ctx (SOME T.Semicolon)
+    val (_, _, ctx) = getTokenCtx ctx
+    val (tk, pos, ctx) = getTokenCtx ctx
+  in
+    case tk of
+      Tk T.EOS => (StmtCompound ea, ctx)
+    | _ => P.clerror pos [P.Ctk T.RBrace]
+  end
+
+  fun parseFuncDefinition id ctx =
+  let
+    val (stmt, ctx) = parseStmtCompound ctx
+  in
+    (Definition (id, stmt), ctx)
+  end
+
   fun parseDef ctx =
   let
-    val (decls, _) = parseDeclaration ctx
+    val (toplev, ctx) = parseDeclaration ctx true
   in
-    List.app (fn decl => printDeclaredId decl) decls;
-    raise Unimplemented
+    case toplev of
+      DeclIds ids => (Declaration ids, ctx)
+    | FuncDef (id, body) =>
+        ctxWithLayer ctx body (fn ctx =>
+          parseFuncDefinition id ctx)
   end
 end