Printf

1 files changed, 189 insertions, 109 deletions

diff --git a/ppc.fun b/ppc.fun
index 0b67e39..e41caec 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -5,11 +5,17 @@ struct
 
   datatype tkPos = TkPos of T.S.pos
 
+  type macroBody = (T.token * T.S.pos) list
+  datatype macro =
+    ObjMacro of macroBody |
+    FuncMacro of string list * macroBody
+
   type t = {
     streams: T.S.t list,
 
     buffer: (T.token * T.S.pos) list,
-    macros: (T.token * T.S.pos) list H.t, (* body is stored reversed *)
+
+    macros: (bool * macro) H.t,
 
     EOSreached: bool,
     incDirs: string list
@@ -33,7 +39,7 @@ struct
   fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos pos)
 
   fun tkErrorPrint (TkPos pos, msg) =
-    printLn $ T.S.pos2str pos ^ ": " ^ msg
+    printf A1 T.S.pos2str pos `": " `msg `"\n" %
 
   fun raiseTkErrorExp pos exp = raise TkErrorExp (pos, exp)
   fun raiseTkErrorExpSPos pos exp = raiseTkErrorExp (TkPos pos) exp
@@ -42,28 +48,28 @@ struct
   let
     val printEtk = fn
         ExpTk tk => T.printToken tk
-      | ExpId => print "identifier"
-      | ExpConst => print "constant"
-      | ExpUnop => print "unary operator"
-      | ExpBinop => print "binary operator"
-      | ExpOp => print "operator"
+      | ExpId => output "identifier"
+      | ExpConst => output "constant"
+      | ExpUnop => output "unary operator"
+      | ExpBinop => output "binary operator"
+      | ExpOp => output "operator"
 
     fun printExpList [] = raise Unreachable
       | printExpList [etk] = printEtk etk
       | printExpList [etk1, etk2] = (
         printEtk etk1;
-        print " or ";
+        output " or ";
         printEtk etk2
       )
       | printExpList (etk :: etks) = (
         printEtk etk;
-        print ", ";
+        output ", ";
         printExpList etks
       )
   in
-    print $ T.S.pos2str pos ^ ": expected ";
+    printf A1 T.S.pos2str pos `": expected " %;
     printExpList exp;
-    print "\n"
+    output "\n"
   end
 
   val updatePpc = fn z =>
@@ -78,7 +84,7 @@ struct
     z
 
   fun create { fname, incDirs } =
-    { streams = [T.S.create fname], buffer = [], macros = H.create 10,
+    { streams = [T.S.create fname], buffer = [], macros = H.createLog 10,
         EOSreached = false, incDirs }
 
   datatype IncludeArg =
@@ -130,34 +136,34 @@ struct
 
   fun findFile arg (stream, incDirs) = 
     case arg of
-        LocalInc (arg, pos) => (
+      LocalInc (arg, pos) => (
+      let
+        val dir = OS.Path.getParent o T.S.getFname $ stream
+        val path = OS.Path.concat (dir, arg)
+
+        val (path, instream) = (path, TextIO.openIn path)
+      in
+        (path, instream)
+      end handle
+      OS.Path.Path => raiseTkErrorSPos pos "invalid argument"
+      | Size => raiseTkErrorSPos pos "resulting path is too long"
+      | IO.Io v => raise IO.Io v
+    )
+    | ExternalInc (arg, pos) =>
+    let
+      fun try (dir :: tail) = (
         let
-          val dir = OS.Path.getParent o T.S.getFname $ stream
           val path = OS.Path.concat (dir, arg)
-
-          val (path, instream) = (path, TextIO.openIn path)
         in
-          (path, instream)
-        end handle
-        OS.Path.Path => raiseTkErrorSPos pos "invalid argument"
-        | Size => raiseTkErrorSPos pos "resulting path is too long"
-        | IO.Io v => raise IO.Io v
+          SOME (path, TextIO.openIn path)
+        end handle _ => try tail
       )
-      | ExternalInc (arg, pos) =>
-      let
-        fun try (dir :: tail) = (
-          let
-            val path = OS.Path.concat (dir, arg)
-          in
-            SOME (path, TextIO.openIn path)
-          end handle _ => try tail
-        )
-          | try [] = NONE
-      in
-        case try incDirs of
-          SOME pair => pair
-        | NONE => raiseTkErrorSPos pos "unable to find header"
-      end
+        | try [] = NONE
+    in
+      case try incDirs of
+        SOME pair => pair
+      | NONE => raiseTkErrorSPos pos "unable to find header"
+    end
 
   fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) =
   let
@@ -169,59 +175,141 @@ struct
   end
     | handleInclude _ = raise Unreachable
 
-  fun handleDefine (P as { streams = head :: _, ... }: t) =
+  fun getDefineMacroBody stream acc =
+  let
+    val (tk, pos, stream) = T.getToken stream
+  in
+    case tk of
+      T.NewLine => (acc, stream)
+    | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine]
+    | _ => getDefineMacroBody stream ((tk, pos) :: acc)
+  end
+
+  fun isFuncMacroDefine nameLength (T.S.Pos (_, line1, col1)) stream =
+  let
+    val (tk, T.S.Pos (_, line2, col2), _) = T.getToken stream
+  in
+    tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2
+  end
+
+  fun parseDefineObjMacro stream =
+  let
+    val (body, stream) = getDefineMacroBody stream []
+  in
+    (ObjMacro body, stream)
+  end
+
+  fun getSpecific stream expList =
+  let
+    val (tk, pos, stream) = T.getToken stream
+  in
+    raise Unimplemented
+  end
+
+  fun parseDefineMacroArgs stream =
+  let
+    datatype arg =
+        Arg of string * T.S.pos |
+        LastArg of string * T.S.pos |
+        EmptyArg
+  in
+    raise Unimplemented
+  end
+
+  fun parseDefineFuncMacro stream =
+  let
+    val (_, _, stream) = T.getToken stream
+  in
+    raise Unimplemented
+  end
+
+  fun parseDefine stream =
   let
     fun getName stream =
     let
         val (tk, pos, stream) = T.getToken stream
     in
       case tk of
