New printf combinator interface

1 files changed, 104 insertions, 73 deletions

diff --git a/parser.fun b/parser.fun
index 9f66fc3..f27510d 100644
--- a/parser.fun
+++ b/parser.fun
@@ -100,7 +100,7 @@ functor Parser(P: PPC): PARSER = struct
     SpecStatic |
     SpecRegister
 
-  datatype stmt = StmtCompound of exprAug
+  datatype stmt = StmtCompound of exprAug list
 
   type declaredId = {
     id: int option,
@@ -168,23 +168,18 @@ functor Parser(P: PPC): PARSER = struct
     (BrComma, T.Comma, 1, true)
   ]
 
-  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
+  fun pStorSpec s out =
+    Printf out `(
+      case s of
+        SpecTypedef => "typedef"
+      | SpecExtern => "extern"
+      | SpecRegister => "register"
+      | SpecStatic => "static"
+    ) %
 
   val Pctype = fn z =>
   let
-    fun Pctype (out, t) =
+    fun pctype t out =
     let
       fun &s = Printf out `s %
     in
@@ -203,20 +198,13 @@ functor Parser(P: PPC): PARSER = struct
       | 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 %
+          Printf out `"{" I plevel `"} " A1 pctype t %
+      | function_t (ret, params) => Printf out
+        Plist pctype params (", ", true) `" -> " A1 pctype ret %
+      | array_t el => Printf out `"[] -> " A1 pctype el %
     end
   in
