Function-like macros

13 files changed, 704 insertions, 272 deletions

diff --git a/ccross.mlb b/ccross.mlb
index db831ea..38c8146 100644
--- a/ccross.mlb
+++ b/ccross.mlb
@@ -8,6 +8,7 @@ in
 
     stream.sig stream.sml
     hashtable.sig hashtable.sml
+    tree.sig tree.sml
     tokenizer.sig tokenizer.fun
     ppc.sig ppc.fun
     exn_handler.sig exn_handler.fun
diff --git a/ccross.sml b/ccross.sml
index 1dab748..babe630 100644
--- a/ccross.sml
+++ b/ccross.sml
@@ -2,7 +2,7 @@ structure ccross:> CCROSS = struct
   structure T:> TOKENIZER =
     Tokenizer(structure H = Hashtable; structure S = Stream)
 
-  structure ppc:> PPC = ppc(structure H = Hashtable; structure T = T)
+  structure ppc:> PPC = ppc(structure Tree = Tree; structure T = T)
 
   structure D:> DRIVER = Driver(ppc)
 
diff --git a/common.sml b/common.sml
index c186377..d00b1a8 100644
--- a/common.sml
+++ b/common.sml
@@ -96,21 +96,53 @@ fun % (a, f) = f a
 val s = FRU.set
 val u = FRU.upd
 
-fun output s = TextIO.output (TextIO.stdOut, s)
+fun sysExit code = Posix.Process.exit $ Word8.fromInt code
+
+fun exit code = (
+  TextIO.closeOut TextIO.stdOut;
+  TextIO.closeOut TextIO.stdErr;
+  sysExit code
+)
+
+fun output stream s = TextIO.output (stream, s)
+
+fun fprint stream g = Fold.fold ((false, output stream), fn _ => ()) g
+fun printf g = fprint TextIO.stdOut g
+fun Printf output g = Fold.fold ((false, output), fn _ => ()) g
+
 local
-  fun printBuffer _ [] = ()
-    | printBuffer stream (s :: acc) =
-      (TextIO.output (stream, s); printBuffer stream acc)
+  fun ifF flag cl = if not flag then cl () else ()
 in
-  fun fprintf stream f = Fold.fold
-    ((stream, []), fn (stream, acc) => printBuffer stream (rev acc)) f
-  fun printf f = fprintf TextIO.stdOut f
+  fun ` z = Fold.step1 (fn (s, (ign, output)) =>
+    (ifF ign (fn () => output s); (ign, output))) z
+
+  fun A0 z = Fold.step1 (fn (f, (ign, output)) =>
+    (ifF ign (fn () => f output); (ign, output))) z
+  fun A1 z = Fold.step2 (fn (f, v, (ign, output)) =>
+    (ifF ign (fn () => f (output, v)); (ign, output))) z
+end
 
-  fun ` z = Fold.step1 (fn (str, (s, acc)) => (s, str :: acc)) z
-  fun A0 z = Fold.step1 (fn (f, (s, a)) => (s, f () :: a)) z
-  fun A1 z = Fold.step2 (fn (f, v, (s, a)) => (s, f v :: a)) z
-  fun bind A f = fn z => Fold.fold z A f
+fun Ign z = Fold.step1 (fn (_, (_, output)) => (true, output)) z
 