-           T.Id id => (id, pos, stream)
-         | _ => raiseTkErrorExpSPos pos [ExpId]
+        T.Id id => (id, pos, stream)
+      | _ => raiseTkErrorExpSPos pos [ExpId]
     end
 
-    fun getBody stream acc =
-    let
-      val (tk, pos, stream) = T.getToken stream
-    in
-      case tk of
-           T.NewLine => (acc, stream)
-         | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine]
-         | _ => getBody stream ((tk, pos) :: acc)
-    end
+    val (macroName, pos, stream) = getName stream
 
-    val (macroName, pos, head) = getName head
-    val (macroBody, head) = getBody head []
+    val parser =
+      if isFuncMacroDefine (size macroName) pos stream then
+        parseDefineFuncMacro
+      else
+        parseDefineObjMacro
+
+    val (macro, stream) = parser stream
+  in
+    ((macroName, pos), macro, stream)
+  end
 
-    val () = H.insert (#macros P) macroName macroBody handle
+  fun handleDefine (P as { streams = head :: _, ... }: t) =
+  let
+    val ((macroName, pos), macro, head) = parseDefine head
+
+    val () = H.insert (#macros P) macroName (false, macro) handle
         H.Exists => raiseTkErrorSPos pos "macro redefinition"
   in
     updatePpc P u#streams (fn s => head :: tl s) %
   end
     | handleDefine _ = raise Unreachable
 
-  fun handleRegularToken tk pos P =
+  val directiveTable = [
+      (T.CppInclude, handleInclude),
+      (T.CppDefine, handleDefine)
+  ]
+
+  fun expandObjMacro (id, pos) body ppc =
   let
-    fun def () = (tk, TkPos pos, P)
+    val mstart = (T.MacroStart id, pos)
+    val mend = (T.MacroEnd id,
+        if body = [] then pos else (#2 o hd) body)
+    val revBody = List.concat [[mend], body, [mstart]]
+  in
+    updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) %
+  end
+
+  fun expandFuncMacro (_, _) (_, _) _ =
+    raise Unimplemented
+
+  fun handleRegularToken tk pos ppc =
+  let
+    fun def () = (tk, TkPos pos, ppc)
+
+    fun checkAndMark (true, _) = (NONE, NONE)
+      | checkAndMark (false, macro) = (SOME (true, macro), SOME macro)
   in
     case tk of
-         T.Id id => (
-           case H.lookup (#macros P) id of
-                NONE => def ()
-              | SOME body =>
-              let
-                val mstart = (T.MacroStart id, pos)
-                val mend = (T.MacroEnd,
-                    if body = [] then pos else (#2 o hd) body)
-                val revBody = List.concat [[mend], body, [mstart]]
-              in
-                getToken $ updatePpc P
-                      u#buffer (fn buf => List.revAppend (revBody, buf)) %
-              end
-       )
-       | _ => def ()
+      T.Id id => (
+        case H.lookup2 (#macros ppc) id
+            checkAndMark (fn () => NONE)
+        of
+          NONE => def ()
+        | SOME (ObjMacro body) =>
+            getToken $ expandObjMacro (id, pos) body ppc
+        | SOME (FuncMacro (arg, body)) =>
+            getToken $ expandFuncMacro (id, pos) (arg, body) ppc
+    )
+    | T.MacroEnd id =>
+    let
+      val () = H.lookup2 (#macros ppc) id
+             (fn (_, body) => (SOME (false, body), ()))
+             (fn () => raise Unreachable)
+    in
+      def ()
+    end
+    | _ => def ()
   end
 
+  and handleToken tk pos ppc =
+    case List.find (fn (tk', _) => tk' = tk) directiveTable of
+      SOME (_, f) => getToken o f $ ppc
+    | NONE => handleRegularToken tk pos ppc
+
   and getToken (P as { streams = [stream], EOSreached = true, ... }) =
   let
     val (pos, stream) = T.S.EOFpos stream
@@ -229,72 +317,64 @@ struct
     (T.EOS, TkPos pos, updatePpc P s#streams [stream] %)
   end
     | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
-      handleRegularToken tk pos (updatePpc P s#buffer tail %)
+      handleToken tk pos (updatePpc P s#buffer tail %)
     | getToken (P as { streams = head :: tail, ... }: t) =
   let
     val (tk, pos, head) = T.getToken head
-    val directiveTable = [
-        (T.CppInclude, handleInclude),
-        (T.CppDefine, handleDefine)
-    ]
   in
     if tk = T.EOS then
       case tail of
-           [] => getToken $ updatePpc P s#EOSreached true %
-         | _ => getToken $ updatePpc P s#streams tail %
+        [] => getToken $ updatePpc P s#EOSreached true %
+      | _ => getToken $ updatePpc P s#streams tail %
     else
-      case List.find (fn (tk', _) => tk' = tk) directiveTable of
-        SOME (_, f) => getToken o f $
-         updatePpc P s#streams (head :: tail) %
-      | NONE =>
-      let
-        val ppc = updatePpc P u#streams (fn s => head :: tl s) %
-      in
-        handleRegularToken tk pos ppc
-      end
+      handleToken tk pos $ updatePpc P s#streams (head :: tail) %
   end
   | getToken _ = raise Unreachable
 
-
-  fun debugPrint' ppc shouldPrintLine (fname, line) =
+  fun debugPrint' ppc (shouldPrintLine, indent) (fname, line) =
   let
     val (tk, pos, ppc) = getToken ppc
     val TkPos (t as (T.S.Pos (fname', line', col))) = pos
 
-    fun printLine () =
-      printOnNL $ fname' ^ ":" ^ Int.toString line' ^ "\n\t"
+    fun repeat n s = String.concat (List.tabulate (n, fn _ => s))
+    val Indent = fn z => bind A0 (fn () => repeat indent "\t") z
 
-    fun finish shouldPrintLine =
+    fun printLine () = printf `"\n" Indent `fname' `":" I line' `" \t" %
+
+    fun finish pair =
       if tk <> T.EOS then
-        debugPrint' ppc shouldPrintLine (fname', line')
+        debugPrint' ppc pair (fname', line')
       else
         ()
   in
     case tk of
-         T.MacroStart macroName => (
-           printOnNL $ "macro " ^ macroName ^ " (" ^ T.S.pos2str t ^ ") {";
-           finish true
-       )
-       | T.MacroEnd => (printOnNL "}\n"; finish true)
-       | _ => (
-          if shouldPrintLine orelse fname' <> fname
-                orelse line' <> line
-          then
-            printLine()
-          else
-            ();
-          print $ Int.toString col ^ ":";
-          T.printToken tk;
-          print " ";
-          finish false
-       )
+      T.MacroStart macroName => (
+        printf `"\n" Indent A1 T.S.pos2str t `": macro " `macroName `" {" %;
+        finish (true, indent + 1)
+    )
+    | T.MacroEnd id => (
+      output "\n";
+      printf Indent `"} " `id %;
+      finish (true, indent - 1)
+    )
+    | _ => (
+      if shouldPrintLine orelse fname' <> fname orelse line' <> line
+      then
+        printLine()
+      else
+        ();
+      printf I col `":" %;
+      T.printToken tk;
+      printf `" " %;
+      finish (false, indent)
+    )
   end
 
   fun debugPrint fname incDirs =
   let
     val ppc = create { fname, incDirs }
   in
-    debugPrint' ppc true ("", 0);
-    print "\n"
+    debugPrint' ppc (true, 0) ("", 0);
+    output "\n"
   end
 end