l4/pkg/ocaml/ocaml/contrib/tools/lexer301.mll

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: lexer301.mll 6720 2004-11-30 18:57:04Z doligez $ *)
  14
  15 (* The lexer definition *)
  16
  17 {
  18 open Misc
  19
  20 type token =
  21     AMPERAMPER
  22   | AMPERSAND
  23   | AND
  24   | AS
  25   | ASSERT
  26   | BACKQUOTE
  27   | BAR
  28   | BARBAR
  29   | BARRBRACKET
  30   | BEGIN
  31   | CHAR of (char)
  32   | CLASS
  33   | COLON
  34   | COLONCOLON
  35   | COLONEQUAL
  36   | COLONGREATER
  37   | COMMA
  38   | CONSTRAINT
  39   | DO
  40   | DONE
  41   | DOT
  42   | DOTDOT
  43   | DOWNTO
  44   | ELSE
  45   | END
  46   | EOF
  47   | EQUAL
  48   | EXCEPTION
  49   | EXTERNAL
  50   | FALSE
  51   | FLOAT of (string)
  52   | FOR
  53   | FUN
  54   | FUNCTION
  55   | FUNCTOR
  56   | GREATER
  57   | GREATERRBRACE
  58   | GREATERRBRACKET
  59   | IF
  60   | IN
  61   | INCLUDE
  62   | INFIXOP0 of (string)
  63   | INFIXOP1 of (string)
  64   | INFIXOP2 of (string)
  65   | INFIXOP3 of (string)
  66   | INFIXOP4 of (string)
  67   | INHERIT
  68   | INITIALIZER
  69   | INT of (int)
  70   | LABEL of (string)
  71   | LAZY
  72   | LBRACE
  73   | LBRACELESS
  74   | LBRACKET
  75   | LBRACKETBAR
  76   | LBRACKETLESS
  77   | LESS
  78   | LESSMINUS
  79   | LET
  80   | LIDENT of (string)
  81   | LPAREN
  82   | MATCH
  83   | METHOD
  84   | MINUS
  85   | MINUSDOT
  86   | MINUSGREATER
  87   | MODULE
  88   | MUTABLE
  89   | NEW
  90   | OBJECT
  91   | OF
  92   | OPEN
  93   | OPTLABEL of (string)
  94   | OR
  95   | PARSER
  96   | PLUS
  97   | PREFIXOP of (string)
  98   | PRIVATE
  99   | QUESTION
 100   | QUESTION2
 101   | QUOTE
 102   | RBRACE
 103   | RBRACKET
 104   | REC
 105   | RPAREN
 106   | SEMI
 107   | SEMISEMI
 108   | SHARP
 109   | SIG
 110   | STAR
 111   | STRING of (string)
 112   | STRUCT
 113   | THEN
 114   | TILDE
 115   | TO
 116   | TRUE
 117   | TRY
 118   | TYPE
 119   | UIDENT of (string)
 120   | UNDERSCORE
 121   | VAL
 122   | VIRTUAL
 123   | WHEN
 124   | WHILE
 125   | WITH
 126
 127 type error =
 128   | Illegal_character of char
 129   | Unterminated_comment
 130   | Unterminated_string
 131   | Unterminated_string_in_comment
 132   | Keyword_as_label of string
 133 ;;
 134
 135 exception Error of error * int * int
 136
 137 (* The table of keywords *)
 138
 139 let keyword_table =
 140   create_hashtable 149 [
 141     "and", AND;
 142     "as", AS;
 143     "assert", ASSERT;
 144     "begin", BEGIN;
 145     "class", CLASS;
 146     "constraint", CONSTRAINT;
 147     "do", DO;
 148     "done", DONE;
 149     "downto", DOWNTO;
 150     "else", ELSE;
 151     "end", END;
 152     "exception", EXCEPTION;
 153     "external", EXTERNAL;
 154     "false", FALSE;
 155     "for", FOR;
 156     "fun", FUN;
 157     "function", FUNCTION;
 158     "functor", FUNCTOR;
 159     "if", IF;
 160     "in", IN;
 161     "include", INCLUDE;
 162     "inherit", INHERIT;
 163     "initializer", INITIALIZER;
 164     "lazy", LAZY;
 165     "let", LET;
 166     "match", MATCH;
 167     "method", METHOD;
 168     "module", MODULE;
 169     "mutable", MUTABLE;
 170     "new", NEW;
 171     "object", OBJECT;
 172     "of", OF;
 173     "open", OPEN;
 174     "or", OR;
 175     "parser", PARSER;
 176     "private", PRIVATE;
 177     "rec", REC;
 178     "sig", SIG;
 179     "struct", STRUCT;
 180     "then", THEN;
 181     "to", TO;
 182     "true", TRUE;
 183     "try", TRY;
 184     "type", TYPE;
 185     "val", VAL;
 186     "virtual", VIRTUAL;
 187     "when", WHEN;
 188     "while", WHILE;
 189     "with", WITH;
 190
 191     "mod", INFIXOP3("mod");
 192     "land", INFIXOP3("land");
 193     "lor", INFIXOP3("lor");
 194     "lxor", INFIXOP3("lxor");
 195     "lsl", INFIXOP4("lsl");
 196     "lsr", INFIXOP4("lsr");
 197     "asr", INFIXOP4("asr")
 198 ]
 199
 200 (* To buffer string literals *)
 201
 202 let initial_string_buffer = String.create 256
 203 let string_buff = ref initial_string_buffer
 204 let string_index = ref 0
 205
 206 let reset_string_buffer () =
 207   string_buff := initial_string_buffer;
 208   string_index := 0
 209
 210 let store_string_char c =
 211   if !string_index >= String.length (!string_buff) then begin
 212     let new_buff = String.create (String.length (!string_buff) * 2) in
 213       String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff));
 214       string_buff := new_buff
 215   end;
 216   String.unsafe_set (!string_buff) (!string_index) c;
 217   incr string_index
 218
 219 let get_stored_string () =
 220   let s = String.sub (!string_buff) 0 (!string_index) in
 221   string_buff := initial_string_buffer;
 222   s
 223
 224 (* To translate escape sequences *)
 225
 226 let char_for_backslash = function
 227   | 'n' -> '\010'
 228   | 'r' -> '\013'
 229   | 'b' -> '\008'
 230   | 't' -> '\009'
 231   | c   -> c
 232
 233 let char_for_decimal_code lexbuf i =
 234   let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
 235            10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
 236                 (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in
 237   Char.chr(c land 0xFF)
 238
 239 (* To store the position of the beginning of a string and comment *)
 240 let string_start_pos = ref 0;;
 241 let comment_start_pos = ref [];;
 242 let in_comment () = !comment_start_pos <> [];;
 243
 244 (* Error report *)
 245
 246 open Format
 247
 248 let report_error ppf = function
 249   | Illegal_character c ->
 250       fprintf ppf "Illegal character (%s)" (Char.escaped c)
 251   | Unterminated_comment ->
 252       fprintf ppf "Comment not terminated"
 253   | Unterminated_string ->
 254       fprintf ppf "String literal not terminated"
 255   | Unterminated_string_in_comment ->
 256       fprintf ppf "This comment contains an unterminated string literal"
 257   | Keyword_as_label kwd ->
 258       fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
 259 ;;
 260
 261 }
 262
 263 let blank = [' ' '\010' '\013' '\009' '\012']
 264 let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
 265 let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
 266 let identchar =
 267   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 268 let symbolchar =
 269   ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
 270 let decimal_literal = ['0'-'9']+
 271 let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
 272 let oct_literal = '0' ['o' 'O'] ['0'-'7']+
 273 let bin_literal = '0' ['b' 'B'] ['0'-'1']+
 274 let float_literal =
 275   ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
 276
 277 rule token = parse
 278     blank +
 279       { token lexbuf }
 280   | "_"
 281       { UNDERSCORE }
 282   | "~"  { TILDE }
 283   | "~" lowercase identchar * ':'
 284       { let s = Lexing.lexeme lexbuf in
 285         let name = String.sub s 1 (String.length s - 2) in
 286         if Hashtbl.mem keyword_table name then
 287           raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
 288                        Lexing.lexeme_end lexbuf));
 289         LABEL name }
 290   | "?"  { QUESTION }
 291   | "?" lowercase identchar * ':'
 292       { let s = Lexing.lexeme lexbuf in
 293         let name = String.sub s 1 (String.length s - 2) in
 294         if Hashtbl.mem keyword_table name then
 295           raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf,
 296                        Lexing.lexeme_end lexbuf));
 297         OPTLABEL name }
 298   | lowercase identchar *
 299       { let s = Lexing.lexeme lexbuf in
 300           try
 301             Hashtbl.find keyword_table s
 302           with Not_found ->
 303             LIDENT s }
 304   | uppercase identchar *
 305       { UIDENT(Lexing.lexeme lexbuf) }       (* No capitalized keywords *)
 306   | decimal_literal | hex_literal | oct_literal | bin_literal
 307       { INT (int_of_string(Lexing.lexeme lexbuf)) }
 308   | float_literal
 309       { FLOAT (Lexing.lexeme lexbuf) }
 310   | "\""
 311       { reset_string_buffer();
 312         let string_start = Lexing.lexeme_start lexbuf in
 313         string_start_pos := string_start;
 314         string lexbuf;
 315         lexbuf.Lexing.lex_start_pos <-
 316           string_start - lexbuf.Lexing.lex_abs_pos;
 317         STRING (get_stored_string()) }
 318   | "'" [^ '\\' '\''] "'"
 319       { CHAR(Lexing.lexeme_char lexbuf 1) }
 320   | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
 321       { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
 322   | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
 323       { CHAR(char_for_decimal_code lexbuf 2) }
 324   | "(*"
 325       { comment_start_pos := [Lexing.lexeme_start lexbuf];
 326         comment lexbuf;
 327         token lexbuf }
 328   | "(*)"
 329       { let loc = Location.curr lexbuf
 330         and warn = Warnings.Comment_start
 331         in
 332         Location.prerr_warning loc warn;
 333         comment_start_pos := [Lexing.lexeme_start lexbuf];
 334         comment lexbuf;
 335         token lexbuf
 336       }
 337   | "*)"
 338       { let loc = Location.curr lexbuf
 339         and warn = Warnings.Comment_not_end
 340         in
 341         Location.prerr_warning loc warn;
 342         lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
 343         STAR
 344       }
 345   | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
 346       (* # linenum ...  *)
 347       { token lexbuf }
 348   | "#"  { SHARP }
 349   | "&"  { AMPERSAND }
 350   | "&&" { AMPERAMPER }
 351   | "`"  { BACKQUOTE }
 352   | "'"  { QUOTE }
 353   | "("  { LPAREN }
 354   | ")"  { RPAREN }
 355   | "*"  { STAR }
 356   | ","  { COMMA }
 357   | "??" { QUESTION2 }
 358   | "->" { MINUSGREATER }
 359   | "."  { DOT }
 360   | ".." { DOTDOT }
 361   | ":"  { COLON }
 362   | "::" { COLONCOLON }
 363   | ":=" { COLONEQUAL }
 364   | ":>" { COLONGREATER }
 365   | ";"  { SEMI }
 366   | ";;" { SEMISEMI }
 367   | "<"  { LESS }
 368   | "<-" { LESSMINUS }
 369   | "="  { EQUAL }
 370   | "["  { LBRACKET }
 371   | "[|" { LBRACKETBAR }
 372   | "[<" { LBRACKETLESS }
 373   | "]"  { RBRACKET }
 374   | "{"  { LBRACE }
 375   | "{<" { LBRACELESS }
 376   | "|"  { BAR }
 377   | "||" { BARBAR }
 378   | "|]" { BARRBRACKET }
 379   | ">"  { GREATER }
 380   | ">]" { GREATERRBRACKET }
 381   | "}"  { RBRACE }
 382   | ">}" { GREATERRBRACE }
 383
 384   | "!=" { INFIXOP0 "!=" }
 385   | "+"  { PLUS }
 386   | "-"  { MINUS }
 387   | "-." { MINUSDOT }
 388
 389   | "!" symbolchar *
 390             { PREFIXOP(Lexing.lexeme lexbuf) }
 391   | ['~' '?'] symbolchar +
 392             { PREFIXOP(Lexing.lexeme lexbuf) }
 393   | ['=' '<' '>' '|' '&' '$'] symbolchar *
 394             { INFIXOP0(Lexing.lexeme lexbuf) }
 395   | ['@' '^'] symbolchar *
 396             { INFIXOP1(Lexing.lexeme lexbuf) }
 397   | ['+' '-'] symbolchar *
 398             { INFIXOP2(Lexing.lexeme lexbuf) }
 399   | "**" symbolchar *
 400             { INFIXOP4(Lexing.lexeme lexbuf) }
 401   | ['*' '/' '%'] symbolchar *
 402             { INFIXOP3(Lexing.lexeme lexbuf) }
 403   | eof { EOF }
 404   | _
 405       { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]),
 406                      Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) }
 407
 408 and comment = parse
 409     "(*"
 410       { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
 411         comment lexbuf;
 412       }
 413   | "*)"
 414       { match !comment_start_pos with
 415         | [] -> assert false
 416         | [x] -> comment_start_pos := [];
 417         | _ :: l -> comment_start_pos := l;
 418                     comment lexbuf;
 419        }
 420   | "\""
 421       { reset_string_buffer();
 422         string_start_pos := Lexing.lexeme_start lexbuf;
 423         begin try string lexbuf
 424         with Error (Unterminated_string, _, _) ->
 425           let st = List.hd !comment_start_pos in
 426           raise (Error (Unterminated_string_in_comment, st, st + 2))
 427         end;
 428         string_buff := initial_string_buffer;
 429         comment lexbuf }
 430   | "''"
 431       { comment lexbuf }
 432   | "'" [^ '\\' '\''] "'"
 433       { comment lexbuf }
 434   | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'"
 435       { comment lexbuf }
 436   | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
 437       { comment lexbuf }
 438   | eof
 439       { let st = List.hd !comment_start_pos in
 440         raise (Error (Unterminated_comment, st, st + 2));
 441       }
 442   | _
 443       { comment lexbuf }
 444
 445 and string = parse
 446     '"'
 447       { () }
 448   | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
 449       { string lexbuf }
 450   | '\\' ['\\' '"' 'n' 't' 'b' 'r']
 451       { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
 452         string lexbuf }
 453   | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
 454       { store_string_char(char_for_decimal_code lexbuf 1);
 455          string lexbuf }
 456   | eof
 457       { raise (Error (Unterminated_string,
 458                       !string_start_pos, !string_start_pos+1)) }
 459   | _
 460       { store_string_char(Lexing.lexeme_char lexbuf 0);
 461         string lexbuf }