Declaration

1 files changed, 525 insertions, 3 deletions

diff --git a/parser.fun b/parser.fun
index 15134a8..db44c9a 100644
--- a/parser.fun
+++ b/parser.fun
@@ -111,6 +111,31 @@ functor Parser(P: PPC): PARSER = struct
     (* last two are prio and leftAssoc *)
     EPbinop of binop * P.tkPos * int * bool
 
+  datatype storageSpec =
+    SpecTypedef |
+    SpecExtern |
+    SpecStatic |
+    SpecRegister
+
+  datatype ctype =
+    void_t |
+    char_t |
+    uchar_t |
+    short_t |
+    ushort_t |
+    int_t |
+    uint_t |
+    long_t |
+    ulong_t |
+    longlong_t |
+    ulonglong_t |
+    float_t |
+    double_t |
+
+    pointer_t of int * ctype |
+    function_t of ctype * ctype list |
+    array_t of ctype
+
   type def = expr
 
   datatype token =
@@ -120,6 +145,57 @@ functor Parser(P: PPC): PARSER = struct
     TkBraces of (token * P.tkPos) list |
     TkTernary of (token * P.tkPos) list
 
+  val PstorSpec = fn z =>
+  let
+    fun f (out, s) =
+      Printf out `(
+        case s of
+          SpecTypedef => "typedef"
+        | SpecExtern => "extern"
+        | SpecRegister => "register"
+        | SpecStatic => "static"
+      ) %
+  in
+    bind A1 f
+  end z
+
+  val Pctype = fn z =>
+  let
+    fun Pctype (out, t) =
+    let
+      fun &s = Printf out `s %
+    in
+      case t of
+        void_t => &"void"
+      | char_t => &"char"
+      | uchar_t => &"unsigned char"
+      | short_t => &"short"
+      | ushort_t => &"usigned short"
+      | int_t => &"int"
+      | uint_t => &"unsigned int"
+      | long_t => &"long"
+      | ulong_t => &"unsigned long"
+      | longlong_t => &"long long"
+      | ulonglong_t => &"unsigned long long"
+      | float_t => &"float"
+      | double_t => &"double"
+      | pointer_t (plevel, t) =>
+          Printf out `"[" I plevel `"]" A1 Pctype t %
+      | function_t (ret, params) =>
+          let
+            fun Pparams (_, []) = ()
+              | Pparams (out, [p]) = Printf out A1 Pctype p %
+              | Pparams (out, (p1 :: p2 :: t)) =
+                Printf out A1 Pctype p1 `", " A1 Pparams (p2 :: t) %
+          in
+            Printf out `"(" A1 Pparams params `") -> " A1 Pctype ret %
+          end
+      | array_t el => Printf out `"() -> " A1 Pctype el %
+    end
+  in
+    bind A1 Pctype
+  end z
+
   fun PtokenL (_, []) = ()
     | PtokenL (out, head :: tail) =
     let
