{
open Fnlib Memory Config Mixture Const Parser;

(* For Quote/Antiquote --- object language embedding. *)

val quotation = ref false

datatype lexingMode =
    NORMALlm
  | QUOTElm
  | ANTIQUOTElm

val lexingMode = ref NORMALlm

val parCount = Stack.new() : int Stack.t

fun resetLexerState() =
(
  lexingMode := NORMALlm;
  Stack.clear parCount
)

(* For nesting comments *)

val comment_depth = ref 0

(* The table of keywords *)

val keyword_table = (Hasht.new 53 : (string,token) Hasht.t)

val () =
List.app (fn (str,tok) => Hasht.insert keyword_table str tok)
[
  ("abstype",      ABSTYPE),
  ("and",          AND),
  ("andalso",      ANDALSO),
  ("as",           AS),
  ("case",         CASE),
  ("datatype",     DATATYPE),
  ("do",           DO),
  ("else",         ELSE),
  ("eqtype",       EQTYPE),
  ("end",          END),
  ("exception",    EXCEPTION),
  ("fn",           FN),
  ("fun",          FUN),
  ("functor",      FUNCTOR),
  ("handle",       HANDLE),
  ("if",           IF),
  ("in",           IN),
  ("include",      INCLUDE),
  ("infix",        INFIX),
  ("infixr",       INFIXR),
  ("let",          LET),
  ("local",        LOCAL),
  ("nonfix",       NONFIX),
  ("of",           OF),
  ("op",           OP),
  ("open",         OPEN),
  ("orelse",       ORELSE),
  ("prim_eqtype",  PRIM_EQTYPE),
  ("prim_EQtype",  PRIM_REFTYPE),
  ("prim_type",    PRIM_TYPE),
  ("prim_val",     PRIM_VAL),
  ("raise",        RAISE),
  ("rec",          REC),
  ("sharing",      SHARING),
  ("sig",          SIG),
  ("signature",    SIGNATURE),
  ("struct",       STRUCT),
  ("structure",    STRUCTURE),
  ("then",         THEN),
  ("type",         TYPE),
  ("val",          VAL),
  ("where",        WHERE),
  ("while",        WHILE),
  ("with",         WITH),
  ("withtype",     WITHTYPE),
  ("#",            HASH),
  ("->",           ARROW),
  ("|",            BAR),
  (":>",           COLONGT),
  (":",            COLON),
  ("=>",           DARROW),
  ("=",            EQUALS),
  ("*",            STAR)
]

fun mkKeyword lexbuf =
  let val s = getLexeme lexbuf in
    Hasht.find keyword_table s
    handle Subscript => ID s
  end

val savedLexemeStart = ref 0

val initial_string_buffer = CharArray.array(256, #"\000")
val string_buff = ref initial_string_buffer
val string_index = ref 0

fun reset_string_buffer() =
(
  string_buff := initial_string_buffer;
  string_index := 0;
  ()
)

fun store_string_char c =
  let open CharArray
      val len = length (!string_buff)
  in
    if !string_index >= len then
      let val new_buff = array(len * 2, #"\000") in
        copy
          { src = !string_buff, si = 0, len = NONE, dst = new_buff, di = 0 };
        string_buff := new_buff
      end
    else ();
    update(!string_buff, !string_index, c);
    incr string_index
  end

fun get_stored_string() =
  let open CharArray
      val s = extract(!string_buff, 0, SOME (!string_index))
  in
    string_buff := initial_string_buffer;
    s
  end

(*
fun splitQualId s =
  let open CharVector
      val len' = size s - 1
      fun parse n =
        if n >= len' then
          ("", s)
        else if sub(s, n) = #"." then
          ( normalizedUnitName (extract(s, 0, SOME n)),
            extract(s, n + 1, SOME(len' - n)) )
        else
          parse (n+1)
  in parse 0 end
*)

(* cvr: NOTE normalizeUnitName done elsewhere now *)
fun splitQualId s =
  let open CharVector
      val len' = size s
      fun parse i n acc =
        if n >= len' then
          (extract(s, i, SOME (len' - i)) :: acc)
        else if sub(s, n) = #"." then
          parse (n+1) (n+1) ((extract(s, i, SOME (n - i)))::acc)
        else
          parse i (n+1) acc
  in parse 0 0 [] end



fun mkQualId lexbuf =
  let val  id = splitQualId(getLexeme lexbuf) in
    if id = ["*"] then
      QUAL_STAR { qual="", id=id }
    else
      QUAL_ID   { qual="", id=id }
  end

fun charCodeOfDecimal lexbuf i =
  100 * (Char.ord(getLexemeChar lexbuf i) - 48) +
   10 * (Char.ord(getLexemeChar lexbuf (i+1)) - 48) +
        (Char.ord(getLexemeChar lexbuf (i+2)) - 48)


fun charCodeOfHexadecimal lexbuf i =
    let fun hexval c = 
	    if #"0" <= c andalso c <= #"9" then Char.ord c - 48
	    else (Char.ord c - 55) mod 32;
    in 
       4096 * hexval(getLexemeChar lexbuf (i+1)) +
        256 * hexval(getLexemeChar lexbuf (i+2)) +
         16 * hexval(getLexemeChar lexbuf (i+3)) +
              hexval(getLexemeChar lexbuf (i+4)) 
    end

fun lexError msg lexbuf =
(
  resetLexerState();
  raise LexicalError(msg, getLexemeStart lexbuf, getLexemeEnd lexbuf)
)

fun constTooLarge msg lexbuf =
(
  resetLexerState();
  lexError (msg ^ " constant is too large") lexbuf
)

prim_val sml_word_of_string    : string -> word = 1 "sml_word_of_dec"
prim_val sml_word_of_hexstring : string -> word = 1 "sml_word_of_hex"

fun notTerminated msg lexbuf =
(
  resetLexerState();
  raise LexicalError (msg ^ " not terminated",
                      !savedLexemeStart, getLexemeEnd lexbuf)
)

fun skipString msg skip lexbuf =
  let
    val pos1 = getLexemeStart lexbuf
    val pos2 = getLexemeEnd lexbuf
  in
    skip lexbuf;
    resetLexerState();
    raise (LexicalError(msg, pos1, pos2))
  end

fun scanString scan lexbuf =
(
  reset_string_buffer();
  savedLexemeStart := getLexemeStart lexbuf;
  scan lexbuf;
  setLexStartPos lexbuf (!savedLexemeStart - getLexAbsPos lexbuf)
)

}

rule Token = parse
    [^ `\000`-`\255`]
      { lexError "this will be never called!" lexbuf }
  | ""
      { case !lexingMode of
            NORMALlm =>
              TokenN lexbuf
          | QUOTElm =>
              (scanString Quotation lexbuf;
               case !lexingMode of
                   NORMALlm =>
                     QUOTER (get_stored_string())
                 | ANTIQUOTElm =>
                     QUOTEM (get_stored_string())
                 | QUOTElm =>
                     fatalError "Token")
          | ANTIQUOTElm =>
              AntiQuotation lexbuf
      }

and TokenN = parse
    [` ` `\n` `\r` `\t` `\^L`]  { TokenN lexbuf }
  | "(*"
      { savedLexemeStart := getLexemeStart lexbuf;
        comment_depth := 1; Comment lexbuf; TokenN lexbuf
      }
  | "*)"
      { lexError "unmatched comment bracket" lexbuf }
  | "'" [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]+
                { TYVAR   (getLexeme lexbuf) }
  | "0"         { ZDIGIT 0 }
  | [`1`-`9`]   { NZDIGIT   (sml_int_of_string(getLexeme lexbuf)) }
  | "0" [`0`-`9`]+
                { ZPOSINT2  (sml_int_of_string(getLexeme lexbuf))
                  handle Fail _ => constTooLarge "integer" lexbuf
                }
  | [`1`-`9`] [`0`-`9`]+
                { NZPOSINT2 (sml_int_of_string(getLexeme lexbuf))
                  handle Fail _ => constTooLarge "integer" lexbuf
                }
  | "~" [`0`-`9`]+
                { NEGINT    (sml_int_of_string(getLexeme lexbuf))
                  handle Fail _ => constTooLarge "integer" lexbuf
                }
  | "~"? "0x" [`0`-`9` `a`-`f` `A`-`F`]+
                { NEGINT    (sml_hex_of_string(getLexeme lexbuf))
                  handle Fail _ => constTooLarge "integer" lexbuf
                }
  | "0w" [`0`-`9`]+
                { WORD (sml_word_of_string(getLexeme lexbuf))
                  handle Fail _ => constTooLarge "word" lexbuf
                }
  | "0wx" [`0`-`9` `a`-`f` `A`-`F`]+
                { WORD (sml_word_of_hexstring(getLexeme lexbuf))
                  handle Fail _ => constTooLarge "word" lexbuf
                }
  | "~"? [`0`-`9`]+ (`.` [`0`-`9`]+)? ([`e` `E`] `~`? [`0`-`9`]+)?
                { REAL (sml_float_of_string (getLexeme lexbuf))
                  handle Fail _ => constTooLarge "real" lexbuf
                }
  | "\""
      { scanString String lexbuf;
        STRING (get_stored_string())
      }
  | "#\""
      { scanString String lexbuf;
        let val s = get_stored_string() in
          if size s <> 1 then
            lexError "ill-formed character constant" lexbuf
          else ();
          CHAR (CharVector.sub(s, 0))
        end }
  | "_"         { UNDERBAR }
  | ","         { COMMA }
  | "..."       { DOTDOTDOT }
  | "{"         { LBRACE }
  | "}"         { RBRACE }
  | "["         { LBRACKET }
  | "#["        { HASHLBRACKET }
  | "]"         { RBRACKET }
  | "("
     { if not(Stack.null parCount) then
         Stack.push (Stack.pop parCount + 1) parCount
       else ();
       LPAREN
     }
  | ")"
      { if not(Stack.null parCount) then
          let val count = Stack.pop parCount - 1 in
            if count = 0 then
              (lexingMode := QUOTElm; Token lexbuf)
            else
              (Stack.push count parCount; RPAREN)
          end
        else
          RPAREN
      }
  | ";"         { SEMICOLON }
  | (eof | `\^Z`) { EOF }
  | ""          { if !quotation then TokenIdQ lexbuf else TokenId lexbuf }

and TokenId = parse
    ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
    | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
       `~` `\`` `^` `|` `*`]+ )
      { mkKeyword lexbuf }
  | ((  [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
      | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
        `~` `\`` `^` `|` `*`]+ )
      ".")+
    ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
    | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
       `~` `\`` `^` `|` `*`]+ )
      { mkQualId lexbuf }
  | _
      { lexError "ill-formed token" lexbuf }

and TokenIdQ = parse
    ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
    | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
       `~` `^` `|` `*`]+ )
      { mkKeyword lexbuf }
  | ((  [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
      | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
        `~` `^` `|` `*`]+ )
     ".")+
    ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
    | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
       `~` `^` `|` `*`]+ )
      { mkQualId lexbuf }
  | "`"
      { lexingMode := QUOTElm; QUOTEL }
  | _
      { lexError "ill-formed token" lexbuf }

