#include directive

12 files changed, 294 insertions, 87 deletions

diff --git a/.gitignore b/.gitignore
index c495a68..0d3416d 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,3 +3,4 @@ ccross
 doc/todo.txt
 mlmon.out*
 *dot
+log*
diff --git a/ccross.mlb b/ccross.mlb
index 6e36d72..322b1e4 100644
--- a/ccross.mlb
+++ b/ccross.mlb
@@ -4,23 +4,14 @@ ann
 in
 	$(SML_LIB)/basis/basis.mlb
     $(SML_LIB)/basis/mlton.mlb
-    general.sml
+    common.sml
 
-    stream.sig
-    stream.sml
+    stream.sig stream.sml
+    hashtable.sig hashtable.sml
+    tokenizer.sig tokenizer.fun
+    cpp.sig cpp.fun
+    exn_handler.sig exn_handler.fun
+    driver.sig driver.fun
 
-    hashtable.sig
-    hashtable.sml
-
-    tokenizer.sig
-    tokenizer.fun
-
-    cpp.sig
-    cpp.fun
-
-    exn_handler.sig
-    exn_handler.fun
-
-    ccross.sig
-    ccross.sml
+    ccross.sig ccross.sml
 end
diff --git a/ccross.sig b/ccross.sig
index 3bfaf9e..023d15f 100644
--- a/ccross.sig
+++ b/ccross.sig
@@ -1,4 +1,4 @@
 signature CCROSS = sig
-  structure P: CPP 
+  structure D: DRIVER
   structure ExnHandler: EXN_HANDLER
 end
diff --git a/ccross.sml b/ccross.sml
index 749687b..d42368d 100644
--- a/ccross.sml
+++ b/ccross.sml
@@ -4,13 +4,11 @@ structure ccross:> CCROSS = struct
 
   structure P:> CPP = Cpp(T)
 
+  structure D:> DRIVER = Driver(P)
+
   structure ExnHandler:> EXN_HANDLER =
     ExnHandler(structure T = T; structure P = P)
 end
 
 val () = MLton.Exn.setTopLevelHandler ccross.ExnHandler.handler
-
-fun main [fname] = ccross.P.debugPrint fname
-  | main _  = printLn "Expected a single argument: file name"
-
-val () = main $ CommandLine.arguments ()
+val () = ccross.D.exec ()
diff --git a/general.sml b/common.sml
index cb4652a..cb4652a 100644
--- a/general.sml
+++ b/common.sml
diff --git a/cpp.fun b/cpp.fun
index f9d16e5..8884a59 100644
--- a/cpp.fun
+++ b/cpp.fun
@@ -5,7 +5,8 @@ functor Cpp(T: TOKENIZER): CPP = struct
   type tkPos = T.S.pos
   type t =
     { streams: T.S.t list, fileInfo: T.S.fileInfo list,
-      lastPos: tkPos option, firstId: T.S.fileId };
+      lastPos: tkPos option, firstId: T.S.fileId,
+      incDirs: string list }
 
   datatype tkExp =
     Tk of T.token |
@@ -16,44 +17,29 @@ functor Cpp(T: TOKENIZER): CPP = struct
     BinOp |
     Op
 
-  type tkExpectedValue = string * tkExp list
+  type tkExpectedVal = string * tkExp list
 
   exception StreamTooOld
-  exception TkExpected of tkExpectedValue
+  exception TkExpected of tkExpectedVal
 
-  fun create fname =
+  type tkErrorVal = string * string
+  exception TkError of tkErrorVal
+
+  fun create fname incDirs =
   let
     val stream = T.S.create fname
     val info = T.S.convert stream
   in
