path: root/cpp.sml

fun $ (x, y) = x y
infixr 0 $

fun printLn s = (print s; print "\n")

datatype token =
    Invalid |
    Number of string |
    Id of string |
    CharConst of string * int |

    kwBreak |
    kwCase |
    kwChar |
    kwConst |
    kwContinue |
    kwDefault |
    kwDouble |
    kwElse |
    kwEnum |
    kwExtern |
    kwFloat |
    kwFor |
    kwGoto |
    kwInt |
    kwLong |
    kwRegister |
    kwReturn |
    kwShort |
    kwSigned |
    kwSizeof |
    kwStruct |
    kwSwitch |
    kwTypedef |
    kwUnion |
    kwUnsigned |
    kwVoid |
    kwVolatile |

    OParen |
    CParen |

    Plus |
    DoublePlus|
    Minus |
    DoubleMinus |

    Semicolon |
    EqualSign |
    DoubleEqualSign |
    ExclMark |
    ExclMarkEqualSign |

    QuestionMark |
    Colon |

    Hash |
    DoubleHash |

    CppInclude |
    CppDefine

val kwPrefix  = #"@"
val cppPrefix = #"$"

val tokenRepr =
let
  fun & repr = str kwPrefix ^ repr
  fun % repr = str cppPrefix ^ repr
in
  [
    (OParen, "("),
    (CParen, ")"),

    (kwBreak, &"break"),
    (kwCase, &"case"),
    (kwChar, &"char"),
    (kwConst, &"const"),
    (kwContinue, &"continue"),
    (kwDefault, &"default"),
    (kwDouble, &"double"),
    (kwElse, &"else"),
    (kwEnum, &"enum"),
    (kwExtern, &"extern"),
    (kwFloat, &"float"),
    (kwFor, &"for"),
    (kwGoto, &"goto"),
    (kwInt, &"int"),
    (kwLong, &"long"),
    (kwRegister, &"register"),
    (kwReturn, &"return"),
    (kwShort, &"short"),
    (kwSigned, &"signed"),
    (kwSizeof, &"sizeof"),
    (kwStruct, &"struct"),
    (kwSwitch, &"switch"),
    (kwTypedef, &"typedef"),
    (kwUnion, &"union"),
    (kwUnsigned, &"unsigned"),
    (kwVoid, &"void"),
    (kwVolatile, &"volatile"),

    (Plus, "+"),
    (DoublePlus, "++"),
    (Minus, "-"),
    (DoubleMinus, "--"),

    (Semicolon, ";"),
    (EqualSign, "="),
    (DoubleEqualSign, "=="),
    (ExclMark, "!"),
    (ExclMarkEqualSign, "!="),

    (QuestionMark, "?"),
    (Colon, ":"),

    (Hash, "#"),
    (DoubleHash, "##"),

    (CppInclude, % "include"),
    (CppDefine, % "define")
]
end

exception TokenWithoutRepr

val printToken = fn
   (Number s) => printLn $ "Num: " ^ s
  | (Id s) => printLn $ "Id: " ^ s
  | (CharConst (repr, _)) => printLn repr
  | v =>
    case List.find (fn (x, _) => x = v) tokenRepr of
    SOME (_, repr) => printLn repr
    | NONE => raise TokenWithoutRepr

type fileId = int
type fileOffset = int
type pos = fileId * fileOffset
type fullToken = pos * token

type stream = {
     (* list of file ids, file names and file contents *)
     allFiles: (fileId * string * string) list,
     (* stack of file ids, file offsets and file contents *)
     stack: (fileId * fileOffset * string) list
}

exception EndOfStream
exception EndOfFile
exception InvalidStream
exception InvalidStreamAdvance

fun calcFilePos s offset =
let
  fun calc s cur offset (line, col) =
    if cur = offset then
      (line, col)
    else
      calc s (cur + 1) offset
        (if String.sub (s, cur) = #"\n" then (line + 1, 1)
            else (line, col + 1))
