path: root/ppc.fun

functor ppc(structure Tree: TREE; structure T: TOKENIZER): PPC =
struct

  structure T = T

  type mLayers = (string * T.S.pos) list
  datatype tkPos = TkPos of T.S.pos * mLayers

  type macroBody = (T.token * tkPos) list
  datatype macro =
    ObjMacro of macroBody |
    FuncMacro of string list * macroBody

  datatype layer = Stream of T.S.t | Tokens of (T.token * tkPos) list

  type t = {
    buffer: layer list,

    macros: (string, bool * T.S.pos * macro) Tree.t,
    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

  datatype tkClass =
    Ctk of T.token |
    Cid |
    Cconst |
    Cunop |
    Cbinop |
    Cop

  fun pos2tkPos pos = TkPos (pos, [])
  fun tkPos2pos (TkPos (pos, [])) =  pos
    | tkPos2pos _ = raise Unreachable

  val dummyEOSpos = pos2tkPos $ T.S.Pos ("<Unreachable>", 0, 0)

  val PlayersU = fn z =>
  let
    fun PlayersU (out, ((macroName, pos) :: layers)) =
      Printf out F `"\tfrom " `macroName `" at " T.S.Ppos pos `"\n"
        A1 PlayersU layers %
      | PlayersU (_, []) = ()
  in
    bind A1 PlayersU
  end z

  fun warningLow (TkPos (pos, layers)) msg f g =
    printf F T.S.Ppos pos `":" `msg `": "
      (fn (a, _) => g (a, fn (_, out) =>
        (Printf out `"\n" PlayersU layers %; f ())))

  fun warning pos g = warningLow pos "warning" (fn () => ()) g
  fun error pos g = warningLow pos "error" (fn () => exit 1) g

  fun errorSpos pos g = error (pos2tkPos pos) g

  fun clerror (TkPos (pos, layers)) cls =
  let
    fun Pcl (out, cl) =
      case cl of
        Ctk tk => Printf out T.Ptk tk %
      | Cid => Printf out `"identifier" %
      | Cconst => Printf out `"constant" %
      | Cunop => Printf out `"unary operator" %
      | Cbinop => Printf out `"binary operator" %
      | Cop => Printf out `"operator" %

    fun Pcls (_, []) = raise Unreachable
      | Pcls (out, [cl]) = Printf out A1 Pcl cl %
      | Pcls (out, [cl1, cl2]) =
          Printf out A1 Pcl cl1 `" or " A1 Pcl cl2 %
      | Pcls (out, cl :: cls) =
        Printf out A1 Pcl cl `", " A1 Pcls cls %
  in
    printf F T.S.Ppos pos `":error: expected " A1 Pcls cls `"\n"
        PlayersU layers;
    exit 1
  end

  val updatePpc = fn z =>
    let
      fun from buffer macros debugMode incDirs =
        { buffer, macros, debugMode, incDirs }
      fun to f { buffer, macros, debugMode, incDirs } =
        f buffer macros debugMode incDirs
    in
      FRU.makeUpdate4 (from, from, to)
    end z

  fun create { fname, incDirs, debugMode } =
    { buffer = [Stream $ T.S.create fname], macros = Tree.empty, debugMode,
        incDirs }

  fun printLayer out (macro, pos) = Printf out `macro `" " T.S.Ppos pos %

  fun printLayers _ [] = ()
    | printLayers out [layer] = printLayer out layer
    | printLayers out (layer :: layers) = (
      printLayer out layer;
      Printf out `", ";
      printLayers out layers
    )

  fun convPos (T.S.Pos (fname, line, col)) plen =
  let
    val fname = String.extract (fname, plen, NONE)
  in
    T.S.Pos ("@" ^ fname, line, col)
  end

  fun findPrefix s1 s2 =
  let
    fun findPrefix' i s1 s2 =
      if i = size s1 orelse i = size s2 then
        String.substring (s1, 0, i)
      else if String.sub (s1, i) = String.sub (s2, i) then
        findPrefix' (i + 1) s1 s2
      else
        String.substring (s1, 0, i)
  in
    findPrefix' 0 s1 s2
  end

  fun PlayersCompact (_, _, []) = ""
    | PlayersCompact (out, startPrx, L as (layer :: layers)) =
  let
    fun getFname (_, T.S.Pos (fname, _, _)) = fname

    fun findCommonPrefix prefix [] = prefix
      | findCommonPrefix prefix (layer :: layers) =
        findCommonPrefix (findPrefix prefix $ getFname layer) layers

    val (startPrx, layers) =
      case startPrx of
        SOME prx => (prx, L)
      | NONE => (getFname layer, layers)
    val prefix = findCommonPrefix startPrx layers
    val plen = size prefix
  in
    Printf out `prefix `" | " %;
    printLayers out $ map (fn (m, pos) => (m, convPos pos plen)) L;
    prefix
  end

  val startCache = (0, [], ("", 0))

  fun printTokenCompact (off, layers, (fname, line)) out (tk, pos) =
  let
    val TkPos (T.S.Pos (fname', line', col'), layers') = pos

    fun Ppos out =
      case layers' of
        [] => Printf out `fname' `":" I line' `"| \t" %
      | _ =>
        let
          val prefix = PlayersCompact (out, SOME fname', layers')
          val fname' = String.extract (fname', size prefix, NONE)
        in
          Printf out `"; @" `fname' `":" I line' `"| \t" %
        end
  in
    if layers <> layers' orelse fname' <> fname orelse line' <> line then
      Printf out F R off A0 Ppos %
    else
      ();
    Printf out I col' `":" T.Ptk tk `" ";
    (off, layers', (fname', line'))
  end

  val PmacroHeader = fn z =>
  let
    fun printMacroHeader (out, id, mLayers) =
    let
      fun Players (out, x, y) = ignore $ PlayersCompact (out, x, y)
    in
      Printf out F `"expanding (" A2 Players NONE (rev mLayers)
        `") macro " `id %
    end
  in
    bind A2 printMacroHeader
  end z

  val PtokenL = fn z =>
  let
    fun printTokenL (out, offset, l) =
    let
      fun printList _ [] = ()
        | printList cache (tk :: tail) =
          printList (printTokenCompact cache out tk) tail

      fun getLast5 (l as _ :: _ :: _ :: _ :: _ :: []) = l
        | getLast5 (_ :: xs) = getLast5 xs
        | getLast5 _ = raise Unreachable

      val cache = (offset, [], ("", 0))
    in
      if length l <= 10 then
        printList cache l
      else
        let
          val first5 = List.take (l, 5)
          val last5 = getLast5 l
        in
          printList cache first5;
          Printf out `"\n\t...";
          printList cache last5
        end;
      Printf out `"\n" %
    end
  in
    bind A2 printTokenL
  end z

  fun updateH head = fn s => Stream head :: tl s

  fun handleMacroEnd id ppc =
  let
    val f = fn (_, pos, macro) => (SOME (false, pos, macro), ())
    val ((), tree) = macrosLookup (#macros ppc) id (f, ())
  in
    updatePpc ppc s#macros tree %
  end

  fun getTokenNoexpand (P as { buffer = Tokens tks :: _, ... }: t) = (
    case tks of
      (T.MacroEnd id, _) :: tail =>
      let
        val ppc = handleMacroEnd id P
        val ppc = updatePpc ppc u#buffer (fn buf => Tokens tail :: tl buf) %
      in
        getTokenNoexpand ppc
      end
    | (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
    val (tk, pos, head) = T.getToken head
  in
    (tk, pos2tkPos pos, updatePpc P u#buffer (updateH head) %)
  end
    | getTokenNoexpand ppc = (T.EOS, dummyEOSpos, ppc)

  fun checkClass (tk, pos) clList =
  let
    fun belongsToClass tk (Ctk tk') = tk = tk'
      | belongsToClass (T.Id _) (Cid) = true
      | belongsToClass _ Cid = false
      | belongsToClass _ _ = raise Unreachable

    fun checkClass' [] = clerror pos clList
      | checkClass' (cl :: tail) =
        if belongsToClass tk cl then
          ()
        else
          checkClass' tail
  in
    checkClass' clList
  end

  fun getClassGeneric clList getToken ppc =
  let
    val (tk, pos, ppc) = getToken ppc
    val () = checkClass (tk, pos) clList
  in
    (tk, pos, ppc)
  end

  fun getClassNoexpand ppc clList =
    getClassGeneric clList getTokenNoexpand ppc

  datatype IncludeArg = LocalInc of string * string | ExternalInc of string

  fun findFile pos arg incDirs =
    case arg of
      LocalInc (dir, arg) => (
      let
        val path = OS.Path.concat (dir, arg)
        val (path, instream) = (path, TextIO.openIn path)
      in
        (path, instream)
      end handle
        OS.Path.Path => errorSpos pos `"invalid argument" %
      | Size => errorSpos pos `"resulting path is too long" %
      | IO.Io v => raise IO.Io v
    )
    | ExternalInc arg =>
    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 => errorSpos pos `"unable to find header" %
    end

  fun checkEndsWith pos arg c =
  let
    fun find i =
      if i = size arg then
        errorSpos pos `"unfinished #include argument" %
      else if String.sub (arg, i) = c then
        if i + 1 = size arg then
          String.extract (arg, 1, SOME $ size arg - 2)
        else
          errorSpos pos `"some garbage after #include argument" %
      else
        find (i + 1)
  in
    find 1
  end

  fun parseIncludeArg pos arg dir =
  let
    fun eatSpaces s off =
      if off = size s then
        errorSpos pos `"invalid #include argument" %
      else if String.sub (s, off) = #" " then
        eatSpaces s (off + 1)
      else
        String.extract (s, off, NONE)

    val arg = eatSpaces arg 0
    val start = String.sub (arg, 0)
    val check = checkEndsWith pos arg
  in
    if start = #"\"" then
      LocalInc (dir, check #"\"")
    else if start = #"<" then
      ExternalInc $ check #">"
    else
      errorSpos pos `"invalid #include argument" %
  end

  fun dprintf ppc =
    if #debugMode ppc then
      printf
    else
      printf Ign

  val PDP = fn z => bind A0 (fn out => Printf out F `"!!! " %) z

  fun handleInclude (T.PpcInclude (dir, arg), pos) ppc =
  let
    val arg = parseIncludeArg pos arg dir
    val (path, instream) = findFile pos arg (#incDirs ppc)
    val () = dprintf ppc PDP T.S.Ppos pos `": #include: " `path %
    val stream = T.S.createFromInstream path instream
  in
    updatePpc ppc u#buffer (fn buf => Stream stream :: buf) %
  end
    | handleInclude _ _ = raise Unreachable

  fun getDefineMacroBody ppc acc =
  let
    val (tk, pos, ppc) = getTokenNoexpand ppc
  in
    case tk of
      T.NewLine => (acc, ppc)
    | T.EOS => clerror pos [Ctk T.NewLine]
    | _ => getDefineMacroBody ppc ((tk, pos) :: acc)
  end

  fun isFuncMacroDefine len (T.S.Pos (_, line1, col1)) ppc =
  let
    val (tk, TkPos (T.S.Pos (_, line2, col2), _), _) = getTokenNoexpand ppc
  in
    tk = T.LParen andalso line1 = line2 andalso col1 + len = col2
  end

  fun PrintMacroBody (out, body) =
    if body = [] then
      ()
    else (
      Printf out `" {";
      Printf out PtokenL 1 body;
      Printf out `"}\n" %
    )

  fun parseDefineObjMacro ppc =
  let
    val (body, ppc) = getDefineMacroBody ppc []
  in
    dprintf ppc A1 PrintMacroBody body;
    (ObjMacro body, ppc)
  end

  fun validateArgs args =
  let
    fun validateArg (id, _) [] = id
      | validateArg (id, pos) ((id', pos') :: tail) =
        if id = id' then
          error 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 ppc =
  let
    datatype arg = Arg of string * tkPos | LastArg of string * tkPos

    fun parseArg ppc =
    let
      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), ppc)
         | T.Coma => (Arg (id, posId), ppc)
         | _ => raise Unreachable
    end

    fun parseArgs ppc =
    let
      val (tk, _, ppc) = getTokenNoexpand ppc

      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
        ([], ppc)
      else
        let
          val (args, ppc) = parse ppc []
          val args = validateArgs args
        in
          (args, ppc)
        end
    end
  in
    parseArgs ppc
  end

  fun parseDefineFuncMacro ppc =
  let
    val (params, ppc) = parseDefineMacroArgs ppc
    val (body, ppc) = getDefineMacroBody ppc []

    fun printParams out =
    let
      fun printParams' [] = ()
        | printParams' [p] = Printf out `p %
        | printParams' (p :: ps) = (Printf out `p `", "; printParams' ps)
    in
      Printf out `"(";
      printParams' params;
      Printf out `")" %
    end
  in
    dprintf ppc A0 printParams;
    dprintf ppc A1 PrintMacroBody body;
    (FuncMacro (params, rev body), ppc)
  end

  fun parseDefine ppc =
  let
    val (macroName, pos, ppc) = getClassNoexpand ppc [Cid]
    val pos = tkPos2pos pos
    val macroName =
      case macroName of T.Id id => id | _ => raise Unreachable

    val () = dprintf ppc PDP T.S.Ppos pos `": #define " `macroName %

    val parser =
      if isFuncMacroDefine (size macroName) pos ppc then
        parseDefineFuncMacro
      else
        parseDefineObjMacro

    val (macro, ppc) = parser ppc
  in
    ((macroName, pos), macro, ppc)
  end

  fun handleDefine _ ppc =
  let
    val ((macroName, pos), macro, ppc) = parseDefine ppc

    val (prevVal, macros) =
        insertMacro (#macros ppc) macroName (false, pos, macro)

    fun eqMacroBody [] [] = true
      | eqMacroBody [] _ = false
      | eqMacroBody _ [] = false
      | eqMacroBody ((tk1, _) :: tl1) ((tk2, _) :: tl2) =
        if tk1 <> tk2 then false else eqMacroBody tl1 tl2

    fun eqMacro (ObjMacro b1, ObjMacro b2) = eqMacroBody b1 b2
      | eqMacro (FuncMacro (pl1, b1), FuncMacro (pl2, b2)) =
        pl1 = pl2 andalso eqMacroBody b1 b2
      | eqMacro _ = false
  in
    case prevVal of
      SOME (_, pos', macro') =>
        if not $ eqMacro (macro, macro') then (
            warning (pos2tkPos pos) `macroName `" macro redefinition" %;
            printf F `"See " T.S.Ppos pos' %
        ) else
          ()
    | NONE => ();
    updatePpc ppc s#macros macros %
  end

  fun addLayer (id, TkPos (pos, layers)) = (id, pos) :: layers

  fun setLayers idPos body =
  let
    fun formLayers (tk, TkPos (pos, _)) = (tk, TkPos (pos, addLayer idPos))
  in
    List.map formLayers body
  end

  fun insertRevBody body ppc =
  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 Pbody = fn z =>
  let
    fun printBody (out, msg, body) = (
      Printf out F `msg `" {";
      Printf out PtokenL 1 body;
      Printf out `"}\n" %
    )
  in
    bind A2 printBody
  end z

  datatype collectCtx =
    AfterIf | AfterIfdef | AfterIfndef | AfterElse | AfterElif

  fun expandObjMacro (id, pos) body ppc =
  let
    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 PmacroHeader id mLayers;
    dprintf ppc Pbody "body" (rev revBody);
    insertRevBody revBody ppc
  end

  and parseFuncMacroArgs mPos params ppc =
  let

    fun getTokenRestricted ppc =
    let
      val (tk, pos, ppc) = getTokenNoexpand ppc
    in
      if T.isPpcDir tk then
        error pos `"preprocessor directive inside macro arguments" %
      else
        (tk, pos, ppc)
    end

    fun parseArg level ppc acc =
    let
      val (tk, pos, ppc) = getTokenRestricted ppc
      fun continue dx = parseArg (level + dx) ppc ((tk, pos) :: acc)
    in
      case tk of
        T.EOS => error mPos `"unfinished argument list" %
      | T.LParen => continue 1
      | T.Coma =>
          if level > 0 then
            continue 0
          else
            (true, rev acc, ppc)
      | T.RParen =>
          if level > 0 then
            continue (~1)
          else
            (false, rev acc, ppc)
      | T.NewLine => parseArg level ppc acc
      | _ => continue 0
    end

    fun parseArgs ppc params acc =
    let
      fun bind _ [] = error mPos `"too many arguments" %
        | bind body (param :: params) = ((param, body), params)

      val (continue, arg, ppc) = parseArg 0 ppc []
      val (bindedParam, otherParams) = bind arg params
    in
      if continue then
        parseArgs ppc otherParams (bindedParam :: acc)
      else
        if length otherParams > 0 then
          error mPos `"not enough arguments" %
        else
          (rev (bindedParam :: acc), ppc)
    end

    val (_, _, ppc) = getClassGeneric [Ctk T.LParen]
            getTokenRestricted ppc
    val (res, ppc) = parseArgs ppc params []
  in
    (res, ppc)
  end

  and expandArgument ppc arg =
  let
    val ppc = updatePpc ppc s#buffer [Tokens 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 (id, pos)_ [] acc =
    if acc = [] then
      [(T.MacroEnd id, pos)]
    else
      rev $ (T.MacroEnd id, #2 o hd $ acc) :: acc
    | subst idPos 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
    case findArg bindedParams of
        NONE => subst idPos bindedParams tail (P :: acc)
      | SOME arg =>
          subst idPos bindedParams tail (List.revAppend (arg, acc))
  end
    | subst bindedParams idPos (P :: tail) acc =
        subst bindedParams idPos tail (P :: acc)

  and printBinded z =
  let
    fun printBinded (out, (msg, params)) =
    let
      fun print [] = ()
        | print ((p, args) :: tail) = (
        Printf out `p `": ";
        Printf out PtokenL 1 args;
        print tail
      )
    in
      Printf out F `msg `" {\n";
      print params;
      Printf out `"}\n" %
    end
  in
    bind A1 printBinded
  end z

  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 PmacroHeader id mLayers %
    val (bindedParams, ppc) = parseFuncMacroArgs mPos params ppc

    val bp1 = apply addLayers2args bindedParams
    val () = dprintf ppc printBinded ("args", bp1) %

    val bp2 = apply (expandArgument ppc) bp1
    val () = dprintf ppc printBinded ("expanded args", bp2) %

    val body = setLayers (id, mPos) body
    val body = subst (id, mPos) bp2 body []
  in
    dprintf ppc Pbody "subst" body;
    insertRevBody (rev body) ppc
  end

  and collectRevBody ifPos acc ctx ppc =
  let
    fun collect level ppc acc =
    let
      val (tk, pos, ppc) = getTokenNoexpand ppc
      fun def dl = collect (level + dl) ppc ((tk, pos) :: acc)

      fun unexpected tk prevTk =
        error pos `"unexpected " T.Ptk tk `" inside " T.Ptk prevTk %

      fun handleIfdef ifTk =
        if tk = T.PpcElif then
          unexpected tk ifTk
        else
          (SOME (tk, pos), acc, ppc)

      fun handleElse () =
        if level > 0 then
          def 0
        else
          case ctx of
            AfterIf => (SOME (tk, pos), acc, ppc)
          | AfterIfdef => handleIfdef T.PpcIfdef
          | AfterIfndef => handleIfdef T.PpcIfndef
          | AfterElse => unexpected tk T.PpcElse
          | AfterElif => def 0
    in
      case tk of
        T.EOS => errorSpos ifPos `"unfinished conditional directive" %
      | T.PpcEndif =>
          if level = 0 then
            if ctx = AfterElif then
              (NONE, (tk, pos) :: acc, ppc)
            else
              let
                val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
              in
                (NONE, acc, ppc)
              end
          else
            def (~1)
      | T.PpcElse => handleElse ()
      | T.PpcElif => handleElse ()
      | T.PpcIf => def 1
      | T.PpcIfdef => def 1
      | T.PpcIfndef => def 1
      | _ => def 0
    end
  in
    collect 0 ppc acc
  end

  and finishElse collect ppc =
  let
    val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
    val (_, body, ppc) = collect [] AfterElse ppc
  in
    (body, ppc)
  end

  and getIfdefRevBody ifTk ifPos cond ppc =
  let
    val collect = collectRevBody ifPos
    val afterTk = if ifTk = T.PpcIfdef then AfterIfdef else AfterIfndef

    val (elseTk, ifTrue, ppc) = collect [] afterTk ppc
    val (ifFalse, ppc) =
      case elseTk of
        SOME (T.PpcElse, _) => finishElse collect ppc
      | NONE => ([], ppc)
      | _ => raise Unreachable
  in
    (if cond then ifTrue else ifFalse, ppc)
  end

  and getIfRevBody ifPos cond ppc =
  let
    val collect = collectRevBody ifPos
    val (elseTk, ifTrue, ppc) = collect [] AfterIf ppc
    val (ifFalse, ppc) =
      case elseTk of
        NONE => ([], ppc)
      | SOME (T.PpcElse, _) => finishElse collect ppc
      | SOME (T.PpcElif, pos) =>
        let
          val (_, body, ppc) = collect [(T.PpcIf, pos)] AfterElif ppc
        in
          (body, ppc)
        end
      | _ => raise Unreachable
  in
    (if cond then ifTrue else ifFalse, 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 PDP T.S.Ppos ifPos `": #" `form `" "
        `id `" -> " B cond `"\n"%;
    (cond, ppc)
  end

  and skip ppc cl =
  let
    val (tk, _, ppc) = getTokenNoexpand ppc
  in
    case tk of
      T.EOS => cl ()
    | T.NewLine => ppc
    | _ => skip ppc cl
  end

  and ifEval ifPos ppc =
  let
    val ppc =
      skip ppc (fn () => errorSpos ifPos `"unfinished #if condition" %)
    val cond = true
  in
    dprintf ppc PDP T.S.Ppos ifPos `": #if -> " B cond `" (skipping)";
    (cond, ppc)
  end

  and handleIf (tk, ifPos) ppc =
  let
    val (eval, getRevBody) =
      case tk of
        T.PpcIfdef => (ifdefEval true, getIfdefRevBody T.PpcIfdef)
      | T.PpcIfndef => (ifdefEval false, getIfdefRevBody T.PpcIfndef)
      | T.PpcIf => (ifEval, getIfRevBody)
      | _ => raise Unreachable

    val (cond, ppc) = eval ifPos ppc
    val (revBody, ppc) = getRevBody ifPos cond ppc
  in
    dprintf ppc `" {" PtokenL 1 (rev revBody) `"}\n";
    insertRevBody revBody ppc
  end

  and handleUndef _ ppc =
  let
    val (tk, pos, ppc) = getTokenNoexpand ppc
    val id = case tk of T.Id id => id | _ => raise Unreachable
    val (_, _, ppc) = getClassNoexpand ppc [Ctk T.NewLine]
    val (prevVal, macros) = Tree.delete macroCompare (#macros ppc) id
  in
    dprintf ppc PDP `"#undef " `id `"\n" %;
    case prevVal of
      NONE => warning pos
        `"#undef: no macro with provided name was defined" %
    | SOME _ => ();
    updatePpc ppc s#macros macros %
  end

  and handleStray (tk, pos) _ = errorSpos pos `"stray " T.Ptk tk %

  and handlePragma (_, pos) ppc = (
    dprintf ppc PDP `"#pragma -> ignored\n";
    skip ppc (fn () => errorSpos pos `"unfinished #pragma" %)
  )

  and ppcFallback (_, pos) _ =
    errorSpos pos `"directive is not implemented" %

  and handleRegularToken tk pos ppc =
  let
    fun checkAndMark (true, _, _) = (NONE, NONE)
      | checkAndMark (false, pos, macro) =
        (SOME (true, pos, 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 => handleMacro id
    | T.MacroEnd id => getToken $ handleMacroEnd id ppc
    | _ => def ()
  end

  and handleToken tk pos ppc =
  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, handleUndef),
        (%T.PpcIf, handleIf),
        (%T.PpcElse, handleStray),
        (%T.PpcElif, handleStray),
        (%T.PpcEndif, handleStray),
        (%T.PpcWarning, ppcFallback),
        (%T.PpcError, ppcFallback),
        (%T.PpcPragma, handlePragma)
    ]
  in
    case List.find (fn (f, _) => f tk) directiveTable of
      SOME (_, f) => getToken $ f (tk, tkPos2pos pos) ppc
    | NONE => handleRegularToken tk pos ppc
  end

  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
    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#buffer (updateH head) %
  end

  and getTokenSkipNL ppc =
  let
    val (tk, pos, ppc) = getToken ppc
  in
    case tk of
      T.NewLine => getTokenSkipNL ppc
    | _ => (tk, pos, ppc)
  end

  fun debugPrint' (out, cache, ppc) =
  let
    val (tk, pos, ppc) = getToken ppc
    val cache = printTokenCompact cache out (tk, pos)
  in
    if tk = T.EOS then
      ()
    else
      Printf out A2 debugPrint' cache ppc %
  end

  fun debugPrint fname incDirs =
  let
    val ppc = create { fname, incDirs, debugMode = true }
  in
    printf A2 debugPrint' startCache ppc F %
  end

  val getToken = getTokenSkipNL
end