path: root/ppc.fun

functor ppc(structure H: HASHTABLE; structure T: TOKENIZER): PPC =
struct

  structure T = T

  datatype tkPos = TkPos of T.S.pos

  type t = {
    streams: T.S.t list,

    buffer: (T.token * T.S.pos) list,
    macros: (T.token * T.S.pos) list H.t, (* body is stored reversed *)

    EOSreached: bool,
    incDirs: string list
  }

  type tkErrorVal = tkPos * string
  exception TkError of tkErrorVal

  datatype expTk =
    ExpTk of T.token |
    ExpId |
    ExpConst |
    ExpUnop |
    ExpBinop |
    ExpOp

  type tkErrorExpVal = tkPos * expTk list
  exception TkErrorExp of tkErrorExpVal

  fun raiseTkError msg pos = raise TkError (pos, msg)
  fun raiseTkErrorSPos pos msg = raiseTkError msg (TkPos pos)

  fun tkErrorPrint (TkPos pos, msg) =
    printLn $ T.S.pos2str pos ^ ": " ^ msg

  fun raiseTkErrorExp pos exp = raise TkErrorExp (pos, exp)
  fun raiseTkErrorExpSPos pos exp = raiseTkErrorExp (TkPos pos) exp

  fun tkErrorExpPrint (TkPos pos, exp) =
  let
    val printEtk = fn
        ExpTk tk => T.printToken tk
      | ExpId => print "identifier"
      | ExpConst => print "constant"
      | ExpUnop => print "unary operator"
      | ExpBinop => print "binary operator"
      | ExpOp => print "operator"

    fun printExpList [] = raise Unreachable
      | printExpList [etk] = printEtk etk
      | printExpList [etk1, etk2] = (
        printEtk etk1;
        print " or ";
        printEtk etk2
      )
      | printExpList (etk :: etks) = (
        printEtk etk;
        print ", ";
        printExpList etks
      )
  in
    print $ T.S.pos2str pos ^ ": expected ";
    printExpList exp;
    print "\n"
  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
    in
      FRU.makeUpdate5 (from, from, to)
    end
    z

  fun create { fname, incDirs } =
    { streams = [T.S.create fname], buffer = [], macros = H.create 10,
        EOSreached = false, incDirs }

  datatype IncludeArg =
    LocalInc of string * T.S.pos |
    ExternalInc of string * T.S.pos

  fun parseIncludeArg stream =
  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 (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
  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 =>
  let
    val (pos, _) = T.S.EOFpos stream
  in
    raiseTkErrorSPos pos "unexpected EOF during #include argument parsing"
  end

  fun findFile arg (stream, incDirs) = 
    case arg of
        LocalInc (arg, pos) => (
        let
          val dir = OS.Path.getParent o T.S.getFname $ stream
          val path = OS.Path.concat (dir, arg)

          val (path, instream) = (path, TextIO.openIn path)
        in
          (path, instream)
        end handle
        OS.Path.Path => raiseTkErrorSPos pos "invalid argument"
        | Size => raiseTkErrorSPos pos "resulting path is too long"
        | IO.Io v => raise IO.Io v
      )
      | ExternalInc (arg, pos) =>
      let
        fun try (dir :: tail) = (
          let
            val path = OS.Path.concat (dir, arg)
          in
            SOME (path, TextIO.openIn path)
          end handle _ => try tail
        )
          | try [] = NONE
      in
        case try incDirs of
          SOME pair => pair
        | NONE => raiseTkErrorSPos pos "unable to find header"
      end

  fun handleInclude (P as { streams = head :: tail, incDirs, ... }: t) =
  let
    val (arg, oldHead) = parseIncludeArg head
    val (path, instream) = findFile arg (head, incDirs)
    val head = T.S.createFromInstream path instream
  in
    updatePpc P s#streams (head :: oldHead :: tail) %
  end
    | handleInclude _ = raise Unreachable

  fun handleDefine (P as { streams = head :: _, ... }: t) =
  let
    fun getName stream =
    let
        val (tk, pos, stream) = T.getToken stream
    in
      case tk of
           T.Id id => (id, pos, stream)
         | _ => raiseTkErrorExpSPos pos [ExpId]
    end

    fun getBody stream acc =
    let
      val (tk, pos, stream) = T.getToken stream
    in
      case tk of
           T.NewLine => (acc, stream)
         | T.EOS => raiseTkErrorExpSPos pos [ExpTk T.NewLine]
         | _ => getBody stream ((tk, pos) :: acc)
    end

    val (macroName, pos, head) = getName head
    val (macroBody, head) = getBody head []

    val () = H.insert (#macros P) macroName macroBody handle
        H.Exists => raiseTkErrorSPos pos "macro redefinition"
  in
    updatePpc P u#streams (fn s => head :: tl s) %
  end
    | handleDefine _ = raise Unreachable

  fun handleRegularToken tk pos P =
  let
    fun def () = (tk, TkPos pos, P)
  in
    case tk of
         T.Id id => (
           case H.lookup (#macros P) id of
                NONE => def ()
              | SOME body =>
              let
                val mstart = (T.MacroStart id, pos)
                val mend = (T.MacroEnd,
                    if body = [] then pos else (#2 o hd) body)
                val revBody = List.concat [[mend], body, [mstart]]
              in
                getToken $ updatePpc P
                      u#buffer (fn buf => List.revAppend (revBody, buf)) %
              end
       )
       | _ => def ()
  end

  and getToken (P as { streams = [stream], EOSreached = true, ... }) =
  let
    val (pos, stream) = T.S.EOFpos stream
  in
    (T.EOS, TkPos pos, updatePpc P s#streams [stream] %)
  end
    | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
      handleRegularToken tk pos (updatePpc P s#buffer tail %)
    | getToken (P as { streams = head :: tail, ... }: t) =
  let
    val (tk, pos, head) = T.getToken head
    val directiveTable = [
        (T.CppInclude, handleInclude),
        (T.CppDefine, handleDefine)
    ]
  in
    if tk = T.EOS then
      case tail of
           [] => getToken $ updatePpc P s#EOSreached true %
         | _ => getToken $ updatePpc P s#streams tail %
    else
      case List.find (fn (tk', _) => tk' = tk) directiveTable of
        SOME (_, f) => getToken o f $
         updatePpc P s#streams (head :: tail) %
      | NONE =>
      let
        val ppc = updatePpc P u#streams (fn s => head :: tl s) %
      in
        handleRegularToken tk pos ppc
      end
  end
  | getToken _ = raise Unreachable


  fun debugPrint' ppc shouldPrintLine (fname, line) =
  let
    val (tk, pos, ppc) = getToken ppc
    val TkPos (t as (T.S.Pos (fname', line', col))) = pos

    fun printLine () =
      printOnNL $ fname' ^ ":" ^ Int.toString line' ^ "\n\t"

    fun finish shouldPrintLine =
      if tk <> T.EOS then
        debugPrint' ppc shouldPrintLine (fname', line')
      else
        ()
  in
    case tk of
         T.MacroStart macroName => (
           printOnNL $ "macro " ^ macroName ^ " (" ^ T.S.pos2str t ^ ") {";
           finish true
       )
       | T.MacroEnd => (printOnNL "}\n"; finish true)
       | _ => (
          if shouldPrintLine orelse fname' <> fname
                orelse line' <> line
          then
            printLine()
          else
            ();
          print $ Int.toString col ^ ":";
          T.printToken tk;
          print " ";
          finish false
       )
  end

  fun debugPrint fname incDirs =
  let
    val ppc = create { fname, incDirs }
  in
    debugPrint' ppc true ("", 0);
    print "\n"
  end
end