in
  calc s 0 offset (1, 1)
end

fun printPos fileList (id, pos) =
let
  val triple = List.find (fn (fid, _, _) => fid = id) fileList
in
  case triple of
  NONE => raise InvalidStream
  | SOME (_, fname, contents) => 
    let
      val (line, col) = calcFilePos contents pos
      val line = Int.toString line
      val col = Int.toString col
    in
      print $ fname ^ ":" ^ line ^ ":" ^ col ^ ": "
    end
end

fun readFile fname =
let
  open TextIO
  val h = openIn fname
  val s = inputAll h
  val () = closeIn h
in
  s
end

fun getchar
  ({ stack = (id, off, contents) :: rest, allFiles }: stream)
  : (char * stream) =
  if off < String.size contents then
    (String.sub (contents, off),
        { stack = (id, off + 1, contents) :: rest, allFiles })
  else
    raise EndOfFile
  | getchar _ = raise EndOfStream

fun ungetc
  ({ stack = (id, off, contents) :: rest, allFiles }) =
  if off = 0 then
    raise InvalidStream
  else
    { stack = (id, off - 1, contents) :: rest, allFiles }
  | ungetc _ = raise InvalidStream

fun getOffset ({ stack = (_, off, _) :: _, ... }: stream) = off
  | getOffset _ = raise InvalidStream

fun getPosAfterCharRead
  ({ stack = (id, off, _) :: _, ... }: stream) = (id, off - 1)
  | getPosAfterCharRead _ = raise InvalidStream

fun getPos ({ stack = (id, off, _) :: _, ... }: stream) = (id, off)
  | getPos _ = raise InvalidStream

fun getSubstr startOff endOff
  ({ stack = (_, _, contents) :: _, ... }: stream) =
    String.substring (contents, startOff, endOff - startOff)
  | getSubstr _ _ _ = raise InvalidStream

fun advanceToNewFile
  ({ stack = (_, off, contents) :: rest, allFiles }: stream) =
  if off = String.size contents then
    { stack = rest, allFiles }
  else
    raise InvalidStreamAdvance
  | advanceToNewFile _ = raise InvalidStreamAdvance

fun streamInit fname =
let
  val contents = readFile fname
in
  { allFiles = [(0, fname, contents)], stack = [(0, 0, contents)] }
end

fun isSpace c = c = #" " orelse c = #"\t" orelse c = #"\n"
fun isLetter c =
  ord c >= ord #"a" andalso ord c <= ord #"z" orelse
    ord c >= ord #"A" andalso ord c <= ord #"Z"
fun isIdStart c = c = #"_" orelse isLetter c
fun isDigit c = ord c >= ord #"0" andalso ord c <= ord #"9"
fun isIdBody c = isIdStart c orelse isDigit c

(* FSM for parsing symbols *)

val maxStates = 16

exception FsmTableIsTooSmall
exception FsmTableIsTooLarge of int

fun fsmInsert (nextState, buf) curState tk (c :: cs) =
let
  open Array

  val (_, row) = sub (buf, curState)
  val potNextState = sub (row, ord c)
in
  if potNextState <> ~1 then
    fsmInsert (nextState, buf) potNextState tk cs
  else (
    update (row, ord c, !nextState);
    nextState := !nextState + 1;
    fsmInsert (nextState, buf) (!nextState - 1) tk cs
  )
end
 | fsmInsert (_, buf) curState tk [] =
let
  open Array
  val (_, row) = sub (buf, curState)
in
  update (buf, curState, (tk, row))
end

fun isStartForFsmGen () =
let
  open Array

  val lookupTable = array (128, false)

  fun firstChr s = ord $ String.sub (s, 0)
  val () = List.app
    (fn (_, repr) => update (lookupTable, firstChr repr, true))
        $ List.filter
            (fn (_, repr) =>
              let
                val c = String.sub (repr, 0)
              in
                c <> kwPrefix andalso c <> cppPrefix
              end)
            tokenRepr

