path: root/tokenizer.sml

structure Tokenizer:> TOKENIZER = struct
  datatype token =
      Invalid |
      Number of string |
      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 = Stream.pos * token

  datatype tkErrorAuxInfo = TkiEOF | TkiDx of int | TkiStart

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

  exception ExpectedCppDir (* handled in postprocess *)

  exception FsmTableIsTooSmall

  (* Unreachable (should be) *)
  exception TokenWithoutRepr

  val tokenRepr =
  let
    fun & repr = str kwPrefix ^ repr
    fun % repr = str cppPrefix ^ repr
  in
    [
      (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 printToken = fn
     Number s => printLn $ "Num: " ^ s
    | Id s => printLn $ "Id: " ^ s
    | CharConst (repr, _) => printLn repr
    | StringConst s =>
        printLn $ "\"" ^ s ^ "\""
    | v =>
      case List.find (fn (x, _) => x = v) tokenRepr of
      SOME (_, repr) => printLn repr
      | NONE => raise TokenWithoutRepr

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

  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 <> 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 (_, 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 = Stream.getPos stream

    fun get curState stream =
    let
      val (c, stream) = Stream.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, Stream.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) = Stream.getPosAfterCharRead stream
    val pos = Stream.pos2ppos (id, pos + dx) stream
  in
    TkErrorAug (pos, msg)
  end

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

    fun parse' stream acc = let
      val (c, stream) = Stream.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 = Stream.pos2ppos P stream
            in
              raise TkErrorAug (startPos, msg)
            end
        | TkError (TkiEOF, msg) =>
            let
              open Stream
              val pos = pposWithoutCol $ 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) = Stream.getPos stream
    val s = Stream.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 (Stream.ungetc stream)
  end

  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 Char.isDigit c then
          ((), NONE, stream)
        else
          finalize (Stream.ungetc stream)
  end

  fun isOctal c = ord c >= ord #"0" andalso ord c < ord #"8"

  fun chrIntVal c =
    if Char.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) = Stream.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, Stream.ungetc stream)
        end
  in
    follow stream (chrIntVal c) 1
  end

  fun parseHexSeq stream =
  let
    fun follow stream acc count =
      let
        val (c, stream) = Stream.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 Char.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, Stream.ungetc stream)
      end
  in
    follow stream 0 0
  end

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

    val (c, stream) = Stream.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

  fun stringCut s = String.extract (s, 1, SOME $ String.size s - 2)

  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 $ stringCut s
        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 (Stream.pos2ppos pos stream,
            "expected preprocessor directive")
  end

  fun unexpectedCharRaise stream c =
  let
    open Stream
    val pos = pos2ppos (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 Stream.getchar stream of
          (NONE, _) =>
            let
              val pos = Stream.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) = Stream.getchar stream

    val raiseErr = fn () =>
      let
          val pos = Stream.getPosAfterCharRead stream
          val pos = Stream.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 $ Stream.ungetc stream
  in
    case tk of
      CommentStart => getToken $ skipComment stream p
    | DoubleDot => (SOME (p, Dot), Stream.ungetc stream)
    | Hash =>
        if Stream.isFirstOnLine p stream then
          let
            val (tk, stream) = getToken stream
          in
            case tk of
              NONE =>
                raise TkErrorAug (Stream.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) = Stream.getchar stream

    fun @-> parser acc =
      (fn (tk, s) => (SOME tk, s)) $ parseGeneric stream parser acc
  in
    case c of
      NONE => (NONE, stream)
    | SOME c =>
      if Char.isSpace c then
        getToken stream
      else if isIdStart c then
        @-> idParser ()
      else if Char.isDigit c then
        @-> numParser ()
      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

end