path: root/tokenizer.fun

functor Tokenizer(structure H: HASHTABLE; structure S: STREAM)
    : TOKENIZER =
struct

  structure S = S

  datatype intType = ItDec | ItOct | ItHex
  datatype intSfx = IsNone | IsU | IsL | IsUL | IsLL | IsULL
  datatype floatSfx = FsNone | FsF | FsL

  datatype numConst =
    IntConst of intType * string * intSfx |
    FloatConst of string * floatSfx

  datatype token =
    Invalid |
    EOS |
    NewLine |

    Num of numConst |

    Id of string |
    CharConst of string * int |
    StringConst of string |

    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 |

    LParen |
    RParen |
    LBracket |
    RBracket |
    LBrace |
    RBrace |

    QuestionMark |
    Colon |
    Coma |
    Semicolon |

    Arrow |
    Plus |
    DoublePlus|
    Minus |
    DoubleMinus |
    Ampersand |
    Asterisk |
    Slash |
    Tilde |
    ExclMark |
    Percent |
    DoubleGreater |
    DoubleLess |
    Greater |
    Less |
    EqualSign |
    LessEqualSign |
    GreaterEqualSign |
    DoubleEqualSign |
    ExclMarkEqualSign |
    Cap |
    VerticalBar |
    DoubleAmpersand |
    DoubleVerticalBar |

    AsteriskEqualSign |
    SlashEqualSign |
    PercentEqualSign |
    PlusEqualSign |
    MinusEqualSign |
    DoubleLessEqualSign |
    DoubleGreaterEqualSign |
    AmpersandEqualSign |
    CapEqualSign |
    VerticalBarEqualSign |

    Hash |
    DoubleHash |

    Dot |
    DoubleDot |
    TripleDot |

    CommentStart |

    CppInclude |
    CppDefine |
    CppUndef |
    CppIf |
    CppIfdef |
    CppIfndef |
    CppElse |
    CppElif |
    CppEndif |
    CppWarning |
    CppError |
    CppPragma

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

  type fullToken = S.pos * token

  datatype tkErrorAuxInfo = TkiEOF | TkiDx of int | TkiStart

  exception TkError of tkErrorAuxInfo * string
  exception TkErrorAug of S.ppos * string

  exception ExpectedCppDir (* handled in postprocess *)

  exception FsmTableIsTooSmall

  (* Unreachable (should be) *)
  exception TokenWithoutRepr
  exception SuffixWithoutRepr

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

      (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"),

      (LParen, "("),
      (RParen, ")"),
      (LBracket, "["),
      (RBracket, "]"),
      (LBrace, "{"),
      (RBrace, "}"),

      (QuestionMark, "?"),
      (Colon, ":"),
      (Coma, ","),
      (Semicolon, ";"),

      (Arrow, "->"),
      (Plus, "+"),
      (DoublePlus, "++"),
      (Minus, "-"),
      (DoubleMinus, "--"),
      (Ampersand, "&"),
      (Asterisk, "*"),
      (Slash, "/"),
      (Tilde, "~"),
      (ExclMark, "!"),
      (Percent, "%"),
      (DoubleLess, "<<"),
      (DoubleGreater, ">>"),
      (Less, "<"),
      (Greater, ">"),
      (EqualSign, "="),
      (LessEqualSign, "<="),
      (GreaterEqualSign, ">="),
      (DoubleEqualSign, "=="),
      (ExclMarkEqualSign, "!="),
      (Cap, "^"),
      (VerticalBar, "|"),
      (DoubleAmpersand, "&&"),
      (DoubleVerticalBar, "||"),

      (AsteriskEqualSign, "*="),
      (SlashEqualSign, "/="),
      (PercentEqualSign, "%="),
      (PlusEqualSign, "+="),
      (MinusEqualSign, "-="),
      (DoubleLessEqualSign, "<<="),
      (DoubleGreaterEqualSign, ">>="),
      (AmpersandEqualSign, "&="),
      (CapEqualSign, "^="),
      (VerticalBarEqualSign, "|="),

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

      (Dot, "."),
      (DoubleDot, ".."),
      (TripleDot, "..."),

      (CommentStart, "/*"),

      (CppInclude, %"include"),
      (CppDefine, %"define"),
      (CppUndef, %"undef"),
      (CppIf, %"if"),
      (CppIfdef, %"ifdef"),
      (CppIfndef, %"ifndef"),
      (CppElse, %"else"),
      (CppElif, %"elif"),
      (CppEndif, %"endif"),
      (CppWarning, %"warning"),
      (CppError, %"error"),
      (CppPragma, %"pragma")
  ]
  end

  val intSuffixRepr = [
    (IsNone, ""),
    (IsU, "u"),
    (IsL, "l"),
    (IsUL, "ul"),
    (IsLL, "ll"),
    (IsULL, "ull")
  ]

  val floatSuffixRepr = [
    (FsNone, ""),
    (FsF, "f"),
    (FsL, "l")
  ]

  fun getSfxRepr sfx buf onError =
    case List.find (fn (sfx', _) => sfx' = sfx) buf of
      NONE => onError ()
    | SOME (_, repr) => repr

  fun getSfxReprSimple sfx buf =
    getSfxRepr sfx buf (fn () => raise SuffixWithoutRepr)

  val token2str = fn
      Id s => "id:" ^ s
    | Num (IntConst (it, str, sfx)) =>
      let
        val intType =
          case it of
            ItDec => ""
          | ItOct => "0"
          | ItHex => "0x"
      in
        intType ^ str ^ "`" ^ getSfxReprSimple sfx intSuffixRepr ^ "`"
      end
    | Num (FloatConst (str, sfx)) =>
        str ^ "`" ^ getSfxReprSimple sfx floatSuffixRepr ^ "`"
    | CharConst (repr, _) => repr
    | StringConst s =>
        "\"" ^ s ^ "\""
    | v =>
      case List.find (fn (x, _) => x = v) tokenRepr of
      SOME (_, repr) => repr
      | NONE => raise TokenWithoutRepr

  fun printToken tk = print $ token2str tk

  fun isIdStart c = Char.isAlpha c orelse c = #"_"
  fun isIdBody c = Char.isAlphaNum c orelse c = #"_"

  fun isOctal c = ord c >= ord #"0" andalso ord c < ord #"8"
  val isDigit = Char.isDigit
  val isHexDigit = Char.isHexDigit

  fun isPrintable c = Char.isPrint c andalso c <> #" "

  (* FSM for parsing symbols *)

  val maxStates = 51

  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 (tk, repr) =>
                let
                  val c = String.sub (repr, 0)
                in
                  c <> kwPrefix andalso c <> cppPrefix
                    andalso tk <> NewLine
                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 (_, repr)) :: tks) acc =
          filterNeeded tks
              (if isStartForFsm $ String.sub (repr, 0) then
                 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
      printLn $ "note: Fsm table size can be smaller: "
          ^ Int.toString (!nextState) ^ " is enough"
    else ();
    T
  end

  (* Unused right now
  fun printTable (nextState, buf) =
  let
    fun printRow i row =
      if i = length row then
        print "\n"
      else
        let
          val state = sub (row, i)
        in
          if state = ~1 then
            ()
          else
            print ((str (chr i)) ^ ": " ^ (Int.toString state) ^ ", ");
            printRow (i + 1) row
        end

    fun print' rowNum buf =
      if rowNum = !nextState then
        ()
      else
        let
          val (tk, row) = sub (buf, rowNum)
        in
          print ((token2string tk) ^ ": ");
          printRow 0 row;
          print' (rowNum + 1) buf
        end
  in
    print ("NextState: " ^ Int.toString (!nextState) ^ "\n");
    print' 0 buf;
    print "\n"
  end
  *)

  val fsmTable = lazy fsmTableCreate

  fun fsmEat stream =
  let
    open Array
    val pos = S.getPos stream

    fun get curState stream =
    let
      val (c, stream) = S.getchar 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, S.ungetc stream)
            else
              get nextState stream
          end
    end
  in
    (fn (tk, stream) => ((pos, tk), stream)) $ get 0 stream
  end

  fun tkError2aug stream (dx, msg) =
  let
    val (id, pos) = S.getPosAfterCharRead stream
    val pos = S.pos2ppos (id, pos + dx) stream
  in
    TkErrorAug (pos, msg)
  end

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

    fun parse' stream acc = let
      val (c, stream) = S.getchar stream

      val (acc, tk, stream) = parser acc (stream, startOff) c handle
          TkError (TkiDx dx, msg) => raise tkError2aug stream (dx, msg)
        | TkError (TkiStart, msg) =>
            let
              val startPos = S.pos2ppos P stream
            in
              raise TkErrorAug (startPos, msg)
            end
        | TkError (TkiEOF, msg) =>
            let
              val pos = S.pposWithoutCol $ S.pos2ppos P stream
            in
              raise TkErrorAug (pos, msg)
            end
    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) = S.getPos stream
    val s = S.getSubstr startOff endOff stream
  in
    s
  end

  fun keywordHashtableGen () =
  let
    val table = H.create 128
    val () =
      List.app
        (fn (tk, repr) =>
            if String.sub (repr, 0) = kwPrefix then
              H.insert table (String.extract (repr, 1, NONE)) tk
            else
              ())
        tokenRepr
  in
    table
  end

  val keywordHashtable = lazy keywordHashtableGen

  fun findKeyword str =
    case H.lookup (keywordHashtable ()) str of
      NONE => Id str
    | SOME tk => tk

  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 (S.ungetc stream)
  end

  datatype intMode = ImDec | ImOct | ImInvalidOct | ImHex
  datatype floatMode = FmDot | FmExp

  datatype npState = NpInit | IntMode of intMode | FloatMode of floatMode

  fun getLongestSeq acc pred stream =
  let
    val (c, stream') = S.getchar stream
  in
    if isSome c andalso pred $ valOf c then
      getLongestSeq (valOf c :: acc) pred stream'
    else
      (implode $ rev acc, stream)
  end

  fun skipDigitSeq off stream =
  let
    val (res, stream) = getLongestSeq [] isDigit stream
  in
    if res = "" then
      raise TkError (TkiDx off, "expected digit")
    else
      (String.size res, stream)
  end

  fun getSuffixCommon buf off stream =
  let
    val (sfx, stream) = getLongestSeq [] Char.isAlpha stream
    val sfx = String.map (fn c => Char.toLower c) sfx
    val sfx =
      case List.find (fn (_, repr) => repr = sfx) buf of
        NONE => raise TkError (TkiDx off, "unknown suffix")
      | SOME (sfx, _) => sfx
  in
    (sfx, stream)
  end

  val getIntSuffix = getSuffixCommon intSuffixRepr 0
  fun getFloatSuffix off = getSuffixCommon floatSuffixRepr off

  (*
   * It seems that there is an ambiguity in C:
   * gcc/clang/cparser consider 0xe-3 as a fp constant and reject it.
   * Right now we do not, but it may be reconsidered.
   *)
  fun numParser NpInit (stream, _) (SOME c) =
    if c = #"0" then
      let
        val (c, stream') = S.getchar stream
      in
        case c of
          NONE =>
            (NpInit, SOME $ Num $ IntConst (ItOct, "", IsNone), stream')
        | SOME c =>
          if Char.toLower c = #"x" then
            (IntMode ImHex, NONE, stream')
          else
            (IntMode ImOct, NONE, stream)
      end
    else
      (IntMode ImDec, NONE, stream)
    | numParser NpInit _ NONE = raise Unreachable
    | numParser (IntMode mode) (stream, startOff) c =
    let
      val (pred, res, offset) =
        case mode of
          ImDec => (isDigit, ItDec, 0)
        | ImOct => (isOctal, ItOct, 1)
        | ImInvalidOct => (isDigit, ItOct, 1)
        | ImHex => (isHexDigit, ItHex, 2)

      fun checkAndRaise m msg =
        if mode = m then raise TkError (TkiStart, msg) else ()

      fun finish () =
      let
        val () = checkAndRaise ImInvalidOct "invalid octal constant"
        val stream = S.ungetc stream
        val str = finishSeqRead (startOff + offset) stream
        val (sfx, stream) = getIntSuffix stream
      in
        (IntMode mode, SOME $ Num $ IntConst (res, str, sfx), stream)
      end
    in
      case c of
        NONE => finish ()
      | SOME c =>
          if pred c then
            (IntMode mode, NONE, stream)
          else if c = #"." then
            (FloatMode FmDot, NONE, stream)
          else if Char.toLower c = #"e" then
            (checkAndRaise ImHex
                "floating constant can not come with 0x prefix";
            (FloatMode FmExp, NONE, stream))
          else
            finish ()
    end
    | numParser (FloatMode FmDot) (stream, startOff) _ =
    let
      val (len, stream) = skipDigitSeq 0 $ S.ungetc stream

      val (c, stream') = S.getchar stream

      fun finish () =
      let
        val str = finishSeqRead startOff stream
        val (sfx, stream) = getFloatSuffix len stream
      in
        (FloatMode FmDot, SOME $ Num $ FloatConst (str, sfx), stream)
      end
    in
      case c of
        NONE => finish ()
      | SOME c =>
          if Char.toLower c = #"e" then
            (FloatMode FmExp, NONE, stream')
          else
            finish ()
    end
    | numParser (FloatMode FmExp) (stream, startOff) c =
    let
      val (off, stream) =
        if c = NONE then
          raise TkError (TkiDx 0, "expected digit")
        else if valOf c <> #"+" andalso valOf c <> #"-" then
          (0, S.ungetc stream)
        else
          (~1, stream)

      val (len, stream) = skipDigitSeq off stream
      val str = finishSeqRead startOff stream
      val (sfx, stream) = getFloatSuffix len stream
    in
      (FloatMode FmDot, SOME $ Num $ FloatConst (str, sfx), stream)
    end

  fun chrIntVal c =
    if isDigit c then
      ord c - ord #"0"
    else if ord c >= ord #"a" andalso ord c <= ord #"z" then
      ord c - ord #"a" + 10
    else if ord c >= ord #"A" andalso ord c <= ord #"Z" then
      ord c - ord #"A" + 10
    else
      raise Unreachable

  fun parseOctalSeq stream c =
  let
    fun follow stream acc count =
      if count = 3 then
        (SOME $ chr acc, stream)
      else
        let
          val (c, stream) = S.getchar stream
        in
          case c of
            NONE => (SOME $ chr acc, stream)
          | SOME c =>
              if isOctal c then
                follow stream (acc * 8 + chrIntVal c) (count + 1)
              else
                (SOME $ chr acc, S.ungetc stream)
        end
  in
    follow stream (chrIntVal c) 1
  end

  fun parseHexSeq stream =
  let
    fun follow stream acc count =
      let
        val (c, stream) = S.getchar stream

        val noHex = TkError (TkiDx 0, "\\x without hex digits")
      in
        case c of
          NONE =>
              if count = 0 then
                raise noHex
              else
                (SOME $ chr acc, stream)
        | SOME c =>
            if isHexDigit c then
              if count = 2 then
                raise TkError (TkiDx 2, "hex sequence out of range")
              else
                follow stream (acc * 16 + chrIntVal c) (count + 1)
            else
              if count = 0 then
                raise noHex
              else
                (SOME $ chr acc, S.ungetc stream)
      end
  in
    follow stream 0 0
  end

  fun eatEscSeq stream =
  let
    fun raiseErr0 msg = raise TkError (TkiDx 0, msg)

    val (c, stream) = S.getchar stream
    val c =
      case c of
        NONE => raiseErr0 "unfinished escape sequence"
      | SOME c => c

    fun & c = (SOME c, stream)
  in
    case c of
      #"'" => & #"'"
    | #"\"" => & #"\""
    | #"?" => & #"?"
    | #"\\" => & #"\\"
    | #"a" => & #"\a"
    | #"b" => & #"\b"
    | #"f" => & #"\f"
    | #"n" => & #"\n"
    | #"r" => & #"\r"
    | #"t" => & #"\t"
    | #"v" => & #"\v"
    | #"\n" => (NONE, stream)
    | #"x" => parseHexSeq stream
    | c =>
      if isOctal c then
        parseOctalSeq stream c
      else
        raiseErr0 "unknown escape sequence"
  end

  datatype SeqParseState = SeqInit | SeqStart | SeqValue of int | SeqTerm

  datatype seqParseMode = SpmChr | SpmStr

  fun seqBound SpmChr = #"'"
    | seqBound SpmStr = #"\""

  fun seqExnConv mode (TkError (v, msg)) =
  let
    val bound = if mode = SpmChr then "'" else "\""
    val msg =
      String.translate (fn c => if c = #"%" then bound else str c) msg
  in
    TkError (v, msg)
  end
    | seqExnConv _ _ = raise Unreachable

  fun unfinishedSeq SpmChr = "unfinished character constant"
    | unfinishedSeq SpmStr = "unfinished string literal"

  fun seqParser mode SeqInit (stream, _) (SOME c) =
    if seqBound mode = c then
      (SeqStart, NONE, stream)
    else
      raise Unreachable
    | seqParser mode SeqStart (stream, _) (SOME c) =
      if c <> seqBound mode then
        let
          val (c, stream) =
              if c <> #"\\" then (SOME c, stream) else eatEscSeq stream
        in
          if c = NONE then
            (SeqStart, NONE, stream)
          else
            (SeqValue (ord $ Option.valOf c), NONE, stream)
        end
      else if mode = SpmStr then
          (SeqTerm, SOME $ StringConst "", stream)
      else
        raise seqExnConv SpmChr $ TkError (TkiDx 0, "expected value after %")
    | seqParser mode (SeqValue v) (stream, startOff) (SOME c) =
      if seqBound mode = c then
        let
          fun term s v =
            if mode = SpmChr then
              CharConst (s, v)
            else
              StringConst $ String.extract (s, 1, SOME $ String.size s - 2)
        in
          (SeqTerm, SOME $ term (finishSeqRead startOff stream) v, stream)
        end
      else if mode = SpmStr then
        let
          val (_, stream) =
            if c <> #"\\" then (SOME c, stream) else eatEscSeq stream
        in
          (SeqValue v, NONE, stream)
        end
      else
        raise seqExnConv SpmChr $ TkError (TkiDx 0, "expected % after value")
    | seqParser _ SeqTerm _ (SOME _) =
      raise Unreachable
    | seqParser mode state (_, _) NONE =
      raise case state of
        SeqInit => Unreachable
      | SeqStart => seqExnConv mode $ TkError (TkiStart, unfinishedSeq mode)
      | SeqValue _ =>
          seqExnConv mode $ TkError (TkiStart, unfinishedSeq mode)
      | SeqTerm => Unreachable

  val charParser = seqParser SpmChr
  val strParser = seqParser SpmStr

  fun formCppDir (Id s) =
  let
    open String
  in
    case List.find
      (fn (_, repr) =>
          sub (repr, 0) = cppPrefix andalso
              extract (repr, 1, NONE) = s)
      tokenRepr
    of
      SOME (tk, _) => tk
    | NONE => raise ExpectedCppDir
  end
    | formCppDir kwElse = CppElse
    | formCppDir _ = raise ExpectedCppDir

  fun handleCppDir tk prevPos stream =
  let
    val (pos, tk') = tk
  in
    (prevPos, formCppDir tk') handle
        ExpectedCppDir =>
           raise TkErrorAug (S.pos2ppos pos stream,
            "expected preprocessor directive")
  end

  fun unexpectedCharRaise stream c =
  let
    val pos = S.pos2ppos (S.getPosAfterCharRead stream) stream
    val repr =
      if isPrintable c then
        str c
      else
        "<" ^ Int.toString (ord c) ^ ">"
  in
        raise TkErrorAug (pos, "unexpected character " ^ repr)
  end

  fun skipComment stream pos =
  let
    fun skip prevIsAsterisk stream =
    let
      val (c, stream) =
        case S.getchar stream of
          (NONE, _) =>
            let
              val pos = S.pos2ppos pos stream
            in
                raise TkErrorAug (pos, "unfinished comment")
            end
       | (SOME c, stream) => (c, stream)
    in
      if prevIsAsterisk andalso c = #"/" then
        stream
      else
        skip (c = #"*") stream
    end
  in
    skip false stream
  end

  fun handleBackslash stream =
  let
    val (c, stream) = S.getchar stream

    val raiseErr = fn () =>
      let
          val pos = S.getPosAfterCharRead stream
          val pos = S.pos2ppos pos stream
      in
        raise TkErrorAug (pos, "expected \\n after backslash")
      end
  in
    case c of
      SOME c =>
        if c = #"\n" then
          stream
        else
          raiseErr ()
    | NONE => raiseErr ()
  end

  fun processSymbol stream =
  let
    val (T as (p, tk), stream) = fsmEat $ S.ungetc stream
  in
    case tk of
      CommentStart => getToken $ skipComment stream p
    | DoubleDot => (SOME (p, Dot), S.ungetc stream)
    | Hash =>
        if S.isFirstOnLine p stream then
          let
            val (tk, stream) = getToken stream
          in
            case tk of
              NONE =>
                raise TkErrorAug (S.pos2ppos p stream,
                    "unfinished preprecessor directive")
            | SOME tk =>
                (SOME $ handleCppDir tk p stream, stream)
          end
        else
          (SOME T, stream)
    | _ => (SOME T, stream)
  end

  and getToken stream =
  let
    val (c, stream) = S.getchar stream

    fun @-> parser acc =
      (fn (tk, s) => (SOME tk, s)) $ parserWrapper stream parser acc
  in
    case c of
      NONE => (NONE, stream)
    | SOME c =>
      if c = #"\n" then
        (SOME (S.getPosAfterCharRead stream, NewLine), stream)
      else if Char.isSpace c then
        getToken stream
      else if isIdStart c then
        @-> idParser ()
      else if isDigit c then
        @-> numParser NpInit
      else if c = #"'" then
        @-> charParser SeqInit
      else if c = #"\"" then
        @-> strParser SeqInit
      else if isStartForFsm c then
        processSymbol stream
      else if c = #"\\" then
        getToken $ handleBackslash stream
      else
        unexpectedCharRaise stream c
  end

  fun tokenize stream =
  let
    fun aux acc stream =
    let
      val (tk, stream) = getToken stream
    in
      case tk of
        NONE => rev acc
      | SOME tk => aux (tk :: acc) stream
    end
  in
    aux [] stream
  end

  fun debugPrint tkl fname =
  let
    fun print' line _ ((_, NewLine) :: tks) =
      print' (line + 1) true tks
      | print' line firstOnLine ((_, tk) :: tks) = (
        if firstOnLine then (
          print "\n";
          printLn $ fname ^ ":" ^ Int.toString line;
          print "\t")
        else
          ();
        printToken tk;
        print " ";
        print' line false tks
      )
      | print' _ _ [] = ()
  in
    print' 1 true tkl;
    print "\n"
  end
end