@@ -483,11 +559,457 @@ 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 =
+  let
+    val (tk, pos, ctx') = getTokenCtx ctx
+
+    val storageSpecs = [
+        (T.kwTypedef, SpecTypedef),
+        (T.kwExtern, SpecExtern),
+        (T.kwStatic, SpecStatic),
+        (T.kwRegister, SpecRegister)
+    ]
+
+    val cmp = (fn tk' => case tk of Tk tk => tk = tk' | _ => false)
+    val cmp2 = (fn (tk', _) => case tk of Tk tk => tk = tk' | _ => false)
+  in
+    case List.find cmp typeSpecs of
+      SOME tk => (SOME (TypeSpec tk, pos), ctx')
+    | NONE => (
+      case List.find cmp2 storageSpecs of
+        SOME (_, spec) => (SOME (StorageSpec spec, pos), ctx')
+      | NONE => (NONE, ctx)
+    )
+  end
+
+  fun parseDeclPrefix ctx =
+  let
+    fun collect ctx (storSpec, typeReprId) =
+    let
+      val (spec, ctx) = tryGetSpec ctx
+    in
+      case spec of
+        NONE =>
+            if typeReprId = 0 then
+              let
+                val (_, pos, _) = getTokenCtx ctx
+              in
+                P.error pos `"expected type specifier" %
+              end
+            else
+              ((storSpec, typeRepr2type typeReprId), ctx)
+      | SOME (StorageSpec spec, pos) => (
+          case storSpec of
+            NONE => collect ctx (SOME spec, typeReprId)
+          | SOME _ =>
+              P.error pos `"storage specifier is already provided" %
+      )
+      | SOME (TypeSpec tk, pos) =>
+          collect ctx (storSpec, advanceTypeRepr typeReprId (tk, pos))
+    end
+  in
+    collect ctx (NONE, 0)
+  end
+
+  datatype declParts =
+    Pointer of int |
+    Id of int * P.tkPos |
+    FuncApp of (int option * P.tkPos * ctype) list |
+    ArrayApplication
+
+  fun Ppart (out, part) =
+    case part of
+      Pointer plevel => Printf out `"[" I plevel `"] " %
+    | Id _ => Printf out `"id" %
+    | FuncApp _ => Printf out `"()" %
+    | ArrayApplication => Printf out `"[]" %
+
+  fun parseFuncParams ctx =
+  let
+    fun collect ctx acc =
+    let
+      val (prefix, ctx) = parseDeclPrefix ctx
+      val (parts, ctx) = parseDeclarator (false, true) [] ctx
+      val declaredId = assembleDeclarator prefix parts
+
+      val (tk, pos, ctx) = getTokenCtx ctx
+    in
+      case tk of
+        Tk T.EOS => (rev $ declaredId :: acc, ctx)
+      | Tk T.Comma => collect ctx (declaredId :: acc)
+      | _ => P.clerror pos [P.Ctk T.Comma, P.Ctk T.RParen]
+    end
+
+    fun collect2 () =
+    let
+      val (tk, _, _) = getTokenCtx ctx
+    in
+      case tk of
+        Tk T.EOS => ([], ctx)
+      | _ => collect ctx []
+    end
+
+    val (params, ctx) = collect2 ()
+    val params =
+      map (fn ((id, pos), _, ctype, _) => (id, pos, ctype)) params
+  in
+    (FuncApp params, ctx)
+  end
+
+  and parseDDeclarator (untilEnd, abstractOk) ctx parts =
+  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]
+
+    fun collectTail parts 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
+        collectTail (part :: parts) ctx
+      end
+    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)
+    end
+  in
+    collectTail parts 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 assembleDeclarator (storSpec, ctype) parts =
+  let
+    val parts = rev parts
+
+    val (id, pos) =
+      case hd parts of
+        Id (id, pos) => (id, pos)
+      | _ => raise Unreachable
+
+    fun complete (Pointer plevel :: tail) =
+        pointer_t (plevel, complete tail)
+      | complete (FuncApp params :: tail) =
+      let
+        (* TODO: check params uniqness *)
+        val params = map (fn (_, _, ctype) => ctype) params
+      in
+        function_t (complete tail, params)
+      end
+      | complete (ArrayApplication :: tail) = array_t (complete tail)
+      | complete [] = ctype
+      | complete _ = raise Unreachable
+
+    val params =
+      case parts of
+        _ :: FuncApp p :: _  => SOME $ map (fn (id, pos, _) => (id, pos)) p
+      | _ => NONE
+
+    val idType = complete $ tl parts
+  in
+    ((SOME id, pos), storSpec, idType, params)
+  end
+
+  fun printDeclaredId ((id, _), storSpec, ctype, params) =
+  let
+    fun Pstor (_, NONE) = ()
+      | Pstor (out, SOME s) = Printf out PstorSpec s %
+  in
+    printf A1 Pstor storSpec Popt P.? id `": " Pctype ctype `"\n" %;
+    case params of
+      NONE => ()
+    | SOME params => (
+        printf `"params: " %;
+        List.app (fn (id, _) => printf Popt P.?id `", " %) params;
+        printf `"\n" %
+    )
+  end
+
+  fun parseDeclaration ctx =
+  let
+    val (prefix, ctx) = parseDeclPrefix ctx
+
+    fun collectDeclarators acc ctx =
+    let
+      val (parts, ctx) = parseDeclarator (false, false) [] ctx
+      val declaredId = assembleDeclarator prefix parts
+
+      val (tk, pos, ctx) = getTokenCtx ctx
+    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]
+    end
+  in
+    collectDeclarators [] ctx
+  end
+
   fun parseDef ctx =
   let
-    val (expr, ctx) = parseExpr ctx NONE
-    val () = printf A2 printExpr 0 expr %
+    val (decls, _) = parseDeclaration ctx
   in
-    (raise Unimplemented, ctx)
+    List.app (fn decl => printDeclaredId decl) decls;
+    raise Unimplemented
   end
 end