Conditional inclusion

1 files changed, 349 insertions, 227 deletions

diff --git a/ppc.fun b/ppc.fun
index fcd0676..58ca66f 100644
--- a/ppc.fun
+++ b/ppc.fun
@@ -3,22 +3,21 @@ struct
 
   structure T = T
 
-  type layers = (string * T.S.pos) list
-  datatype tkPos = TkPos of T.S.pos * layers
+  type mLayers = (string * T.S.pos) list
+  datatype tkPos = TkPos of T.S.pos * mLayers
 
-  type macroBody = (T.token * T.S.pos) list
+  type macroBody = (T.token * tkPos) list
   datatype macro =
     ObjMacro of macroBody |
     FuncMacro of string list * macroBody
 
-  type t = {
-    streams: T.S.t list,
+  datatype layer = Stream of T.S.t | Tokens of (T.token * tkPos) list
 
-    buffer: (T.token * tkPos) list,
+  type t = {
+    buffer: layer list,
 
     macros: (string, bool * macro) Tree.t,
 
-    restricted: bool,
     debugMode: bool,
     incDirs: string list
   }
@@ -45,8 +44,8 @@ struct
 
   val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0)
 
-  fun raiseTkError msg pos = raise TkError (pos, msg)
-  fun raiseTkErrorSPos pos msg = raiseTkError msg $ pos2tkPos pos
+  fun raiseTkError pos msg = raise TkError (pos, msg)
+  (* fun raiseTkErrorSPos pos = raiseTkError (pos2tkPos pos) *)
 
   fun printLayers ((macroName, pos) :: layers) = (
     printf `"\t" `macroName `" " T.S.Ppos pos %;
@@ -60,7 +59,6 @@ struct
   )
 
   fun raiseTkClassError pos cls = raise TkClassError (pos, cls)
-  fun raiseTkClassErrorSPos pos cls = raiseTkClassError (pos2tkPos pos) cls
 
   fun tkClassErrorPrint (TkPos (pos, layers), cls) =
   let
@@ -93,18 +91,17 @@ struct
 
   val updatePpc = fn z =>
     let
-      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
+      fun from buffer macros debugMode incDirs =
+        { buffer, macros, debugMode, incDirs }
+      fun to f { buffer, macros, debugMode, incDirs } =
+        f buffer macros debugMode incDirs
     in
-      FRU.makeUpdate6 (from, from, to)
+      FRU.makeUpdate4 (from, from, to)
     end z
 
   fun create { fname, incDirs, debugMode } =
-    { streams = [T.S.create fname], buffer = [], macros = Tree.empty,
-        restricted = false, debugMode, incDirs }
+    { buffer = [Stream $ T.S.create fname], macros = Tree.empty, debugMode,
+        incDirs }
 
   fun compareLayers cached macroLayers =
   let
@@ -172,30 +169,44 @@ struct
     (offset2, layers', (fname', line'))
   end
 
-  val printMacroHeader = fn z =>
+  val Players = fn z =>
   let
-    fun printMacroHeader (out, (id, mLayers)) =
+    fun Players (out, layers) =
     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
+      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
-      Printf out `"\n" `"(" A1 Players layers `"): macro " `id %
+      printLayers layers
     end
   in
+    bind A1 Players
+  end z
+
+  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
+
+  val printMacroHeader = fn z =>
+  let
+    fun printMacroHeader (out, (id, mLayers)) =
+      Printf out `"\n" `"(" Players (rev mLayers) `"): macro " `id %
+  in
     bind A1 printMacroHeader
   end z
 
@@ -220,69 +231,66 @@ struct
     bind A1 printTokenL
   end z
 
-  datatype IncludeArg =
-    LocalInc of string * T.S.pos |
-    ExternalInc of string * T.S.pos
+  fun updateH head = fn s => Stream head :: tl s
 
-  fun parseIncludeArg stream =
+  fun getTokenNoexpand (P as { buffer = Tokens tks :: _, ... }: t) = (
+    case tks of
+      (tk, pos) :: tail =>
+        (tk, pos, updatePpc P u#buffer (fn buf => Tokens tail :: tl buf) %)
+    | [] => getTokenNoexpand $ updatePpc P u#buffer tl %
+  )
+    | getTokenNoexpand (P as { buffer = Stream head :: _, ... }: t) =
   let
-    fun eat pred stream skipFirst acc =
-    let
-      val (c, stream') = T.S.getcharEx stream
-    in
-      if pred c then
-        eat pred stream' skipFirst (c :: acc)
-      else
-        (implode o rev $ acc, if skipFirst then stream' else stream)
-    end
-    val (_, stream) = eat Char.isSpace stream false []
-    val (pos, stream) = T.S.getPos stream
-    val (start, stream) = T.S.getcharEx stream
-    val finish =
-      if start = #"\"" then
-        #"\""
-      else if start = #"<" then
-        #">"
-      else
-        raiseTkErrorSPos pos "expected \" or <"
+    val (tk, pos, head) = T.getToken head
+  in
+    (tk, pos2tkPos pos, updatePpc P u#buffer (updateH head) %)
+  end
+    | getTokenNoexpand _ = raise Unreachable
+
+  fun checkClass (tk, pos) clList raiseClassErr =
+  let
+    fun belongsToClass tk (Ctk tk') = tk = tk'
+      | belongsToClass (T.Id _) (Cid) = true
+      | belongsToClass _ Cid = false
+      | belongsToClass _ _ = raise Unreachable
 
-    val (arg, stream) = eat (fn c => c <> finish) stream true []
-    val (_, stream) =
-      eat (fn c => c = #" " orelse c = #"\t") stream false []
-    val (c, stream) = T.S.getcharEx stream
+    fun checkClass' [] = raiseClassErr pos clList
+      | checkClass' (cl :: tail) =
+        if belongsToClass tk cl then
+          ()
+        else
+          checkClass' tail
   in
-    if c <> #"\n" then
-      let
-        val (pos, _) = T.S.getPosAfterChar stream
-      in
-        raiseTkErrorSPos pos "expected '\n'"
-      end
-    else
-      (if start = #"\"" then LocalInc (arg, pos)
-        else ExternalInc (arg, pos), stream)
-  end handle T.S.EOF =>
+    checkClass' clList
+  end
+
+  fun getClassGeneric clList getToken raiseClassErr buf =
   let
-    val (pos, _) = T.S.EOFpos stream
+    val (tk, pos, buf) = getToken buf
+    val () = checkClass (tk, pos) clList raiseClassErr
   in
-    raiseTkErrorSPos pos "unexpected EOF during #include argument parsing"
+    (tk, pos, buf)
   end
 
-  fun findFile arg (stream, incDirs) = 
+  fun getClassNoexpand (ppc: t) clList =
+    getClassGeneric clList getTokenNoexpand raiseTkClassError ppc
+
+  datatype IncludeArg = LocalInc of string * string | ExternalInc of string
+
+  fun findFile pos arg incDirs =
     case arg of
-      LocalInc (arg, pos) => (
+      LocalInc (dir, arg) => (
       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"
+        OS.Path.Path => raiseTkError pos "invalid argument"
+      | Size => raiseTkError pos "resulting path is too long"
       | IO.Io v => raise IO.Io v
     )
-    | ExternalInc (arg, pos) =>
+    | ExternalInc arg =>
     let
       fun try (dir :: tail) = (
         let
@@ -295,149 +303,157 @@ struct
     in
       case try incDirs of
         SOME pair => pair
-      | NONE => raiseTkErrorSPos pos "unable to find header"
+      | NONE => raiseTkError pos "unable to find header"
     end
 
-  fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) =
+  fun checkEndsWith pos arg c =
   let
-    val (arg, oldHead) = parseIncludeArg head
-    val (path, instream) = findFile arg (head, incDirs)
-    val head = T.S.createFromInstream path instream
+    fun find i =
+      if i = size arg then
+        raiseTkError 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"
+      else
+        find (i + 1)
   in
-    updatePpc P s#streams (head :: oldHead :: tail) %
+    find 1
   end
-    | handleInclude _ = raise Unreachable
 
-  fun getDefineMacroBody stream acc =
+  fun parseIncludeArg pos arg dir =
   let
-    val (tk, pos, stream) = T.getToken stream
-  in
-    case tk of
-      T.NewLine => (acc, stream)
-    | T.EOS => raiseTkClassErrorSPos pos [Ctk T.NewLine]
-    | _ => getDefineMacroBody stream ((tk, pos) :: acc)
-  end
+    fun eatSpaces s off =
+      if off = size s then
+        raiseTkError pos "invalid #include argument"
+      else if String.sub (s, off) = #" " then
+        eatSpaces s (off + 1)
+      else
+        String.extract (s, off, NONE)
 
-  fun isFuncMacroDefine nameLength (T.S.Pos (_, line1, col1)) stream =
-  let
-    val (tk, T.S.Pos (_, line2, col2), _) = T.getToken stream
+    val arg = eatSpaces arg 0
+    val start = String.sub (arg, 0)
+    val check = checkEndsWith pos arg
   in
-    tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2
+    if start = #"<" then
+      LocalInc (dir, check #">")
+    else if start = #"\"" then
+      ExternalInc $ check #"\""
+    else
+      raiseTkError pos "invalid #include argument"
   end
 
-  fun dBprintf debugMode =
-    if debugMode then
+  fun dprintf ppc =
+    if #debugMode ppc then
       printf
     else
-      printf Ign true
-  fun dprintf ppc = dBprintf (#debugMode ppc)
+      printf Ign
 
-  fun PrintMacroBody (out, body) =
+  fun handleInclude (T.PpcInclude (dir, arg), pos) ppc =
   let
-    val body = List.map (fn (tk, pos) => (tk, pos2tkPos pos)) body
+    val arg = parseIncludeArg pos arg dir
+    val (path, instream) = findFile pos arg (#incDirs ppc)
+    val () = dprintf ppc `"\n#include: " `path %
+    val stream = T.S.createFromInstream path instream
   in
-    Printf out `" {";
-    Printf out printTokenL (0, [], body);
-    Printf out `"}" %
+    updatePpc ppc u#buffer (fn buf => Stream stream :: buf) %
   end
+    | handleInclude _ _ = raise Unreachable
 
-  fun parseDefineObjMacro debugMode stream =
+  fun getDefineMacroBody ppc acc =
   let
-    val (body, stream) = getDefineMacroBody stream []
+    val (tk, pos, ppc) = getTokenNoexpand ppc
   in
-    dBprintf debugMode A1 PrintMacroBody body;
-    (ObjMacro body, stream)
+    case tk of
+      T.NewLine => (acc, ppc)
+    | T.EOS => raiseTkClassError pos [Ctk T.NewLine]
+    | _ => getDefineMacroBody ppc ((tk, pos) :: acc)
   end
 
-  fun checkClass (tk, pos) clList raiseClassErr =
+  fun isFuncMacroDefine len (TkPos (T.S.Pos (_, line1, col1), [])) ppc =
   let
-    fun belongsToClass tk (Ctk tk') = tk = tk'
-      | belongsToClass (T.Id _) (Cid) = true
-      | belongsToClass _ Cid = false
-      | belongsToClass _ _ = raise Unreachable
-
-    fun checkClass' [] = raiseClassErr pos clList
-      | checkClass' (cl :: tail) =
-        if belongsToClass tk cl then
-          ()
-        else
-          checkClass' tail
+    val (tk, TkPos (T.S.Pos (_, line2, col2), _), _) = getTokenNoexpand ppc
   in
-    checkClass' clList
+    tk = T.LParen andalso line1 = line2 andalso col1 + len = col2
   end
+    | isFuncMacroDefine _ _ _ = raise Unreachable
 
-  fun getClassGeneric clList getToken raiseClassErr buf =
+  fun PrintMacroBody (out, body) =
+    if body = [] then
+      ()
+    else (
+      Printf out `" {";
+      Printf out printTokenL (0, [], body);
+      Printf out `"}" %
+    )
+
+  fun parseDefineObjMacro ppc =
   let
-    val (tk, pos, buf) = getToken buf
-    val () = checkClass (tk, pos) clList raiseClassErr
+    val (body, ppc) = getDefineMacroBody ppc []
   in
-    (tk, pos, buf)
+    dprintf ppc A1 PrintMacroBody body;
+    (ObjMacro body, ppc)
   end
 
-  fun getClassFromStream stream clList =
-    getClassGeneric clList T.getToken raiseTkClassErrorSPos stream
-
   fun validateArgs args =
   let
     fun validateArg (id, _) [] = id
       | validateArg (id, pos) ((id', pos') :: tail) =
         if id = id' then
-          raiseTkErrorSPos pos' "macro argument name is already taken"
+          raiseTkError pos' "macro argument name is already taken"
         else
           validateArg (id, pos) tail
 
     fun validate [] = []
       | validate (arg :: args) = validateArg arg args :: validate args
-
   in
     validate args
   end
 
-  fun parseDefineMacroArgs stream =
+  fun parseDefineMacroArgs ppc =
   let
-    datatype arg =
-        Arg of string * T.S.pos |
-        LastArg of string * T.S.pos
+    datatype arg = Arg of string * tkPos | LastArg of string * tkPos
 
-    fun parseArg stream =
+    fun parseArg ppc =
     let
-      val (tkId, posId, stream) = getClassFromStream stream [Cid]
-      val (tk, _, stream) = getClassFromStream stream [Ctk T.RParen, Ctk T.Coma]
+      val (tkId, posId, ppc) = getClassNoexpand ppc [Cid]
+      val (tk, _, ppc) = getClassNoexpand ppc [Ctk T.RParen, Ctk T.Coma]
       val id = case tkId of T.Id id => id | _ => raise Unreachable
     in
       case tk of
-           T.RParen => (LastArg (id, posId), stream)
-         | T.Coma => (Arg (id, posId), stream)
+           T.RParen => (LastArg (id, posId), ppc)
+         | T.Coma => (Arg (id, posId), ppc)
          | _ => raise Unreachable
     end
 
-    fun parseArgs stream =
+    fun parseArgs ppc =
     let
-      val (tk, _, stream) = T.getToken stream
+      val (tk, _, ppc) = getTokenNoexpand ppc
 
-      fun parse stream acc =
-        case parseArg stream of
-             (LastArg p, stream) => (rev (p :: acc), stream)
-           | (Arg p, stream) => parse stream (p :: acc)
+      fun parse ppc acc =
+        case parseArg ppc of
+             (LastArg p, ppc) => (rev (p :: acc), ppc)
+           | (Arg p, ppc) => parse ppc (p :: acc)
     in
       if tk = T.RParen then
-        ([], stream)
+        ([], ppc)
       else
         let
-          val (args, stream) = parse stream []
+          val (args, ppc) = parse ppc []
           val args = validateArgs args
         in
-          (args, stream)
+          (args, ppc)
         end
     end
   in
-    parseArgs stream
+    parseArgs ppc
   end
 
-  fun parseDefineFuncMacro debugMode stream =
+  fun parseDefineFuncMacro ppc =
   let
-    val (params, stream) = parseDefineMacroArgs stream
-    val (body, stream) = getDefineMacroBody stream []
+    val (params, ppc) = parseDefineMacroArgs ppc
+    val (body, ppc) = getDefineMacroBody ppc []
 
     fun printParams out =
     let
@@ -450,58 +466,58 @@ struct
       Printf out `")" %
     end
   in
-    dBprintf debugMode A0 printParams;
-    dBprintf debugMode A1 PrintMacroBody body;
-    (FuncMacro (params, rev body), stream)
+    dprintf ppc A0 printParams;
+    dprintf ppc A1 PrintMacroBody body;
+    (FuncMacro (params, rev body), ppc)
   end
 
-  fun parseDefine stream debugMode =
+  fun parseDefine ppc =
   let
-    val (macroName, pos, stream) = getClassFromStream stream [Cid]
+    val (macroName, pos, ppc) = getClassNoexpand ppc [Cid]
     val macroName =
       case macroName of T.Id id => id | _ => raise Unreachable
 
-    val () = dBprintf debugMode `"\ndefine " `macroName %
+    val () = dprintf ppc `"\ndefine " `macroName %
 
     val parser =
-      if isFuncMacroDefine (size macroName) pos stream then
+      if isFuncMacroDefine (size macroName) pos ppc then
         parseDefineFuncMacro
       else
         parseDefineObjMacro
 
-    val (macro, stream) = parser debugMode stream
+    val (macro, ppc) = parser ppc
   in
-    ((macroName, pos), macro, stream)
+    ((macroName, pos), macro, ppc)
   end
 
-  fun updateH head = fn s => head :: tl s
-
-  fun handleDefine (P as { streams = head :: _, ... }: t) =
+  fun handleDefine _ ppc =
   let
-    val ((macroName, pos), macro, head) = parseDefine head (#debugMode P)
+    val ((macroName, pos), macro, ppc) = parseDefine ppc
 
-    val macros = insertMacro (#macros P) macroName (false, macro) handle
-        Tree.Exists => raiseTkErrorSPos pos "macro redefinition"
+    val macros = insertMacro (#macros ppc) macroName (false, macro)
+      handle Tree.Exists => raiseTkError pos "macro redefinition"
   in
-    updatePpc P u#streams (updateH head) s#macros macros %
+    updatePpc ppc s#macros macros %
   end
-    | handleDefine _ = raise Unreachable
-
-  val directiveTable = [
-      (T.PpcInclude, handleInclude),
-      (T.PpcDefine, handleDefine)
-  ]
 
   fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers
-  fun addLayers idPos body =
+
+  fun setLayers idPos body =
   let
-    fun formLayers (tk, pos) = (tk, TkPos (pos, addLayer idPos))
+    fun formLayers (tk, TkPos (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)) %
+  let
+    fun f (B as (Stream _ :: _)) = Tokens (rev body) :: B
+      | f (Tokens tks :: tail) =
+        Tokens (List.revAppend (body, tks)) :: tail
+      | f _ = raise Unreachable
+  in
+    updatePpc ppc u#buffer f %
+  end
 
   val printBody = fn z =>
   let
@@ -516,12 +532,10 @@ struct
 
   fun expandObjMacro (id, pos) body ppc =
   let
-    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 mend = (T.MacroEnd id, if body = [] then pos else (#2 o hd) body)
+    val revBody = setLayers (id, pos) $ List.concat [[mend], body]
 
     val mLayers = addLayer (id, pos)
-
   in
     dprintf ppc printMacroHeader (id, mLayers);
     dprintf ppc printBody (mLayers, "body", rev revBody);
@@ -533,12 +547,23 @@ struct
 
   and parseFuncMacroArgs mPos params ppc =
   let
+
+    fun getTokenRestricted ppc =
+    let
+      val (tk, pos, ppc) = getTokenNoexpand ppc
+    in
+      if T.isPpcDir tk then
+        raiseTkError pos "preprocessor directive inside macro arguments"
+      else
+        (tk, pos, ppc)
+    end
+
     fun parseArg ppc acc =
     let
-      val (tk, pos, ppc) = getToken ppc (* TODO: should be restricted *)
+      val (tk, pos, ppc) = getTokenRestricted ppc
     in
       case tk of
-        T.EOS => raiseTkError "unfinished argument list" mPos
+        T.EOS => raiseTkError mPos "unfinished argument list"
       | T.Coma => (true, rev acc, ppc)
       | T.RParen => (false, rev acc, ppc)
       | _ => parseArg ppc ((tk, pos) :: acc)
@@ -546,7 +571,7 @@ struct
 
     fun parseArgs ppc params acc =
     let
-      fun bind _ [] = raiseTkError "too many arguments" mPos
+      fun bind _ [] = raiseTkError mPos "too many arguments"
         | bind body (param :: params) = ((param, body), params)
 
       val (continue, arg, ppc) = parseArg ppc []
@@ -556,22 +581,21 @@ struct
         parseArgs ppc otherParams (bindedParam :: acc)
       else
         if length otherParams > 0 then
-          raiseTkError "not enough arguments" mPos
+          raiseTkError mPos "not enough arguments"
         else
           (rev (bindedParam :: acc), ppc)
     end
 
-    val ppc = updatePpc ppc s#restricted true %
-    val (_, _, ppc) = getClass ppc [Ctk T.LParen]
+    val (_, _, ppc) = getClassGeneric [Ctk T.LParen]
+            getTokenRestricted raiseTkClassError ppc
     val (res, ppc) = parseArgs ppc params []
-    val ppc = updatePpc ppc s#restricted false %
   in
     (res, ppc)
   end
 
   and expandArgument ppc arg =
   let
-    val ppc = updatePpc ppc s#streams [] s#buffer arg %
+    val ppc = updatePpc ppc s#buffer [Tokens arg] %
     fun getAll ppc acc =
     let
       val (tk, pos, ppc) = getToken ppc
@@ -641,20 +665,103 @@ struct
     val bp2 = apply (expandArgument ppc) bp1
     val () = dprintf ppc printBinded (mLayers, "expanded args", bp2) %
 
-    val body = addLayers (id, mPos) body
+    val body = setLayers (id, mPos) body
     val body = subst bp2 body []
   in
     dprintf ppc printBody (mLayers, "subst", body);
     insertRevBody (rev body) ppc
   end
 
+  and getIfRevBody ifPos cond (ppc: t) =
+  let
+    fun collect level f acc ppc =
+    let
+      val (tk, pos, ppc) = getTokenNoexpand ppc
+      fun def dx = collect (level + dx) f (f ((tk, pos), acc)) ppc
+    in
+      case tk of
+        T.PpcEndif =>
+          if level = 0 then
+            let
+              val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
+            in
+              (acc, ppc)
+            end
+          else
+            def (~1)
+      | T.EOS => raiseTkError ifPos "unfinished conditional directive"
+      | _ =>
+        if tk = T.PpcIf orelse tk = T.PpcIfdef
+          orelse tk = T.PpcIfndef
+        then
+          def 1
+        else
+          def 0
+    end
+
+    val skip = collect 0 (fn (_, _) => []) []
+    val collect = collect 0 (op ::) []
+  in
+    (if cond then collect else skip) ppc
+  end
+
+  and ifdefEval pos ifPos ppc =
+  let
+    fun isDefined id =
+      case Tree.lookup macroCompare (#macros ppc) id of
+           SOME _ => true
+         | _ => false
+
+    val (macro, _, ppc) = getClassNoexpand ppc [Cid]
+    val id = case macro of T.Id id => id | _ => raise Unreachable
+    val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
+
+    val defined = isDefined id
+    val (cond, form) =
+      if pos then
+        (defined, "ifdef")
+      else
+        (not defined, "ifndef")
+  in
+    dprintf ppc `"\n" PtkPos ifPos `": #" `form `" " `id `" -> " B cond %;
+    (cond, ppc)
+  end
+
+  and ifEval ifPos ppc =
+  let
+    fun skip ppc =
+    let
+      val (tk, _, ppc) = getTokenNoexpand ppc
+    in
+      case tk of
+        T.EOS => raiseTkError ifPos "unfinished #if condition"
+      | T.NewLine => ppc
+      | _ => skip ppc
+    end
+  in
+    (true, skip ppc)
+  end
+
+  and handleIf (tk, ifPos) ppc =
+  let
+    val dprintf = dprintf ppc `"\n"
+    val (cond, ppc) =
+      (case tk of
+        T.PpcIfdef => ifdefEval true
+      | T.PpcIfndef => ifdefEval false
+      | _ => ifEval) ifPos ppc
+
+    val (revBody, ppc) = getIfRevBody ifPos cond ppc
+  in
+    dprintf `"{" printTokenL (1, [], rev revBody) `"}\n";
+    insertRevBody revBody ppc
+  end
+
   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 =
@@ -671,7 +778,7 @@ struct
     end
   in
     case tk of
-      T.Id id => if (#restricted ppc) then def () else handleMacro id
+      T.Id id => handleMacro id
     | T.MacroEnd id =>
     let
       val f = fn (_, macro) => (SOME (false, macro), ())
@@ -682,40 +789,55 @@ struct
     | _ => def ()
   end
 
-  and handleToken tk pos ppc =
-  let
-    fun checkMode () =
-      if (#restricted ppc) then
-        raiseTkError "directive in unexpected place" pos
-      else
-        ppc
-  in
-    case List.find (fn (tk', _) => tk' = tk) directiveTable of
-      SOME (_, f) => getToken o f $ checkMode ()
+  and ppcFallback (_, pos) _ =
+    raiseTkError pos "directive is not implemented"
+
+  and handleToken tk pos (ppc: t) =
+  let
+    fun %tk = fn tk' => tk' = tk
+    val directiveTable = [
+        (fn T.PpcInclude _ => true | _ => false, handleInclude),
+        (%T.PpcDefine, handleDefine),
+        (%T.PpcIfdef, handleIf),
+        (%T.PpcIfndef, handleIf),
+        (%T.PpcUndef, ppcFallback),
+        (%T.PpcIf, handleIf),
+        (%T.PpcElse, ppcFallback),
+        (%T.PpcElif, ppcFallback),
+        (%T.PpcEndif, ppcFallback),
+        (%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
     | NONE => handleRegularToken tk pos ppc
   end
 
-  and getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
-      handleToken tk pos (updatePpc P s#buffer tail %)
-    | getToken (P as { streams = [], ... }: t) = (T.EOS, dummyEOSpos, P)
-    | getToken (P as { streams = head :: tail, restricted, ... }: t) =
+  and getToken (P as { buffer = Tokens tks :: _, ... }: t) = (
+    case tks of
+      (tk, pos) :: tail =>
+        handleToken tk pos
+            (updatePpc P u#buffer (fn b => Tokens tail :: tl b) %)
+    | [] => getToken $ updatePpc P u#buffer tl %
+  )
+    | getToken (P as { buffer = [], ... }: t) = (T.EOS, dummyEOSpos, P)
+    | getToken (P as { buffer = Stream head :: tail, ... }: t) =
   let
     val (tk, pos, head) = T.getToken head
   in
-    if tk = T.EOS then
-        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
+    case (tk, tail) of
+      (T.EOS, []) =>
+      let
+        val (pos, head) = T.S.EOFpos head
+      in
+        (T.EOS, pos2tkPos pos, updatePpc P s#buffer [Stream head] %)
+      end
+    | (T.EOS, tail) => getToken $ updatePpc P s#buffer tail %
+    | (_, _) =>
         handleToken tk (pos2tkPos pos) $
-            updatePpc P u#streams (updateH head) %
+            updatePpc P u#buffer (updateH head) %
   end
 
   fun debugPrint' cache ppc =