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