and Comment = parse
    "(*"
      { (incr comment_depth; Comment lexbuf) }
  | "*)"
      { (decr comment_depth;
         if !comment_depth > 0 then Comment lexbuf else ()) }
  | (eof | `\^Z`)
      { notTerminated "comment" lexbuf }
  | _
      { Comment lexbuf }

and String = parse
    `"`
      { () }
  | `\\` [`\\` `"` `a` `b` `t` `n` `v` `f` `r`]
      { store_string_char(char_for_backslash(getLexemeChar lexbuf 1));
        String lexbuf }
  | `\\` [` ` `\t` `\n` `\r`]+ `\\`
      { String lexbuf }
  | `\\` `^` [`@`-`_`]
      { store_string_char(
          Char.chr(Char.ord(getLexemeChar lexbuf 2) - 64));
        String lexbuf }
  | `\\` [`0`-`9`] [`0`-`9`] [`0`-`9`]
      { let val code = charCodeOfDecimal lexbuf 1 in
          if code >= 256 then
            skipString "character code is too large" SkipString lexbuf
          else ();
          store_string_char(Char.chr code);
          String lexbuf
        end }
  | "\\u" [`0`-`9``a`-`f``A`-`F`] [`0`-`9``a`-`f``A`-`F`] 
          [`0`-`9``a`-`f``A`-`F`] [`0`-`9``a`-`f``A`-`F`]
      { let val code = charCodeOfHexadecimal lexbuf 1 in
          if code >= 256 then
            skipString "character code is too large" SkipString lexbuf
          else ();
          store_string_char(Char.chr code);
          String lexbuf
        end }
  | `\\`
      { skipString "ill-formed escape sequence" SkipString lexbuf }
  | (eof | `\^Z`)
      { notTerminated "string" lexbuf }
  | [`\n` `\r`]
      { skipString "newline not permitted in string" SkipString lexbuf }
  | [`\^A`-`\^Z` `\127` `\255`]
      { skipString "invalid character in string" SkipString lexbuf }
  | _
      { (store_string_char(getLexemeChar lexbuf 0);
         String lexbuf) }

