path: root/ppc.fun

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

  structure T = T

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

  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 * tkPos) list,

    macros: (bool * macro) H.t,

    EOSreached: bool,
    incDirs: string list
  }

  type tkErrorVal = tkPos * string
  exception TkError of tkErrorVal

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

  type tkClassErrorVal = tkPos * tkClass list
  exception TkClassError of tkClassErrorVal

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

  fun printLayers ((macroName, pos) :: layers) = (
    printf `"\t" `macroName `" " A1 T.S.pos2str pos %;
    printLayers layers
  )
    | printLayers [] = ()

  fun tkErrorPrint (TkPos (pos, layers), msg) = (
    printf A1 T.S.pos2str pos `": " `msg `"\n" %;
    printLayers layers
  )

  fun raiseTkClassError pos cls = raise TkClassError (pos, cls)
  fun raiseTkClassErrorSPos pos cls =
    raiseTkClassError (TkPos (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"

    fun printClassList [] = raise Unreachable
      | printClassList [ctk] = printCtk ctk
      | printClassList [ctk1, ctk2] = (
        printCtk ctk1;
        output " or ";
        printCtk ctk2
      )
      | printClassList (ctk :: ctks) = (
        printCtk ctk;
        output ", ";
        printClassList ctks
      )
  in
    printf A1 T.S.pos2str pos `": expected " %;
    printClassList cls;
    output "\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
    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 => raiseTkClassErrorSPos pos [Ctk 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 getClass stream clList =
  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) =
        if belongsToClass tk cl then
          ()
        else
          checkClass tail

    val () = checkClass clList
  in
    (tk, pos, stream)
  end

  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"
        else
          validateArg (id, pos) tail

    fun validate [] = []
      | validate (arg :: args) = validateArg arg args :: validate args

  in
    validate args
  end

  fun parseDefineMacroArgs stream =
  let
    datatype arg =
        Arg of string * T.S.pos |
        LastArg of string * T.S.pos

    fun parseArg stream =
    let
      val (tkId, posId, stream) = getClass stream [Cid]
      val (tk, _, stream) = getClass stream [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)
         | _ => raise Unreachable
    end

    fun parseArgs stream =
    let
      val (tk, _, stream) = T.getToken stream

      fun parse stream acc =
        case parseArg stream of
             (LastArg p, stream) => (rev (p :: acc), stream)
           | (Arg p, stream) => parse stream (p :: acc)
    in
      if tk = T.RParen then
        ([], stream)
      else
        let
          val (args, stream) = parse stream []
          val args = validateArgs args
        in
          (args, stream)
        end
    end
  in
    parseArgs stream
  end

  fun parseDefineFuncMacro stream =
  let
    val (args, 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 =
    let
        val (tk, pos, stream) = T.getToken stream
    in
      case tk of
        T.Id id => (id, pos, stream)
      | _ => raiseTkClassErrorSPos pos [Cid]
    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, TkPos (mPos, layers)) body ppc =
  let
    val mend = (T.MacroEnd id, if body = [] then mPos else (#2 o hd) body)

    fun formLayers (tk, pos) = (tk, TkPos (pos, (id, mPos) :: layers))

    val revBody = List.map formLayers $ List.concat [[mend], body]
  in
    updatePpc ppc u#buffer (fn buf => List.revAppend (revBody, buf)) %
  end

  fun expandFuncMacro (_, _) (_, _) _ =
  let
  in
    raise Unimplemented
  end

  fun handleRegularToken tk pos ppc =
  let
    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 => (tk, pos, ppc)
        | 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
      getToken ppc
    end
    | _ => (tk, pos, ppc)
  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 (TkPos (pos, [])) $
                updatePpc P s#streams (head :: tail) %
  end
  | getToken _ = raise Unreachable

  fun debugPrint' 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
  in
    printTkPos pos;
    T.printToken tk;
    printf `"\n" %;
    if tk = T.EOS then
      ()
    else
      debugPrint' ppc
  end

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