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 |
    MacroEnd of string |

    Num of numConst |

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

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

    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 |

    PpcInclude of string * string |
    PpcDefine |
    PpcUndef |
    PpcIf |
    PpcIfdef |
    PpcIfndef |
    PpcElse |
    PpcElif |
    PpcEndif |
    PpcWarning |
    PpcError |
    PpcPragma

  datatype tkErrorAuxInfo = TkiEOF | TkiDx of int | TkiStart

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

  exception FsmTableIsTooSmall

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

  val kwPrefix  = #"`"
  val ppcPrefix = #"$"
  val otherPrefix = #"@"

  val tokenRepr =
  let
    fun & repr = str kwPrefix ^ repr
    fun % repr = str ppcPrefix ^ repr
    fun ` repr = str otherPrefix ^ repr
  in
    [
      (NewLine, `"NewLine"),
      (EOS, `"EOS"),
      (Invalid, `"Invalid"),

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

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

      (PpcDefine, %"define"),
      (PpcUndef, %"undef"),
      (PpcIf, %"if"),
      (PpcIfdef, %"ifdef"),
      (PpcIfndef, %"ifndef"),
      (PpcElse, %"else"),
      (PpcElif, %"elif"),
      (PpcEndif, %"endif"),
      (PpcWarning, %"warning"),
      (PpcError, %"error"),
      (PpcPragma, %"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)

  fun printToken (out, tk) =
    case tk of
      Id s => Printf out `s %
    | MacroEnd macro => Printf out `"mend(" `macro `")" %
    | NewLine => Printf out `"\\n" %
    | PpcInclude (dir, arg) =>
        Printf out `"#include(" `dir `", " `arg `")" %
    | Num (IntConst (it, str, sfx)) =>
      let
        val intType =
          case it of
            ItDec => ""
          | ItOct => "0"
          | ItHex => "0x"
      in
        Printf out `intType `str  `(getSfxReprSimple sfx intSuffixRepr) %
      end
    | Num (FloatConst (str, sfx)) =>
        Printf out `str `(getSfxReprSimple sfx floatSuffixRepr) %
    | CharConst (repr, _) => Printf out `repr %
    | StringConst s => Printf out `"\"" `s `"\"" %
    | v =>
      case List.find (fn (x, _) => x = v) tokenRepr of
      SOME (_, repr) =>
      let
        val head = String.sub (repr, 0)
        val head = if head = ppcPrefix then #"#" else head
        val tail = String.extract (repr, 1, NONE)
      in
        Printf out C head `tail %
      end
      | NONE => raise TokenWithoutRepr

  val Ptk = fn z => bind A1 printToken z

  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 (_, repr) =>
                let
                  val c = String.sub (repr, 0)
                in
                  c <> kwPrefix andalso c <> ppcPrefix
                    andalso c <> otherPrefix
                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
      printf `"note: Fsm table size can be smaller: "
            I (!nextState) `" is enough" %
    else ();
    T
  end

  fun printTable (nextState, buf) =
  let
    open Array
    fun printRow i row =
      if i = length row then
        printf `"\n" %
      else
        let
          val state = sub (row, i)
        in
          if state = ~1 then
            ()
          else
            printf C (chr i) `" -> " I state `", " %;
            printRow (i + 1) row
        end

    fun print' rowNum buf =
      if rowNum = !nextState then
        ()
      else
        let
          val (tk, row) = sub (buf, rowNum)
        in
          printf `"row " I rowNum `" - " Ptk tk `": \t" %;
          printRow 0 row;
          print' (rowNum + 1) buf
        end
  in
    printf `"FSM table:\n";
    printf `"NextState: " I (!nextState) `"\n" %;
    print' 0 buf;
    printf `"\n" %
  end

  val fsmTable = lazy fsmTableCreate

  fun fsmEat stream =
  let
    open Array
    val (pos, stream) = 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
    val (tk, stream) = get 0 stream
  in
    (tk, pos, stream)
  end

  fun tkError2aug stream (dx, msg) =
  let
    val off = S.getOffset stream - 1 + dx
    val (pos, _) = S.getPosRaw off stream
  in
    TkErrorAug (pos, msg)
  end

  fun parserWrapper stream parser acc =
  let
    val stream = S.ungetc stream

    val startOff = S.getOffset stream
    val (pos, stream) = 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) => raise TkErrorAug (pos, msg)
        | TkError (TkiEOF, msg) =>
            let
              val (pos, _) = S.EOFpos 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
    (tk, pos, stream)
  end

  fun finishSeqRead startOff stream =
    S.getSubstr startOff (S.getOffset stream) stream

  fun keywordHashtableGen () =
  let
    val table = H.createLog 7
    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 getDir stream = OS.Path.getParent o S.getFname $ stream

  fun completePpcInclude (S.Pos (fname, line, _)) stream =
  let
    val pos = S.Pos (fname, line, 1)
    val (line, stream) = S.getLine stream
  in
    case line of
      SOME line => (PpcInclude (getDir stream, line), stream)
    | NONE => raise TkErrorAug (pos, "line does not end with '\n'\n")
  end

  fun isPpcDir (PpcInclude _) = true
    | isPpcDir tk =
      case List.find (fn (tk', _) => tk' = tk) tokenRepr of
        SOME (_, repr) => String.sub (repr, 0) = ppcPrefix
      | NONE => false

  fun handlePpcDir (tk, pos) stream =
  let
    open String
    fun error () =
      raise TkErrorAug (pos, "expected preprocessor directive")

    fun getById id =
    let
      fun right repr =
        sub (repr, 0) = ppcPrefix andalso extract (repr, 1, NONE) = id
    in
      case List.find (fn (_, repr) => right repr) tokenRepr of
        SOME (tk, _) => (tk, stream)
      | NONE =>
          if id = "include" then
            completePpcInclude pos stream
          else
            error ()
    end
  in
    case tk of
      Id id => getById id
    | kwElse => (PpcElse, stream)
    | kwIf => (PpcIf, stream)
    | _ => error ()
  end

  (*
  fun formPpcDir (Id s)  =
  let
    open String
  in
    case List.find
      (fn (_, repr) =>
          sub (repr, 0) = ppcPrefix andalso
              extract (repr, 1, NONE) = s)
      tokenRepr
    of
      SOME (tk, _) => tk
    | NONE => raise ExpectedPpcDir
  end
    | formPpcDir kwElse = PpcElse
    | formPpcDir kwIf = PpcIf
    | formPpcDir _ = raise ExpectedPpcDir

  fun handlePpcDir (pos, tk) stream =
    formPpcDir tk stream handle ExpectedPpcDir =>
           raise TkErrorAug (pos, "expected preprocessor directive")
  *)

  fun unexpectedCharRaise stream c =
  let
    val (pos, _) = S.getPosAfterChar 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, _) => raise TkErrorAug (pos, "unfinished comment")
         | (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.getPosAfterChar 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 (tk, pos, stream) = fsmEat $ S.ungetc stream
  in
    case tk of
      CommentStart => getToken $ skipComment stream pos
    | DoubleDot => (Dot, pos, S.ungetc stream)
    | Hash =>
        if S.isFirstOnLine stream (S.getOffset stream - 1) then
          let
            val (tk, pos', stream) = getToken stream
          in
            if tk = EOS then
              raise TkErrorAug (pos, "unfinished preprecessor directive")
            else
              let
                val (tk, stream) = handlePpcDir (tk, pos') stream
              in
                (tk, pos, stream)
              end
          end
        else
          (tk, pos, stream)
    | _ => (tk, pos, stream)
  end

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

    fun conv tk (pos, stream) = (tk, pos, stream)
    fun @-> parser acc = parserWrapper stream parser acc
  in
    case c of
      NONE => conv EOS $ S.EOFpos stream
    | SOME c =>
      if c = #"\n" then
        conv NewLine $ S.getPosAfterChar 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 debugPrint fname =
  let
    val stream = S.create fname

    fun print line stream =
    let
      val (tk, S.Pos (_, line', col'), stream) = getToken stream
    in
      if line <> line' then
        printf `"\nline " I line' `": \t" %
      else
        ();
      printf I col' `":" Ptk tk `" ";
      if tk = EOS then
        ()
      else
        print line' stream
    end
  in
    printTable $ fsmTable ();
    printf `"Tokenizing file: " `fname;
    print 0 stream;
    printf `"\n" %
  end
end