diff options
Diffstat (limited to 'cpp.fun')
| -rw-r--r-- | cpp.fun | 260 |
1 files changed, 210 insertions, 50 deletions
@@ -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 |