Transition from exception-based errors to printf-based

1 files changed, 99 insertions, 129 deletions

diff --git a/ppc.fun b/ppc.fun
index c590ff5..2872848 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -17,7 +17,6 @@ struct
     buffer: layer list,
 
     macros: (string, bool * T.S.pos * macro) Tree.t,
-
     debugMode: bool,
     incDirs: string list
   }
@@ -26,9 +25,6 @@ struct
   val insertMacro = Tree.insert macroCompare
   val macrosLookup = fn z => Tree.lookup2 macroCompare z
 
-  type tkErrorVal = tkPos * string
-  exception TkError of tkErrorVal
-
   datatype tkClass =
     Ctk of T.token |
     Cid |
@@ -37,57 +33,53 @@ struct
     Cbinop |
     Cop
 
-  type tkClassErrorVal = tkPos * tkClass list
-  exception TkClassError of tkClassErrorVal
-
   fun pos2tkPos pos = TkPos (pos, [])
+  fun tkPos2pos (TkPos (pos, [])) =  pos
+    | tkPos2pos _ = raise Unreachable
 
   val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0)
 
-  fun raiseTkError pos msg = raise TkError (pos, msg)
-  fun raiseTkErrorP pos g =
-    sprintf (fn (a, f) => g (a, raiseTkError pos o f))
+  val PlayersU = fn z =>
+  let
+    fun PlayersU (out, ((macroName, pos) :: layers)) =
+      Printf out `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n"
+        A1 PlayersU layers %
+      | PlayersU (_, []) = ()
+  in
+    bind A1 PlayersU
+  end z
 
-  fun printLayersU ((macroName, pos) :: layers) = (
-    printf `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n" %;
-    printLayersU layers
-  )
-    | printLayersU [] = ()
+  fun warningLow (TkPos (pos, layers)) msg f g =
+    printf `"\n" T.S.Ppos pos `":" `msg `": "
+      (fn (a, _) => g (a, fn (_, out) =>
+        (Printf out `"\n" PlayersU layers %; f ())))
 
-  fun tkErrorPrint (TkPos (pos, layers), msg) = (
-    printf T.S.Ppos pos `": " `msg `"\n" %;
-    printLayersU layers
-  )
+  fun warning pos g = warningLow pos "warning" (fn () => ()) g
+  fun error pos g = warningLow pos "error" (fn () => exit 1) g
 
-  fun raiseTkClassError pos cls = raise TkClassError (pos, cls)
+  fun errorSpos pos g = error (pos2tkPos pos) g
 
-  fun tkClassErrorPrint (TkPos (pos, layers), cls) =
+  fun clerror (TkPos (pos, layers)) cls =
   let
-    val printCtk = fn
-        Ctk tk => printf T.Ptk tk %
-      | Cid => printf `"identifier" %
-      | Cconst => printf `"constant" %
-      | Cunop => printf `"unary operator" %
-      | Cbinop => printf `"binary operator" %
-      | Cop => printf `"operator" %
+    fun Pcl (out, cl) =
+      case cl of
+        Ctk tk => Printf out T.Ptk tk %
+      | Cid => Printf out `"identifier" %
+      | Cconst => Printf out `"constant" %
+      | Cunop => Printf out `"unary operator" %
+      | Cbinop => Printf out `"binary operator" %
+      | Cop => Printf out `"operator" %
 
-    fun printClassList [] = raise Unreachable
-      | printClassList [ctk] = printCtk ctk
-      | printClassList [ctk1, ctk2] = (
-        printCtk ctk1;
-        printf `" or ";
-        printCtk ctk2
-      )
-      | printClassList (ctk :: ctks) = (
-        printCtk ctk;
-        printf `", ";
-        printClassList ctks
-      )
+    fun Pcls (_, []) = raise Unreachable
+      | Pcls (out, [cl]) = Printf out A1 Pcl cl %
+      | Pcls (out, [cl1, cl2]) =
+          Printf out A1 Pcl cl1 `" or " A1 Pcl cl2 %
+      | Pcls (out, cl :: cls) =
+        Printf out A1 Pcl cl `", " A1 Pcls cls %
   in
-    printf T.S.Ppos pos `": expected " %;
-    printClassList cls;
-    printf `"\n";
-    printLayersU layers
+    printf `"\n" T.S.Ppos pos `":error: expected " A1 Pcls cls `"\n"
+        PlayersU layers;
+    exit 1
   end
 
   val updatePpc = fn z =>
@@ -114,13 +106,6 @@ struct
       printLayers out layers
     )
 
-  val Players = fn z =>
-  let
-    fun Players (out, layers) = printLayers out layers
-  in
-    bind A1 Players
-  end z
-
   fun convPos (T.S.Pos (fname, line, col)) plen =
   let
     val fname = String.extract (fname, plen, NONE)
@@ -141,8 +126,8 @@ struct
     findPrefix' 0 s1 s2
   end
 
-  fun PlayersCompact (_, (_, [])) = ""
-    | PlayersCompact (out, (startPrx, L as (layer :: layers))) =
+  fun PlayersCompact (_, _, []) = ""
+    | PlayersCompact (out, startPrx, L as (layer :: layers)) =
   let
     fun getFname (_, T.S.Pos (fname, _, _)) = fname
 
@@ -173,7 +158,7 @@ struct
         [] => Printf out `fname' `":" I line' `"| \t" %
       | _ =>
         let
-          val prefix = PlayersCompact (out, (SOME fname', layers'))
+          val prefix = PlayersCompact (out, SOME fname', layers')
           val fname' = String.extract (fname', size prefix, NONE)
         in
           Printf out `"; @" `fname' `":" I line' `"| \t" %
@@ -187,40 +172,22 @@ struct
     (off, layers', (fname', line'))
   end
 
-  val PtkPos = fn z =>
-  let
-    fun PtkPos (out, TkPos (pos, layers)) = (
-      if layers <> [] then
-        Printf out `"(" Players layers `") " %
-      else
-        ();
-      Printf out T.S.Ppos pos %
-    )
-  in
-    bind A1 PtkPos
-  end z
-
-  fun warning (TkPos (pos, layers)) g =
-    printf `"\n" T.S.Ppos pos `":warning: "
-      (fn (a, _) => g (a, fn (_, output) =>
-        (output "\n"; printLayersU layers)))
-
-  val printMacroHeader = fn z =>
+  val PmacroHeader = fn z =>
   let
-    fun printMacroHeader (out, (id, mLayers)) =
+    fun printMacroHeader (out, id, mLayers) =
     let
-      fun Players (out, v) = ignore $ PlayersCompact (out, v)
+      fun Players (out, x, y) = ignore $ PlayersCompact (out, x, y)
     in
-      Printf out `"\nexpanding (" A1 Players (NONE, rev mLayers)
+      Printf out `"\nexpanding (" A2 Players NONE (rev mLayers)
         `") macro " `id %
     end
   in
-    bind A1 printMacroHeader
+    bind A2 printMacroHeader
   end z
 
-  val printTokenL = fn z =>
+  val PtokenL = fn z =>
   let
-    fun printTokenL (out, (offset, l)) =
+    fun printTokenL (out, offset, l) =
     let
       fun printList _ [] = ()
         | printList cache (tk :: tail) =
@@ -246,7 +213,7 @@ struct
       Printf out `"\n" %
     end
   in
-    bind A1 printTokenL
+    bind A2 printTokenL
   end z
 
   fun updateH head = fn s => Stream head :: tl s
@@ -280,14 +247,14 @@ struct
   end
     | getTokenNoexpand ppc = (T.EOS, dummyEOSpos, ppc)
 
-  fun checkClass (tk, pos) clList raiseClassErr =
+  fun checkClass (tk, pos) clList =
   let
     fun belongsToClass tk (Ctk tk') = tk = tk'
       | belongsToClass (T.Id _) (Cid) = true
       | belongsToClass _ Cid = false
       | belongsToClass _ _ = raise Unreachable
 
-    fun checkClass' [] = raiseClassErr pos clList
+    fun checkClass' [] = clerror pos clList
       | checkClass' (cl :: tail) =
         if belongsToClass tk cl then
           ()
@@ -297,16 +264,16 @@ struct
     checkClass' clList
   end
 
-  fun getClassGeneric clList getToken raiseClassErr buf =
+  fun getClassGeneric clList getToken ppc =
   let
-    val (tk, pos, buf) = getToken buf
-    val () = checkClass (tk, pos) clList raiseClassErr
+    val (tk, pos, ppc) = getToken ppc
+    val () = checkClass (tk, pos) clList
   in
-    (tk, pos, buf)
+    (tk, pos, ppc)
   end
 
-  fun getClassNoexpand (ppc: t) clList =
-    getClassGeneric clList getTokenNoexpand raiseTkClassError ppc
+  fun getClassNoexpand ppc clList =
+    getClassGeneric clList getTokenNoexpand ppc
 
   datatype IncludeArg = LocalInc of string * string | ExternalInc of string
 
@@ -319,8 +286,8 @@ struct
       in
         (path, instream)
       end handle
-        OS.Path.Path => raiseTkError pos "invalid argument"
-      | Size => raiseTkError pos "resulting path is too long"
+        OS.Path.Path => errorSpos pos `"invalid argument" %
+      | Size => errorSpos pos `"resulting path is too long" %
       | IO.Io v => raise IO.Io v
     )
     | ExternalInc arg =>
@@ -336,19 +303,19 @@ struct
     in
       case try incDirs of
         SOME pair => pair
-      | NONE => raiseTkError pos "unable to find header"
+      | NONE => errorSpos pos `"unable to find header" %
     end
 
   fun checkEndsWith pos arg c =
   let
     fun find i =
       if i = size arg then
-        raiseTkError pos "unfinished #include argument"
+        errorSpos pos `"unfinished #include argument" %
       else if String.sub (arg, i) = c then
         if i + 1 = size arg then
           String.extract (arg, 1, SOME $ size arg - 2)
         else
-          raiseTkError pos "some garbage after #include argument"
+          errorSpos pos `"some garbage after #include argument" %
       else
         find (i + 1)
   in
@@ -359,7 +326,7 @@ struct
   let
     fun eatSpaces s off =
       if off = size s then
-        raiseTkError pos "invalid #include argument"
+        errorSpos pos `"invalid #include argument" %
       else if String.sub (s, off) = #" " then
         eatSpaces s (off + 1)
       else
@@ -374,7 +341,7 @@ struct
     else if start = #"<" then
       ExternalInc $ check #">"
     else
-      raiseTkError pos "invalid #include argument"
+      errorSpos pos `"invalid #include argument" %
   end
 
   fun dprintf ppc =
@@ -383,11 +350,13 @@ struct
     else
       printf Ign
 
+  val PDP = fn z => bind A0 (fn out => out "\n!!! ") z
+
   fun handleInclude (T.PpcInclude (dir, arg), pos) ppc =
   let
     val arg = parseIncludeArg pos arg dir
     val (path, instream) = findFile pos arg (#incDirs ppc)
-    val () = dprintf ppc `"\n#include: " `path %
+    val () = dprintf ppc PDP T.S.Ppos pos `": #include: " `path %
     val stream = T.S.createFromInstream path instream
   in
     updatePpc ppc u#buffer (fn buf => Stream stream :: buf) %
@@ -400,7 +369,7 @@ struct
   in
     case tk of
       T.NewLine => (acc, ppc)
-    | T.EOS => raiseTkClassError pos [Ctk T.NewLine]
+    | T.EOS => clerror pos [Ctk T.NewLine]
     | _ => getDefineMacroBody ppc ((tk, pos) :: acc)
   end
 
@@ -416,7 +385,7 @@ struct
       ()
     else (
       Printf out `" {";
-      Printf out printTokenL (1, body);
+      Printf out PtokenL 1 body;
       Printf out `"}" %
     )
 
@@ -433,7 +402,7 @@ struct
     fun validateArg (id, _) [] = id
       | validateArg (id, pos) ((id', pos') :: tail) =
         if id = id' then
-          raiseTkError pos' "macro argument name is already taken"
+          error pos' `"macro argument name is already taken" %
         else
           validateArg (id, pos) tail
 
@@ -506,11 +475,11 @@ struct
   fun parseDefine ppc =
   let
     val (macroName, pos, ppc) = getClassNoexpand ppc [Cid]
-    val TkPos (pos, _) = pos
+    val pos = tkPos2pos pos
     val macroName =
       case macroName of T.Id id => id | _ => raise Unreachable
 
-    val () = dprintf ppc `"\n#define " `macroName %
+    val () = dprintf ppc PDP T.S.Ppos pos `": #define " `macroName %
 
     val parser =
       if isFuncMacroDefine (size macroName) pos ppc then
@@ -571,15 +540,15 @@ struct
     updatePpc ppc u#buffer f %
   end
 
-  val printBody = fn z =>
+  val Pbody = fn z =>
   let
-    fun printBody (out, (msg, body)) = (
+    fun printBody (out, msg, body) = (
       Printf out `"\n" `msg `" {";
-      Printf out printTokenL (1, body);
+      Printf out PtokenL 1 body;
       Printf out `"}\n" %
     )
   in
-    bind A1 printBody
+    bind A2 printBody
   end z
 
   datatype collectCtx =
@@ -592,8 +561,8 @@ struct
 
     val mLayers = addLayer (id, pos)
   in
-    dprintf ppc printMacroHeader (id, mLayers);
-    dprintf ppc printBody ("body", rev revBody);
+    dprintf ppc PmacroHeader id mLayers;
+    dprintf ppc Pbody "body" (rev revBody);
     insertRevBody revBody ppc
   end
 
@@ -605,7 +574,7 @@ struct
       val (tk, pos, ppc) = getTokenNoexpand ppc
     in
       if T.isPpcDir tk then
-        raiseTkError pos "preprocessor directive inside macro arguments"
+        error pos `"preprocessor directive inside macro arguments" %
       else
         (tk, pos, ppc)
     end
@@ -615,7 +584,7 @@ struct
       val (tk, pos, ppc) = getTokenRestricted ppc
     in
       case tk of
-        T.EOS => raiseTkError mPos "unfinished argument list"
+        T.EOS => error mPos `"unfinished argument list" %
       | T.Coma => (true, rev acc, ppc)
       | T.RParen => (false, rev acc, ppc)
       | _ => parseArg ppc ((tk, pos) :: acc)
@@ -623,7 +592,7 @@ struct
 
     fun parseArgs ppc params acc =
     let
-      fun bind _ [] = raiseTkError mPos "too many arguments"
+      fun bind _ [] = error mPos `"too many arguments" %
         | bind body (param :: params) = ((param, body), params)
 
       val (continue, arg, ppc) = parseArg ppc []
@@ -633,13 +602,13 @@ struct
         parseArgs ppc otherParams (bindedParam :: acc)
       else
         if length otherParams > 0 then
-          raiseTkError mPos "not enough arguments"
+          error mPos `"not enough arguments" %
         else
           (rev (bindedParam :: acc), ppc)
     end
 
     val (_, _, ppc) = getClassGeneric [Ctk T.LParen]
-            getTokenRestricted raiseTkClassError ppc
+            getTokenRestricted ppc
     val (res, ppc) = parseArgs ppc params []
   in
     (res, ppc)
@@ -689,7 +658,7 @@ struct
       fun print [] = ()
         | print ((p, args) :: tail) = (
         Printf out `p `": ";
-        Printf out printTokenL (1, args);
+        Printf out PtokenL 1 args;
         print tail
       )
     in
@@ -712,7 +681,7 @@ struct
     end
     fun apply f bp = List.map (fn (p, arg) => (p, f arg)) bp
 
-    val () = dprintf ppc printMacroHeader (id, mLayers) %
+    val () = dprintf ppc PmacroHeader id mLayers %
     val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc
 
     val bp1 = apply addLayers2args bindedParams
@@ -724,7 +693,7 @@ struct
     val body = setLayers (id, mPos) body
     val body = subst (id, mPos) bp2 body []
   in
-    dprintf ppc printBody ("subst", body);
+    dprintf ppc Pbody "subst" body;
     insertRevBody (rev body) ppc
   end
 
@@ -736,8 +705,7 @@ struct
       fun def dl = collect (level + dl) ppc ((tk, pos) :: acc)
 
       fun unexpected tk prevTk =
-        raiseTkErrorP pos
-            `"unexpected " T.Ptk tk `" inside " T.Ptk prevTk %
+        error pos `"unexpected " T.Ptk tk `" inside " T.Ptk prevTk %
 
       fun handleIfdef ifTk =
         if tk = T.PpcElif then
@@ -757,7 +725,7 @@ struct
           | AfterElif => def 0
     in
       case tk of
-        T.EOS => raiseTkError ifPos "unfinished conditional directive"
+        T.EOS => errorSpos ifPos `"unfinished conditional directive" %
       | T.PpcEndif =>
           if level = 0 then
             if ctx = AfterElif then
@@ -841,7 +809,7 @@ struct
       else
         (not defined, "ifndef")
   in
-    dprintf ppc `"\n" PtkPos ifPos `": #" `form `" " `id `" -> " B cond %;
+    dprintf ppc PDP T.S.Ppos ifPos `": #" `form `" " `id `" -> " B cond %;
     (cond, ppc)
   end
 
@@ -852,13 +820,13 @@ struct
       val (tk, _, ppc) = getTokenNoexpand ppc
     in
       case tk of
-        T.EOS => raiseTkError ifPos "unfinished #if condition"
+        T.EOS => errorSpos ifPos `"unfinished #if condition" %
       | T.NewLine => ppc
       | _ => skip ppc
     end
     val cond = true
   in
-    dprintf ppc `"\n" PtkPos ifPos `": #if -> " B cond `" (skipping)" %;
+    dprintf ppc PDP T.S.Ppos ifPos `": #if -> " B cond `" (skipping)" %;
     (cond, skip ppc)
   end
 
@@ -875,7 +843,7 @@ struct
     val (cond, ppc) = eval ifPos ppc
     val (revBody, ppc) = getRevBody ifPos cond ppc
   in
-    dprintf `" {" printTokenL (1, rev revBody) `"}\n";
+    dprintf `" {" PtokenL 1 (rev revBody) `"}\n";
     insertRevBody revBody ppc
   end
 
@@ -921,10 +889,12 @@ struct
     | _ => def ()
   end
 
+  and handleStray (tk, pos) _ = errorSpos pos `"stray " T.Ptk tk %
+
   and ppcFallback (_, pos) _ =
-    raiseTkError pos "directive is not implemented"
+    errorSpos pos `"directive is not implemented" %
 
-  and handleToken tk pos (ppc: t) =
+  and handleToken tk pos ppc =
   let
     fun %tk = fn tk' => tk' = tk
     val directiveTable = [
@@ -934,16 +904,16 @@ struct
         (%T.PpcIfndef, handleIf),
         (%T.PpcUndef, handleUndef),
         (%T.PpcIf, handleIf),
-        (%T.PpcElse, ppcFallback),
-        (%T.PpcElif, ppcFallback),
-        (%T.PpcEndif, ppcFallback),
+        (%T.PpcElse, handleStray),
+        (%T.PpcElif, handleStray),
+        (%T.PpcEndif, handleStray),
         (%T.PpcWarning, ppcFallback),
         (%T.PpcError, ppcFallback),
         (%T.PpcPragma, ppcFallback)
     ]
   in
     case List.find (fn (f, _) => f tk) directiveTable of
-      SOME (_, f) => getToken $ f (tk, pos) ppc
+      SOME (_, f) => getToken $ f (tk, tkPos2pos pos) ppc
     | NONE => handleRegularToken tk pos ppc
   end
 
@@ -1002,6 +972,6 @@ struct
       | _ => (tk, pos, ppc)
     end
   in
-    getClassGeneric clList getTokenSkipNL raiseTkClassError ppc
+    getClassGeneric clList getTokenSkipNL ppc
   end
 end