-    bind A1 Pctype
+    bind A1 pctype
   end z
 
   val typeSpecs = [
@@ -343,11 +331,11 @@ functor Parser(P: PPC): PARSER = struct
         SOME (repr, _) => repr
       | NONE => raise Unreachable
 
-    fun printRepr (out, l) =
+    fun printRepr l out =
     let
-      fun printRepr' (_, []) = ()
-        | printRepr' (out, [tk]) = Printf out P.Ptk tk %
-        | printRepr' (out, tk1 :: tk2 :: tail) =
+      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 `"]" %
@@ -441,20 +429,23 @@ functor Parser(P: PPC): PARSER = struct
   fun typeRepr2type typeReprId =
     valOf o #1 o Array.sub $ (prefixFsm, typeReprId)
 
-  fun PtokenL (_, []) = ()
-    | PtokenL (out, head :: tail) =
+  fun pTokenL l out =
+  let
+    fun pToken (tk, _) out =
     let
-      fun printL list s e =
-        Printf out `s`"| " A1 PtokenL list `" |"`e `", " A1 PtokenL tail %
-      val (tk, _) = head
+      fun printList list opr cpr = Printf out `(opr ^ "| ")
+        Plist pToken list (",", false) `(" |" ^ cpr) %
     in
       case tk of
-        Tk tk => Printf out P.Ptk tk `"," A1 PtokenL tail %
-      | TkParens list => printL list "(" ")"
-      | TkBrackets list => printL list "[" "]"
-      | TkBraces list => printL list "{" "}"
-      | TkTernary list => printL list "?" ":"
+        Tk tk => Printf out P.Ptk tk %
+      | TkParens list => printList list "(" ")"
+      | TkBrackets list => printList list "[" "]"
+      | TkBraces list => printList list "{" "}"
+      | TkTernary list => printList list "?" ":"
     end
+  in
+    Printf out Plist pToken l (",", false) %
+  end
 
   type parseCtx = P.t * (token * P.tkPos) list list
 
@@ -530,7 +521,7 @@ functor Parser(P: PPC): PARSER = struct
     (v, (fn (ppc, layers) => (ppc, tl layers)) ctx)
   end
 
-  fun Punop (out, unop) =
+  fun Punop unop out =
   let
     fun ~s = Printf out `s %
   in
@@ -546,15 +537,15 @@ functor Parser(P: PPC): PARSER = struct
     | UnopCast ctype => Printf out Pctype ctype %
   end
 
-  and Pbinop (out, binop) =
+  and Pbinop binop out =
     case List.find (fn (binop', _, _, _) => binop' = binop) binopTable
     of
       SOME (_, tk, _, _) => Printf out P.Ptk tk %
     | NONE => raise Unreachable
 
-  and printExpr (out, off, ea) =
+  and printExpr off ea out =
   let
-    fun printExpr' (out, off, EAug (e, pos)) =
+    fun printExpr' off (EAug (e, pos)) out =
     let
       val P = fn z =>
       let
@@ -842,8 +833,10 @@ functor Parser(P: PPC): PARSER = struct
             if typeReprId = 0 then
               let
                 val (_, pos, _) = getTokenCtx ctx
+                val ets = "expected type specifier"
+                val etss = "expected type or storage specifier"
               in
-                P.error pos `"expected type specifier" %
+                P.error pos `(if isSome storSpec then ets else etss) %
               end
             else
               ((storSpec, typeRepr2type typeReprId), ctx)
@@ -860,7 +853,7 @@ functor Parser(P: PPC): PARSER = struct
     collect ctx (NONE, 0)
   end
 
-  and Ppart (out, part) =
+  and Ppart part out =
     case part of
       Pointer plevel => Printf out `"[" I plevel `"] " %
     | Id _ => Printf out `"id" %
@@ -872,7 +865,6 @@ functor Parser(P: PPC): PARSER = struct
     isSome $ List.find
       (fn tk' => case tk of Tk tk => tk = tk' | _ => false) typeSpecs
 
-
   and parseTypeName ctx =
   let
     val (prefix, ctx) = parseDeclPrefix ctx
@@ -987,6 +979,15 @@ functor Parser(P: PPC): PARSER = struct
       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
@@ -1001,7 +1002,7 @@ functor Parser(P: PPC): PARSER = struct
         pointer_t (plevel, complete tail)
       | complete (FuncApp params :: tail) =
       let
-        (* TODO: check params uniqness *)
+        val () = checkParamUniqueness [] params
         val params = map (fn (_, _, ctype) => ctype) params
       in
         function_t (complete tail, params)
@@ -1019,20 +1020,15 @@ functor Parser(P: PPC): PARSER = struct
     { id, pos, spec = storSpec, ctype = complete $ tl parts, params }
   end
 
-  fun printDeclId ({ id, spec, ctype, params, ... }: declaredId) =
-  let
-    fun Pstor (_, NONE) = ()
-      | Pstor (out, SOME s) = Printf out PstorSpec s %
-  in
-    printf A1 Pstor spec Popt P.? id `": " Pctype ctype `"\n" %;
+  fun pDeclId ({ id, spec, ctype, params, ... }: declaredId) out = (
+    Printf out Popt pStorSpec spec `" " Popt P.psid id `": "
+        Pctype ctype `"\n" %;
+
     case params of
       NONE => ()
-    | SOME params => (
-        printf `"params: " %;
-        List.app (fn (id, _) => printf Popt P.?id `", " %) params;
-        printf `"\n" %
-    )
-  end
+    | SOME params => Printf out
+      `"params: " Plist (popt P.psid) (map #1 params) (", ", false) `"\n" %
+  )
 
   datatype declaration =
     DeclIds of declaredId list |
@@ -1074,15 +1070,38 @@ functor Parser(P: PPC): PARSER = struct
 
   fun parseStmtCompound ctx =
   let
-    val (ea, ctx) = parseExpr ctx (SOME T.Semicolon)
-    val (_, _, ctx) = getTokenCtx ctx
-    val (tk, pos, ctx) = getTokenCtx ctx
+    fun collect acc ctx =
+    let
+      val (tk, _, _) = getTokenCtx ctx
+    in
+      case tk of
+        Tk T.EOS => (rev acc, ctx)
+      | _ =>
+          let
+            val (ea, ctx) = parseExpr ctx (SOME T.Semicolon)
+            val (tk, pos, ctx) = getTokenCtx ctx
+          in
+            case tk of
+              Tk T.Semicolon => collect (ea :: acc) ctx
+            | _ => P.clerror pos [P.Ctk T.Semicolon]
+          end
+    end
+
+    val (eas, ctx) = collect [] ctx
   in
-    case tk of
-      Tk T.EOS => (StmtCompound ea, ctx)
-    | _ => P.clerror pos [P.Ctk T.RBrace]
+    (StmtCompound eas, ctx)
   end
 
+  val Pstmt = fn z =>
+  let
+    fun Pstmt off (StmtCompound eas) out =
+      Printf out R off `"{\n"
+        Plist (printExpr (off + 1)) eas ("", false)
+        R off `"}\n" %
+  in
+    bind A2 Pstmt
+  end z
+
   fun parseFuncDefinition id ctx =
   let
     val (stmt, ctx) = parseStmtCompound ctx
@@ -1090,14 +1109,26 @@ functor Parser(P: PPC): PARSER = struct
     (Definition (id, stmt), ctx)
   end
 
+  fun printDef (Definition (id, stmt)) =
+    printf `"Function: " A1 pDeclId id Pstmt 0 stmt %
+  | printDef (Declaration ids) = printf Plist pDeclId ids ("", false) %
+
   fun parseDef ctx =
   let
-    val (toplev, ctx) = parseDeclaration ctx true
+    val (tk, _, _) = getTokenCtx ctx
   in
-    case toplev of
-      DeclIds ids => (Declaration ids, ctx)
-    | FuncDef (id, body) =>
-        ctxWithLayer ctx body (fn ctx =>
-          parseFuncDefinition id ctx)
+    case tk of
+      Tk T.EOS => NONE
+    | _ =>
+      let
+        val (toplev, ctx) = parseDeclaration ctx true
+      in
+        SOME (case toplev of
+          DeclIds ids => (Declaration ids, ctx)
+        | FuncDef (id, body) =>
+            ctxWithLayer ctx body (fn ctx =>
+              parseFuncDefinition id ctx))
+      end
+
   end
 end