-   { streams = [stream] , fileInfo = [info], lastPos = NONE, firstId = #1 info }
-  end
-
-  fun getToken
-    ({ streams = stream :: tail, fileInfo, lastPos, firstId }: t) =
-  let
-    val (tk, stream) = T.getToken stream
-  in
-    case tk of
-      NONE => getToken { streams = tail, fileInfo, lastPos, firstId }
-    | SOME (pos, tk) =>
-        ( tk, { streams = stream :: tail, fileInfo,
-            lastPos = SOME pos, firstId })
+   { streams = [stream] , fileInfo = [info], lastPos = NONE,
+      firstId = #1 info, incDirs }
   end
-    | getToken
-        { streams = [], fileInfo, lastPos = SOME lastPos, firstId } =
-    let
-      val pos = SOME (#1 lastPos, ~1) (* EOF *)
-    in
-      (T.EOS, {streams = [], fileInfo, lastPos = pos, firstId })
-    end
-    | getToken { streams = [], fileInfo, lastPos = NONE, firstId } =
-        (T.EOS, { streams = [], fileInfo,
-            lastPos = SOME (firstId, ~1), firstId })
 
   fun getLastPos ({ lastPos = NONE, ... }: t) = raise Unreachable
     | getLastPos { lastPos = SOME p, ... } = p
 
+  fun getTopFileInfo ({ streams = top :: _, ... }: t) = T.S.convert top
+    | getTopFileInfo _ = raise Unreachable
+
   val tkExp2str = fn
       (Tk tk) => T.token2str tk
     | Id: tkExp => "identifier"
@@ -63,17 +49,24 @@ functor Cpp(T: TOKENIZER): CPP = struct
     | BinOp => "binary operator"
     | Op => "operator"
 
-  fun prepAndRaise (stream: t) (id, pos) expList =
+  fun tkPos2str stream (id, pos) =
   let
     val fileInfo =
       case List.find (fn (id', _, _) => id' = id) $ #fileInfo stream of
         NONE => raise StreamTooOld
       | SOME fileInfo => fileInfo
-    val pos = T.S.ppos2str $ T.S.pos2pposWithFI (id, pos) fileInfo
   in
-    raise TkExpected (pos, expList)
+    T.S.ppos2str $ T.S.pos2pposWithFI (id, pos) fileInfo
   end
 
+  fun prepTkError stream pos msg = raise TkError (tkPos2str stream pos, msg)
+  fun prepLastTkError stream = prepTkError stream (getLastPos stream)
+
+  fun prepTkExpected (stream: t) pos expList =
+    raise TkExpected (tkPos2str stream pos, expList)
+  fun prepLastTkExpected stream = prepTkExpected stream
+    (getLastPos stream)
+
   fun tkExpectedPrint (pos, expList) =
   let
     fun tkExps2str [e] [] = tkExp2str e
@@ -88,39 +81,206 @@ functor Cpp(T: TOKENIZER): CPP = struct
     printLn $ tkExps2str expList []
   end
 
-  fun debugPrint fname =
+  fun tkErrorPrint (pos, msg) = printLn $ pos ^ ": " ^ msg
+
+  exception EmptyPath
+
+  fun getDirOfCurFile ({ streams = top :: _, ... }: t) =
+    OS.Path.getParent $ T.S.getFname top
+    | getDirOfCurFile _ = raise Unreachable
+
+
+  (* TODO: properly handle Size and Path exceptions from concat *)
+  fun findPath _ "" _ = raise EmptyPath
+    | findPath stream fname true =
+    let
+      val path = OS.Path.concat (getDirOfCurFile stream, fname)
+    in
+      (path, TextIO.openIn path)
+    end
+    | findPath stream fname false =
+    let
+      fun try (dir :: tail) =
+      let
+        val fname = OS.Path.concat (dir, fname)
+      in
+        SOME (fname, TextIO.openIn fname) handle _ => try tail
+      end
+        | try [] = NONE
+
+      val instream = try (#incDirs stream)
+    in
+      case instream of
+        NONE => findPath stream fname true
+      | SOME pair => pair
+    end
+
+  fun predSkip stream pred =
+  let
+    val (c, stream) = T.S.getchar stream
+  in
+    case c of
+      NONE => (NONE, stream)
+    | SOME c =>
+      if c = #"\n" then
+        (NONE, stream)
+      else if pred c then
+        (SOME $ #2 $ T.S.getPosAfterCharRead stream, stream)
+      else
+        predSkip stream pred
+  end
+
+  fun tryCollect stream =
   let
-    val stream = create fname
-    val cache = T.S.pposCacheInit $ hd $ #fileInfo stream
+    val top = hd $ #streams stream
 
-    fun print' cache stream first =
+    fun x f = f stream
+
+    fun returnBack top = {
+      streams = top :: tl (#streams stream),
+      fileInfo = x#fileInfo,
+      lastPos = x#lastPos,
+      firstId = x#firstId,
+      incDirs = x#incDirs
+    }
+
+    val (start, s) =
+      case predSkip top (fn c => c = #"<") of
+        (NONE, _) => raise Unreachable
+      | (SOME p, s) => (p, s)
+
+    val (res, s) = predSkip s (fn c => c = #">")
+  in
+    case res of
+      NONE => (NONE, stream)
+    | SOME endOff =>
+        (SOME $ T.S.getSubstr (start + 1) endOff s, returnBack s)
+  end
+
+  fun getToken
+    ({ streams = stream :: tail, fileInfo, lastPos, firstId, incDirs }: t) =
+  let
+    val (tk, stream) = T.getToken stream
+  in
+    case tk of
+      NONE => getToken { streams = tail, fileInfo, lastPos, firstId, incDirs }
+    | SOME (pos, tk) =>
+        if tk = T.CppInclude then
+          handleInclude { streams = stream :: tail, fileInfo,
+            lastPos, firstId, incDirs }
+        else
+          (tk, { streams = stream :: tail, fileInfo,
+              lastPos = SOME pos, firstId, incDirs })
+  end
+    | getToken
+        { streams = [], fileInfo, lastPos = SOME lastPos, firstId, incDirs } =
+    let
+      val pos = SOME (#1 lastPos, ~1) (* EOF *)
+    in
+      (T.EOS, {streams = [], fileInfo, lastPos = pos, firstId, incDirs })
+    end
+    | getToken { streams = [], fileInfo, lastPos = NONE, firstId, incDirs } =
+        (T.EOS, { streams = [], fileInfo,
+            lastPos = SOME (firstId, ~1), firstId, incDirs })
+
+  and handleInclude (stream: t) =
+  let
+    val (tk, streamNew) = getToken stream
+
+    fun die () =
+      prepLastTkError streamNew
+        "#include with macro argument is not implemented"
+  in
+    case tk of
+      T.StringConst path => includeFile streamNew path true
+    | T.EOS => die ()
+    | tk =>
+        if String.sub (T.token2str tk, 0) = #"<" then
+          let
+            val (path, stream) = tryCollect stream
+          in
+            case path of
+              SOME path => includeFile stream path false
+            | NONE => die ()
+          end
+        else
+          die ()
+  end
+
+  and includeFile stream fname localhdr =
+  let
+    val (fname, instream) = findPath stream fname localhdr
+        handle EmptyPath =>
+            prepLastTkError stream "#include path can not be empty"
+    val newStream = T.S.createFromInstream fname instream
+    val newFileInfo = T.S.convert newStream
+  in
+    getToken {
+      streams = newStream :: #streams stream,
+      fileInfo = newFileInfo :: #fileInfo stream,
+      lastPos = #lastPos stream,
+      firstId = #firstId stream,
+      incDirs = #incDirs stream
+    }
+  end
+
+
+  fun debugPrintToken cache tk (line, col) printLineRegardless =
+  let
+    val ` = Int.toString
+  in
+    if printLineRegardless orelse T.S.pposCacheGetLine cache <> line then
+      print $ "\n" ^ T.S.pposCacheGetFname cache ^ ":" ^ `line ^ "\n\t"
+    else
+      ();
+    print $ `col ^ ":" ^ T.token2str tk ^ "  "
+  end
+
+  fun adjustCacheStack (s as (top :: rest)) pos stream =
+  let
+    fun idMatches cache = T.S.pposCacheGetId cache = #1 pos
+    fun metBefore [] = NONE
+      | metBefore (c :: cs) =
+        if idMatches c then
+          SOME (c :: cs)
+        else
+          metBefore cs
+  in
+    if idMatches top then
+      (false, s)
+    else
+      (true, case metBefore rest of
+        NONE => T.S.pposCacheInit (getTopFileInfo stream) :: s
+      | SOME stack => stack)
+  end
+    | adjustCacheStack _ _ _ = raise Unreachable
+
+  fun debugPrint' cacheStack stream first =
     let
       val (tk, stream) = getToken stream
-      val ` = Int.toString
     in
       case tk of
-        T.NewLine => print' cache stream first
+        T.NewLine => debugPrint' cacheStack stream first
       | T.EOS => ()
       | tk =>
         let
-          val ((line, col), cache') = T.S.pposCacheAdvance
-                (getLastPos stream) cache
-          fun printTk () =
-            print $ `col ^ ":" ^ T.token2str tk ^ "  "
+          val pos = getLastPos stream
+          val (stackChanged, cacheStack) =
+                adjustCacheStack cacheStack pos stream
+
+          val oldTop = hd cacheStack
+          val (pair, top) = T.S.pposCacheAdvance pos oldTop
         in
-          if T.S.pposCacheGetLine cache = line andalso not first then
-            printTk ()
-          else
-            (if not first then print "\n" else ();
-            printLn $ T.S.pposCacheGetFname cache' ^ ":" ^ `line;
-            print "\t";
-            printTk ());
-          print' cache' stream false
+          debugPrintToken oldTop tk pair (first orelse stackChanged);
+          debugPrint' (top :: tl cacheStack) stream false
         end
     end
+
+  fun debugPrint stream =
+  let
+    val cache = T.S.pposCacheInit $ hd $ #fileInfo stream
   in
-    print' cache stream true;
+    debugPrint' [cache] stream true;
     print "\n"
   end
-
 end
diff --git a/cpp.sig b/cpp.sig
index beed8c2..e842e13 100644
--- a/cpp.sig
+++ b/cpp.sig
@@ -3,9 +3,12 @@ signature CPP = sig
 
   type t
   type tkPos
-  type tkExpectedValue
 
-  exception TkExpected of tkExpectedValue
+  type tkExpectedVal
+  exception TkExpected of tkExpectedVal
+
+  type tkErrorVal
+  exception TkError of tkErrorVal
 
   datatype tkExp =
     Tk of T.token |
@@ -16,12 +19,12 @@ signature CPP = sig
     BinOp |
     Op
 
-  val create: string -> t
+  val create: string -> string list -> t
   val getToken: t -> T.token * t
   val getLastPos: t -> tkPos
 
-  val prepAndRaise: t -> tkPos -> tkExp list -> 'a
-  val tkExpectedPrint: tkExpectedValue -> unit
+  val tkExpectedPrint: tkExpectedVal -> unit
+  val tkErrorPrint: tkErrorVal -> unit
 
-  val debugPrint: string -> unit
+  val debugPrint: t -> unit
 end
diff --git a/driver.fun b/driver.fun
new file mode 100644
index 0000000..78ca877
--- /dev/null
+++ b/driver.fun
@@ -0,0 +1,39 @@
+functor Driver(P: CPP): DRIVER = struct
+  structure P = P
+
+  type config = {
+    file: string option,
+    includeDirs: string list
+  }
+
+  val initConfig: config = { file = NONE, includeDirs = [] }
+
+  fun die msg = (printLn msg; Posix.Process.exit $ Word8.fromInt 1)
+
+  fun parseCmdArgs { file, includeDirs } [] =
+    if file = NONE then
+      die "missing input file"
+    else
+      { file, includeDirs = rev includeDirs }
+    | parseCmdArgs _ ("-I" :: []) =
+        die "-I: expected directory path after flag"
+    | parseCmdArgs { file, includeDirs } ("-I" :: path :: tail) =
+        parseCmdArgs { file, includeDirs = path :: includeDirs } tail
+    | parseCmdArgs { file, includeDirs } (arg :: tail) =
+      if String.sub (arg, 0) = #"-" then
+        die $ arg ^ ": unknown flag"
+      else
+        case file of
+          NONE => parseCmdArgs { file = SOME arg, includeDirs } tail
+        | SOME _ => die $ arg ^ ": file already specified"
+
+  fun exec () =
+  let
+    val config = parseCmdArgs initConfig (CommandLine.arguments ())
+
+    val cpp = P.create (valOf $ #file config) (#includeDirs config)
+  in
+    P.debugPrint cpp
+  end
+end
+
diff --git a/driver.sig b/driver.sig
new file mode 100644
index 0000000..341b090
--- /dev/null
+++ b/driver.sig
@@ -0,0 +1,3 @@
+signature DRIVER = sig
+  val exec: unit -> unit
+end
diff --git a/exn_handler.fun b/exn_handler.fun
index 6e069d6..7e0aa4d 100644
--- a/exn_handler.fun
+++ b/exn_handler.fun
@@ -37,6 +37,7 @@ struct
     | IO.Io _ => ioExn e
     | T.TkErrorAug (pos, msg) => eprint $ T.S.ppos2str pos ^ ": " ^ msg
     | P.TkExpected v => P.tkExpectedPrint v
+    | P.TkError v => P.tkErrorPrint v
     | _ => otherExn e;
     exit 255)
 end
diff --git a/stream.sig b/stream.sig
index e3c63d9..1307a60 100644
--- a/stream.sig
+++ b/stream.sig
@@ -32,13 +32,18 @@ signature STREAM = sig
   val pposWithoutCol: ppos -> ppos
 
   val getSubstr: fileOffset -> fileOffset -> t -> string
+  val getFname: t -> string
   val isFirstOnLine: pos -> t -> bool
 
-  (* throws IO.Io *)
+  (* both throw IO.Io *)
   val create: string -> t
+  val createFromInstream: string -> TextIO.instream -> t
 
   val pposCacheInit: fileInfo -> pposCache
-  val pposCacheAdvance: pos -> pposCache -> (int * int) * pposCache
+
+  val pposCacheGetId: pposCache -> fileId
   val pposCacheGetLine: pposCache -> int
   val pposCacheGetFname:  pposCache -> string
+
+  val pposCacheAdvance: pos -> pposCache -> (int * int) * pposCache
 end
diff --git a/stream.sml b/stream.sml
index a6afa31..4134293 100644
--- a/stream.sml
+++ b/stream.sml
@@ -74,17 +74,22 @@ structure Stream :> STREAM = struct
   fun getSubstr startOff endOff (_, _, _, contents) =
       String.substring (contents, startOff, endOff - startOff)
 
-  fun create fname =
+  fun getFname (stream: t) = #2 stream
+
+  val lastUsedId = ref ~1
+
+  fun createFromInstream fname instream =
   let
     open TextIO
-
-    val h = openIn fname
-    val contents = inputAll h
-    val () = closeIn h
+    val contents = inputAll instream
+    val () = closeIn instream
   in
-    (0, fname, 0, contents)
+    lastUsedId := !lastUsedId + 1;
+    (!lastUsedId, fname, 0, contents)
   end
 
+  fun create fname = createFromInstream fname (TextIO.openIn fname)
+
   fun isFirstOnLine (_, offset) ((_, _, _, contents) : t) =
     let
       fun returnToNL ~1 = true
@@ -119,6 +124,7 @@ structure Stream :> STREAM = struct
             offset = pos, line, col })
       end
 
+  fun pposCacheGetId (cache: pposCache) = #id cache
   fun pposCacheGetLine (cache: pposCache) = #line cache
   fun pposCacheGetFname (cache: pposCache) = #fname cache
 end