-  val C = fn z => bind A1 str z
-  val I = fn z => bind A1 Int.toString z
+fun bind A f = fn z => Fold.fold z A f
+fun bindWith2str to = bind A1 (fn (output, v) => output (to v))
+
+val I = fn z => bindWith2str Int.toString z
+val C = fn z => bindWith2str str z
+val B = fn z => bindWith2str (fn true => "true" | false => "false") z
+val R = fn z => bind A1 (fn (output, n) => app (fn f => f ())
+        (List.tabulate (n, fn _ => fn () => output "\t"))) z
+
+type ('t, 'a, 'b) a1printer = (bool * (string -> unit)) * 'a -> 't ->
+        ((bool * (string -> unit)) * 'a -> 'b) -> 'b
+
+fun die code g =
+let
+  fun finish (true, _) = raise Unreachable
+    | finish (false, output) = (
+        output "\n";
+        exit code
+    )
+in
+  printf `"error: " (fn (a, _) => g (a, finish))
 end
diff --git a/driver.fun b/driver.fun
index df50b1e..5336987 100644
--- a/driver.fun
+++ b/driver.fun
@@ -1,38 +1,58 @@
 functor Driver(P: PPC): DRIVER = struct
   structure P = P
 
+  datatype execMode = Normal | DebugE | DebugT
+
   type config = {
     file: string option,
-    includeDirs: string list
+    includeDirs: string list,
+    mode: execMode
   }
 
-  val initConfig: config = { file = NONE, includeDirs = [] }
+  val updateC = fn z =>
+  let
+    fun from file includeDirs mode = { file, includeDirs, mode }
+    fun to f { file, includeDirs, mode } = f file includeDirs mode
+  in
+    FRU.makeUpdate3 (from, from, to)
+  end z
+
+  val initConfig: config = { file = NONE, includeDirs = [], mode = Normal }
+
+  val die = fn z => die 1 z
+
+  fun finish ({ file = NONE, ... }: config) = die `"missing input file" %
+    | finish conf = updateC conf u#includeDirs rev %
 
-  fun die msg = (printf `msg `"\n"; Posix.Process.exit $ Word8.fromInt 1)
+  fun parseFlag conf "-dE" tail =
+    parseCmdArgs (updateC conf s#mode DebugE %) tail
+    | parseFlag conf "-dT" tail =
+        parseCmdArgs (updateC conf s#mode DebugT %) tail
+    | parseFlag _ arg _ = die `arg `": unknown flag" %
 
-  fun parseCmdArgs { file, includeDirs } [] =
-    if file = NONE then
-      die "missing input file"
-    else
-      { file, includeDirs = rev includeDirs }
+  and parseCmdArgs conf [] = finish conf
     | parseCmdArgs _ ("-I" :: []) =
-        die "-I: expected directory path after flag"
-    | parseCmdArgs { file, includeDirs } ("-I" :: path :: tail) =
-        parseCmdArgs { file, includeDirs = path :: includeDirs } tail
-    | parseCmdArgs { file, includeDirs } (arg :: tail) =
+        die `"-I: expected directory path after flag" %
+    | parseCmdArgs conf ("-I" :: path :: tail) =
+        parseCmdArgs (updateC conf u#includeDirs
+            (fn dirs => path :: dirs) %) tail
+    | parseCmdArgs (C as { file, ... }) (arg :: tail) =
       if String.sub (arg, 0) = #"-" then
-        die $ arg ^ ": unknown flag"
+        parseFlag C arg tail
       else
         case file of
-          NONE => parseCmdArgs { file = SOME arg, includeDirs } tail
-        | SOME _ => die $ arg ^ ": file already specified"
+          NONE => parseCmdArgs (updateC C s#file (SOME arg) %) tail
+        | SOME _ => die `arg `": file already specified" %
 
   fun exec () =
   let
     val config = parseCmdArgs initConfig (CommandLine.arguments ())
-    val fname = valOf $ #file config
+    val file = valOf $ #file config
   in
-    P.debugPrint fname (#includeDirs config)
+    case (#mode config) of
+      Normal => die `"Normal mode is not implemented yet" %
+    | DebugT => P.T.debugPrint file
+    | DebugE => P.debugPrint file (#includeDirs config)
   end
 end
 
diff --git a/exn_handler.fun b/exn_handler.fun
index 078225f..b4e7275 100644
--- a/exn_handler.fun
+++ b/exn_handler.fun
@@ -2,44 +2,42 @@ functor ExnHandler(structure T: TOKENIZER; structure P: PPC):
     EXN_HANDLER =
 struct
 
-  fun eprint s = printf `"error: " `s %
+  val eprintf = fn z => printf `"error: " z
 
   fun otherExn e =
   let
     val hist = MLton.Exn.history e
   in
-    eprint $ "exception " ^ exnMessage e ^ " was raised\n";
+    eprintf `"exception " `(exnMessage e) `" was raised\n";
     if hist = [] then
-      (output "No stack trace is avaliable\n";
-      output "Recompile with -const \"Exn.keepHistory true\"\n")
+      printf
+        `"No stack trace is avaliable\n"
+        `"Recompile with -const \"Exn.keepHistory true\"\n" %
     else
       List.app (fn x => printf `"\t" `x `"\n" %) hist
   end
 
-  fun exit code = Posix.Process.exit $ Word8.fromInt code
-
   fun ioExn (IO.Io { name, function = _, cause }) =
   let
-    val prefix = name ^ ": "
     val reason =
       case cause of
         OS.SysErr (str, _) => str
       | _ => exnMessage cause
   in
-    printf `prefix `reason `"\n" %
+    eprintf `name `": " `reason `"\n" %
   end
-    | ioExn _ = (output "ioExn: unreachable\n"; exit 254)
+    | ioExn _ = die 126 `"ioExn: unreachable\n" %
 
   fun handler e = (
-    printf `"\n" %;
+    printf `"\n";
     case e of
       T.FsmTableIsTooSmall =>
-          eprint "fsm table is too small. Increate 'maxState' value"
+          eprintf `"fsm table is too small. Increate 'maxState' value\n" %
     | IO.Io _ => ioExn e
-    | T.TkErrorAug (pos, msg) => eprint $ T.S.pos2str pos ^ ": " ^ msg
+    | T.TkErrorAug (pos, msg) => eprintf T.S.Ppos pos `": " `msg `"\n" %
     | P.TkError v => P.tkErrorPrint v
     | P.TkClassError v => P.tkClassErrorPrint v
     | _ => otherExn e;
-    exit 255
-  )
+    exit 1
+  ) handle _ => sysExit 127
 end
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
diff --git a/ppc.sig b/ppc.sig
index d32061b..32f9256 100644
--- a/ppc.sig
+++ b/ppc.sig
@@ -19,7 +19,7 @@ signature PPC = sig
     Cbinop |
     Cop
 
-  val create: { fname: string, incDirs: string list } -> t
+  val create: { fname: string, incDirs: string list, debugMode: bool } -> t
   val debugPrint: string -> string list -> unit
 
 
diff --git a/stream.sig b/stream.sig
index 7925285..8c94adc 100644
--- a/stream.sig
+++ b/stream.sig
@@ -8,7 +8,7 @@ signature STREAM = sig
 
   exception EOF
 
-  val pos2str: pos -> string
+  val Ppos: (pos, 'a, 'b) a1printer
 
   val getchar: t -> char option * t
   val getcharEx: t -> char * t (* throws EOF *)
diff --git a/stream.sml b/stream.sml
index ff4a6ad..fd5932a 100644
--- a/stream.sml
+++ b/stream.sml
@@ -28,12 +28,13 @@ structure Stream :> STREAM = struct
     end
     z
 
-  fun pos2str (Pos (pos, line, col)) =
+  val Ppos = fn z =>
   let
-    val % = Int.toString
+    fun p (out, Pos (fname, line, col)) =
+        Printf out `fname `":" I line `":" I col %
   in
-    pos ^ ":" ^ %line ^ ":" ^ %col
-  end
+    bind A1 p
+  end z
 
   fun getcharSure (S as { contents, off, ... }: t) =
       (String.sub (contents, off), updateStream S s#off (off + 1) %)
diff --git a/tokenizer.fun b/tokenizer.fun
index 12b3257..9d7f8fc 100644
--- a/tokenizer.fun
+++ b/tokenizer.fun
@@ -114,25 +114,25 @@ struct
 
     CommentStart |
 
-    CppInclude |
-    CppDefine |
-    CppUndef |
-    CppIf |
-    CppIfdef |
-    CppIfndef |
-    CppElse |
-    CppElif |
-    CppEndif |
-    CppWarning |
-    CppError |
-    CppPragma
+    PpcInclude |
+    PpcDefine |
+    PpcUndef |
+    PpcIf |
+    PpcIfdef |
+    PpcIfndef |
+    PpcElse |
+    PpcElif |
+    PpcEndif |
+    PpcWarning |
+    PpcError |
+    PpcPragma
 
   datatype tkErrorAuxInfo = TkiEOF | TkiDx of int | TkiStart
 
   exception TkError of tkErrorAuxInfo * string
   exception TkErrorAug of S.pos * string
 
-  exception ExpectedCppDir (* handled in postprocess *)
+  exception ExpectedPpcDir (* handled in postprocess *)
 
   exception FsmTableIsTooSmall
 
@@ -141,17 +141,19 @@ struct
   exception SuffixWithoutRepr
 
   val kwPrefix  = #"`"
-  val cppPrefix = #"$"
+  val ppcPrefix = #"$"
   val otherPrefix = #"@"
 
   val tokenRepr =
   let
     fun & repr = str kwPrefix ^ repr
-    fun % repr = str cppPrefix ^ repr
+    fun % repr = str ppcPrefix ^ repr
+    fun ` repr = str otherPrefix ^ repr
   in
     [
-      (NewLine, "@NewLine"),
-      (EOS, "@EOS"),
+      (NewLine, `"NewLine"),
+      (EOS, `"EOS"),
+      (Invalid, `"Invalid"),
 
       (kwBreak, &"break"),
       (kwCase, &"case"),
@@ -242,18 +244,18 @@ struct
 
       (CommentStart, "/*"),
 
-      (CppInclude, %"include"),
-      (CppDefine, %"define"),
-      (CppUndef, %"undef"),
-      (CppIf, %"if"),
-      (CppIfdef, %"ifdef"),
-      (CppIfndef, %"ifndef"),
-      (CppElse, %"else"),
-      (CppElif, %"elif"),
-      (CppEndif, %"endif"),
-      (CppWarning, %"warning"),
-      (CppError, %"error"),
-      (CppPragma, %"pragma")
+      (PpcInclude, %"include"),
+      (PpcDefine, %"define"),
+      (PpcUndef, %"undef"),
+      (PpcIf, %"if"),
+      (PpcIfdef, %"ifdef"),
+      (PpcIfndef, %"ifndef"),
+      (PpcElse, %"else"),
+      (PpcElif, %"elif"),
+      (PpcEndif, %"endif"),
+      (PpcWarning, %"warning"),
+      (PpcError, %"error"),
+      (PpcPragma, %"pragma")
   ]
   end
 
@@ -280,10 +282,11 @@ struct
   fun getSfxReprSimple sfx buf =
     getSfxRepr sfx buf (fn () => raise SuffixWithoutRepr)
 
-  val token2str = fn
-      Id s => s
-    | MacroStart macro => "m(" ^ macro ^ ")"
-    | MacroEnd macro => "mend(" ^ macro ^ ")"
+  fun printToken (out, tk) =
+    case tk of
+      Id s => Printf out `s %
+    | MacroStart macro => Printf out `"m(" `macro `")" %
+    | MacroEnd macro => Printf out `"mend(" `macro `")" %
     | Num (IntConst (it, str, sfx)) =>
       let
         val intType =
@@ -292,19 +295,25 @@ struct
           | ItOct => "0"
           | ItHex => "0x"
       in
-        intType ^ str ^ getSfxReprSimple sfx intSuffixRepr
+        Printf out `intType `str  `(getSfxReprSimple sfx intSuffixRepr) %
       end
     | Num (FloatConst (str, sfx)) =>
-        str ^ getSfxReprSimple sfx floatSuffixRepr
-    | CharConst (repr, _) => repr
-    | StringConst s =>
-        "\"" ^ s ^ "\""
+        Printf out `str `(getSfxReprSimple sfx floatSuffixRepr) %
+    | CharConst (repr, _) => Printf out `repr %
+    | StringConst s => Printf out `"\"" `s `"\"" %
     | v =>
       case List.find (fn (x, _) => x = v) tokenRepr of
-      SOME (_, repr) => repr
+      SOME (_, repr) =>
+      let
+        val head = String.sub (repr, 0)
+        val head = if head = ppcPrefix then #"#" else head
+        val tail = String.extract (repr, 1, NONE)
+      in
+        Printf out C head `tail %
+      end
       | NONE => raise TokenWithoutRepr
 
-  fun printToken tk = printf A1 token2str tk %
+  val Ptoken = fn z => bind A1 printToken z
 
   fun isIdStart c = Char.isAlpha c orelse c = #"_"
   fun isIdBody c = Char.isAlphaNum c orelse c = #"_"
@@ -356,7 +365,7 @@ struct
                 let
                   val c = String.sub (repr, 0)
                 in
-                  c <> kwPrefix andalso c <> cppPrefix
+                  c <> kwPrefix andalso c <> ppcPrefix
                     andalso c <> otherPrefix
                 end)
               tokenRepr
@@ -401,12 +410,12 @@ struct
     T
   end
 
-  (* Unused right now
   fun printTable (nextState, buf) =
   let
+    open Array
     fun printRow i row =
       if i = length row then
-        output "\n"
+        printf `"\n" %
       else
         let
           val state = sub (row, i)
@@ -414,7 +423,7 @@ struct
           if state = ~1 then
             ()
           else
-            printf C (chr i) `": " I state `", " %;
+            printf C (chr i) `" -> " I state `", " %;
             printRow (i + 1) row
         end
 
@@ -425,16 +434,16 @@ struct
         let
           val (tk, row) = sub (buf, rowNum)
         in
-          printf A1 token2string tk `": " %;
+          printf `"row " I rowNum `" - " Ptoken tk `": \t" %;
           printRow 0 row;
           print' (rowNum + 1) buf
         end
   in
+    printf `"FSM table:\n";
     printf `"NextState: " I (!nextState) `"\n" %;
     print' 0 buf;
-    output "\n"
+    printf `"\n" %
   end
-  *)
 
   val fsmTable = lazy fsmTableCreate
 
@@ -852,26 +861,26 @@ struct
   val charParser = seqParser SpmChr
   val strParser = seqParser SpmStr
 
-  fun formCppDir (Id s) =
+  fun formPpcDir (Id s) =
   let
     open String
   in
     case List.find
       (fn (_, repr) =>
-          sub (repr, 0) = cppPrefix andalso
+          sub (repr, 0) = ppcPrefix andalso
               extract (repr, 1, NONE) = s)
       tokenRepr
     of
       SOME (tk, _) => tk
-    | NONE => raise ExpectedCppDir
+    | NONE => raise ExpectedPpcDir
   end
-    | formCppDir kwElse = CppElse
-    | formCppDir kwIf = CppIf
-    | formCppDir _ = raise ExpectedCppDir
+    | formPpcDir kwElse = PpcElse
+    | formPpcDir kwIf = PpcIf
+    | formPpcDir _ = raise ExpectedPpcDir
 
-  fun handleCppDir (pos, tk) =
-    formCppDir tk handle
-        ExpectedCppDir =>
+  fun handlePpcDir (pos, tk) =
+    formPpcDir tk handle
+        ExpectedPpcDir =>
            raise TkErrorAug (pos, "expected preprocessor directive")
 
   fun unexpectedCharRaise stream c =
@@ -940,7 +949,7 @@ struct
             if tk = EOS then
               raise TkErrorAug (pos, "unfinished preprecessor directive")
             else
-              (handleCppDir (pos', tk), pos, stream)
+              (handlePpcDir (pos', tk), pos, stream)
           end
         else
           (tk, pos, stream)
@@ -977,23 +986,28 @@ struct
         unexpectedCharRaise stream c
   end
 
-  (* TODO: remove *)
-  fun debugPrint tkl fname =
+  fun debugPrint fname =
   let
-    fun print' line _ ((NewLine, _) :: tks) =
-      print' (line + 1) true tks
-      | print' line firstOnLine ((tk, _) :: tks) = (
-        if firstOnLine then
-          printf `"\n" `fname `":" I line `"\t" %
-        else
-          ();
-        printToken tk;
-        output " ";
-        print' line false tks
-      )
-      | print' _ _ [] = ()
+    val stream = S.create fname
+
+    fun print line stream =
+    let
+      val (tk, S.Pos (_, line', col'), stream) = getToken stream
+    in
+      if line <> line' then
+        printf `"\nline " I line' `": \t" %
+      else
+        ();
+      printf I col' `":" Ptoken tk `" ";
+      if tk = EOS then
+        ()
+      else
+        print line' stream
+    end
   in
-    print' 1 true tkl;
-    output "\n"
+    printTable $ fsmTable ();
+    printf `"Tokenizing file: " `fname;
+    print 0 stream;
+    printf `"\n" %
   end
 end
diff --git a/tokenizer.sig b/tokenizer.sig
index f79e62a..53a9f17 100644
--- a/tokenizer.sig
+++ b/tokenizer.sig
@@ -111,27 +111,25 @@ signature TOKENIZER = sig
 
     CommentStart |
 
-    CppInclude |
-    CppDefine |
-    CppUndef |
-    CppIf |
-    CppIfdef |
-    CppIfndef |
-    CppElse |
-    CppElif |
-    CppEndif |
-    CppWarning |
-    CppError |
-    CppPragma
+    PpcInclude |
+    PpcDefine |
+    PpcUndef |
+    PpcIf |
+    PpcIfdef |
+    PpcIfndef |
+    PpcElse |
+    PpcElif |
+    PpcEndif |
+    PpcWarning |
+    PpcError |
+    PpcPragma
 
   (* Fatal. both may be thrown by tokenize *)
   exception FsmTableIsTooSmall
   exception TkErrorAug of S.pos * string
 
   val getToken: S.t -> token * S.pos * S.t
+  val Ptoken: (token, 'a, 'b) a1printer
 
-  val token2str: token -> string
-  val printToken: token -> unit
-
-  val debugPrint: (token * S.pos) list -> string -> unit
+  val debugPrint: string -> unit
 end
diff --git a/tree.sig b/tree.sig
new file mode 100644
index 0000000..afab259
--- /dev/null
+++ b/tree.sig
@@ -0,0 +1,13 @@
+signature TREE = sig
+  type ('k, 'v) t
+  exception Exists
+
+  val empty: ('k, 'v) t
+
+  val insert: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v -> ('k, 'v) t
+  val lookup: ('k -> 'k -> order) -> ('k, 'v) t -> 'k -> 'v option
+  val lookup2: ('k -> 'k -> order) -> ('k, 'v) t -> 'k ->
+        ('v -> 'v option * 'a) * 'a -> 'a * ('k, 'v) t
+
+  val print: ('k, 'v) t -> ('k -> string) -> ('v -> string) -> unit
+end
diff --git a/tree.sml b/tree.sml
new file mode 100644
index 0000000..597e469
--- /dev/null
+++ b/tree.sml
@@ -0,0 +1,75 @@
+structure Tree: TREE = struct
+  datatype ('k, 'v) t = Node of 'k * 'v * ('k, 'v) t * ('k, 'v) t | Empty
+
+  exception Exists
+
+  val empty = Empty
+
+  fun insert _ Empty k v = Node (k, v, Empty, Empty)
+    | insert cmp (Node (k', v', left, right)) k v =
+        case cmp k k' of
+          LESS => Node (k', v', insert cmp left k v, right)
+        | EQUAL => raise Exists
+        | GREATER => Node (k', v', left, insert cmp right k v)
+
+  fun lookup _ Empty _ = NONE
+    | lookup cmp (Node (k', v', left, right)) k =
+        case cmp k k' of
+          LESS => lookup cmp left k
+        | EQUAL => SOME v'
+        | GREATER => lookup cmp right k
+
+  datatype ('k, 'v) arc =
+    Left of 'k * 'v * ('k, 'v) t |
+    Right of 'k * 'v * ('k, 'v) t
+
+  fun assemble n buf =
+  let
+    fun assemble' tree (Left (k, v, right) :: tail) =
+      assemble' (Node (k, v, tree, right)) tail
+      | assemble' tree (Right (k, v, left) :: tail) =
+      assemble' (Node (k, v, left, tree)) tail
+      | assemble' tree [] = tree
+  in
+    assemble' n buf
+  end
+
+  fun lookup' _ _ Empty _ _ g = (g, NONE)
+    | lookup' buf cmp (Node (k', v', left, right)) k f g =
+        case cmp k k' of
+          LESS => lookup' (Left (k', v', right) :: buf) cmp left k f g
+        | GREATER => lookup' (Right (k', v', left) :: buf) cmp right k f g
+        | EQUAL =>
+        let
+          val (newV, result) = f v'
+        in
+          case newV of
+               NONE => (result, NONE)
+             | SOME v => (result, SOME (assemble (Node (k', v, left, right)) buf))
+        end
+
+  fun lookup2 cmp t k (f, g) =
+  let
+    val (result, newTree) = lookup' [] cmp t k f g
+  in
+    (result, case newTree of
+         NONE => t
+       | SOME t => t)
+  end
+
+  fun print t key2str value2str =
+  let
+    fun Pkey z = bindWith2str key2str z
+    fun Pvalue z = bindWith2str value2str z
+
+    fun print' off Empty = printf R off `"()\n" %
+      | print' off (Node (k, v, left, right)) = (
+        printf R off `"(" Pkey k `", " Pvalue v `"\n";
+        print' (off + 1) left;
+        print' (off + 1) right;
+        printf R off `")\n" %
+      )
+  in
+    print' 0 t
+  end
+end