l4/pkg/ocaml/contrib/lex/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 7307 2006-01-04 16:55:50Z doligez $ *)
  14
  15 (* The lexical analyzer for lexer definitions. Bootstrapped! *)
  16
  17 {
  18 open Syntax
  19 open Parser
  20
  21 (* Auxiliaries for the lexical analyzer *)
  22
  23 let brace_depth = ref 0
  24 and comment_depth = ref 0
  25
  26 let in_pattern () = !brace_depth = 0 && !comment_depth = 0
  27
  28 exception Lexical_error of string * string * int * int
  29
  30 let string_buff = Buffer.create 256
  31
  32 let reset_string_buffer () = Buffer.clear string_buff
  33
  34 let store_string_char c = Buffer.add_char string_buff c
  35
  36 let get_stored_string () = Buffer.contents string_buff
  37
  38 let char_for_backslash = function
  39     'n' -> '\n'
  40   | 't' -> '\t'
  41   | 'b' -> '\b'
  42   | 'r' -> '\r'
  43   | c   -> c
  44
  45 let raise_lexical_error lexbuf msg =
  46   let p = Lexing.lexeme_start_p lexbuf in
  47   raise (Lexical_error (msg,
  48                         p.Lexing.pos_fname,
  49                         p.Lexing.pos_lnum,
  50                         p.Lexing.pos_cnum - p.Lexing.pos_bol + 1))
  51 ;;
  52
  53 let handle_lexical_error fn lexbuf =
  54   let p = Lexing.lexeme_start_p lexbuf in
  55   let line = p.Lexing.pos_lnum
  56   and column = p.Lexing.pos_cnum - p.Lexing.pos_bol + 1
  57   and file = p.Lexing.pos_fname
  58   in
  59   try
  60     fn lexbuf
  61   with Lexical_error (msg, "", 0, 0) ->
  62     raise(Lexical_error(msg, file, line, column))
  63
  64 let get_input_name () = Sys.argv.(Array.length Sys.argv - 1)
  65
  66 let warning lexbuf msg =
  67   let p = Lexing.lexeme_start_p lexbuf in
  68   Printf.eprintf "ocamllex warning:\nFile \"%s\", line %d, character %d: %s.\n"
  69     p.Lexing.pos_fname p.Lexing.pos_lnum
  70     (p.Lexing.pos_cnum - p.Lexing.pos_bol + 1) msg;
  71   flush stderr
  72
  73 let decimal_code  c d u =
  74   100 * (Char.code c - 48) + 10 * (Char.code d - 48) + (Char.code u - 48)
  75
  76 let char_for_hexadecimal_code d u =
  77   let d1 = Char.code d in
  78   let val1 = if d1 >= 97 then d1 - 87
  79              else if d1 >= 65 then d1 - 55
  80              else d1 - 48
  81   in
  82   let d2 = Char.code u in
  83   let val2 = if d2 >= 97 then d2 - 87
  84              else if d2 >= 65 then d2 - 55
  85              else d2 - 48
  86   in
  87   Char.chr (val1 * 16 + val2)
  88
  89 let incr_loc lexbuf delta =
  90   let pos = lexbuf.Lexing.lex_curr_p in
  91   lexbuf.Lexing.lex_curr_p <- { pos with
  92     Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
  93     Lexing.pos_bol = pos.Lexing.pos_cnum - delta;
  94   }
  95 ;;
  96
  97 let update_loc lexbuf opt_file line =
  98   let pos = lexbuf.Lexing.lex_curr_p in
  99   let new_file = match opt_file with
 100                  | None -> pos.Lexing.pos_fname
 101                  | Some f -> f
 102   in
 103   lexbuf.Lexing.lex_curr_p <- { pos with
 104     Lexing.pos_fname = new_file;
 105     Lexing.pos_lnum = line;
 106     Lexing.pos_bol = pos.Lexing.pos_cnum;
 107   }
 108 ;;
 109
 110 }
 111
 112 let identstart =
 113   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
 114 let identbody =
 115   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 116 let backslash_escapes =
 117   ['\\' '"' '\'' 'n' 't' 'b' 'r']
 118
 119 rule main = parse
 120     [' ' '\013' '\009' '\012' ] +
 121     { main lexbuf }
 122   | '\010'
 123     { incr_loc lexbuf 0;
 124       main lexbuf }
 125   | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
 126     ('\"' ([^ '\010' '\013' '\"']* as name) '\"')?
 127     [^ '\010' '\013']* '\010'
 128     { update_loc lexbuf name (int_of_string num);
 129       main lexbuf
 130     }
 131   | "(*"
 132     { comment_depth := 1;
 133       handle_lexical_error comment lexbuf;
 134       main lexbuf }
 135   | '_' { Tunderscore }
 136   | identstart identbody *
 137     { match Lexing.lexeme lexbuf with
 138         "rule" -> Trule
 139       | "parse" -> Tparse
 140       | "shortest" -> Tparse_shortest
 141       | "and" -> Tand
 142       | "eof" -> Teof
 143       | "let" -> Tlet
 144       | "as"  -> Tas
 145       | s -> Tident s }
 146   | '"'
 147     { reset_string_buffer();
 148       handle_lexical_error string lexbuf;
 149       Tstring(get_stored_string()) }
 150 (* note: ''' is a valid character literal (by contrast with the compiler) *)
 151   | "'" [^ '\\'] "'"
 152     { Tchar(Char.code(Lexing.lexeme_char lexbuf 1)) }
 153   | "'" '\\' backslash_escapes "'"
 154     { Tchar(Char.code(char_for_backslash (Lexing.lexeme_char lexbuf 2))) }
 155   | "'" '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u)"'"
 156     { let v = decimal_code c d u in
 157       if v > 255 then
 158         raise_lexical_error lexbuf
 159           (Printf.sprintf "illegal escape sequence \\%c%c%c" c d u)
 160       else
 161         Tchar v }
 162   | "'" '\\' 'x'
 163        (['0'-'9' 'a'-'f' 'A'-'F'] as d) (['0'-'9' 'a'-'f' 'A'-'F'] as u) "'"
 164        { Tchar(Char.code(char_for_hexadecimal_code d u)) }
 165   | "'" '\\' (_ as c)
 166     { raise_lexical_error lexbuf
 167         (Printf.sprintf "illegal escape sequence \\%c" c)
 168     }
 169   | '{'
 170     { let p = Lexing.lexeme_end_p lexbuf in
 171       let n1 = p.Lexing.pos_cnum
 172       and l1 = p.Lexing.pos_lnum
 173       and s1 = p.Lexing.pos_bol in
 174       brace_depth := 1;
 175       let n2 = handle_lexical_error action lexbuf in
 176       Taction({start_pos = n1; end_pos = n2;
 177                start_line = l1; start_col = n1 - s1}) }
 178   | '='  { Tequal }
 179   | '|'  { Tor }
 180   | '['  { Tlbracket }
 181   | ']'  { Trbracket }
 182   | '*'  { Tstar }
 183   | '?'  { Tmaybe }
 184   | '+'  { Tplus }
 185   | '('  { Tlparen }
 186   | ')'  { Trparen }
 187   | '^'  { Tcaret }
 188   | '-'  { Tdash }
 189   | '#'  { Tsharp }
 190   | eof  { Tend }
 191   | _
 192     { raise_lexical_error lexbuf
 193         ("illegal character " ^ String.escaped(Lexing.lexeme lexbuf))
 194     }
 195
 196
 197 (* String parsing comes from the compiler lexer *)
 198 and string = parse
 199     '"'
 200     { () }
 201    | '\\' ("\010" | "\013" | "\013\010") ([' ' '\009'] * as spaces)
 202     { incr_loc lexbuf (String.length spaces);
 203       string lexbuf }
 204   | '\\' (backslash_escapes as c)
 205     { store_string_char(char_for_backslash c);
 206       string lexbuf }
 207   | '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9']  as u)
 208     { let v = decimal_code c d u in
 209       if in_pattern () && v > 255 then
 210        warning lexbuf
 211         (Printf.sprintf
 212           "illegal backslash escape in string: `\\%c%c%c'" c d u) ;
 213       store_string_char (Char.chr v);
 214       string lexbuf }
 215  | '\\' 'x' (['0'-'9' 'a'-'f' 'A'-'F'] as d) (['0'-'9' 'a'-'f' 'A'-'F'] as u)
 216     { store_string_char (char_for_hexadecimal_code d u) ;
 217       string lexbuf }
 218   | '\\' (_ as c)
 219     {if in_pattern () then
 220        warning lexbuf
 221         (Printf.sprintf "illegal backslash escape in string: `\\%c'" c) ;
 222       store_string_char '\\' ;
 223       store_string_char c ;
 224       string lexbuf }
 225   | eof
 226     { raise(Lexical_error("unterminated string", "", 0, 0)) }
 227   | '\010'
 228     { store_string_char '\010';
 229       incr_loc lexbuf 0;
 230       string lexbuf }
 231   | _ as c
 232     { store_string_char c;
 233       string lexbuf }
 234
 235 (*
 236    Lexers comment and action are quite similar,
 237    they should lex both strings and characters,
 238    in order not to be confused by what is inside then
 239 *)
 240
 241 and comment = parse
 242     "(*"
 243     { incr comment_depth; comment lexbuf }
 244   | "*)"
 245     { decr comment_depth;
 246       if !comment_depth = 0 then () else comment lexbuf }
 247   | '"'
 248     { reset_string_buffer();
 249       string lexbuf;
 250       reset_string_buffer();
 251       comment lexbuf }
 252   | "'"
 253     { skip_char lexbuf ;
 254       comment lexbuf }
 255   | eof
 256     { raise(Lexical_error("unterminated comment", "", 0, 0)) }
 257   | '\010'
 258     { incr_loc lexbuf 0;
 259       comment lexbuf }
 260   | _
 261     { comment lexbuf }
 262
 263 and action = parse
 264     '{'
 265     { incr brace_depth;
 266       action lexbuf }
 267   | '}'
 268     { decr brace_depth;
 269       if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf }
 270   | '"'
 271     { reset_string_buffer();
 272       handle_lexical_error string lexbuf;
 273       reset_string_buffer();
 274       action lexbuf }
 275  | "'"
 276     { skip_char lexbuf ;
 277       action lexbuf }
 278  | "(*"
 279     { comment_depth := 1;
 280       comment lexbuf;
 281       action lexbuf }
 282   | eof
 283     { raise (Lexical_error("unterminated action", "", 0, 0)) }
 284   | '\010'
 285     { incr_loc lexbuf 0;
 286       action lexbuf }
 287   | _
 288     { action lexbuf }
 289
 290 and skip_char = parse
 291   | '\\'? '\010' "'"
 292      { incr_loc lexbuf 1;
 293      }
 294   | [^ '\\' '\''] "'" (* regular character *)
 295 (* one character and numeric escape sequences *)
 296   | '\\' _ "'"
 297   | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
 298   | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'"
 299      {()}
 300 (* A dieu va ! *)
 301   | "" {()}