Function-like macros

1 files changed, 412 insertions, 132 deletions

diff --git a/ppc.fun b/ppc.fun
index 51b6a4e..fcd0676 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -1,4 +1,4 @@
-functor ppc(structure H: HASHTABLE; structure T: TOKENIZER): PPC =
+functor ppc(structure Tree: TREE; structure T: TOKENIZER): PPC =
 struct
 
   structure T = T
@@ -16,12 +16,17 @@ struct
 
     buffer: (T.token * tkPos) list,
 
-    macros: (bool * macro) H.t,
+    macros: (string, bool * macro) Tree.t,
 
-    EOSreached: bool,
+    restricted: bool,
+    debugMode: bool,
     incDirs: string list
   }
 
+  val macroCompare = fn s1 => fn s2 => String.compare (s1, s2)
+  val insertMacro = Tree.insert macroCompare
+  val macrosLookup = fn z => Tree.lookup2 macroCompare z
+
   type tkErrorVal = tkPos * string
   exception TkError of tkErrorVal
 
@@ -36,67 +41,184 @@ struct
   type tkClassErrorVal = tkPos * tkClass list
   exception TkClassError of tkClassErrorVal
 
+  fun pos2tkPos pos = TkPos (pos, [])
+
+  val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0)
+
   fun raiseTkError msg pos = raise TkError (pos, msg)
-  fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos (pos, []))
+  fun raiseTkErrorSPos pos msg = raiseTkError msg $ pos2tkPos pos
 
   fun printLayers ((macroName, pos) :: layers) = (
-    printf `"\t" `macroName `" " A1 T.S.pos2str pos %;
+    printf `"\t" `macroName `" " T.S.Ppos pos %;
     printLayers layers
   )
     | printLayers [] = ()
 
   fun tkErrorPrint (TkPos (pos, layers), msg) = (
-    printf A1 T.S.pos2str pos `": " `msg `"\n" %;
+    printf T.S.Ppos pos `": " `msg `"\n" %;
     printLayers layers
   )
 
   fun raiseTkClassError pos cls = raise TkClassError (pos, cls)
-  fun raiseTkClassErrorSPos pos cls =
-    raiseTkClassError (TkPos (pos, [])) cls
+  fun raiseTkClassErrorSPos pos cls = raiseTkClassError (pos2tkPos pos) cls
 
   fun tkClassErrorPrint (TkPos (pos, layers), cls) =
   let
     val printCtk = fn
