diff options
Diffstat (limited to 'ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll')
| -rw-r--r-- | ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll | 483 |
1 files changed, 483 insertions, 0 deletions
diff --git a/ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll b/ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll new file mode 100644 index 0000000000..b8e97efefb --- /dev/null +++ b/ocaml-binary-annot/camlp4/Camlp4/Struct/Lexer.mll @@ -0,0 +1,483 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + +(* The lexer definition *) + + +{ + +(** A lexical analyzer. *) + +(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *) +(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *) + +(* type context = +{ loc : Loc.t ; + in_comment : bool ; + |+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the + quotation syntax any more. Default is False (quotations are + lexed). +| + quotations : bool }; + +value default_context : context; + +value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + +value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *) +(* FIXME Beware the context argument must be given like that: + * mk' { (default_context) with ... = ... } strm + *) + +module TokenEval = Token.Eval +module Make (Token : Sig.Camlp4Token) += struct + module Loc = Token.Loc + module Token = Token + + open Lexing + open Sig + + (* Error report *) + module Error = struct + + type t = + | Illegal_character of char + | Illegal_escape of string + | Unterminated_comment + | Unterminated_string + | Unterminated_quotation + | Unterminated_antiquot + | Unterminated_string_in_comment + | Comment_start + | Comment_not_end + | Literal_overflow of string + + exception E of t + + open Format + + let print ppf = + function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Illegal_escape s -> + fprintf ppf "Illegal backslash escape in string or character (%s)" s + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" + | Unterminated_quotation -> + fprintf ppf "Quotation not terminated" + | Unterminated_antiquot -> + fprintf ppf "Antiquotation not terminated" + | Literal_overflow ty -> + fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty + | Comment_start -> + fprintf ppf "this is the start of a comment" + | Comment_not_end -> + fprintf ppf "this is not the end of a comment" + + let to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b + end;; + + let module M = ErrorHandler.Register(Error) in () + + open Error + + (* To store some context information: + * loc : position of the beginning of a string, quotation and comment + * in_comment: are we in a comment? + * quotations: shall we lex quotation? + * If quotations is false it's a SYMBOL token. + * antiquots : shall we lex antiquotations. + *) + + type context = + { loc : Loc.t ; + in_comment : bool ; + quotations : bool ; + antiquots : bool ; + lexbuf : lexbuf ; + buffer : Buffer.t } + + let default_context lb = + { loc = Loc.ghost ; + in_comment = false ; + quotations = true ; + antiquots = false ; + lexbuf = lb ; + buffer = Buffer.create 256 } + + (* To buffer string literals, quotations and antiquotations *) + + let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) + let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) + let buff_contents c = + let contents = Buffer.contents c.buffer in + Buffer.reset c.buffer; contents + + let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) + let quotations c = c.quotations + let antiquots c = c.antiquots + let is_in_comment c = c.in_comment + let in_comment c = { (c) with in_comment = true } + let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc + let move_start_p shift c = + let p = c.lexbuf.lex_start_p in + c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } + + let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf } + let with_curr_loc f c = f (update_loc c) c.lexbuf + let parse_nested f c = + with_curr_loc f c; + set_start_p c; + buff_contents c + let shift n c = { (c) with loc = Loc.move `both n c.loc } + let store_parse f c = store c ; f c c.lexbuf + let parse f c = f c c.lexbuf + let mk_quotation quotation c name loc shift = + let s = parse_nested quotation (update_loc c) in + let contents = String.sub s 0 (String.length s - 2) in + QUOTATION { q_name = name ; + q_loc = loc ; + q_shift = shift ; + q_contents = contents } + + + (* Update the current location with file name and line number. *) + + let update_loc c file line absolute chars = + let lexbuf = c.lexbuf in + let pos = lexbuf.lex_curr_p in + let new_file = match file with + | None -> pos.pos_fname + | Some s -> s + in + lexbuf.lex_curr_p <- { pos with + pos_fname = new_file; + pos_lnum = if absolute then line else pos.pos_lnum + line; + pos_bol = pos.pos_cnum - chars; + } + + let err error loc = + raise(Loc.Exc_located(loc, Error.E error)) + + let warn error loc = + Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error + + } + + let newline = ('\010' | '\013' | "\013\010") + let blank = [' ' '\009' '\012'] + let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] + let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] + let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] + let ident = (lowercase|uppercase) identchar* + let locname = ident + let not_star_symbolchar = + ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] + let symbolchar = '*' | not_star_symbolchar + let quotchar = + ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] + let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] + let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* + let hex_literal = + '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* + let oct_literal = + '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* + let bin_literal = + '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* + let int_literal = + decimal_literal | hex_literal | oct_literal | bin_literal + let float_literal = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? + + (* Delimitors are extended (from 3.09) in a conservative way *) + + (* These chars that can't start an expression or a pattern: *) + let safe_delimchars = ['%' '&' '/' '@' '^'] + + (* These symbols are unsafe since "[<", "[|", etc. exsist. *) + let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] + + let left_delims = ['(' '[' '{'] + let right_delims = [')' ']' '}'] + + let left_delimitor = + (* At least a safe_delimchars *) + left_delims delimchars* safe_delimchars (delimchars|left_delims)* + + (* A '(' or a new super '(' without "(<" *) + | '(' (['|' ':'] delimchars*)? + (* Old brackets, no new brackets starting with "[|" or "[:" *) + | '[' ['|' ':']? + (* Old "[<","{<" and new ones *) + | ['[' '{'] delimchars* '<' + (* Old brace and new ones *) + | '{' (['|' ':'] delimchars*)? + + let right_delimitor = + (* At least a safe_delimchars *) + (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims + (* A ')' or a new super ')' without ">)" *) + | (delimchars* ['|' ':'])? ')' + (* Old brackets, no new brackets ending with "|]" or ":]" *) + | ['|' ':']? ']' + (* Old ">]",">}" and new ones *) + | '>' delimchars* [']' '}'] + (* Old brace and new ones *) + | (delimchars* ['|' ':'])? '}' + + + rule token c = parse + | newline { update_loc c None 1 false 0; NEWLINE } + | blank + as x { BLANKS x } + | "~" (lowercase identchar * as x) ':' { LABEL x } + | "?" (lowercase identchar * as x) ':' { OPTLABEL x } + | lowercase identchar * as x { LIDENT x } + | uppercase identchar * as x { UIDENT x } + | int_literal as i + { try INT(int_of_string i, i) + with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } + | float_literal as f + { try FLOAT(float_of_string f, f) + with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "l" + { try INT32(Int32.of_string i, i) + with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "L" + { try INT64(Int64.of_string i, i) + with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "n" + { try NATIVEINT(Nativeint.of_string i, i) + with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } + | '"' + { with_curr_loc string c; + let s = buff_contents c in STRING (TokenEval.string s, s) } + | "'" (newline as x) "'" + { update_loc c None 1 false 1; CHAR (TokenEval.char x, x) } + | "'" ( [^ '\\' '\010' '\013'] + | '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] + |['0'-'9'] ['0'-'9'] ['0'-'9'] + |'x' hexa_char hexa_char) + as x) "'" { CHAR (TokenEval.char x, x) } + | "'\\" (_ as c) + { err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) } + | "(*" + { store c; COMMENT(parse_nested comment (in_comment c)) } + | "(*)" + { warn Comment_start (Loc.of_lexbuf lexbuf) ; + parse comment (in_comment c); COMMENT (buff_contents c) } + | "*)" + { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; + move_start_p (-1) c; SYMBOL "*" } + | "<<" (quotchar* as beginning) + { if quotations c + then (move_start_p (-String.length beginning); + mk_quotation quotation c "" "" 2) + else parse (symbolchar_star ("<<" ^ beginning)) c } + | "<<>>" + { if quotations c + then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" } + else parse (symbolchar_star "<<>>") c } + | "<@" + { if quotations c then with_curr_loc maybe_quotation_at c + else parse (symbolchar_star "<@") c } + | "<:" + { if quotations c then with_curr_loc maybe_quotation_colon c + else parse (symbolchar_star "<:") c } + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? + [^ '\010' '\013'] * newline + { let inum = int_of_string num + in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) } + | '(' (not_star_symbolchar as op) ')' + { ESCAPED_IDENT (String.make 1 op) } + | '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')' + { ESCAPED_IDENT op } + | '(' (not_star_symbolchar symbolchar* as op) blank+ ')' + { ESCAPED_IDENT op } + | '(' blank+ (symbolchar* not_star_symbolchar as op) ')' + { ESCAPED_IDENT op } + | '(' blank+ (symbolchar+ as op) blank+ ')' + { ESCAPED_IDENT op } + | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" + | ":=" | ":>" | ";" | ";;" | "_" + | left_delimitor | right_delimitor ) as x { SYMBOL x } + | '$' { if antiquots c + then with_curr_loc dollar (shift 1 c) + else parse (symbolchar_star "$") c } + | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar * + as x { SYMBOL x } + | eof + { let pos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ; + pos_cnum = pos.pos_cnum + 1 }; EOI } + | _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) } + + and comment c = parse + "(*" + { store c; with_curr_loc comment c; parse comment c } + | "*)" { store c } + | '<' (':' ident)? ('@' locname)? '<' + { store c; + if quotations c then with_curr_loc quotation c; parse comment c } + | ident { store_parse comment c } + | "\"" + { store c; + begin try with_curr_loc string c + with Loc.Exc_located(_, Error.E Unterminated_string) -> + err Unterminated_string_in_comment (loc c) + end; + Buffer.add_char c.buffer '"'; + parse comment c } + | "''" { store_parse comment c } + | "'''" { store_parse comment c } + | "'" newline "'" + { update_loc c None 1 false 1; store_parse comment c } + | "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c } + | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c } + | "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c } + | eof + { err Unterminated_comment (loc c) } + | newline + { update_loc c None 1 false 0; store_parse comment c } + | _ { store_parse comment c } + + and string c = parse + '"' { set_start_p c } + | '\\' newline ([' ' '\t'] * as space) + { update_loc c None 1 false (String.length space); + store_parse string c } + | '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c } + | '\\' 'x' hexa_char hexa_char { store_parse string c } + | '\\' (_ as x) + { if is_in_comment c + then store_parse string c + else begin + warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); + store_parse string c + end } + | newline + { update_loc c None 1 false 0; store_parse string c } + | eof { err Unterminated_string (loc c) } + | _ { store_parse string c } + + and symbolchar_star beginning c = parse + | symbolchar* as tok { move_start_p (-String.length beginning) c ; + SYMBOL(beginning ^ tok) } + + and maybe_quotation_at c = parse + | (ident as loc) '<' + { mk_quotation quotation c "" loc (1 + String.length loc) } + | symbolchar* as tok { SYMBOL("<@" ^ tok) } + + and maybe_quotation_colon c = parse + | (ident as name) '<' + { mk_quotation quotation c name "" (1 + String.length name) } + | (ident as name) '@' (locname as loc) '<' + { mk_quotation quotation c name loc + (2 + String.length loc + String.length name) } + | symbolchar* as tok { SYMBOL("<:" ^ tok) } + + and quotation c = parse + | '<' (':' ident)? ('@' locname)? '<' { store c ; + with_curr_loc quotation c ; + parse quotation c } + | ">>" { store c } + | eof { err Unterminated_quotation (loc c) } + | newline { update_loc c None 1 false 0 ; + store_parse quotation c } + | _ { store_parse quotation c } + + and dollar c = parse + | '$' { set_start_p c; ANTIQUOT("", "") } + | ('`'? (identchar*|['.' '!']+) as name) ':' + { with_curr_loc (antiquot name) (shift (1 + String.length name) c) } + | _ { store_parse (antiquot "") c } + + and antiquot name c = parse + | '$' { set_start_p c; ANTIQUOT(name, buff_contents c) } + | eof { err Unterminated_antiquot (loc c) } + | newline + { update_loc c None 1 false 0; store_parse (antiquot name) c } + | '<' (':' ident)? ('@' locname)? '<' + { store c; with_curr_loc quotation c; parse (antiquot name) c } + | _ { store_parse (antiquot name) c } + + { + + let lexing_store s buff max = + let rec self n s = + if n >= max then n + else + match Stream.peek s with + | Some x -> + Stream.junk s; + buff.[n] <- x; + succ n + | _ -> n + in + self 0 s + + let from_context c = + let next _ = + let tok = with_curr_loc token c in + let loc = Loc.of_lexbuf c.lexbuf in + Some ((tok, loc)) + in Stream.from next + + let from_lexbuf ?(quotations = true) lb = + let c = { (default_context lb) with + loc = Loc.of_lexbuf lb; + antiquots = !Camlp4_config.antiquotations; + quotations = quotations } + in from_context c + + let setup_loc lb loc = + let start_pos = Loc.start_pos loc in + lb.lex_abs_pos <- start_pos.pos_cnum; + lb.lex_curr_p <- start_pos + + let from_string ?quotations loc str = + let lb = Lexing.from_string str in + setup_loc lb loc; + from_lexbuf ?quotations lb + + let from_stream ?quotations loc strm = + let lb = Lexing.from_function (lexing_store strm) in + setup_loc lb loc; + from_lexbuf ?quotations lb + + let mk () loc strm = + from_stream ~quotations:!Camlp4_config.quotations loc strm +end +} |