and SkipString = parse
    `"`
      { () }
  | `\\` [`\\` `"` `n` `t`]
      { SkipString lexbuf }
  | `\\` [` ` `\t` `\n` `\r`]+ `\\`
      { SkipString lexbuf }
  | (eof | `\^Z`)
      { notTerminated "string" lexbuf }
  | _
      { SkipString lexbuf }

and Quotation = parse
    "`"
      { lexingMode := NORMALlm }
  | `^`
      { lexingMode := ANTIQUOTElm }
  | `\r`
      { Quotation lexbuf }
  | [`\t` `\n`]
      { (store_string_char(getLexemeChar lexbuf 0);
         Quotation lexbuf) }
  | (eof | `\^Z`)
      { lexingMode := NORMALlm;
        notTerminated "quotation" lexbuf
      }
  | [`\^A`-`\^Z` `\127` `\255`]
      { skipString "invalid character in quotation" SkipQuotation lexbuf }
  | _
      { (store_string_char(getLexemeChar lexbuf 0);
         Quotation lexbuf) }

and SkipQuotation = parse
    "`"
      { lexingMode := NORMALlm }
  | (eof | `\^Z`)
      { lexingMode := NORMALlm;
        notTerminated "quotation" lexbuf
      }
  | _
      { SkipQuotation lexbuf }

and AntiQuotation = parse
    ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
    | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
       `~` `|` `*`]+ )
      { lexingMode := QUOTElm;
        mkKeyword lexbuf
      }
  | "("
      { Stack.push 1 parCount; lexingMode := NORMALlm;
        TokenN lexbuf
      }
  | "`"
      { lexingMode := NORMALlm;
        lexError "antiquotation is missing" lexbuf
      }
  | (eof | `\^Z`)
      { lexingMode := NORMALlm;
        notTerminated "antiquotation" lexbuf
      }
  | _
      { lexingMode := QUOTElm;
        lexError "ill-formed antiquotation" lexbuf
      }
;