-        Ctk tk => T.printToken tk
-      | Cid => output "identifier"
-      | Cconst => output "constant"
-      | Cunop => output "unary operator"
-      | Cbinop => output "binary operator"
-      | Cop => output "operator"
+        Ctk tk => printf T.Ptoken tk %
+      | Cid => printf `"identifier" %
+      | Cconst => printf `"constant" %
+      | Cunop => printf `"unary operator" %
+      | Cbinop => printf `"binary operator" %
+      | Cop => printf `"operator" %
 
     fun printClassList [] = raise Unreachable
       | printClassList [ctk] = printCtk ctk
       | printClassList [ctk1, ctk2] = (
         printCtk ctk1;
-        output " or ";
+        printf `" or ";
         printCtk ctk2
       )
       | printClassList (ctk :: ctks) = (
         printCtk ctk;
-        output ", ";
+        printf `", ";
         printClassList ctks
       )
   in
-    printf A1 T.S.pos2str pos `": expected " %;
+    printf T.S.Ppos pos `": expected " %;
     printClassList cls;
-    output "\n";
+    printf `"\n";
     printLayers layers
   end
 
   val updatePpc = fn z =>
     let
-      fun from streams buffer macros EOSreached incDirs =
-        { streams, buffer, macros, EOSreached, incDirs }
-      fun to f { streams, buffer, macros, EOSreached, incDirs } =
-        f streams buffer macros EOSreached incDirs
+      fun from streams buffer macros restricted debugMode incDirs =
+        { streams, buffer, macros, restricted, debugMode, incDirs }
+      fun to f { streams, buffer, macros, restricted, debugMode,
+        incDirs } =
+        f streams buffer macros restricted debugMode incDirs
+    in
+      FRU.makeUpdate6 (from, from, to)
+    end z
+
+  fun create { fname, incDirs, debugMode } =
+    { streams = [T.S.create fname], buffer = [], macros = Tree.empty,
+        restricted = false, debugMode, incDirs }
+
+  fun compareLayers cached macroLayers =
+  let
+    fun dropCommonPrefix [] l2 = ([], l2)
+      | dropCommonPrefix l1 [] = (l1, [])
+      | dropCommonPrefix (e1 :: l1) (e2 :: l2) =
+        if e1 = e2 then
+          dropCommonPrefix l1 l2
+        else
+          (e1 :: l1, e2 :: l2)
+    val (cachedTail, macroTail) =
+      dropCommonPrefix (rev cached) (rev macroLayers)
+  in
+    (length cachedTail, macroTail)
+  end
+
+  fun printClosure offset _ 0 = offset
+    | printClosure offset out toClose =
+  let
+    fun printBrace offset 1 = Printf out R offset `"}" %
+      | printBrace offset toClose = (
+      Printf out R offset `"}\n";
+      printBrace (offset - 1) (toClose - 1)
+    )
+  in
+    Printf out `"\n";
+    printBrace (offset - 1) toClose;
+    offset - toClose
+  end
+
+  fun printNewLayers offset _ [] = offset
+    | printNewLayers offset out layers =
+  let
+    fun printLayer offset (macro, pos) =
+      Printf out R offset `macro `" " T.S.Ppos pos `" {" %
+    val () = Printf out `"\n" %
+
+    fun printLayers offset [layer] = printLayer offset layer
+      | printLayers offset (layer :: tail) = (
+      printLayer offset layer;
+      Printf out `"\n";
+      printLayers (offset + 1) tail
+    )
+      | printLayers _ [] = raise Unreachable
+  in
+    printLayers offset layers;
+    offset + length layers
+  end
+
+  fun printToken (offset, layers, (fname, line)) out (tk, pos) =
+  let
+    val TkPos (T.S.Pos (fname', line', col'), layers') = pos
+    val (toClose, newLayers) = compareLayers layers layers'
+
+    val offset1 = printClosure offset out toClose
+    val offset2 = printNewLayers offset1 out newLayers
+  in
+    if offset1 <> offset orelse offset2 <> offset1 orelse
+      fname' <> fname orelse line' <> line
+    then
+      Printf out `"\n" R offset2 `fname' `":" I line' `"|\t" %
+    else
+      ();
+    Printf out I col' `":" T.Ptoken tk `" ";
+    (offset2, layers', (fname', line'))
+  end
+
+  val printMacroHeader = fn z =>
+  let
+    fun printMacroHeader (out, (id, mLayers)) =
+    let
+      fun Players (out, layers) =
+      let
+        fun printLayer (macro, pos) =
+          Printf out `macro `" " T.S.Ppos pos %
+        fun printLayers [] = ()
+          | printLayers [layer] = printLayer layer
+          | printLayers (layer :: layers) = (
+            printLayer layer;
+            out ", ";
+            printLayers layers
+          )
+      in
+        printLayers layers
+      end
+
+      val layers = rev mLayers
     in
-      FRU.makeUpdate5 (from, from, to)
+      Printf out `"\n" `"(" A1 Players layers `"): macro " `id %
     end
-    z
+  in
+    bind A1 printMacroHeader
+  end z
 
-  fun create { fname, incDirs } =
-    { streams = [T.S.create fname], buffer = [], macros = H.createLog 10,
-        EOSreached = false, incDirs }
+  val startCache = (0, [], ("", 0))
+
+  val printTokenL = fn z =>
+  let
+    fun printTokenL (out, (offset, layers, l)) =
+    let
+      fun printList cache [] = cache
+        | printList cache (tk :: tail) =
+          printList (printToken cache out tk) tail
+
+      val cache = (offset, layers, ("", 0))
+      val (offset, layers', _) = printList cache l
+      val toClose = length layers' - length layers
+    in
+      printClosure offset out toClose;
+      Printf out `"\n" %
+    end
+  in
+    bind A1 printTokenL
+  end z
 
   datatype IncludeArg =
     LocalInc of string * T.S.pos |
@@ -203,35 +325,58 @@ struct
     tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2
   end
 
-  fun parseDefineObjMacro stream =
+  fun dBprintf debugMode =
+    if debugMode then
+      printf
+    else
+      printf Ign true
+  fun dprintf ppc = dBprintf (#debugMode ppc)
+
+  fun PrintMacroBody (out, body) =
+  let
+    val body = List.map (fn (tk, pos) => (tk, pos2tkPos pos)) body
+  in
+    Printf out `" {";
+    Printf out printTokenL (0, [], body);
+    Printf out `"}" %
+  end
+
+  fun parseDefineObjMacro debugMode stream =
   let
     val (body, stream) = getDefineMacroBody stream []
   in
+    dBprintf debugMode A1 PrintMacroBody body;
     (ObjMacro body, stream)
   end
 
-  fun getClass stream clList =
+  fun checkClass (tk, pos) clList raiseClassErr =
   let
-    val (tk, pos, stream) = T.getToken stream
-
     fun belongsToClass tk (Ctk tk') = tk = tk'
       | belongsToClass (T.Id _) (Cid) = true
       | belongsToClass _ Cid = false
       | belongsToClass _ _ = raise Unreachable
 
-    fun checkClass [] =
-      raiseTkClassErrorSPos pos clList
-      | checkClass (cl :: tail) =
+    fun checkClass' [] = raiseClassErr pos clList
+      | checkClass' (cl :: tail) =
         if belongsToClass tk cl then
           ()
         else
-          checkClass tail
+          checkClass' tail
+  in
+    checkClass' clList
+  end
 
-    val () = checkClass clList
+  fun getClassGeneric clList getToken raiseClassErr buf =
+  let
+    val (tk, pos, buf) = getToken buf
+    val () = checkClass (tk, pos) clList raiseClassErr
   in
-    (tk, pos, stream)
+    (tk, pos, buf)
   end
 
+  fun getClassFromStream stream clList =
+    getClassGeneric clList T.getToken raiseTkClassErrorSPos stream
+
   fun validateArgs args =
   let
     fun validateArg (id, _) [] = id
@@ -256,8 +401,8 @@ struct
 
     fun parseArg stream =
     let
-      val (tkId, posId, stream) = getClass stream [Cid]
-      val (tk, _, stream) = getClass stream [Ctk T.RParen, Ctk T.Coma]
+      val (tkId, posId, stream) = getClassFromStream stream [Cid]
+      val (tk, _, stream) = getClassFromStream stream [Ctk T.RParen, Ctk T.Coma]
       val id = case tkId of T.Id id => id | _ => raise Unreachable
     in
       case tk of
@@ -289,29 +434,34 @@ struct
     parseArgs stream
   end
 
-  fun parseDefineFuncMacro stream =
+  fun parseDefineFuncMacro debugMode stream =
   let
-    val (args, stream) = parseDefineMacroArgs stream
+    val (params, stream) = parseDefineMacroArgs stream
     val (body, stream) = getDefineMacroBody stream []
-  in
-    printf `"func macro (" %;
-    List.app (fn arg => printf `arg `", " %) args;
-    printf `") \n" %;
-    (FuncMacro (args, body), stream)
-  end
 
-  fun parseDefine stream =
-  let
-    fun getName stream =
+    fun printParams out =
     let
-        val (tk, pos, stream) = T.getToken stream
+      fun printParams' [] = ()
+        | printParams' [p] = Printf out `p %
+        | printParams' (p :: ps) = (Printf out `p `", "; printParams' ps)
     in
-      case tk of
-        T.Id id => (id, pos, stream)
-      | _ => raiseTkClassErrorSPos pos [Cid]
+      Printf out `"(";
+      printParams' params;
+      Printf out `")" %
     end
+  in
+    dBprintf debugMode A0 printParams;
+    dBprintf debugMode A1 PrintMacroBody body;
+    (FuncMacro (params, rev body), stream)
+  end
 
-    val (macroName, pos, stream) = getName stream
+  fun parseDefine stream debugMode =
+  let
+    val (macroName, pos, stream) = getClassFromStream stream [Cid]
+    val macroName =
+      case macroName of T.Id id => id | _ => raise Unreachable
+
+    val () = dBprintf debugMode `"\ndefine " `macroName %
 
     val parser =
       if isFuncMacroDefine (size macroName) pos stream then
@@ -319,141 +469,271 @@ struct
       else
         parseDefineObjMacro
 
-    val (macro, stream) = parser stream
+    val (macro, stream) = parser debugMode stream
   in
     ((macroName, pos), macro, stream)
   end
 
+  fun updateH head = fn s => head :: tl s
+
   fun handleDefine (P as { streams = head :: _, ... }: t) =
   let
-    val ((macroName, pos), macro, head) = parseDefine head
+    val ((macroName, pos), macro, head) = parseDefine head (#debugMode P)
 
-    val () = H.insert (#macros P) macroName (false, macro) handle
-        H.Exists => raiseTkErrorSPos pos "macro redefinition"
+    val macros = insertMacro (#macros P) macroName (false, macro) handle
+        Tree.Exists => raiseTkErrorSPos pos "macro redefinition"
   in
-    updatePpc P u#streams (fn s => head :: tl s) %
+    updatePpc P u#streams (updateH head) s#macros macros %
   end
     | handleDefine _ = raise Unreachable
 
   val directiveTable = [
-      (T.CppInclude, handleInclude),
-      (T.CppDefine, handleDefine)
+      (T.PpcInclude, handleInclude),
+      (T.PpcDefine, handleDefine)
   ]
 
-  fun expandObjMacro (id, TkPos (mPos, layers)) body ppc =
+  fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers
+  fun addLayers idPos body =
+  let
+    fun formLayers (tk, pos) = (tk, TkPos (pos, addLayer idPos))
+  in
+    List.map formLayers body
+  end
+
+  fun insertRevBody body ppc =
+    updatePpc ppc u#buffer (fn buf => List.revAppend (body, buf)) %
+
+  val printBody = fn z =>
+  let
+    fun printBody (out, (mLayers, msg, body)) = (
+      Printf out `"\n" `msg `" {";
+      Printf out printTokenL (1, mLayers, body);
+      Printf out `"}\n" %
+    )
+  in
+    bind A1 printBody
+  end z
+
+  fun expandObjMacro (id, pos) body ppc =
   let
-    val mend = (T.MacroEnd id, if body = [] then mPos else (#2 o hd) body)
+    val TkPos (pos', _) = pos
+    val mend = (T.MacroEnd id, if body = [] then pos' else (#2 o hd) body)
+    val revBody = addLayers (id, pos) $ List.concat [[mend], body]
+
+    val mLayers = addLayer (id, pos)
+
+  in
+    dprintf ppc printMacroHeader (id, mLayers);
+    dprintf ppc printBody (mLayers, "body", rev revBody);
+    insertRevBody revBody ppc
+  end
+
+  fun getClass ppc clList =
+    getClassGeneric clList getToken raiseTkClassError ppc
+
+  and parseFuncMacroArgs mPos params ppc =
+  let
+    fun parseArg ppc acc =
+    let
+      val (tk, pos, ppc) = getToken ppc (* TODO: should be restricted *)
+    in
+      case tk of
+        T.EOS => raiseTkError "unfinished argument list" mPos
+      | T.Coma => (true, rev acc, ppc)
+      | T.RParen => (false, rev acc, ppc)
+      | _ => parseArg ppc ((tk, pos) :: acc)
+    end
+
+    fun parseArgs ppc params acc =
+    let
+      fun bind _ [] = raiseTkError "too many arguments" mPos
+        | bind body (param :: params) = ((param, body), params)
+
+      val (continue, arg, ppc) = parseArg ppc []
+      val (bindedParam, otherParams) = bind arg params
+    in
+      if continue then
+        parseArgs ppc otherParams (bindedParam :: acc)
+      else
+        if length otherParams > 0 then
+          raiseTkError "not enough arguments" mPos
+        else
+          (rev (bindedParam :: acc), ppc)
+    end
 
-    fun formLayers (tk, pos) = (tk, TkPos (pos, (id, mPos) :: layers))
+    val ppc = updatePpc ppc s#restricted true %
+    val (_, _, ppc) = getClass ppc [Ctk T.LParen]
+    val (res, ppc) = parseArgs ppc params []
+    val ppc = updatePpc ppc s#restricted false %
+  in
+    (res, ppc)
+  end
 
-    val revBody = List.map formLayers $ List.concat [[mend], body]
+  and expandArgument ppc arg =
+  let
+    val ppc = updatePpc ppc s#streams [] s#buffer arg %
+    fun getAll ppc acc =
+    let
+      val (tk, pos, ppc) = getToken ppc
+    in
+      case tk of
+        T.EOS => rev acc
+      | _ => getAll ppc ((tk, pos) :: acc)
+    end
+  in
+    getAll ppc []
+  end
+
+  and subst _ [] (acc: (T.token * tkPos) list) = rev acc
+    | subst bindedParams ((P as (T.Id id, _)) :: tail) acc =
+  let
+    fun findArg ((id', args) :: tail) =
+      if id' = id then
+        SOME args
+      else
+        findArg tail
+      | findArg [] = NONE
   in
-    updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) %
+    case findArg bindedParams of
+        NONE => subst bindedParams tail (P :: acc)
+      | SOME arg =>
+          subst bindedParams tail (List.revAppend (arg, acc))
   end
+    | subst bindedParams (P :: tail) acc =
+        subst bindedParams tail (P :: acc)
+
+  and printBinded z =
+  let
+    fun printBinded (out, (mLayer, msg, params)) =
+    let
+      fun print [] = ()
+        | print ((p, args) :: tail) = (
+        Printf out `p `": ";
+        Printf out printTokenL (1, mLayer, args);
+        print tail
+      )
+    in
+      Printf out `"\n" `msg `" {\n";
+      print params;
+      Printf out `"}\n" %
+    end
+  in
+    bind A1 printBinded
+  end z
 
-  fun expandFuncMacro (_, _) (_, _) _ =
+  and expandFuncMacro (id, mPos) (params, body) ppc =
   let
+    val mLayers = addLayer (id, mPos)
+    fun addLayers2args body =
+    let
+      fun formLayers (tk, TkPos (pos, _)) = (tk, TkPos (pos, mLayers))
+    in
+      List.map formLayers body
+    end
+    fun apply f bp = List.map (fn (p, arg) => (p, f arg)) bp
+
+    val () = dprintf ppc printMacroHeader (id, mLayers) %
+    val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc
+
+    val bp1 = apply addLayers2args bindedParams
+    val () = dprintf ppc printBinded (mLayers, "args", bp1) %
+
+    val bp2 = apply (expandArgument ppc) bp1
+    val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) %
+
+    val body = addLayers (id, mPos) body
+    val body = subst bp2 body []
   in
-    raise Unimplemented
+    dprintf ppc printBody (mLayers, "subst", body);
+    insertRevBody (rev body) ppc
   end
 
-  fun handleRegularToken tk pos ppc =
+  and handleRegularToken tk pos ppc =
   let
     fun checkAndMark (true, _) = (NONE, NONE)
       | checkAndMark (false, macro) = (SOME (true, macro), SOME macro)
+
+    fun getMacro tree id = macrosLookup tree id (checkAndMark, NONE)
+
+    fun def () = (tk, pos, ppc)
+
+    fun handleMacro id =
+    let
+      val (macro, tree) = getMacro (#macros ppc) id
+      fun newPpc () = updatePpc ppc s#macros tree %
+    in
+      case macro of
+        NONE => def ()
+      | SOME (ObjMacro body) =>
+          getToken $ expandObjMacro (id, pos) body (newPpc ())
+      | SOME (FuncMacro (arg, body)) =>
+          getToken $ expandFuncMacro (id, pos) (arg, body) (newPpc ())
+    end
   in
     case tk of
-      T.Id id => (
-        case H.lookup2 (#macros ppc) id
-            checkAndMark (fn () => NONE)
-        of
-          NONE => (tk, pos, ppc)
-        | SOME (ObjMacro body) =>
-            getToken $ expandObjMacro (id, pos) body ppc
-        | SOME (FuncMacro (arg, body)) =>
-            getToken $ expandFuncMacro (id, pos) (arg, body) ppc
-    )
+      T.Id id => if (#restricted ppc) then def () else handleMacro id
     | T.MacroEnd id =>
     let
-      val () = H.lookup2 (#macros ppc) id
-             (fn (_, body) => (SOME (false, body), ()))
-             (fn () => raise Unreachable)
+      val f = fn (_, macro) => (SOME (false, macro), ())
+      val ((), tree) = macrosLookup (#macros ppc) id (f, ())
     in
-      getToken ppc
+      getToken $ updatePpc ppc s#macros tree %
     end
-    | _ => (tk, pos, ppc)
+    | _ => 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
+    fun checkMode () =
+      if (#restricted ppc) then
+        raiseTkError "directive in unexpected place" pos
+      else
+        ppc
   in
-    (T.EOS, TkPos (pos, []), updatePpc P s#streams [stream] %)
+    case List.find (fn (tk', _) => tk' = tk) directiveTable of
+      SOME (_, f) => getToken o f $ checkMode ()
+    | NONE => handleRegularToken tk pos ppc
   end
-    | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
+
+  and getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
       handleToken tk pos (updatePpc P s#buffer tail %)
-    | getToken (P as { streams = head :: tail, ... }: t) =
+    | getToken (P as { streams = [], ... }: t) = (T.EOS, dummyEOSpos, P)
+    | getToken (P as { streams = head :: tail, restricted, ... }: t) =
   let
     val (tk, pos, head) = T.getToken head
   in
     if tk = T.EOS then
-        case tail of
-          [] => getToken $ updatePpc P s#EOSreached true %
+        case (restricted, tail) of
+          (true, _) =>
+            (T.EOS, dummyEOSpos, updatePpc P u#streams (updateH head) %)
+        | (false, []) =>
+          let
+            val (pos, head) = T.S.EOFpos head
+          in
+            (T.EOS, pos2tkPos pos, updatePpc P s#streams [head] %)
+          end
         | _ => getToken $ updatePpc P s#streams tail %
     else
-        handleToken tk (TkPos (pos, [])) $
-                updatePpc P s#streams (head :: tail) %
+        handleToken tk (pos2tkPos pos) $
+            updatePpc P u#streams (updateH head) %
   end
-  | getToken _ = raise Unreachable
 
-  fun debugPrint' ppc =
+  fun debugPrint' cache ppc =
   let
     val (tk, pos, ppc) = getToken ppc
-
-    fun printTkPos (TkPos (pos, layers)) =
-    let
-      fun printLayer (macroName, pos) =
-        printf `macroName `" " A1 T.S.pos2str pos %
-
-      fun printLayers' [layer] = printLayer layer
-        | printLayers' (layer :: layers) = (
-        printLayer layer;
-        output ", ";
-        printLayers' layers
-      )
-        | printLayers' [] = raise Unreachable
-
-      fun printLayers [] = ()
-        | printLayers layers = (
-        output " (";
-        printLayers' layers;
-        output ")"
-      )
-    in
-      printf A1 T.S.pos2str pos %;
-      printLayers layers;
-      output ": "
-    end
+    val cache = printToken cache (output TextIO.stdOut) (tk, pos)
   in
-    printTkPos pos;
-    T.printToken tk;
-    printf `"\n" %;
     if tk = T.EOS then
       ()
     else
-      debugPrint' ppc
+      debugPrint' cache ppc
   end
 
   fun debugPrint fname incDirs =
   let
-    val ppc = create { fname, incDirs }
+    val ppc = create { fname, incDirs, debugMode = true }
   in
-    debugPrint' ppc;
-    output "\n"
+    debugPrint' startCache ppc;
+    printf `"\n" %
   end
 end