home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Lexer.lex < prev    next >
Encoding:
Text File  |  1997-08-18  |  11.9 KB  |  440 lines  |  [TEXT/R*ch]
  1. {
  2. open Fnlib Memory Config Mixture Const Parser;
  3.  
  4. (* For Quote/Antiquote --- object language embedding. *)
  5.  
  6. val quotation = ref false
  7.  
  8. datatype lexingMode =
  9.     NORMALlm
  10.   | QUOTElm
  11.   | ANTIQUOTElm
  12.  
  13. val lexingMode = ref NORMALlm
  14.  
  15. val parCount = Stack.new() : int Stack.t
  16.  
  17. fun resetLexerState() =
  18. (
  19.   lexingMode := NORMALlm;
  20.   Stack.clear parCount
  21. )
  22.  
  23. (* For nesting comments *)
  24.  
  25. val comment_depth = ref 0
  26.  
  27. (* The table of keywords *)
  28.  
  29. val keyword_table = (Hasht.new 53 : (string,token) Hasht.t)
  30.  
  31. val () =
  32. List.app (fn (str,tok) => Hasht.insert keyword_table str tok)
  33. [
  34.   ("abstraction",  ABSTRACTION),
  35.   ("abstype",      ABSTYPE),
  36.   ("and",          AND),
  37.   ("andalso",      ANDALSO),
  38.   ("as",           AS),
  39.   ("case",         CASE),
  40.   ("datatype",     DATATYPE),
  41.   ("do",           DO),
  42.   ("else",         ELSE),
  43.   ("eqtype",       EQTYPE),
  44.   ("end",          END),
  45.   ("exception",    EXCEPTION),
  46.   ("fn",           FN),
  47.   ("fun",          FUN),
  48.   ("handle",       HANDLE),
  49.   ("if",           IF),
  50.   ("in",           IN),
  51.   ("infix",        INFIX),
  52.   ("infixr",       INFIXR),
  53.   ("let",          LET),
  54.   ("local",        LOCAL),
  55.   ("nonfix",       NONFIX),
  56.   ("of",           OF),
  57.   ("op",           OP),
  58.   ("open",         OPEN),
  59.   ("orelse",       ORELSE),
  60.   ("prim_eqtype",  PRIM_EQTYPE),
  61.   ("prim_EQtype",  PRIM_REFTYPE),
  62.   ("prim_type",    PRIM_TYPE),
  63.   ("prim_val",     PRIM_VAL),
  64.   ("raise",        RAISE),
  65.   ("rec",          REC),
  66.   ("sig",          SIG),
  67.   ("signature",    SIGNATURE),
  68.   ("struct",       STRUCT),
  69.   ("structure",    STRUCTURE),
  70.   ("then",         THEN),
  71.   ("type",         TYPE),
  72.   ("val",          VAL),
  73.   ("while",        WHILE),
  74.   ("with",         WITH),
  75.   ("withtype",     WITHTYPE),
  76.   ("#",            HASH),
  77.   ("->",           ARROW),
  78.   ("|",            BAR),
  79.   (":",            COLON),
  80.   (":>",           COLONGT),
  81.   ("=>",           DARROW),
  82.   ("=",            EQUALS),
  83.   ("*",            STAR)
  84. ]
  85.  
  86. fun mkKeyword lexbuf =
  87.   let val s = getLexeme lexbuf in
  88.     Hasht.find keyword_table s
  89.     handle Subscript => ID s
  90.   end
  91.  
  92. val savedLexemeStart = ref 0
  93.  
  94. val initial_string_buffer = CharArray.array(256, #"\000")
  95. val string_buff = ref initial_string_buffer
  96. val string_index = ref 0
  97.  
  98. fun reset_string_buffer() =
  99. (
  100.   string_buff := initial_string_buffer;
  101.   string_index := 0;
  102.   ()
  103. )
  104.  
  105. fun store_string_char c =
  106.   let open CharArray
  107.       val len = length (!string_buff)
  108.   in
  109.     if !string_index >= len then
  110.       let val new_buff = array(len * 2, #"\000") in
  111.         copy
  112.           { src = !string_buff, si = 0, len = NONE, dst = new_buff, di = 0 };
  113.         string_buff := new_buff
  114.       end
  115.     else ();
  116.     update(!string_buff, !string_index, c);
  117.     incr string_index
  118.   end
  119.  
  120. fun get_stored_string() =
  121.   let open CharArray
  122.       val s = extract(!string_buff, 0, SOME (!string_index))
  123.   in
  124.     string_buff := initial_string_buffer;
  125.     s
  126.   end
  127.  
  128. fun splitQualId s =
  129.   let open CharVector
  130.       val len' = size s - 1
  131.       fun parse n =
  132.         if n >= len' then
  133.           ("", s)
  134.         else if sub(s, n) = #"." then
  135.           ( normalizedUnitName (extract(s, 0, SOME n)),
  136.             extract(s, n + 1, SOME(len' - n)) )
  137.         else
  138.           parse (n+1)
  139.   in parse 0 end
  140.  
  141. fun mkQualId lexbuf =
  142.   let val (qual, id) = splitQualId(getLexeme lexbuf) in
  143.     if id = "*" then
  144.       QUAL_STAR { qual=qual, id=id }
  145.     else
  146.       QUAL_ID   { qual=qual, id=id }
  147.   end
  148.  
  149. fun charCodeOfDecimal lexbuf i =
  150.   100 * (Char.ord(getLexemeChar lexbuf i) - 48) +
  151.    10 * (Char.ord(getLexemeChar lexbuf (i+1)) - 48) +
  152.         (Char.ord(getLexemeChar lexbuf (i+2)) - 48)
  153.  
  154. fun lexError msg lexbuf =
  155. (
  156.   resetLexerState();
  157.   raise LexicalError(msg, getLexemeStart lexbuf, getLexemeEnd lexbuf)
  158. )
  159.  
  160. fun constTooLarge msg lexbuf =
  161. (
  162.   resetLexerState();
  163.   lexError (msg ^ " constant is too large") lexbuf
  164. )
  165.  
  166. prim_val sml_word_of_string    : string -> word = 1 "sml_word_of_dec"
  167. prim_val sml_word_of_hexstring : string -> word = 1 "sml_word_of_hex"
  168.  
  169. fun notTerminated msg lexbuf =
  170. (
  171.   resetLexerState();
  172.   raise LexicalError (msg ^ " not terminated",
  173.                       !savedLexemeStart, getLexemeEnd lexbuf)
  174. )
  175.  
  176. fun skipString msg skip lexbuf =
  177.   let
  178.     val pos1 = getLexemeStart lexbuf
  179.     val pos2 = getLexemeEnd lexbuf
  180.   in
  181.     skip lexbuf;
  182.     resetLexerState();
  183.     raise (LexicalError(msg, pos1, pos2))
  184.   end
  185.  
  186. fun scanString scan lexbuf =
  187. (
  188.   reset_string_buffer();
  189.   savedLexemeStart := getLexemeStart lexbuf;
  190.   scan lexbuf;
  191.   setLexStartPos lexbuf (!savedLexemeStart - getLexAbsPos lexbuf)
  192. )
  193.  
  194. }
  195.  
  196. rule Token = parse
  197.     [^ `\000`-`\255`]
  198.       { lexError "this will be never called!" lexbuf }
  199.   | ""
  200.       { case !lexingMode of
  201.             NORMALlm =>
  202.               TokenN lexbuf
  203.           | QUOTElm =>
  204.               (scanString Quotation lexbuf;
  205.                case !lexingMode of
  206.                    NORMALlm =>
  207.                      QUOTER (get_stored_string())
  208.                  | ANTIQUOTElm =>
  209.                      QUOTEM (get_stored_string())
  210.                  | QUOTElm =>
  211.                      fatalError "Token")
  212.           | ANTIQUOTElm =>
  213.               AntiQuotation lexbuf
  214.       }
  215.  
  216. and TokenN = parse
  217.     [` ` `\n` `\r` `\t` `\^L`]  { TokenN lexbuf }
  218.   | "(*"
  219.       { savedLexemeStart := getLexemeStart lexbuf;
  220.         comment_depth := 1; Comment lexbuf; TokenN lexbuf
  221.       }
  222.   | "*)"
  223.       { lexError "unmatched comment bracket" lexbuf }
  224.   | "'" [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]+
  225.                 { TYVAR   (getLexeme lexbuf) }
  226.   | "0"         { ZDIGIT 0 }
  227.   | [`1`-`9`]   { NZDIGIT   (sml_int_of_string(getLexeme lexbuf)) }
  228.   | "0" [`0`-`9`]+
  229.                 { ZPOSINT2  (sml_int_of_string(getLexeme lexbuf))
  230.                   handle Fail _ => constTooLarge "integer" lexbuf
  231.                 }
  232.   | [`1`-`9`] [`0`-`9`]+
  233.                 { NZPOSINT2 (sml_int_of_string(getLexeme lexbuf))
  234.                   handle Fail _ => constTooLarge "integer" lexbuf
  235.                 }
  236.   | "~" [`0`-`9`]+
  237.                 { NEGINT    (sml_int_of_string(getLexeme lexbuf))
  238.                   handle Fail _ => constTooLarge "integer" lexbuf
  239.                 }
  240.   | "~"? "0x" [`0`-`9` `a`-`f` `A`-`F`]+
  241.                 { NEGINT    (sml_hex_of_string(getLexeme lexbuf))
  242.                   handle Fail _ => constTooLarge "integer" lexbuf
  243.                 }
  244.   | "0w" [`0`-`9`]+
  245.                 { WORD (sml_word_of_string(getLexeme lexbuf))
  246.                   handle Fail _ => constTooLarge "word" lexbuf
  247.                 }
  248.   | "0wx" [`0`-`9` `a`-`f` `A`-`F`]+
  249.                 { WORD (sml_word_of_hexstring(getLexeme lexbuf))
  250.                   handle Fail _ => constTooLarge "word" lexbuf
  251.                 }
  252.   | "~"? [`0`-`9`]+ (`.` [`0`-`9`]+)? ([`e` `E`] `~`? [`0`-`9`]+)?
  253.                 { REAL (sml_float_of_string (getLexeme lexbuf))
  254.                   handle Fail _ => constTooLarge "real" lexbuf
  255.                 }
  256.   | "\""
  257.       { scanString String lexbuf;
  258.         STRING (get_stored_string())
  259.       }
  260.   | "#\""
  261.       { scanString String lexbuf;
  262.         let val s = get_stored_string() in
  263.           if size s <> 1 then
  264.             lexError "ill-formed character constant" lexbuf
  265.           else ();
  266.           CHAR (CharVector.sub(s, 0))
  267.         end }
  268.   | "_"         { UNDERBAR }
  269.   | ","         { COMMA }
  270.   | "..."       { DOTDOTDOT }
  271.   | "{"         { LBRACE }
  272.   | "}"         { RBRACE }
  273.   | "["         { LBRACKET }
  274.   | "#["        { HASHLBRACKET }
  275.   | "]"         { RBRACKET }
  276.   | "("
  277.      { if not(Stack.null parCount) then
  278.          Stack.push (Stack.pop parCount + 1) parCount
  279.        else ();
  280.        LPAREN
  281.      }
  282.   | ")"
  283.       { if not(Stack.null parCount) then
  284.           let val count = Stack.pop parCount - 1 in
  285.             if count = 0 then
  286.               (lexingMode := QUOTElm; Token lexbuf)
  287.             else
  288.               (Stack.push count parCount; RPAREN)
  289.           end
  290.         else
  291.           RPAREN
  292.       }
  293.   | ";"         { SEMICOLON }
  294.   | (eof | `\^Z`) { EOF }
  295.   | ""          { if !quotation then TokenIdQ lexbuf else TokenId lexbuf }
  296.  
  297. and TokenId = parse
  298.     ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  299.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  300.        `~` `\`` `^` `|` `*`]+ )
  301.       { mkKeyword lexbuf }
  302.   | ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  303.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  304.        `~` `\`` `^` `|` `*`]+ )
  305.     "."
  306.     ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  307.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  308.        `~` `\`` `^` `|` `*`]+ )
  309.       { mkQualId lexbuf }
  310.   | _
  311.       { lexError "ill-formed token" lexbuf }
  312.  
  313. and TokenIdQ = parse
  314.     ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  315.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  316.        `~` `^` `|` `*`]+ )
  317.       { mkKeyword lexbuf }
  318.   | ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  319.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  320.        `~` `^` `|` `*`]+ )
  321.     "."
  322.     ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  323.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  324.        `~` `^` `|` `*`]+ )
  325.       { mkQualId lexbuf }
  326.   | "`"
  327.       { lexingMode := QUOTElm; QUOTEL }
  328.   | _
  329.       { lexError "ill-formed token" lexbuf }
  330.  
  331. and Comment = parse
  332.     "(*"
  333.       { (incr comment_depth; Comment lexbuf) }
  334.   | "*)"
  335.       { (decr comment_depth;
  336.          if !comment_depth > 0 then Comment lexbuf else ()) }
  337.   | (eof | `\^Z`)
  338.       { notTerminated "comment" lexbuf }
  339.   | _
  340.       { Comment lexbuf }
  341.  
  342. and String = parse
  343.     `"`
  344.       { () }
  345.   | `\\` [`\\` `"` `a` `b` `t` `n` `v` `f` `r`]
  346.       { store_string_char(char_for_backslash(getLexemeChar lexbuf 1));
  347.         String lexbuf }
  348.   | `\\` [` ` `\t` `\n` `\r`]+ `\\`
  349.       { String lexbuf }
  350.   | `\\` `^` [`@`-`_`]
  351.       { store_string_char(
  352.           Char.chr(Char.ord(getLexemeChar lexbuf 2) - 64));
  353.         String lexbuf }
  354.   | `\\` [`0`-`9`] [`0`-`9`] [`0`-`9`]
  355.       { let val code = charCodeOfDecimal lexbuf 1 in
  356.           if code >= 256 then
  357.             skipString "character code is too large" SkipString lexbuf
  358.           else ();
  359.           store_string_char(Char.chr code);
  360.           String lexbuf
  361.         end }
  362.   | `\\`
  363.       { skipString "ill-formed escape sequence" SkipString lexbuf }
  364.   | (eof | `\^Z`)
  365.       { notTerminated "string" lexbuf }
  366.   | [`\n` `\r`]
  367.       { skipString "newline not permitted in string" SkipString lexbuf }
  368.   | [`\^A`-`\^Z` `\127` `\255`]
  369.       { skipString "invalid character in string" SkipString lexbuf }
  370.   | _
  371.       { (store_string_char(getLexemeChar lexbuf 0);
  372.          String lexbuf) }
  373.  
  374. and SkipString = parse
  375.     `"`
  376.       { () }
  377.   | `\\` [`\\` `"` `n` `t`]
  378.       { SkipString lexbuf }
  379.   | `\\` [` ` `\t` `\n` `\r`]+ `\\`
  380.       { SkipString lexbuf }
  381.   | (eof | `\^Z`)
  382.       { notTerminated "string" lexbuf }
  383.   | _
  384.       { SkipString lexbuf }
  385.  
  386. and Quotation = parse
  387.     "`"
  388.       { lexingMode := NORMALlm }
  389.   | `^`
  390.       { lexingMode := ANTIQUOTElm }
  391.   | `\r`
  392.       { Quotation lexbuf }
  393.   | [`\t` `\n`]
  394.       { (store_string_char(getLexemeChar lexbuf 0);
  395.          Quotation lexbuf) }
  396.   | (eof | `\^Z`)
  397.       { lexingMode := NORMALlm;
  398.         notTerminated "quotation" lexbuf
  399.       }
  400.   | [`\^A`-`\^Z` `\127` `\255`]
  401.       { skipString "invalid character in quotation" SkipQuotation lexbuf }
  402.   | _
  403.       { (store_string_char(getLexemeChar lexbuf 0);
  404.          Quotation lexbuf) }
  405.  
  406. and SkipQuotation = parse
  407.     "`"
  408.       { lexingMode := NORMALlm }
  409.   | (eof | `\^Z`)
  410.       { lexingMode := NORMALlm;
  411.         notTerminated "quotation" lexbuf
  412.       }
  413.   | _
  414.       { SkipQuotation lexbuf }
  415.  
  416. and AntiQuotation = parse
  417.     ( [`A`-`Z` `a`-`z`] [ `A`-`Z` `a`-`z` `0`-`9` `_` `'`]*
  418.     | [`!` `%` `&` `$` `#` `+` `-` `/` `:` `<` `=` `>` `?` `@` `\\`
  419.        `~` `|` `*`]+ )
  420.       { lexingMode := QUOTElm;
  421.         mkKeyword lexbuf
  422.       }
  423.   | "("
  424.       { Stack.push 1 parCount; lexingMode := NORMALlm;
  425.         TokenN lexbuf
  426.       }
  427.   | "`"
  428.       { lexingMode := NORMALlm;
  429.         lexError "antiquotation is missing" lexbuf
  430.       }
  431.   | (eof | `\^Z`)
  432.       { lexingMode := NORMALlm;
  433.         notTerminated "antiquotation" lexbuf
  434.       }
  435.   | _
  436.       { lexingMode := QUOTElm;
  437.         lexError "ill-formed antiquotation" lexbuf
  438.       }
  439. ;
  440.