in
  fn c => sub (lookupTable, ord c)
end

val isStartForFsm = isStartForFsmGen ()

fun fsmTableCreate () =
let
  open Array

  val T as (nextState, buf) =
    (ref 1, array (maxStates, (Invalid, array (128, ~1))))
  val r = ref 1

  fun filterNeeded [] acc = acc
    | filterNeeded ((T as (tk, repr)) :: tks) acc =
        filterNeeded tks
            (if isStartForFsm $ String.sub (repr, 0) then
               (printToken tk; T :: acc)
             else
              acc)

  val tokenRepr = filterNeeded tokenRepr []

  fun fsmInsert' T curState tk repr = fsmInsert T curState tk repr handle
    Subscript => raise FsmTableIsTooSmall
in
  while !r < length buf do (
    update (buf, !r, (Invalid, array(128, ~1)));
    r := !r + 1
  );

  List.app (fn (v, p) => fsmInsert' T 0 v $ explode p) tokenRepr;
  if !nextState <> maxStates then
    raise FsmTableIsTooLarge $ !nextState
  else ();
  T
end

val fsmTable = fsmTableCreate ()

fun fsmEat stream =
let
  open Array
  val stream = ungetc stream
  val pos = getPos stream

  fun get curState stream =
  let
    val (c, stream) = (fn (c, s) => (SOME c, s)) $ getchar stream handle
        _ => (NONE, stream)
  in
    case c of
    NONE => (#1 $ sub (#2 fsmTable, curState), stream)
    | SOME c =>
        let
          val (tk, row) = sub (#2 fsmTable, curState)
          val nextState = sub (row, ord c)
        in
          if nextState = ~1 then
            (tk, ungetc stream)
          else
            get nextState stream
        end
  end
in
  (fn (tk, stream) => ((pos, tk), stream)) $ get 0 stream
end

exception UnexpectedCharacter of char

fun isFirstOnLine (tk: fullToken) (stream: stream) =
let
  val (id, offset) = #1 tk
in
  case List.find (fn (fid, _, _) => id = fid) (#allFiles stream) of
  NONE => raise InvalidStream
  | SOME (_, _, contents) =>
      let
        fun returnToNL ~1 = true
          | returnToNL offset =
          let
            val chr = String.sub (contents, offset)
          in
            if chr = #"\n" then
              true
            else if isSpace chr then
              returnToNL (offset - 1)
            else
              false
          end
      in
        returnToNL (offset - 1)
      end
end

fun parseGeneric stream parser acc =
let
  val stream = ungetc stream
  val P as (_, startOff) = getPos stream

  fun parse' stream acc = let
    val (c, stream) = (fn (c, s) => (SOME c, s)) $ getchar stream handle
        _ => (NONE, stream)

    val (acc, tk, stream) = parser acc (stream, startOff) c
  in
    case tk of
    NONE => parse' stream acc
    | _ => (valOf tk, stream)
  end

  val (tk, stream) = parse' stream acc
in
  ((P, tk): fullToken, stream)
end

fun finishSeqRead startOff stream =
let
  val (_, endOff) = getPos stream
  val s = getSubstr startOff endOff stream
in
  s
end

fun findKeyword s =
  case List.find
    (fn (_, repr) =>
        String.sub (repr, 0) = kwPrefix andalso
          String.extract (repr, 1, NONE) = s)
    tokenRepr
  of
    SOME (tk, _) => tk
  | NONE => Id s

fun idParser () (stream, startOff) c =
let
  fun finalize stream =
  let
    val s = finishSeqRead startOff stream
    val tk = findKeyword s
  in
    ((), SOME tk, stream)
  end
in
  case c of
  NONE => finalize stream
  | SOME c =>
      if isIdBody c then
        ((), NONE, stream)
      else
        finalize (ungetc stream)
end

val formCppDirExn = Fail $ "Expected cpp direcive\n"

fun formCppDir (Id s) tkl =
let
  open String
  fun conv tk = ((#1 $ hd tkl, tk) :: tl tkl)
in
  case List.find
    (fn (_, repr) =>
        sub (repr, 0) = cppPrefix andalso
            extract (repr, 1, NONE) = s)
    tokenRepr
  of
    SOME (tk, _) => conv tk
  | NONE => raise formCppDirExn
end
  | formCppDir _ _ = raise formCppDirExn

fun numParser () (stream, startOff) c =
let
  fun finalize stream =
    ((), SOME $ Number (finishSeqRead startOff stream), stream)
in
  case c of
    NONE => finalize stream
  | SOME c =>
      if isDigit c then
        ((), NONE, stream)
      else
        finalize (ungetc stream)
end

exception IncompleteEsqSeq

fun eatEscSeq stream =
let
  val (c, stream) = getchar stream handle
    _ => raise IncompleteEsqSeq
in
  (case c of
  #"\\" => #"\\"
  | #"t" => #"\t"
  | #"n" => #"\n"
  | c => c,
    stream)
end

datatype CharParseState = ChInit | ChStart | ChValue of int | ChTerm
exception CharConstExn of string

val chExnExpValue = CharConstExn "expected value after '"
val chExnExpTerm = CharConstExn "expected ' after value"
val chExnStart = CharConstExn "can not start parsing (unreachable)"
val chExnAfterTerm = CharConstExn "can not finish parsing (unreachable)"

fun charParser ChInit (stream, _) (SOME c) =
  if c = #"'" then
    (ChStart, NONE, stream)
  else
    raise chExnStart
  | charParser ChStart (stream, _) (SOME c) =
    if c <> #"'" then
      let
        val (c, stream) =
          if c <> #"\\" then (c, stream) else eatEscSeq stream
      in
        (ChValue $ ord c, NONE, stream)
      end
    else
      raise chExnExpValue
  | charParser (ChValue v) (stream, startOff) (SOME c) =
    if c = #"'" then
      (ChTerm,
        SOME $ CharConst (finishSeqRead startOff stream, v), stream)
    else
      raise chExnExpTerm
  | charParser ChTerm _ (SOME _) =
    raise chExnAfterTerm
  | charParser state (_, _) NONE =
    raise case state of
      ChInit => chExnStart
    | ChStart => chExnExpValue
    | ChValue _ => chExnExpTerm
    | ChTerm => chExnAfterTerm

fun tokenize stream tkl =
let
  fun getcharSkipEof stream = getchar stream handle
    EndOfFile => getcharSkipEof (advanceToNewFile stream)

  val (c, stream) = (fn (c, s) => (SOME c, s)) $ getcharSkipEof stream
  handle
    EndOfStream => (NONE, stream)

  fun cont (tk, stream) = tokenize stream (tk :: tkl)
  fun @-> parser acc = cont $ parseGeneric stream parser acc
in
  case c of
  NONE => (rev tkl, #allFiles stream)
  | SOME c => 
    if isSpace c then
      tokenize stream tkl
    else if isIdStart c then
      let
        val isCppDir = (fn Hash => true | _ => false) (#2 $ hd tkl)
            handle Empty => false
        val (tk, stream) = parseGeneric stream idParser ()
      in
        tokenize stream
            (if isCppDir then (formCppDir (#2 tk) tkl) else (tk :: tkl))
      end
    else if isDigit c then
      @-> numParser ()
    else if c = #"'" then
      @-> charParser ChInit
    else if isStartForFsm c then
      cont $ fsmEat stream
    else
      raise UnexpectedCharacter c
end

fun main [fname] =
let
  val stream = streamInit fname
  val (tkl, fileList) = tokenize stream []
in
  List.app (fn (p, x) => (printPos fileList p; printToken x)) tkl
end
  | main _  = printLn "Expected a signle argument: file name"

val () = main $ CommandLine.arguments ()