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 macroBody = (T.token * T.S.pos) list
  datatype macro =
    ObjMacro of macroBody |
    FuncMacro of string list * macroBody

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

    buffer: (T.token * T.S.pos) list,

    macros: (bool * macro) H.t,

    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) =
    printf A1 T.S.pos2str pos `": " `msg `"\n" %

  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 => output "identifier"
      | ExpConst => output "constant"
      | ExpUnop => output "unary operator"
      | ExpBinop => output "binary operator"
      | ExpOp => output "operator"

    fun printExpList [] = raise Unreachable
      | printExpList [etk] = printEtk etk
      | printExpList [etk1, etk2] = (
        printEtk etk1;
        output " or ";
        printEtk etk2
      )
      | printExpList (etk :: etks) = (
        printEtk etk;
        output ", ";
        printExpList etks
      )
  in
    printf A1 T.S.pos2str pos `": expected " %;
    printExpList exp;
    output "\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.createLog 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 getDefineMacroBody 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]
    | _ => getDefineMacroBody stream ((tk, pos) :: acc)
  end

  fun isFuncMacroDefine nameLength (T.S.Pos (_, line1, col1)) stream =
  let
    val (tk, T.S.Pos (_, line2, col2), _) = T.getToken stream
  in
    tk = T.LParen andalso line1 = line2 andalso col1 + nameLength = col2
  end

  fun parseDefineObjMacro stream =
  let
    val (body, stream) = getDefineMacroBody stream []
  in
    (ObjMacro body, stream)
  end

  fun getSpecific stream expList =
  let
    val (tk, pos, stream) = T.getToken stream
  in
    raise Unimplemented
  end

  fun parseDefineMacroArgs stream =
  let
    datatype arg =
        Arg of string * T.S.pos |
        LastArg of string * T.S.pos |
        EmptyArg
  in
    raise Unimplemented
  end

  fun parseDefineFuncMacro stream =
  let
    val (_, _, stream) = T.getToken stream
  in
    raise Unimplemented
  end

  fun parseDefine stream =
  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

    val (macroName, pos, stream) = getName stream

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

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

  fun handleDefine (P as { streams = head :: _, ... }: t) =
  let
    val ((macroName, pos), macro, head) = parseDefine head

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

  val directiveTable = [
      (T.CppInclude, handleInclude),
      (T.CppDefine, handleDefine)
  ]

  fun expandObjMacro (id, pos) body ppc =
  let
    val mstart = (T.MacroStart id, pos)
    val mend = (T.MacroEnd id,
        if body = [] then pos else (#2 o hd) body)
    val revBody = List.concat [[mend], body, [mstart]]
  in
    updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) %
  end

  fun expandFuncMacro (_, _) (_, _) _ =
    raise Unimplemented

  fun handleRegularToken tk pos ppc =
  let
    fun def () = (tk, TkPos pos, ppc)

    fun checkAndMark (true, _) = (NONE, NONE)
      | checkAndMark (false, macro) = (SOME (true, macro), SOME macro)
  in
    case tk of
      T.Id id => (
        case H.lookup2 (#macros ppc) id
            checkAndMark (fn () => NONE)
        of
          NONE => def ()
        | SOME (ObjMacro body) =>
            getToken $ expandObjMacro (id, pos) body ppc
        | SOME (FuncMacro (arg, body)) =>
            getToken $ expandFuncMacro (id, pos) (arg, body) ppc
    )
    | T.MacroEnd id =>
    let
      val () = H.lookup2 (#macros ppc) id
             (fn (_, body) => (SOME (false, body), ()))
             (fn () => raise Unreachable)
    in
      def ()
    end
    | _ => 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
  in
    (T.EOS, TkPos pos, updatePpc P s#streams [stream] %)
  end
    | getToken (P as { buffer = (tk, pos) :: tail, ... }: t) =
      handleToken tk pos (updatePpc P s#buffer tail %)
    | getToken (P as { streams = head :: tail, ... }: t) =
  let
    val (tk, pos, head) = T.getToken head
  in
    if tk = T.EOS then
      case tail of
        [] => getToken $ updatePpc P s#EOSreached true %
      | _ => getToken $ updatePpc P s#streams tail %
    else
      handleToken tk pos $ updatePpc P s#streams (head :: tail) %
  end
  | getToken _ = raise Unreachable

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

    fun repeat n s = String.concat (List.tabulate (n, fn _ => s))
    val Indent = fn z => bind A0 (fn () => repeat indent "\t") z

    fun printLine () = printf `"\n" Indent `fname' `":" I line' `" \t" %

    fun finish pair =
      if tk <> T.EOS then
        debugPrint' ppc pair (fname', line')
      else
        ()
  in
    case tk of
      T.MacroStart macroName => (
        printf `"\n" Indent A1 T.S.pos2str t `": macro " `macroName `" {" %;
        finish (true, indent + 1)
    )
    | T.MacroEnd id => (
      output "\n";
      printf Indent `"} " `id %;
      finish (true, indent - 1)
    )
    | _ => (
      if shouldPrintLine orelse fname' <> fname orelse line' <> line
      then
        printLine()
      else
        ();
      printf I col `":" %;
      T.printToken tk;
      printf `" " %;
      finish (false, indent)
    )
  end

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