diff options
Diffstat (limited to 'ocaml-binary-annot/parsing')
| -rw-r--r-- | ocaml-binary-annot/parsing/.cvsignore | 9 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/asttypes.mli | 40 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/lexer.mli | 36 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/lexer.mll | 514 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/linenum.mli | 23 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/linenum.mll | 74 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/location.ml | 259 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/location.mli | 57 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/longident.ml | 43 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/longident.mli | 24 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/parse.ml | 64 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/parse.mli | 20 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/parser.mly | 1677 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/parsetree.mli | 287 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/printast.ml | 736 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/printast.mli | 20 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/syntaxerr.ml | 43 | ||||
| -rw-r--r-- | ocaml-binary-annot/parsing/syntaxerr.mli | 27 |
18 files changed, 3953 insertions, 0 deletions
diff --git a/ocaml-binary-annot/parsing/.cvsignore b/ocaml-binary-annot/parsing/.cvsignore new file mode 100644 index 0000000000..5602bf8a2d --- /dev/null +++ b/ocaml-binary-annot/parsing/.cvsignore @@ -0,0 +1,9 @@ +parser.ml +parser.mli +lexer.ml +lexer_tmp.mll +lexer_tmp.ml +linenum.ml +parser.output +parser.automaton +parser.conflicts diff --git a/ocaml-binary-annot/parsing/asttypes.mli b/ocaml-binary-annot/parsing/asttypes.mli new file mode 100644 index 0000000000..2530b44c6a --- /dev/null +++ b/ocaml-binary-annot/parsing/asttypes.mli @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Auxiliary a.s.t. types used by parsetree and typedtree. *) + +type constant = + Const_int of int + | Const_char of char + | Const_string of string + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + +type rec_flag = Nonrecursive | Recursive | Default + +type direction_flag = Upto | Downto + +type private_flag = Private | Public + +type mutable_flag = Immutable | Mutable + +type virtual_flag = Virtual | Concrete + +type override_flag = Override | Fresh + +type closed_flag = Closed | Open + +type label = string diff --git a/ocaml-binary-annot/parsing/lexer.mli b/ocaml-binary-annot/parsing/lexer.mli new file mode 100644 index 0000000000..3ddb5dde7c --- /dev/null +++ b/ocaml-binary-annot/parsing/lexer.mli @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The lexical analyzer *) + +val token: Lexing.lexbuf -> Parser.token +val skip_sharp_bang: Lexing.lexbuf -> unit + +type error = + | Illegal_character of char + | Illegal_escape of string + | Unterminated_comment + | Unterminated_string + | Unterminated_string_in_comment + | Keyword_as_label of string + | Literal_overflow of string +;; + +exception Error of error * Location.t + +open Format + +val report_error: formatter -> error -> unit + +val in_comment : unit -> bool;; diff --git a/ocaml-binary-annot/parsing/lexer.mll b/ocaml-binary-annot/parsing/lexer.mll new file mode 100644 index 0000000000..5da264ec09 --- /dev/null +++ b/ocaml-binary-annot/parsing/lexer.mll @@ -0,0 +1,514 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* The lexer definition *) + +{ +open Lexing +open Misc +open Parser + +type error = + | Illegal_character of char + | Illegal_escape of string + | Unterminated_comment + | Unterminated_string + | Unterminated_string_in_comment + | Keyword_as_label of string + | Literal_overflow of string +;; + +exception Error of error * Location.t;; + +(* The table of keywords *) + +let keyword_table = + create_hashtable 149 [ + "and", AND; + "as", AS; + "assert", ASSERT; + "begin", BEGIN; + "class", CLASS; + "constraint", CONSTRAINT; + "do", DO; + "done", DONE; + "downto", DOWNTO; + "else", ELSE; + "end", END; + "exception", EXCEPTION; + "external", EXTERNAL; + "false", FALSE; + "for", FOR; + "fun", FUN; + "function", FUNCTION; + "functor", FUNCTOR; + "if", IF; + "in", IN; + "include", INCLUDE; + "inherit", INHERIT; + "initializer", INITIALIZER; + "lazy", LAZY; + "let", LET; + "match", MATCH; + "method", METHOD; + "module", MODULE; + "mutable", MUTABLE; + "new", NEW; + "object", OBJECT; + "of", OF; + "open", OPEN; + "or", OR; +(* "parser", PARSER; *) + "private", PRIVATE; + "rec", REC; + "sig", SIG; + "struct", STRUCT; + "then", THEN; + "to", TO; + "true", TRUE; + "try", TRY; + "type", TYPE; + "val", VAL; + "virtual", VIRTUAL; + "when", WHEN; + "while", WHILE; + "with", WITH; + + "mod", INFIXOP3("mod"); + "land", INFIXOP3("land"); + "lor", INFIXOP3("lor"); + "lxor", INFIXOP3("lxor"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +] + +(* To buffer string literals *) + +let initial_string_buffer = String.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0 + +let store_string_char c = + if !string_index >= String.length (!string_buff) then begin + let new_buff = String.create (String.length (!string_buff) * 2) in + String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); + string_buff := new_buff + end; + String.unsafe_set (!string_buff) (!string_index) c; + incr string_index + +let get_stored_string () = + let s = String.sub (!string_buff) 0 (!string_index) in + string_buff := initial_string_buffer; + s + +(* To store the position of the beginning of a string and comment *) +let string_start_loc = ref Location.none;; +let comment_start_loc = ref [];; +let in_comment () = !comment_start_loc <> [];; + +(* To translate escape sequences *) + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + if (c < 0 || c > 255) then + if in_comment () + then 'x' + else raise (Error(Illegal_escape (Lexing.lexeme lexbuf), + Location.curr lexbuf)) + else Char.chr c + +let char_for_hexadecimal_code lexbuf i = + let d1 = Char.code (Lexing.lexeme_char lexbuf i) in + let val1 = if d1 >= 97 then d1 - 87 + else if d1 >= 65 then d1 - 55 + else d1 - 48 + in + let d2 = Char.code (Lexing.lexeme_char lexbuf (i+1)) in + let val2 = if d2 >= 97 then d2 - 87 + else if d2 >= 65 then d2 - 55 + else d2 - 48 + in + Char.chr (val1 * 16 + val2) + +(* To convert integer literals, allowing max_int + 1 (PR#4210) *) + +let cvt_int_literal s = + - int_of_string ("-" ^ s) +let cvt_int32_literal s = + Int32.neg (Int32.of_string ("-" ^ String.sub s 0 (String.length s - 1))) +let cvt_int64_literal s = + Int64.neg (Int64.of_string ("-" ^ String.sub s 0 (String.length s - 1))) +let cvt_nativeint_literal s = + Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0 (String.length s - 1))) + +(* Remove underscores from float literals *) + +let remove_underscores s = + let l = String.length s in + let rec remove src dst = + if src >= l then + if dst >= l then s else String.sub s 0 dst + else + match s.[src] with + '_' -> remove (src + 1) dst + | c -> s.[dst] <- c; remove (src + 1) (dst + 1) + in remove 0 0 + +(* Update the current location with file name and line number. *) + +let update_loc lexbuf file line absolute chars = + 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; + } +;; + +(* Error report *) + +open Format + +let report_error 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" + | Keyword_as_label kwd -> + fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd + | Literal_overflow ty -> + fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty +;; + +} + +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 symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* +let hex_literal = + '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['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' '_']*)? + +rule token = parse + | newline + { update_loc lexbuf None 1 false 0; + token lexbuf + } + | blank + + { token lexbuf } + | "_" + { UNDERSCORE } + | "~" + { TILDE } + | "~" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Location.curr lexbuf)); + LABEL name } + | "?" { QUESTION } + | "??" { QUESTIONQUESTION } + | "?" lowercase identchar * ':' + { let s = Lexing.lexeme lexbuf in + let name = String.sub s 1 (String.length s - 2) in + if Hashtbl.mem keyword_table name then + raise (Error(Keyword_as_label name, Location.curr lexbuf)); + OPTLABEL name } + | lowercase identchar * + { let s = Lexing.lexeme lexbuf in + try + Hashtbl.find keyword_table s + with Not_found -> + LIDENT s } + | uppercase identchar * + { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) + | int_literal + { try + INT (cvt_int_literal (Lexing.lexeme lexbuf)) + with Failure _ -> + raise (Error(Literal_overflow "int", Location.curr lexbuf)) + } + | float_literal + { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) } + | int_literal "l" + { try + INT32 (cvt_int32_literal (Lexing.lexeme lexbuf)) + with Failure _ -> + raise (Error(Literal_overflow "int32", Location.curr lexbuf)) } + | int_literal "L" + { try + INT64 (cvt_int64_literal (Lexing.lexeme lexbuf)) + with Failure _ -> + raise (Error(Literal_overflow "int64", Location.curr lexbuf)) } + | int_literal "n" + { try + NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf)) + with Failure _ -> + raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) } + | "\"" + { reset_string_buffer(); + let string_start = lexbuf.lex_start_p in + string_start_loc := Location.curr lexbuf; + string lexbuf; + lexbuf.lex_start_p <- string_start; + STRING (get_stored_string()) } + | "'" newline "'" + { update_loc lexbuf None 1 false 1; + CHAR (Lexing.lexeme_char lexbuf 1) } + | "'" [^ '\\' '\'' '\010' '\013'] "'" + { CHAR(Lexing.lexeme_char lexbuf 1) } + | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] "'" + { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { CHAR(char_for_decimal_code lexbuf 2) } + | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" + { CHAR(char_for_hexadecimal_code lexbuf 3) } + | "'\\" _ + { let l = Lexing.lexeme lexbuf in + let esc = String.sub l 1 (String.length l - 1) in + raise (Error(Illegal_escape esc, Location.curr lexbuf)) + } + | "(*" + { comment_start_loc := [Location.curr lexbuf]; + comment lexbuf; + token lexbuf } + | "(*)" + { let loc = Location.curr lexbuf in + Location.prerr_warning loc Warnings.Comment_start; + comment_start_loc := [Location.curr lexbuf]; + comment lexbuf; + token lexbuf + } + | "*)" + { let loc = Location.curr lexbuf in + Location.prerr_warning loc Warnings.Comment_not_end; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + let curpos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; + STAR + } + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? + [^ '\010' '\013'] * newline + { update_loc lexbuf name (int_of_string num) true 0; + token lexbuf + } + | "#" { SHARP } + | "&" { AMPERSAND } + | "&&" { AMPERAMPER } + | "`" { BACKQUOTE } + | "'" { QUOTE } + | "(" { LPAREN } + | ")" { RPAREN } + | "*" { STAR } + | "," { COMMA } + | "->" { MINUSGREATER } + | "." { DOT } + | ".." { DOTDOT } + | ":" { COLON } + | "::" { COLONCOLON } + | ":=" { COLONEQUAL } + | ":>" { COLONGREATER } + | ";" { SEMI } + | ";;" { SEMISEMI } + | "<" { LESS } + | "<-" { LESSMINUS } + | "=" { EQUAL } + | "[" { LBRACKET } + | "[|" { LBRACKETBAR } + | "[<" { LBRACKETLESS } + | "[>" { LBRACKETGREATER } + | "]" { RBRACKET } + | "{" { LBRACE } + | "{<" { LBRACELESS } + | "|" { BAR } + | "||" { BARBAR } + | "|]" { BARRBRACKET } + | ">" { GREATER } + | ">]" { GREATERRBRACKET } + | "}" { RBRACE } + | ">}" { GREATERRBRACE } + | "!" { BANG } + + | "!=" { INFIXOP0 "!=" } + | "+" { PLUS } + | "+." { PLUSDOT } + | "-" { MINUS } + | "-." { MINUSDOT } + + | "!" symbolchar + + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['~' '?'] symbolchar + + { PREFIXOP(Lexing.lexeme lexbuf) } + | ['=' '<' '>' '|' '&' '$'] symbolchar * + { INFIXOP0(Lexing.lexeme lexbuf) } + | ['@' '^'] symbolchar * + { INFIXOP1(Lexing.lexeme lexbuf) } + | ['+' '-'] symbolchar * + { INFIXOP2(Lexing.lexeme lexbuf) } + | "**" symbolchar * + { INFIXOP4(Lexing.lexeme lexbuf) } + | ['*' '/' '%'] symbolchar * + { INFIXOP3(Lexing.lexeme lexbuf) } + | eof { EOF } + | _ + { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), + Location.curr lexbuf)) + } + +and comment = parse + "(*" + { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; + comment lexbuf; + } + | "*)" + { match !comment_start_loc with + | [] -> assert false + | [x] -> comment_start_loc := []; + | _ :: l -> comment_start_loc := l; + comment lexbuf; + } + | "\"" + { reset_string_buffer(); + string_start_loc := Location.curr lexbuf; + begin try string lexbuf + with Error (Unterminated_string, _) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> comment_start_loc := []; + raise (Error (Unterminated_string_in_comment, loc)) + end; + reset_string_buffer (); + comment lexbuf } + | "''" + { comment lexbuf } + | "'" newline "'" + { update_loc lexbuf None 1 false 1; + comment lexbuf + } + | "'" [^ '\\' '\'' '\010' '\013' ] "'" + { comment lexbuf } + | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" + { comment lexbuf } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + { comment lexbuf } + | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" + { comment lexbuf } + | eof + { match !comment_start_loc with + | [] -> assert false + | loc :: _ -> comment_start_loc := []; + raise (Error (Unterminated_comment, loc)) + } + | newline + { update_loc lexbuf None 1 false 0; + comment lexbuf + } + | _ + { comment lexbuf } + +and string = parse + '"' + { () } + | '\\' newline ([' ' '\t'] * as space) + { update_loc lexbuf None 1 false (String.length space); + string lexbuf + } + | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] + { store_string_char(char_for_hexadecimal_code lexbuf 2); + string lexbuf } + | '\\' _ + { if in_comment () + then string lexbuf + else begin +(* Should be an error, but we are very lax. + raise (Error (Illegal_escape (Lexing.lexeme lexbuf), + Location.curr lexbuf)) +*) + let loc = Location.curr lexbuf in + Location.prerr_warning loc Warnings.Illegal_backslash; + store_string_char (Lexing.lexeme_char lexbuf 0); + store_string_char (Lexing.lexeme_char lexbuf 1); + string lexbuf + end + } + | newline + { if not (in_comment ()) then + Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; + update_loc lexbuf None 1 false 0; + let s = Lexing.lexeme lexbuf in + for i = 0 to String.length s - 1 do + store_string_char s.[i]; + done; + string lexbuf + } + | eof + { raise (Error (Unterminated_string, !string_start_loc)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } + +and skip_sharp_bang = parse + | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" + { update_loc lexbuf None 3 false 0 } + | "#!" [^ '\n']* '\n' + { update_loc lexbuf None 1 false 0 } + | "" { () } diff --git a/ocaml-binary-annot/parsing/linenum.mli b/ocaml-binary-annot/parsing/linenum.mli new file mode 100644 index 0000000000..50cc57e8ee --- /dev/null +++ b/ocaml-binary-annot/parsing/linenum.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* An auxiliary lexer for determining the line number corresponding to + a file position, honoring the directives # linenum "filename" *) + +val for_position: string -> int -> string * int * int + (* [Linenum.for_position file loc] returns a triple describing + the location [loc] in the file named [file]. + First result is name of actual source file. + Second result is line number in that source file. + Third result is position of beginning of that line in [file]. *) diff --git a/ocaml-binary-annot/parsing/linenum.mll b/ocaml-binary-annot/parsing/linenum.mll new file mode 100644 index 0000000000..91e71e972c --- /dev/null +++ b/ocaml-binary-annot/parsing/linenum.mll @@ -0,0 +1,74 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* An auxiliary lexer for determining the line number corresponding to + a file position, honoring the directives # linenum "filename" *) + +{ +let filename = ref "" +let linenum = ref 0 +let linebeg = ref 0 + +let parse_sharp_line s = + try + (* Update the line number and file name *) + let l1 = ref 0 in + while let c = s.[!l1] in c < '0' || c > '9' do incr l1 done; + let l2 = ref (!l1 + 1) in + while let c = s.[!l2] in c >= '0' && c <= '9' do incr l2 done; + linenum := int_of_string(String.sub s !l1 (!l2 - !l1)); + let f1 = ref (!l2 + 1) in + while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done; + let f2 = ref (!f1 + 1) in + while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done; + if !f1 < String.length s then + filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1) + with Failure _ | Invalid_argument _ -> + Misc.fatal_error "Linenum.parse_sharp_line" +} + +rule skip_line = parse + "#" [' ' '\t']* ['0'-'9']+ [' ' '\t']* + ("\"" [^ '\n' '\r' '"' (* '"' *) ] * "\"")? + [^ '\n' '\r'] * + ('\n' | '\r' | "\r\n") + { parse_sharp_line(Lexing.lexeme lexbuf); + linebeg := Lexing.lexeme_start lexbuf; + Lexing.lexeme_end lexbuf } + | [^ '\n' '\r'] * + ('\n' | '\r' | "\r\n") + { incr linenum; + linebeg := Lexing.lexeme_start lexbuf; + Lexing.lexeme_end lexbuf } + | [^ '\n' '\r'] * eof + { incr linenum; + linebeg := Lexing.lexeme_start lexbuf; + raise End_of_file } + +{ + +let for_position file loc = + let ic = open_in_bin file in + let lb = Lexing.from_channel ic in + filename := file; + linenum := 1; + linebeg := 0; + begin try + while skip_line lb <= loc do () done + with End_of_file -> () + end; + close_in ic; + (!filename, !linenum - 1, !linebeg) + +} diff --git a/ocaml-binary-annot/parsing/location.ml b/ocaml-binary-annot/parsing/location.ml new file mode 100644 index 0000000000..15b074acd4 --- /dev/null +++ b/ocaml-binary-annot/parsing/location.ml @@ -0,0 +1,259 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Lexing + +type t = { loc_start: position; loc_end: position; loc_ghost: bool };; + +let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true };; + +let in_file name = + let loc = { + pos_fname = name; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = -1; + } in + { loc_start = loc; loc_end = loc; loc_ghost = true } +;; + +let curr lexbuf = { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.lex_curr_p; + loc_ghost = false +};; + +let init lexbuf fname = + lexbuf.lex_curr_p <- { + pos_fname = fname; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; + } +;; + +let symbol_rloc () = { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = false; +};; + +let symbol_gloc () = { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = true; +};; + +let rhs_loc n = { + loc_start = Parsing.rhs_start_pos n; + loc_end = Parsing.rhs_end_pos n; + loc_ghost = false; +};; + +let input_name = ref "_none_" +let input_lexbuf = ref (None : lexbuf option) + +(* Terminal info *) + +let status = ref Terminfo.Uninitialised + +let num_loc_lines = ref 0 (* number of lines already printed after input *) + +(* Highlight the locations using standout mode. *) + +let highlight_terminfo ppf num_lines lb loc1 loc2 = + Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) + (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) + let pos0 = -lb.lex_abs_pos in + (* Do nothing if the buffer does not contain the whole phrase. *) + if pos0 < 0 then raise Exit; + (* Count number of lines in phrase *) + let lines = ref !num_loc_lines in + for i = pos0 to lb.lex_buffer_len - 1 do + if lb.lex_buffer.[i] = '\n' then incr lines + done; + (* If too many lines, give up *) + if !lines >= num_lines - 2 then raise Exit; + (* Move cursor up that number of lines *) + flush stdout; Terminfo.backup !lines; + (* Print the input, switching to standout for the location *) + let bol = ref false in + print_string "# "; + for pos = 0 to lb.lex_buffer_len - pos0 - 1 do + if !bol then (print_string " "; bol := false); + if pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then + Terminfo.standout true; + if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then + Terminfo.standout false; + let c = lb.lex_buffer.[pos + pos0] in + print_char c; + bol := (c = '\n') + done; + (* Make sure standout mode is over *) + Terminfo.standout false; + (* Position cursor back to original location *) + Terminfo.resume !num_loc_lines; + flush stdout + +(* Highlight the location by printing it again. *) + +let highlight_dumb ppf lb loc = + (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) + let pos0 = -lb.lex_abs_pos in + (* Do nothing if the buffer does not contain the whole phrase. *) + if pos0 < 0 then raise Exit; + let end_pos = lb.lex_buffer_len - pos0 - 1 in + (* Determine line numbers for the start and end points *) + let line_start = ref 0 and line_end = ref 0 in + for pos = 0 to end_pos do + if lb.lex_buffer.[pos + pos0] = '\n' then begin + if loc.loc_start.pos_cnum > pos then incr line_start; + if loc.loc_end.pos_cnum > pos then incr line_end; + end + done; + (* Print character location (useful for Emacs) *) + Format.fprintf ppf "Characters %i-%i:@." + loc.loc_start.pos_cnum loc.loc_end.pos_cnum; + (* Print the input, underlining the location *) + Format.pp_print_string ppf " "; + let line = ref 0 in + let pos_at_bol = ref 0 in + for pos = 0 to end_pos do + let c = lb.lex_buffer.[pos + pos0] in + if c <> '\n' then begin + if !line = !line_start && !line = !line_end then + (* loc is on one line: print whole line *) + Format.pp_print_char ppf c + else if !line = !line_start then + (* first line of multiline loc: print ... before loc_start *) + if pos < loc.loc_start.pos_cnum + then Format.pp_print_char ppf '.' + else Format.pp_print_char ppf c + else if !line = !line_end then + (* last line of multiline loc: print ... after loc_end *) + if pos < loc.loc_end.pos_cnum + then Format.pp_print_char ppf c + else Format.pp_print_char ppf '.' + else if !line > !line_start && !line < !line_end then + (* intermediate line of multiline loc: print whole line *) + Format.pp_print_char ppf c + end else begin + if !line = !line_start && !line = !line_end then begin + (* loc is on one line: underline location *) + Format.fprintf ppf "@. "; + for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do + Format.pp_print_char ppf ' ' + done; + for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do + Format.pp_print_char ppf '^' + done + end; + if !line >= !line_start && !line <= !line_end then begin + Format.fprintf ppf "@."; + if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " " + end; + incr line; + pos_at_bol := pos + 1; + end + done + +(* Highlight the location using one of the supported modes. *) + +let rec highlight_locations ppf loc1 loc2 = + match !status with + Terminfo.Uninitialised -> + status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2 + | Terminfo.Bad_term -> + begin match !input_lexbuf with + None -> false + | Some lb -> + let norepeat = + try Sys.getenv "TERM" = "norepeat" with Not_found -> false in + if norepeat then false else + try highlight_dumb ppf lb loc1; true + with Exit -> false + end + | Terminfo.Good_term num_lines -> + begin match !input_lexbuf with + None -> false + | Some lb -> + try highlight_terminfo ppf num_lines lb loc1 loc2; true + with Exit -> false + end + +(* Print the location in some way or another *) + +open Format + +let reset () = + num_loc_lines := 0 + +let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) = + ("File \"", "\", line ", ", characters ", "-", ":", "") + +(* return file, line, char from the given position *) +let get_pos_info pos = + let (filename, linenum, linebeg) = + if pos.pos_fname = "" && !input_name = "" then + ("", -1, 0) + else if pos.pos_fname = "" then + Linenum.for_position !input_name pos.pos_cnum + else + (pos.pos_fname, pos.pos_lnum, pos.pos_bol) + in + (filename, linenum, pos.pos_cnum - linebeg) +;; + +let print ppf loc = + let (file, line, startchar) = get_pos_info loc.loc_start in + let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in + let (startchar, endchar) = + if startchar < 0 then (0, 1) else (startchar, endchar) + in + if file = "" then begin + if highlight_locations ppf loc none then () else + fprintf ppf "Characters %i-%i:@." + loc.loc_start.pos_cnum loc.loc_end.pos_cnum + end else begin + fprintf ppf "%s%s%s%i" msg_file file msg_line line; + fprintf ppf "%s%i" msg_chars startchar; + fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head; + end +;; + +let print_error ppf loc = + print ppf loc; + fprintf ppf "Error: "; +;; + +let print_error_cur_file ppf = print_error ppf (in_file !input_name);; + +let print_warning loc ppf w = + if Warnings.is_active w then begin + let printw ppf w = + let n = Warnings.print ppf w in + num_loc_lines := !num_loc_lines + n + in + fprintf ppf "%a" print loc; + fprintf ppf "Warning %a@." printw w; + pp_print_flush ppf (); + incr num_loc_lines; + end +;; + +let prerr_warning loc w = print_warning loc err_formatter w;; + +let echo_eof () = + print_newline (); + incr num_loc_lines diff --git a/ocaml-binary-annot/parsing/location.mli b/ocaml-binary-annot/parsing/location.mli new file mode 100644 index 0000000000..a496a35506 --- /dev/null +++ b/ocaml-binary-annot/parsing/location.mli @@ -0,0 +1,57 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Source code locations (ranges of positions), used in parsetree. *) + +open Format + +type t = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +(* Note on the use of Lexing.position in this module. + If [pos_fname = ""], then use [!input_name] instead. + If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and + re-parse the file to get the line and character numbers. + Else all fields are correct. +*) + +val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) +val in_file : string -> t;; +(** Return an empty ghost range located in a given file. *) +val init : Lexing.lexbuf -> string -> unit +(** Set the file name and line number of the [lexbuf] to be the start + of the named file. *) +val curr : Lexing.lexbuf -> t +(** Get the location of the current token from the [lexbuf]. *) + +val symbol_rloc: unit -> t +val symbol_gloc: unit -> t +val rhs_loc: int -> t + +val input_name: string ref +val input_lexbuf: Lexing.lexbuf option ref + +val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) +val print_error: formatter -> t -> unit +val print_error_cur_file: formatter -> unit +val print_warning: t -> formatter -> Warnings.t -> unit +val prerr_warning: t -> Warnings.t -> unit +val echo_eof: unit -> unit +val reset: unit -> unit + +val highlight_locations: formatter -> t -> t -> bool diff --git a/ocaml-binary-annot/parsing/longident.ml b/ocaml-binary-annot/parsing/longident.ml new file mode 100644 index 0000000000..1b459ca3f4 --- /dev/null +++ b/ocaml-binary-annot/parsing/longident.ml @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +let rec flat accu = function + Lident s -> s :: accu + | Ldot(lid, s) -> flat (s :: accu) lid + | Lapply(l1, l2) -> Misc.fatal_error "Longident.flat" + +let flatten lid = flat [] lid + +let last = function + Lident s -> s + | Ldot(lid, s) -> s + | Lapply(l1, l2) -> Misc.fatal_error "Longident.last" + +let rec split_at_dots s pos = + try + let dot = String.index_from s pos '.' in + String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) + with Not_found -> + [String.sub s pos (String.length s - pos)] + +let parse s = + match split_at_dots s 0 with + [] -> Lident "" (* should not happen, but don't put assert false + so as not to crash the toplevel (see Genprintval) *) + | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl diff --git a/ocaml-binary-annot/parsing/longident.mli b/ocaml-binary-annot/parsing/longident.mli new file mode 100644 index 0000000000..4568bc953c --- /dev/null +++ b/ocaml-binary-annot/parsing/longident.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Long identifiers, used in parsetree. *) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +val flatten: t -> string list +val last: t -> string +val parse: string -> t diff --git a/ocaml-binary-annot/parsing/parse.ml b/ocaml-binary-annot/parsing/parse.ml new file mode 100644 index 0000000000..7f3e4cdc02 --- /dev/null +++ b/ocaml-binary-annot/parsing/parse.ml @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Entry points in the parser *) + +open Location + +(* Skip tokens to the end of the phrase *) + +let rec skip_phrase lexbuf = + try + match Lexer.token lexbuf with + Parser.SEMISEMI | Parser.EOF -> () + | _ -> skip_phrase lexbuf + with + | Lexer.Error (Lexer.Unterminated_comment, _) -> () + | Lexer.Error (Lexer.Unterminated_string, _) -> () + | Lexer.Error (Lexer.Unterminated_string_in_comment, _) -> () + | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf +;; + +let maybe_skip_phrase lexbuf = + if Parsing.is_current_lookahead Parser.SEMISEMI + || Parsing.is_current_lookahead Parser.EOF + then () + else skip_phrase lexbuf + +let wrap parsing_fun lexbuf = + try + let ast = parsing_fun Lexer.token lexbuf in + Parsing.clear_parser(); + ast + with + | Lexer.Error(Lexer.Unterminated_comment, _) as err -> raise err + | Lexer.Error(Lexer.Unterminated_string, _) as err -> raise err + | Lexer.Error(Lexer.Unterminated_string_in_comment, _) as err -> raise err + | Lexer.Error(Lexer.Illegal_character _, _) as err -> + if !Location.input_name = "" then skip_phrase lexbuf; + raise err + | Syntaxerr.Error _ as err -> + if !Location.input_name = "" then maybe_skip_phrase lexbuf; + raise err + | Parsing.Parse_error | Syntaxerr.Escape_error -> + let loc = Location.curr lexbuf in + if !Location.input_name = "" + then maybe_skip_phrase lexbuf; + raise(Syntaxerr.Error(Syntaxerr.Other loc)) +;; + +let implementation = wrap Parser.implementation +and interface = wrap Parser.interface +and toplevel_phrase = wrap Parser.toplevel_phrase +and use_file = wrap Parser.use_file diff --git a/ocaml-binary-annot/parsing/parse.mli b/ocaml-binary-annot/parsing/parse.mli new file mode 100644 index 0000000000..87a09f0e2a --- /dev/null +++ b/ocaml-binary-annot/parsing/parse.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Entry points in the parser *) + +val implementation : Lexing.lexbuf -> Parsetree.structure +val interface : Lexing.lexbuf -> Parsetree.signature +val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase +val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list diff --git a/ocaml-binary-annot/parsing/parser.mly b/ocaml-binary-annot/parsing/parser.mly new file mode 100644 index 0000000000..b4fa1d41b1 --- /dev/null +++ b/ocaml-binary-annot/parsing/parser.mly @@ -0,0 +1,1677 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the Q Public License version 1.0. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +/* The parser definition */ + +%{ +open Location +open Asttypes +open Longident +open Parsetree + +let mktyp d = + { ptyp_desc = d; ptyp_loc = symbol_rloc() } +let mkpat d = + { ppat_desc = d; ppat_loc = symbol_rloc() } +let mkexp d = + { pexp_desc = d; pexp_loc = symbol_rloc() } +let mkmty d = + { pmty_desc = d; pmty_loc = symbol_rloc() } +let mksig d = + { psig_desc = d; psig_loc = symbol_rloc() } +let mkmod d = + { pmod_desc = d; pmod_loc = symbol_rloc() } +let mkstr d = + { pstr_desc = d; pstr_loc = symbol_rloc() } +let mkfield d = + { pfield_desc = d; pfield_loc = symbol_rloc() } +let mkclass d = + { pcl_desc = d; pcl_loc = symbol_rloc() } +let mkcty d = + { pcty_desc = d; pcty_loc = symbol_rloc() } + +let reloc_pat x = { x with ppat_loc = symbol_rloc () };; +let reloc_exp x = { x with pexp_loc = symbol_rloc () };; + +let mkoperator name pos = + { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos } + +(* + Ghost expressions and patterns: + expressions and patterns that do not appear explicitely in the + source file they have the loc_ghost flag set to true. + Then the profiler will not try to instrument them and the + -stypes option will not try to display their type. + + Every grammar rule that generates an element with a location must + make at most one non-ghost element, the topmost one. + + How to tell whether your location must be ghost: + A location corresponds to a range of characters in the source file. + If the location contains a piece of code that is syntactically + valid (according to the documentation), and corresponds to the + AST node, then the location must be real; in all other cases, + it must be ghost. +*) +let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };; +let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };; +let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };; + +let mkassert e = + match e with + | {pexp_desc = Pexp_construct (Lident "false", None, false) } -> + mkexp (Pexp_assertfalse) + | _ -> mkexp (Pexp_assert (e)) +;; + +let mkinfix arg1 name arg2 = + mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2])) + +let neg_float_string f = + if String.length f > 0 && f.[0] = '-' + then String.sub f 1 (String.length f - 1) + else "-" ^ f + +let mkuminus name arg = + match name, arg.pexp_desc with + | "-", Pexp_constant(Const_int n) -> + mkexp(Pexp_constant(Const_int(-n))) + | "-", Pexp_constant(Const_int32 n) -> + mkexp(Pexp_constant(Const_int32(Int32.neg n))) + | "-", Pexp_constant(Const_int64 n) -> + mkexp(Pexp_constant(Const_int64(Int64.neg n))) + | "-", Pexp_constant(Const_nativeint n) -> + mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n))) + | ("-" | "-."), Pexp_constant(Const_float f) -> + mkexp(Pexp_constant(Const_float(neg_float_string f))) + | _ -> + mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg])) + +let mkuplus name arg = + let desc = arg.pexp_desc in + match name, desc with + | "+", Pexp_constant(Const_int _) + | "+", Pexp_constant(Const_int32 _) + | "+", Pexp_constant(Const_int64 _) + | "+", Pexp_constant(Const_nativeint _) + | ("+" | "+."), Pexp_constant(Const_float _) -> mkexp desc + | _ -> + mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg])) + +let rec mktailexp = function + [] -> + ghexp(Pexp_construct(Lident "[]", None, false)) + | e1 :: el -> + let exp_el = mktailexp el in + let l = {loc_start = e1.pexp_loc.loc_start; + loc_end = exp_el.pexp_loc.loc_end; + loc_ghost = true} + in + let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in + {pexp_desc = Pexp_construct(Lident "::", Some arg, false); pexp_loc = l} + +let rec mktailpat = function + [] -> + ghpat(Ppat_construct(Lident "[]", None, false)) + | p1 :: pl -> + let pat_pl = mktailpat pl in + let l = {loc_start = p1.ppat_loc.loc_start; + loc_end = pat_pl.ppat_loc.loc_end; + loc_ghost = true} + in + let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in + {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l} + +let ghstrexp e = + { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} } + +let array_function str name = + Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)) + +let rec deep_mkrangepat c1 c2 = + if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else + ghpat(Ppat_or(ghpat(Ppat_constant(Const_char c1)), + deep_mkrangepat (Char.chr(Char.code c1 + 1)) c2)) + +let rec mkrangepat c1 c2 = + if c1 > c2 then mkrangepat c2 c1 else + if c1 = c2 then mkpat(Ppat_constant(Const_char c1)) else + reloc_pat (deep_mkrangepat c1 c2) + +let syntax_error () = + raise Syntaxerr.Escape_error + +let unclosed opening_name opening_num closing_name closing_num = + raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name, + rhs_loc closing_num, closing_name))) + +let bigarray_function str name = + Ldot(Ldot(Lident "Bigarray", str), name) + +let bigarray_untuplify = function + { pexp_desc = Pexp_tuple explist} -> explist + | exp -> [exp] + +let bigarray_get arr arg = + let get = if !Clflags.fast then "unsafe_get" else "get" in + match bigarray_untuplify arg with + [c1] -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)), + ["", arr; "", c1])) + | [c1;c2] -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)), + ["", arr; "", c1; "", c2])) + | [c1;c2;c3] -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)), + ["", arr; "", c1; "", c2; "", c3])) + | coords -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")), + ["", arr; "", ghexp(Pexp_array coords)])) + +let bigarray_set arr arg newval = + let set = if !Clflags.fast then "unsafe_set" else "set" in + match bigarray_untuplify arg with + [c1] -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)), + ["", arr; "", c1; "", newval])) + | [c1;c2] -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)), + ["", arr; "", c1; "", c2; "", newval])) + | [c1;c2;c3] -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)), + ["", arr; "", c1; "", c2; "", c3; "", newval])) + | coords -> + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), + ["", arr; + "", ghexp(Pexp_array coords); + "", newval])) + +let lapply p1 p2 = + if !Clflags.applicative_functors + then Lapply(p1, p2) + else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc()))) + +let exp_of_label lbl = + mkexp (Pexp_ident(Lident(Longident.last lbl))) + +let pat_of_label lbl = + mkpat (Ppat_var(Longident.last lbl)) + +%} + +/* Tokens */ + +%token AMPERAMPER +%token AMPERSAND +%token AND +%token AS +%token ASSERT +%token BACKQUOTE +%token BANG +%token BAR +%token BARBAR +%token BARRBRACKET +%token BEGIN +%token <char> CHAR +%token CLASS +%token COLON +%token COLONCOLON +%token COLONEQUAL +%token COLONGREATER +%token COMMA +%token CONSTRAINT +%token DO +%token DONE +%token DOT +%token DOTDOT +%token DOWNTO +%token ELSE +%token END +%token EOF +%token EQUAL +%token EXCEPTION +%token EXTERNAL +%token FALSE +%token <string> FLOAT +%token FOR +%token FUN +%token FUNCTION +%token FUNCTOR +%token GREATER +%token GREATERRBRACE +%token GREATERRBRACKET +%token IF +%token IN +%token INCLUDE +%token <string> INFIXOP0 +%token <string> INFIXOP1 +%token <string> INFIXOP2 +%token <string> INFIXOP3 +%token <string> INFIXOP4 +%token INHERIT +%token INITIALIZER +%token <int> INT +%token <int32> INT32 +%token <int64> INT64 +%token <string> LABEL +%token LAZY +%token LBRACE +%token LBRACELESS +%token LBRACKET +%token LBRACKETBAR +%token LBRACKETLESS +%token LBRACKETGREATER +%token LESS +%token LESSMINUS +%token LET +%token <string> LIDENT +%token LPAREN +%token MATCH +%token METHOD +%token MINUS +%token MINUSDOT +%token MINUSGREATER +%token MODULE +%token MUTABLE +%token <nativeint> NATIVEINT +%token NEW +%token OBJECT +%token OF +%token OPEN +%token <string> OPTLABEL +%token OR +/* %token PARSER */ +%token PLUS +%token PLUSDOT +%token <string> PREFIXOP +%token PRIVATE +%token QUESTION +%token QUESTIONQUESTION +%token QUOTE +%token RBRACE +%token RBRACKET +%token REC +%token RPAREN +%token SEMI +%token SEMISEMI +%token SHARP +%token SIG +%token STAR +%token <string> STRING +%token STRUCT +%token THEN +%token TILDE +%token TO +%token TRUE +%token TRY +%token TYPE +%token <string> UIDENT +%token UNDERSCORE +%token VAL +%token VIRTUAL +%token WHEN +%token WHILE +%token WITH + +/* Precedences and associativities. + +Tokens and rules have precedences. A reduce/reduce conflict is resolved +in favor of the first rule (in source file order). A shift/reduce conflict +is resolved by comparing the precedence and associativity of the token to +be shifted with those of the rule to be reduced. + +By default, a rule has the precedence of its rightmost terminal (if any). + +When there is a shift/reduce conflict between a rule and a token that +have the same precedence, it is resolved using the associativity: +if the token is left-associative, the parser will reduce; if +right-associative, the parser will shift; if non-associative, +the parser will declare a syntax error. + +We will only use associativities with operators of the kind x * x -> x +for example, in the rules of the form expr: expr BINOP expr +in all other cases, we define two precedences if needed to resolve +conflicts. + +The precedences must be listed from low to high. +*/ + +%nonassoc IN +%nonassoc below_SEMI +%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ +%nonassoc LET /* above SEMI ( ...; let ... in ...) */ +%nonassoc below_WITH +%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ +%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ +%nonassoc THEN /* below ELSE (if ... then ...) */ +%nonassoc ELSE /* (if ... then ... else ...) */ +%nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */ +%right COLONEQUAL /* expr (e := e := e) */ +%nonassoc AS +%left BAR /* pattern (p|p|p) */ +%nonassoc below_COMMA +%left COMMA /* expr/expr_comma_list (e,e,e) */ +%right MINUSGREATER /* core_type2 (t -> t -> t) */ +%right OR BARBAR /* expr (e || e || e) */ +%right AMPERSAND AMPERAMPER /* expr (e && e && e) */ +%nonassoc below_EQUAL +%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ +%right INFIXOP1 /* expr (e OP e OP e) */ +%right COLONCOLON /* expr (e :: e :: e) */ +%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT /* expr (e OP e OP e) */ +%left INFIXOP3 STAR /* expr (e OP e OP e) */ +%right INFIXOP4 /* expr (e OP e OP e) */ +%nonassoc prec_unary_minus prec_unary_plus /* unary - */ +%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */ +%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */ +%nonassoc below_SHARP +%nonassoc SHARP /* simple_expr/toplevel_directive */ +%nonassoc below_DOT +%nonassoc DOT +/* Finally, the first tokens of simple_expr are above everything else. */ +%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64 + LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN + NEW NATIVEINT PREFIXOP STRING TRUE UIDENT + + +/* Entry points */ + +%start implementation /* for implementation files */ +%type <Parsetree.structure> implementation +%start interface /* for interface files */ +%type <Parsetree.signature> interface +%start toplevel_phrase /* for interactive use */ +%type <Parsetree.toplevel_phrase> toplevel_phrase +%start use_file /* for the #use directive */ +%type <Parsetree.toplevel_phrase list> use_file + +%% + +/* Entry points */ + +implementation: + structure EOF { $1 } +; +interface: + signature EOF { List.rev $1 } +; +toplevel_phrase: + top_structure SEMISEMI { Ptop_def $1 } + | seq_expr SEMISEMI { Ptop_def[ghstrexp $1] } + | toplevel_directive SEMISEMI { $1 } + | EOF { raise End_of_file } +; +top_structure: + structure_item { [$1] } + | structure_item top_structure { $1 :: $2 } +; +use_file: + use_file_tail { $1 } + | seq_expr use_file_tail { Ptop_def[ghstrexp $1] :: $2 } +; +use_file_tail: + EOF { [] } + | SEMISEMI EOF { [] } + | SEMISEMI seq_expr use_file_tail { Ptop_def[ghstrexp $2] :: $3 } + | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 } + | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 } + | structure_item use_file_tail { Ptop_def[$1] :: $2 } + | toplevel_directive use_file_tail { $1 :: $2 } +; + +/* Module expressions */ + +module_expr: + mod_longident + { mkmod(Pmod_ident $1) } + | STRUCT structure END + { mkmod(Pmod_structure($2)) } + | STRUCT structure error + { unclosed "struct" 1 "end" 3 } + | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr + { mkmod(Pmod_functor($3, $5, $8)) } + | module_expr LPAREN module_expr RPAREN + { mkmod(Pmod_apply($1, $3)) } + | module_expr LPAREN module_expr error + { unclosed "(" 2 ")" 4 } + | LPAREN module_expr COLON module_type RPAREN + { mkmod(Pmod_constraint($2, $4)) } + | LPAREN module_expr COLON module_type error + { unclosed "(" 1 ")" 5 } + | LPAREN module_expr RPAREN + { $2 } + | LPAREN module_expr error + { unclosed "(" 1 ")" 3 } + | LPAREN VAL expr RPAREN + { mkmod(Pmod_unpack $3) } + | LPAREN VAL expr COLON package_type RPAREN + { mkmod(Pmod_unpack( + ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)), None)))) } + | LPAREN VAL expr COLON package_type COLONGREATER package_type RPAREN + { mkmod(Pmod_unpack( + ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)), + Some(ghtyp(Ptyp_package $7)))))) } + | LPAREN VAL expr COLONGREATER package_type RPAREN + { mkmod(Pmod_unpack( + ghexp(Pexp_constraint($3, None, Some(ghtyp(Ptyp_package $5)))))) } + | LPAREN VAL expr COLON error + { unclosed "(" 1 ")" 5 } + | LPAREN VAL expr COLONGREATER error + { unclosed "(" 1 ")" 5 } + | LPAREN VAL expr error + { unclosed "(" 1 ")" 4 } +; +structure: + structure_tail { $1 } + | seq_expr structure_tail { ghstrexp $1 :: $2 } +; +structure_tail: + /* empty */ { [] } + | SEMISEMI { [] } + | SEMISEMI seq_expr structure_tail { ghstrexp $2 :: $3 } + | SEMISEMI structure_item structure_tail { $2 :: $3 } + | structure_item structure_tail { $1 :: $2 } +; +structure_item: + LET rec_flag let_bindings + { match $3 with + [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp) + | _ -> mkstr(Pstr_value($2, List.rev $3)) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) } + | TYPE type_declarations + { mkstr(Pstr_type(List.rev $2)) } + | EXCEPTION UIDENT constructor_arguments + { mkstr(Pstr_exception($2, $3)) } + | EXCEPTION UIDENT EQUAL constr_longident + { mkstr(Pstr_exn_rebind($2, $4)) } + | MODULE UIDENT module_binding + { mkstr(Pstr_module($2, $3)) } + | MODULE REC module_rec_bindings + { mkstr(Pstr_recmodule(List.rev $3)) } + | MODULE TYPE ident EQUAL module_type + { mkstr(Pstr_modtype($3, $5)) } + | OPEN mod_longident + { mkstr(Pstr_open $2) } + | CLASS class_declarations + { mkstr(Pstr_class (List.rev $2)) } + | CLASS TYPE class_type_declarations + { mkstr(Pstr_class_type (List.rev $3)) } + | INCLUDE module_expr + { mkstr(Pstr_include $2) } +; +module_binding: + EQUAL module_expr + { $2 } + | COLON module_type EQUAL module_expr + { mkmod(Pmod_constraint($4, $2)) } + | LPAREN UIDENT COLON module_type RPAREN module_binding + { mkmod(Pmod_functor($2, $4, $6)) } +; +module_rec_bindings: + module_rec_binding { [$1] } + | module_rec_bindings AND module_rec_binding { $3 :: $1 } +; +module_rec_binding: + UIDENT COLON module_type EQUAL module_expr { ($1, $3, $5) } +; + +/* Module types */ + +module_type: + mty_longident + { mkmty(Pmty_ident $1) } + | SIG signature END + { mkmty(Pmty_signature(List.rev $2)) } + | SIG signature error + { unclosed "sig" 1 "end" 3 } + | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type + %prec below_WITH + { mkmty(Pmty_functor($3, $5, $8)) } + | module_type WITH with_constraints + { mkmty(Pmty_with($1, List.rev $3)) } + | MODULE TYPE OF module_expr + { mkmty(Pmty_typeof $4) } + | LPAREN module_type RPAREN + { $2 } + | LPAREN module_type error + { unclosed "(" 1 ")" 3 } +; +signature: + /* empty */ { [] } + | signature signature_item { $2 :: $1 } + | signature signature_item SEMISEMI { $2 :: $1 } +; +signature_item: + VAL val_ident COLON core_type + { mksig(Psig_value($2, {pval_type = $4; pval_prim = []})) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mksig(Psig_value($2, {pval_type = $4; pval_prim = $6})) } + | TYPE type_declarations + { mksig(Psig_type(List.rev $2)) } + | EXCEPTION UIDENT constructor_arguments + { mksig(Psig_exception($2, $3)) } + | MODULE UIDENT module_declaration + { mksig(Psig_module($2, $3)) } + | MODULE REC module_rec_declarations + { mksig(Psig_recmodule(List.rev $3)) } + | MODULE TYPE ident + { mksig(Psig_modtype($3, Pmodtype_abstract)) } + | MODULE TYPE ident EQUAL module_type + { mksig(Psig_modtype($3, Pmodtype_manifest $5)) } + | OPEN mod_longident + { mksig(Psig_open $2) } + | INCLUDE module_type + { mksig(Psig_include $2) } + | CLASS class_descriptions + { mksig(Psig_class (List.rev $2)) } + | CLASS TYPE class_type_declarations + { mksig(Psig_class_type (List.rev $3)) } +; + +module_declaration: + COLON module_type + { $2 } + | LPAREN UIDENT COLON module_type RPAREN module_declaration + { mkmty(Pmty_functor($2, $4, $6)) } +; +module_rec_declarations: + module_rec_declaration { [$1] } + | module_rec_declarations AND module_rec_declaration { $3 :: $1 } +; +module_rec_declaration: + UIDENT COLON module_type { ($1, $3) } +; + +/* Class expressions */ + +class_declarations: + class_declarations AND class_declaration { $3 :: $1 } + | class_declaration { [$1] } +; +class_declaration: + virtual_flag class_type_parameters LIDENT class_fun_binding + { let params, variance = List.split (fst $2) in + {pci_virt = $1; pci_params = params, snd $2; + pci_name = $3; pci_expr = $4; pci_variance = variance; + pci_loc = symbol_rloc ()} } +; +class_fun_binding: + EQUAL class_expr + { $2 } + | COLON class_type EQUAL class_expr + { mkclass(Pcl_constraint($4, $2)) } + | labeled_simple_pattern class_fun_binding + { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) } +; +class_type_parameters: + /*empty*/ { [], symbol_gloc () } + | LBRACKET type_parameter_list RBRACKET { List.rev $2, symbol_rloc () } +; +class_fun_def: + labeled_simple_pattern MINUSGREATER class_expr + { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $3)) } + | labeled_simple_pattern class_fun_def + { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) } +; +class_expr: + class_simple_expr + { $1 } + | FUN class_fun_def + { $2 } + | class_simple_expr simple_labeled_expr_list + { mkclass(Pcl_apply($1, List.rev $2)) } + | LET rec_flag let_bindings IN class_expr + { mkclass(Pcl_let ($2, List.rev $3, $5)) } +; +class_simple_expr: + LBRACKET core_type_comma_list RBRACKET class_longident + { mkclass(Pcl_constr($4, List.rev $2)) } + | class_longident + { mkclass(Pcl_constr($1, [])) } + | OBJECT class_structure END + { mkclass(Pcl_structure($2)) } + | OBJECT class_structure error + { unclosed "object" 1 "end" 3 } + | LPAREN class_expr COLON class_type RPAREN + { mkclass(Pcl_constraint($2, $4)) } + | LPAREN class_expr COLON class_type error + { unclosed "(" 1 ")" 5 } + | LPAREN class_expr RPAREN + { $2 } + | LPAREN class_expr error + { unclosed "(" 1 ")" 3 } +; +class_structure: + class_self_pattern class_fields + { $1, List.rev $2 } +; +class_self_pattern: + LPAREN pattern RPAREN + { reloc_pat $2 } + | LPAREN pattern COLON core_type RPAREN + { mkpat(Ppat_constraint($2, $4)) } + | /* empty */ + { ghpat(Ppat_any) } +; +class_fields: + /* empty */ + { [] } + | class_fields INHERIT override_flag class_expr parent_binder + { Pcf_inher ($3, $4, $5) :: $1 } + | class_fields VAL virtual_value + { Pcf_valvirt $3 :: $1 } + | class_fields VAL value + { Pcf_val $3 :: $1 } + | class_fields virtual_method + { Pcf_virt $2 :: $1 } + | class_fields concrete_method + { Pcf_meth $2 :: $1 } + | class_fields CONSTRAINT constrain + { Pcf_cstr $3 :: $1 } + | class_fields INITIALIZER seq_expr + { Pcf_init $3 :: $1 } +; +parent_binder: + AS LIDENT + { Some $2 } + | /* empty */ + { None } +; +virtual_value: + override_flag MUTABLE VIRTUAL label COLON core_type + { if $1 = Override then syntax_error (); + $4, Mutable, $6, symbol_rloc () } + | VIRTUAL mutable_flag label COLON core_type + { $3, $2, $5, symbol_rloc () } +; +value: + override_flag mutable_flag label EQUAL seq_expr + { $3, $2, $1, $5, symbol_rloc () } + | override_flag mutable_flag label type_constraint EQUAL seq_expr + { $3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))), + symbol_rloc () } +; +virtual_method: + METHOD override_flag PRIVATE VIRTUAL label COLON poly_type + { if $2 = Override then syntax_error (); + $5, Private, $7, symbol_rloc () } + | METHOD override_flag VIRTUAL private_flag label COLON poly_type + { if $2 = Override then syntax_error (); + $5, $4, $7, symbol_rloc () } +; +concrete_method : + METHOD override_flag private_flag label strict_binding + { $4, $3, $2, ghexp(Pexp_poly ($5, None)), symbol_rloc () } + | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr + { $4, $3, $2, ghexp(Pexp_poly($8,Some $6)), symbol_rloc () } +; + +/* Class types */ + +class_type: + class_signature + { $1 } + | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_fun("?" ^ $2 , + {ptyp_desc = + Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); + ptyp_loc = $4.ptyp_loc}, + $6)) } + | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_fun("?" ^ $1 , + {ptyp_desc = + Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); + ptyp_loc = $2.ptyp_loc}, + $4)) } + | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_fun($1, $3, $5)) } + | simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_fun("", $1, $3)) } +; +class_signature: + LBRACKET core_type_comma_list RBRACKET clty_longident + { mkcty(Pcty_constr ($4, List.rev $2)) } + | clty_longident + { mkcty(Pcty_constr ($1, [])) } + | OBJECT class_sig_body END + { mkcty(Pcty_signature $2) } + | OBJECT class_sig_body error + { unclosed "object" 1 "end" 3 } +; +class_sig_body: + class_self_type class_sig_fields + { $1, List.rev $2 } +; +class_self_type: + LPAREN core_type RPAREN + { $2 } + | /* empty */ + { mktyp(Ptyp_any) } +; +class_sig_fields: + /* empty */ { [] } + | class_sig_fields INHERIT class_signature { Pctf_inher $3 :: $1 } + | class_sig_fields VAL value_type { Pctf_val $3 :: $1 } + | class_sig_fields virtual_method_type { Pctf_virt $2 :: $1 } + | class_sig_fields method_type { Pctf_meth $2 :: $1 } + | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 } +; +value_type: + VIRTUAL mutable_flag label COLON core_type + { $3, $2, Virtual, $5, symbol_rloc () } + | MUTABLE virtual_flag label COLON core_type + { $3, Mutable, $2, $5, symbol_rloc () } + | label COLON core_type + { $1, Immutable, Concrete, $3, symbol_rloc () } +; +method_type: + METHOD private_flag label COLON poly_type + { $3, $2, $5, symbol_rloc () } +; +virtual_method_type: + METHOD PRIVATE VIRTUAL label COLON poly_type + { $4, Private, $6, symbol_rloc () } + | METHOD VIRTUAL private_flag label COLON poly_type + { $4, $3, $6, symbol_rloc () } +; +constrain: + core_type EQUAL core_type { $1, $3, symbol_rloc () } +; +class_descriptions: + class_descriptions AND class_description { $3 :: $1 } + | class_description { [$1] } +; +class_description: + virtual_flag class_type_parameters LIDENT COLON class_type + { let params, variance = List.split (fst $2) in + {pci_virt = $1; pci_params = params, snd $2; + pci_name = $3; pci_expr = $5; pci_variance = variance; + pci_loc = symbol_rloc ()} } +; +class_type_declarations: + class_type_declarations AND class_type_declaration { $3 :: $1 } + | class_type_declaration { [$1] } +; +class_type_declaration: + virtual_flag class_type_parameters LIDENT EQUAL class_signature + { let params, variance = List.split (fst $2) in + {pci_virt = $1; pci_params = params, snd $2; + pci_name = $3; pci_expr = $5; pci_variance = variance; + pci_loc = symbol_rloc ()} } +; + +/* Core expressions */ + +seq_expr: + | expr %prec below_SEMI { $1 } + | expr SEMI { reloc_exp $1 } + | expr SEMI seq_expr { mkexp(Pexp_sequence($1, $3)) } +; +labeled_simple_pattern: + QUESTION LPAREN label_let_pattern opt_default RPAREN + { ("?" ^ fst $3, $4, snd $3) } + | QUESTION label_var + { ("?" ^ fst $2, None, snd $2) } + | OPTLABEL LPAREN let_pattern opt_default RPAREN + { ("?" ^ $1, $4, $3) } + | OPTLABEL pattern_var + { ("?" ^ $1, None, $2) } + | TILDE LPAREN label_let_pattern RPAREN + { (fst $3, None, snd $3) } + | TILDE label_var + { (fst $2, None, snd $2) } + | LABEL simple_pattern + { ($1, None, $2) } + | simple_pattern + { ("", None, $1) } +; +pattern_var: + LIDENT { mkpat(Ppat_var $1) } + | UNDERSCORE { mkpat Ppat_any } +; +opt_default: + /* empty */ { None } + | EQUAL seq_expr { Some $2 } +; +label_let_pattern: + label_var + { $1 } + | label_var COLON core_type + { let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) } +; +label_var: + LIDENT { ($1, mkpat(Ppat_var $1)) } +; +let_pattern: + pattern + { $1 } + | pattern COLON core_type + { mkpat(Ppat_constraint($1, $3)) } +; +expr: + simple_expr %prec below_SHARP + { $1 } + | simple_expr simple_labeled_expr_list + { mkexp(Pexp_apply($1, List.rev $2)) } + | LET rec_flag let_bindings IN seq_expr + { mkexp(Pexp_let($2, List.rev $3, $5)) } + | LET MODULE UIDENT module_binding IN seq_expr + { mkexp(Pexp_letmodule($3, $4, $6)) } + | LET OPEN mod_longident IN seq_expr + { mkexp(Pexp_open($3, $5)) } + | FUNCTION opt_bar match_cases + { mkexp(Pexp_function("", None, List.rev $3)) } + | FUN labeled_simple_pattern fun_def + { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) } + | FUN LPAREN TYPE LIDENT RPAREN fun_def + { mkexp(Pexp_newtype($4, $6)) } + | MATCH seq_expr WITH opt_bar match_cases + { mkexp(Pexp_match($2, List.rev $5)) } + | TRY seq_expr WITH opt_bar match_cases + { mkexp(Pexp_try($2, List.rev $5)) } + | TRY seq_expr WITH error + { syntax_error() } + | expr_comma_list %prec below_COMMA + { mkexp(Pexp_tuple(List.rev $1)) } + | constr_longident simple_expr %prec below_SHARP + { mkexp(Pexp_construct($1, Some $2, false)) } + | name_tag simple_expr %prec below_SHARP + { mkexp(Pexp_variant($1, Some $2)) } + | IF seq_expr THEN expr ELSE expr + { mkexp(Pexp_ifthenelse($2, $4, Some $6)) } + | IF seq_expr THEN expr + { mkexp(Pexp_ifthenelse($2, $4, None)) } + | WHILE seq_expr DO seq_expr DONE + { mkexp(Pexp_while($2, $4)) } + | FOR val_ident EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE + { mkexp(Pexp_for($2, $4, $6, $5, $8)) } + | expr COLONCOLON expr + { mkexp(Pexp_construct(Lident "::", + Some(ghexp(Pexp_tuple[$1;$3])), + false)) } + | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN + { mkexp(Pexp_construct(Lident "::", + Some(ghexp(Pexp_tuple[$5;$7])), + false)) } + | expr INFIXOP0 expr + { mkinfix $1 $2 $3 } + | expr INFIXOP1 expr + { mkinfix $1 $2 $3 } + | expr INFIXOP2 expr + { mkinfix $1 $2 $3 } + | expr INFIXOP3 expr + { mkinfix $1 $2 $3 } + | expr INFIXOP4 expr + { mkinfix $1 $2 $3 } + | expr PLUS expr + { mkinfix $1 "+" $3 } + | expr PLUSDOT expr + { mkinfix $1 "+." $3 } + | expr MINUS expr + { mkinfix $1 "-" $3 } + | expr MINUSDOT expr + { mkinfix $1 "-." $3 } + | expr STAR expr + { mkinfix $1 "*" $3 } + | expr EQUAL expr + { mkinfix $1 "=" $3 } + | expr LESS expr + { mkinfix $1 "<" $3 } + | expr GREATER expr + { mkinfix $1 ">" $3 } + | expr OR expr + { mkinfix $1 "or" $3 } + | expr BARBAR expr + { mkinfix $1 "||" $3 } + | expr AMPERSAND expr + { mkinfix $1 "&" $3 } + | expr AMPERAMPER expr + { mkinfix $1 "&&" $3 } + | expr COLONEQUAL expr + { mkinfix $1 ":=" $3 } + | subtractive expr %prec prec_unary_minus + { mkuminus $1 $2 } + | additive expr %prec prec_unary_plus + { mkuplus $1 $2 } + | simple_expr DOT label_longident LESSMINUS expr + { mkexp(Pexp_setfield($1, $3, $5)) } + | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), + ["",$1; "",$4; "",$7])) } + | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")), + ["",$1; "",$4; "",$7])) } + | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr + { bigarray_set $1 $4 $7 } + | label LESSMINUS expr + { mkexp(Pexp_setinstvar($1, $3)) } + | ASSERT simple_expr %prec below_SHARP + { mkassert $2 } + | LAZY simple_expr %prec below_SHARP + { mkexp (Pexp_lazy ($2)) } + | OBJECT class_structure END + { mkexp (Pexp_object($2)) } + | OBJECT class_structure error + { unclosed "object" 1 "end" 3 } +; +simple_expr: + val_longident + { mkexp(Pexp_ident $1) } + | constant + { mkexp(Pexp_constant $1) } + | constr_longident %prec prec_constant_constructor + { mkexp(Pexp_construct($1, None, false)) } + | name_tag %prec prec_constant_constructor + { mkexp(Pexp_variant($1, None)) } + | LPAREN seq_expr RPAREN + { reloc_exp $2 } + | LPAREN seq_expr error + { unclosed "(" 1 ")" 3 } + | BEGIN seq_expr END + { reloc_exp $2 } + | BEGIN END + { mkexp (Pexp_construct (Lident "()", None, false)) } + | BEGIN seq_expr error + { unclosed "begin" 1 "end" 3 } + | LPAREN seq_expr type_constraint RPAREN + { let (t, t') = $3 in mkexp(Pexp_constraint($2, t, t')) } + | simple_expr DOT label_longident + { mkexp(Pexp_field($1, $3)) } + | mod_longident DOT LPAREN seq_expr RPAREN + { mkexp(Pexp_open($1, $4)) } + | mod_longident DOT LPAREN seq_expr error + { unclosed "(" 3 ")" 5 } + | simple_expr DOT LPAREN seq_expr RPAREN + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")), + ["",$1; "",$4])) } + | simple_expr DOT LPAREN seq_expr error + { unclosed "(" 3 ")" 5 } + | simple_expr DOT LBRACKET seq_expr RBRACKET + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")), + ["",$1; "",$4])) } + | simple_expr DOT LBRACKET seq_expr error + { unclosed "[" 3 "]" 5 } + | simple_expr DOT LBRACE expr RBRACE + { bigarray_get $1 $4 } + | simple_expr DOT LBRACE expr_comma_list error + { unclosed "{" 3 "}" 5 } + | LBRACE record_expr RBRACE + { let (exten, fields) = $2 in mkexp(Pexp_record(fields, exten)) } + | LBRACE record_expr error + { unclosed "{" 1 "}" 3 } + | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET + { mkexp(Pexp_array(List.rev $2)) } + | LBRACKETBAR expr_semi_list opt_semi error + { unclosed "[|" 1 "|]" 4 } + | LBRACKETBAR BARRBRACKET + { mkexp(Pexp_array []) } + | LBRACKET expr_semi_list opt_semi RBRACKET + { reloc_exp (mktailexp (List.rev $2)) } + | LBRACKET expr_semi_list opt_semi error + { unclosed "[" 1 "]" 4 } + | PREFIXOP simple_expr + { mkexp(Pexp_apply(mkoperator $1 1, ["",$2])) } + | BANG simple_expr + { mkexp(Pexp_apply(mkoperator "!" 1, ["",$2])) } + | NEW class_longident + { mkexp(Pexp_new($2)) } + | LBRACELESS field_expr_list opt_semi GREATERRBRACE + { mkexp(Pexp_override(List.rev $2)) } + | LBRACELESS field_expr_list opt_semi error + { unclosed "{<" 1 ">}" 4 } + | LBRACELESS GREATERRBRACE + { mkexp(Pexp_override []) } + | simple_expr SHARP label + { mkexp(Pexp_send($1, $3)) } + | LPAREN MODULE module_expr RPAREN + { mkexp (Pexp_pack $3) } + | LPAREN MODULE module_expr COLON package_type RPAREN + { mkexp (Pexp_constraint (ghexp (Pexp_pack $3), + Some (ghtyp (Ptyp_package $5)), None)) } + | LPAREN MODULE module_expr COLON error + { unclosed "(" 1 ")" 5 } +; +simple_labeled_expr_list: + labeled_simple_expr + { [$1] } + | simple_labeled_expr_list labeled_simple_expr + { $2 :: $1 } +; +labeled_simple_expr: + simple_expr %prec below_SHARP + { ("", $1) } + | label_expr + { $1 } +; +label_expr: + LABEL simple_expr %prec below_SHARP + { ($1, $2) } + | TILDE label_ident + { $2 } + | QUESTION label_ident + { ("?" ^ fst $2, snd $2) } + | OPTLABEL simple_expr %prec below_SHARP + { ("?" ^ $1, $2) } +; +label_ident: + LIDENT { ($1, mkexp(Pexp_ident(Lident $1))) } +; +let_bindings: + let_binding { [$1] } + | let_bindings AND let_binding { $3 :: $1 } +; +let_binding: + val_ident fun_binding + { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) } + | val_ident COLON typevar_list DOT core_type EQUAL seq_expr + { (ghpat(Ppat_constraint({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, + ghtyp(Ptyp_poly($3,$5)))), + $7) } + | pattern EQUAL seq_expr + { ($1, $3) } +; +fun_binding: + strict_binding + { $1 } + | type_constraint EQUAL seq_expr + { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) } +; +strict_binding: + EQUAL seq_expr + { $2 } + | labeled_simple_pattern fun_binding + { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) } + | LPAREN TYPE LIDENT RPAREN fun_binding + { mkexp(Pexp_newtype($3, $5)) } +; +match_cases: + pattern match_action { [$1, $2] } + | match_cases BAR pattern match_action { ($3, $4) :: $1 } +; +fun_def: + match_action { $1 } + | labeled_simple_pattern fun_def + { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) } + | LPAREN TYPE LIDENT RPAREN fun_def + { mkexp(Pexp_newtype($3, $5)) } +; +match_action: + MINUSGREATER seq_expr { $2 } + | WHEN seq_expr MINUSGREATER seq_expr { mkexp(Pexp_when($2, $4)) } +; +expr_comma_list: + expr_comma_list COMMA expr { $3 :: $1 } + | expr COMMA expr { [$3; $1] } +; +record_expr: + simple_expr WITH lbl_expr_list opt_semi { (Some $1, List.rev $3) } + | lbl_expr_list opt_semi { (None, List.rev $1) } +; +lbl_expr_list: + label_longident EQUAL expr + { [$1,$3] } + | label_longident + { [$1, exp_of_label $1] } + | lbl_expr_list SEMI label_longident EQUAL expr + { ($3, $5) :: $1 } + | lbl_expr_list SEMI label_longident + { ($3, exp_of_label $3) :: $1 } +; +field_expr_list: + label EQUAL expr + { [$1,$3] } + | field_expr_list SEMI label EQUAL expr + { ($3, $5) :: $1 } +; +expr_semi_list: + expr { [$1] } + | expr_semi_list SEMI expr { $3 :: $1 } +; +type_constraint: + COLON core_type { (Some $2, None) } + | COLON core_type COLONGREATER core_type { (Some $2, Some $4) } + | COLONGREATER core_type { (None, Some $2) } + | COLON error { syntax_error() } + | COLONGREATER error { syntax_error() } +; + +/* Patterns */ + +pattern: + simple_pattern + { $1 } + | pattern AS val_ident + { mkpat(Ppat_alias($1, $3)) } + | pattern_comma_list %prec below_COMMA + { mkpat(Ppat_tuple(List.rev $1)) } + | constr_longident pattern %prec prec_constr_appl + { mkpat(Ppat_construct($1, Some $2, false)) } + | name_tag pattern %prec prec_constr_appl + { mkpat(Ppat_variant($1, Some $2)) } + | pattern COLONCOLON pattern + { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$1;$3])), + false)) } + | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN + { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$5;$7])), + false)) } + | pattern BAR pattern + { mkpat(Ppat_or($1, $3)) } + | LAZY simple_pattern + { mkpat(Ppat_lazy $2) } +; +simple_pattern: + val_ident %prec below_EQUAL + { mkpat(Ppat_var $1) } + | UNDERSCORE + { mkpat(Ppat_any) } + | signed_constant + { mkpat(Ppat_constant $1) } + | CHAR DOTDOT CHAR + { mkrangepat $1 $3 } + | constr_longident + { mkpat(Ppat_construct($1, None, false)) } + | name_tag + { mkpat(Ppat_variant($1, None)) } + | SHARP type_longident + { mkpat(Ppat_type $2) } + | LBRACE lbl_pattern_list record_pattern_end RBRACE + { mkpat(Ppat_record(List.rev $2, $3)) } + | LBRACE lbl_pattern_list opt_semi error + { unclosed "{" 1 "}" 4 } + | LBRACKET pattern_semi_list opt_semi RBRACKET + { reloc_pat (mktailpat (List.rev $2)) } + | LBRACKET pattern_semi_list opt_semi error + { unclosed "[" 1 "]" 4 } + | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET + { mkpat(Ppat_array(List.rev $2)) } + | LBRACKETBAR BARRBRACKET + { mkpat(Ppat_array []) } + | LBRACKETBAR pattern_semi_list opt_semi error + { unclosed "[|" 1 "|]" 4 } + | LPAREN pattern RPAREN + { reloc_pat $2 } + | LPAREN pattern error + { unclosed "(" 1 ")" 3 } + | LPAREN pattern COLON core_type RPAREN + { mkpat(Ppat_constraint($2, $4)) } + | LPAREN pattern COLON core_type error + { unclosed "(" 1 ")" 5 } + | LPAREN MODULE UIDENT RPAREN + { mkpat(Ppat_unpack $3) } + | LPAREN MODULE UIDENT COLON package_type RPAREN + { mkpat(Ppat_constraint(mkpat(Ppat_unpack $3),ghtyp(Ptyp_package $5))) } + | LPAREN MODULE UIDENT COLON package_type error + { unclosed "(" 1 ")" 6 } +; + +pattern_comma_list: + pattern_comma_list COMMA pattern { $3 :: $1 } + | pattern COMMA pattern { [$3; $1] } +; +pattern_semi_list: + pattern { [$1] } + | pattern_semi_list SEMI pattern { $3 :: $1 } +; +lbl_pattern_list: + label_longident EQUAL pattern { [($1, $3)] } + | label_longident { [($1, pat_of_label $1)] } + | lbl_pattern_list SEMI label_longident EQUAL pattern { ($3, $5) :: $1 } + | lbl_pattern_list SEMI label_longident { ($3, pat_of_label $3) :: $1 } +; +record_pattern_end: + opt_semi { Closed } + | SEMI UNDERSCORE opt_semi { Open } +; + +/* Primitive declarations */ + +primitive_declaration: + STRING { [$1] } + | STRING primitive_declaration { $1 :: $2 } +; + +/* Type declarations */ + +type_declarations: + type_declaration { [$1] } + | type_declarations AND type_declaration { $3 :: $1 } +; + +type_declaration: + type_parameters LIDENT type_kind constraints + { let (params, variance) = List.split $1 in + let (kind, private_flag, manifest) = $3 in + ($2, {ptype_params = params; + ptype_cstrs = List.rev $4; + ptype_kind = kind; + ptype_private = private_flag; + ptype_manifest = manifest; + ptype_variance = variance; + ptype_loc = symbol_rloc()}) } +; +constraints: + constraints CONSTRAINT constrain { $3 :: $1 } + | /* empty */ { [] } +; +type_kind: + /*empty*/ + { (Ptype_abstract, Public, None) } + | EQUAL core_type + { (Ptype_abstract, Public, Some $2) } + | EQUAL PRIVATE core_type + { (Ptype_abstract, Private, Some $3) } + | EQUAL constructor_declarations + { (Ptype_variant(List.rev $2), Public, None) } + | EQUAL PRIVATE constructor_declarations + { (Ptype_variant(List.rev $3), Private, None) } + | EQUAL private_flag BAR constructor_declarations + { (Ptype_variant(List.rev $4), $2, None) } + | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE + { (Ptype_record(List.rev $4), $2, None) } + | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations + { (Ptype_variant(List.rev $6), $4, Some $2) } + | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE + { (Ptype_record(List.rev $6), $4, Some $2) } +; +type_parameters: + /*empty*/ { [] } + | type_parameter { [$1] } + | LPAREN type_parameter_list RPAREN { List.rev $2 } +; +type_parameter: + type_variance QUOTE ident { $3, $1 } +; +type_variance: + /* empty */ { false, false } + | PLUS { true, false } + | MINUS { false, true } +; +type_parameter_list: + type_parameter { [$1] } + | type_parameter_list COMMA type_parameter { $3 :: $1 } +; +constructor_declarations: + constructor_declaration { [$1] } + | constructor_declarations BAR constructor_declaration { $3 :: $1 } +; +constructor_declaration: + constr_ident constructor_arguments { ($1, $2, symbol_rloc()) } +; +constructor_arguments: + /*empty*/ { [] } + | OF core_type_list { List.rev $2 } +; +label_declarations: + label_declaration { [$1] } + | label_declarations SEMI label_declaration { $3 :: $1 } +; +label_declaration: + mutable_flag label COLON poly_type { ($2, $1, $4, symbol_rloc()) } +; + +/* "with" constraints (additional type equations over signature components) */ + +with_constraints: + with_constraint { [$1] } + | with_constraints AND with_constraint { $3 :: $1 } +; +with_constraint: + TYPE type_parameters label_longident with_type_binder core_type constraints + { let params, variance = List.split $2 in + ($3, Pwith_type {ptype_params = params; + ptype_cstrs = List.rev $6; + ptype_kind = Ptype_abstract; + ptype_manifest = Some $5; + ptype_private = $4; + ptype_variance = variance; + ptype_loc = symbol_rloc()}) } + /* used label_longident instead of type_longident to disallow + functor applications in type path */ + | TYPE type_parameters label_longident COLONEQUAL core_type + { let params, variance = List.split $2 in + ($3, Pwith_typesubst {ptype_params = params; + ptype_cstrs = []; + ptype_kind = Ptype_abstract; + ptype_manifest = Some $5; + ptype_private = Public; + ptype_variance = variance; + ptype_loc = symbol_rloc()}) } + | MODULE mod_longident EQUAL mod_ext_longident + { ($2, Pwith_module $4) } + | MODULE mod_longident COLONEQUAL mod_ext_longident + { ($2, Pwith_modsubst $4) } +; +with_type_binder: + EQUAL { Public } + | EQUAL PRIVATE { Private } +; + +/* Polymorphic types */ + +typevar_list: + QUOTE ident { [$2] } + | typevar_list QUOTE ident { $3 :: $1 } +; +poly_type: + core_type + { mktyp(Ptyp_poly([], $1)) } + | typevar_list DOT core_type + { mktyp(Ptyp_poly(List.rev $1, $3)) } +; + +/* Core types */ + +core_type: + core_type2 + { $1 } + | core_type2 AS QUOTE ident + { mktyp(Ptyp_alias($1, $4)) } +; +core_type2: + simple_core_type_or_tuple + { $1 } + | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 + { mktyp(Ptyp_arrow("?" ^ $2 , + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); + ptyp_loc = $4.ptyp_loc}, $6)) } + | OPTLABEL core_type2 MINUSGREATER core_type2 + { mktyp(Ptyp_arrow("?" ^ $1 , + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); + ptyp_loc = $2.ptyp_loc}, $4)) } + | LIDENT COLON core_type2 MINUSGREATER core_type2 + { mktyp(Ptyp_arrow($1, $3, $5)) } + | core_type2 MINUSGREATER core_type2 + { mktyp(Ptyp_arrow("", $1, $3)) } +; + +simple_core_type: + simple_core_type2 %prec below_SHARP + { $1 } + | LPAREN core_type_comma_list RPAREN %prec below_SHARP + { match $2 with [sty] -> sty | _ -> raise Parse_error } +; +simple_core_type2: + QUOTE ident + { mktyp(Ptyp_var $2) } + | UNDERSCORE + { mktyp(Ptyp_any) } + | type_longident + { mktyp(Ptyp_constr($1, [])) } + | simple_core_type2 type_longident + { mktyp(Ptyp_constr($2, [$1])) } + | LPAREN core_type_comma_list RPAREN type_longident + { mktyp(Ptyp_constr($4, List.rev $2)) } + | LESS meth_list GREATER + { mktyp(Ptyp_object $2) } + | LESS GREATER + { mktyp(Ptyp_object []) } + | SHARP class_longident opt_present + { mktyp(Ptyp_class($2, [], $3)) } + | simple_core_type2 SHARP class_longident opt_present + { mktyp(Ptyp_class($3, [$1], $4)) } + | LPAREN core_type_comma_list RPAREN SHARP class_longident opt_present + { mktyp(Ptyp_class($5, List.rev $2, $6)) } + | LBRACKET tag_field RBRACKET + { mktyp(Ptyp_variant([$2], true, None)) } +/* PR#3835: this is not LR(1), would need lookahead=2 + | LBRACKET simple_core_type2 RBRACKET + { mktyp(Ptyp_variant([$2], true, None)) } +*/ + | LBRACKET BAR row_field_list RBRACKET + { mktyp(Ptyp_variant(List.rev $3, true, None)) } + | LBRACKET row_field BAR row_field_list RBRACKET + { mktyp(Ptyp_variant($2 :: List.rev $4, true, None)) } + | LBRACKETGREATER opt_bar row_field_list RBRACKET + { mktyp(Ptyp_variant(List.rev $3, false, None)) } + | LBRACKETGREATER RBRACKET + { mktyp(Ptyp_variant([], false, None)) } + | LBRACKETLESS opt_bar row_field_list RBRACKET + { mktyp(Ptyp_variant(List.rev $3, true, Some [])) } + | LBRACKETLESS opt_bar row_field_list GREATER name_tag_list RBRACKET + { mktyp(Ptyp_variant(List.rev $3, true, Some (List.rev $5))) } + | LPAREN MODULE package_type RPAREN + { mktyp(Ptyp_package $3) } +; +package_type: + mty_longident { ($1, []) } + | mty_longident WITH package_type_cstrs { ($1, $3) } + +package_type_cstr: + TYPE LIDENT EQUAL core_type { ($2, $4) } +; +package_type_cstrs: + package_type_cstr { [$1] } + | package_type_cstr AND package_type_cstrs { $1::$3 } +; +row_field_list: + row_field { [$1] } + | row_field_list BAR row_field { $3 :: $1 } +; +row_field: + tag_field { $1 } + | simple_core_type2 { Rinherit $1 } +; +tag_field: + name_tag OF opt_ampersand amper_type_list + { Rtag ($1, $3, List.rev $4) } + | name_tag + { Rtag ($1, true, []) } +; +opt_ampersand: + AMPERSAND { true } + | /* empty */ { false } +; +amper_type_list: + core_type { [$1] } + | amper_type_list AMPERSAND core_type { $3 :: $1 } +; +opt_present: + LBRACKETGREATER name_tag_list RBRACKET { List.rev $2 } + | /* empty */ { [] } +; +name_tag_list: + name_tag { [$1] } + | name_tag_list name_tag { $2 :: $1 } +; +simple_core_type_or_tuple: + simple_core_type { $1 } + | simple_core_type STAR core_type_list + { mktyp(Ptyp_tuple($1 :: List.rev $3)) } +; +core_type_comma_list: + core_type { [$1] } + | core_type_comma_list COMMA core_type { $3 :: $1 } +; +core_type_list: + simple_core_type { [$1] } + | core_type_list STAR simple_core_type { $3 :: $1 } +; +meth_list: + field SEMI meth_list { $1 :: $3 } + | field opt_semi { [$1] } + | DOTDOT { [mkfield Pfield_var] } +; +field: + label COLON poly_type { mkfield(Pfield($1, $3)) } +; +label: + LIDENT { $1 } +; + +/* Constants */ + +constant: + INT { Const_int $1 } + | CHAR { Const_char $1 } + | STRING { Const_string $1 } + | FLOAT { Const_float $1 } + | INT32 { Const_int32 $1 } + | INT64 { Const_int64 $1 } + | NATIVEINT { Const_nativeint $1 } +; +signed_constant: + constant { $1 } + | MINUS INT { Const_int(- $2) } + | MINUS FLOAT { Const_float("-" ^ $2) } + | MINUS INT32 { Const_int32(Int32.neg $2) } + | MINUS INT64 { Const_int64(Int64.neg $2) } + | MINUS NATIVEINT { Const_nativeint(Nativeint.neg $2) } + | PLUS INT { Const_int $2 } + | PLUS FLOAT { Const_float $2 } + | PLUS INT32 { Const_int32 $2 } + | PLUS INT64 { Const_int64 $2 } + | PLUS NATIVEINT { Const_nativeint $2 } +; + +/* Identifiers and long identifiers */ + +ident: + UIDENT { $1 } + | LIDENT { $1 } +; +val_ident: + LIDENT { $1 } + | LPAREN operator RPAREN { $2 } +; +operator: + PREFIXOP { $1 } + | INFIXOP0 { $1 } + | INFIXOP1 { $1 } + | INFIXOP2 { $1 } + | INFIXOP3 { $1 } + | INFIXOP4 { $1 } + | BANG { "!" } + | PLUS { "+" } + | PLUSDOT { "+." } + | MINUS { "-" } + | MINUSDOT { "-." } + | STAR { "*" } + | EQUAL { "=" } + | LESS { "<" } + | GREATER { ">" } + | OR { "or" } + | BARBAR { "||" } + | AMPERSAND { "&" } + | AMPERAMPER { "&&" } + | COLONEQUAL { ":=" } +; +constr_ident: + UIDENT { $1 } +/* | LBRACKET RBRACKET { "[]" } */ + | LPAREN RPAREN { "()" } + | COLONCOLON { "::" } +/* | LPAREN COLONCOLON RPAREN { "::" } */ + | FALSE { "false" } + | TRUE { "true" } +; + +val_longident: + val_ident { Lident $1 } + | mod_longident DOT val_ident { Ldot($1, $3) } +; +constr_longident: + mod_longident %prec below_DOT { $1 } + | LBRACKET RBRACKET { Lident "[]" } + | LPAREN RPAREN { Lident "()" } + | FALSE { Lident "false" } + | TRUE { Lident "true" } +; +label_longident: + LIDENT { Lident $1 } + | mod_longident DOT LIDENT { Ldot($1, $3) } +; +type_longident: + LIDENT { Lident $1 } + | mod_ext_longident DOT LIDENT { Ldot($1, $3) } +; +mod_longident: + UIDENT { Lident $1 } + | mod_longident DOT UIDENT { Ldot($1, $3) } +; +mod_ext_longident: + UIDENT { Lident $1 } + | mod_ext_longident DOT UIDENT { Ldot($1, $3) } + | mod_ext_longident LPAREN mod_ext_longident RPAREN { lapply $1 $3 } +; +mty_longident: + ident { Lident $1 } + | mod_ext_longident DOT ident { Ldot($1, $3) } +; +clty_longident: + LIDENT { Lident $1 } + | mod_ext_longident DOT LIDENT { Ldot($1, $3) } +; +class_longident: + LIDENT { Lident $1 } + | mod_longident DOT LIDENT { Ldot($1, $3) } +; + +/* Toplevel directives */ + +toplevel_directive: + SHARP ident { Ptop_dir($2, Pdir_none) } + | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) } + | SHARP ident INT { Ptop_dir($2, Pdir_int $3) } + | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) } + | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) } +; + +/* Miscellaneous */ + +name_tag: + BACKQUOTE ident { $2 } +; +rec_flag: + /* empty */ { Nonrecursive } + | REC { Recursive } +; +direction_flag: + TO { Upto } + | DOWNTO { Downto } +; +private_flag: + /* empty */ { Public } + | PRIVATE { Private } +; +mutable_flag: + /* empty */ { Immutable } + | MUTABLE { Mutable } +; +virtual_flag: + /* empty */ { Concrete } + | VIRTUAL { Virtual } +; +override_flag: + /* empty */ { Fresh } + | BANG { Override } +; +opt_bar: + /* empty */ { () } + | BAR { () } +; +opt_semi: + | /* empty */ { () } + | SEMI { () } +; +subtractive: + | MINUS { "-" } + | MINUSDOT { "-." } +; +additive: + | PLUS { "+" } + | PLUSDOT { "+." } +; +%% diff --git a/ocaml-binary-annot/parsing/parsetree.mli b/ocaml-binary-annot/parsing/parsetree.mli new file mode 100644 index 0000000000..976283ff19 --- /dev/null +++ b/ocaml-binary-annot/parsing/parsetree.mli @@ -0,0 +1,287 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Abstract syntax tree produced by parsing *) + +open Asttypes + +(* Type expressions for the core language *) + +type core_type = + { ptyp_desc: core_type_desc; + ptyp_loc: Location.t } + +and core_type_desc = + Ptyp_any + | Ptyp_var of string + | Ptyp_arrow of label * core_type * core_type + | Ptyp_tuple of core_type list + | Ptyp_constr of Longident.t * core_type list + | Ptyp_object of core_field_type list + | Ptyp_class of Longident.t * core_type list * label list + | Ptyp_alias of core_type * string + | Ptyp_variant of row_field list * bool * label list option + | Ptyp_poly of string list * core_type + | Ptyp_package of package_type + +and package_type = Longident.t * (string * core_type) list + +and core_field_type = + { pfield_desc: core_field_desc; + pfield_loc: Location.t } + +and core_field_desc = + Pfield of string * core_type + | Pfield_var + +and row_field = + Rtag of label * bool * core_type list + | Rinherit of core_type + +(* Type expressions for the class language *) + +type 'a class_infos = + { pci_virt: virtual_flag; + pci_params: string list * Location.t; + pci_name: string; + pci_expr: 'a; + pci_variance: (bool * bool) list; + pci_loc: Location.t } + +(* Value expressions for the core language *) + +type pattern = + { ppat_desc: pattern_desc; + ppat_loc: Location.t } + +and pattern_desc = + Ppat_any + | Ppat_var of string + | Ppat_alias of pattern * string + | Ppat_constant of constant + | Ppat_tuple of pattern list + | Ppat_construct of Longident.t * pattern option * bool + | Ppat_variant of label * pattern option + | Ppat_record of (Longident.t * pattern) list * closed_flag + | Ppat_array of pattern list + | Ppat_or of pattern * pattern + | Ppat_constraint of pattern * core_type + | Ppat_type of Longident.t + | Ppat_lazy of pattern + | Ppat_unpack of string + +type expression = + { pexp_desc: expression_desc; + pexp_loc: Location.t } + +and expression_desc = + Pexp_ident of Longident.t + | Pexp_constant of constant + | Pexp_let of rec_flag * (pattern * expression) list * expression + | Pexp_function of label * expression option * (pattern * expression) list + | Pexp_apply of expression * (label * expression) list + | Pexp_match of expression * (pattern * expression) list + | Pexp_try of expression * (pattern * expression) list + | Pexp_tuple of expression list + | Pexp_construct of Longident.t * expression option * bool + | Pexp_variant of label * expression option + | Pexp_record of (Longident.t * expression) list * expression option + | Pexp_field of expression * Longident.t + | Pexp_setfield of expression * Longident.t * expression + | Pexp_array of expression list + | Pexp_ifthenelse of expression * expression * expression option + | Pexp_sequence of expression * expression + | Pexp_while of expression * expression + | Pexp_for of string * expression * expression * direction_flag * expression + | Pexp_constraint of expression * core_type option * core_type option + | Pexp_when of expression * expression + | Pexp_send of expression * string + | Pexp_new of Longident.t + | Pexp_setinstvar of string * expression + | Pexp_override of (string * expression) list + | Pexp_letmodule of string * module_expr * expression + | Pexp_assert of expression + | Pexp_assertfalse + | Pexp_lazy of expression + | Pexp_poly of expression * core_type option + | Pexp_object of class_structure + | Pexp_newtype of string * expression + | Pexp_pack of module_expr + | Pexp_open of Longident.t * expression + +(* Value descriptions *) + +and value_description = + { pval_type: core_type; + pval_prim: string list } + +(* Type declarations *) + +and type_declaration = + { ptype_params: string list; + ptype_cstrs: (core_type * core_type * Location.t) list; + ptype_kind: type_kind; + ptype_private: private_flag; + ptype_manifest: core_type option; + ptype_variance: (bool * bool) list; + ptype_loc: Location.t } + +and type_kind = + Ptype_abstract + | Ptype_variant of (string * core_type list * Location.t) list + | Ptype_record of + (string * mutable_flag * core_type * Location.t) list + +and exception_declaration = core_type list + +(* Type expressions for the class language *) + +and class_type = + { pcty_desc: class_type_desc; + pcty_loc: Location.t } + +and class_type_desc = + Pcty_constr of Longident.t * core_type list + | Pcty_signature of class_signature + | Pcty_fun of label * core_type * class_type + +and class_signature = core_type * class_type_field list + +and class_type_field = + Pctf_inher of class_type + | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t) + | Pctf_virt of (string * private_flag * core_type * Location.t) + | Pctf_meth of (string * private_flag * core_type * Location.t) + | Pctf_cstr of (core_type * core_type * Location.t) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(* Value expressions for the class language *) + +and class_expr = + { pcl_desc: class_expr_desc; + pcl_loc: Location.t } + +and class_expr_desc = + Pcl_constr of Longident.t * core_type list + | Pcl_structure of class_structure + | Pcl_fun of label * expression option * pattern * class_expr + | Pcl_apply of class_expr * (label * expression) list + | Pcl_let of rec_flag * (pattern * expression) list * class_expr + | Pcl_constraint of class_expr * class_type + +and class_structure = pattern * class_field list + +and class_field = + Pcf_inher of override_flag * class_expr * string option + | Pcf_valvirt of (string * mutable_flag * core_type * Location.t) + | Pcf_val of (string * mutable_flag * override_flag * expression * Location.t) + | Pcf_virt of (string * private_flag * core_type * Location.t) + | Pcf_meth of (string * private_flag *override_flag * expression * Location.t) + | Pcf_cstr of (core_type * core_type * Location.t) + | Pcf_let of rec_flag * (pattern * expression) list * Location.t + | Pcf_init of expression + +and class_declaration = class_expr class_infos + +(* Type expressions for the module language *) + +and module_type = + { pmty_desc: module_type_desc; + pmty_loc: Location.t } + +and module_type_desc = + Pmty_ident of Longident.t + | Pmty_signature of signature + | Pmty_functor of string * module_type * module_type + | Pmty_with of module_type * (Longident.t * with_constraint) list + | Pmty_typeof of module_expr + +and signature = signature_item list + +and signature_item = + { psig_desc: signature_item_desc; + psig_loc: Location.t } + +and signature_item_desc = + Psig_value of string * value_description + | Psig_type of (string * type_declaration) list + | Psig_exception of string * exception_declaration + | Psig_module of string * module_type + | Psig_recmodule of (string * module_type) list + | Psig_modtype of string * modtype_declaration + | Psig_open of Longident.t + | Psig_include of module_type + | Psig_class of class_description list + | Psig_class_type of class_type_declaration list + +and modtype_declaration = + Pmodtype_abstract + | Pmodtype_manifest of module_type + +and with_constraint = + Pwith_type of type_declaration + | Pwith_module of Longident.t + | Pwith_typesubst of type_declaration + | Pwith_modsubst of Longident.t + +(* value expressions for the module language *) + +and module_expr = + { pmod_desc: module_expr_desc; + pmod_loc: Location.t } + +and module_expr_desc = + Pmod_ident of Longident.t + | Pmod_structure of structure + | Pmod_functor of string * module_type * module_expr + | Pmod_apply of module_expr * module_expr + | Pmod_constraint of module_expr * module_type + | Pmod_unpack of expression + +and structure = structure_item list + +and structure_item = + { pstr_desc: structure_item_desc; + pstr_loc: Location.t } + +and structure_item_desc = + Pstr_eval of expression + | Pstr_value of rec_flag * (pattern * expression) list + | Pstr_primitive of string * value_description + | Pstr_type of (string * type_declaration) list + | Pstr_exception of string * exception_declaration + | Pstr_exn_rebind of string * Longident.t + | Pstr_module of string * module_expr + | Pstr_recmodule of (string * module_type * module_expr) list + | Pstr_modtype of string * module_type + | Pstr_open of Longident.t + | Pstr_class of class_declaration list + | Pstr_class_type of class_type_declaration list + | Pstr_include of module_expr + +(* Toplevel phrases *) + +type toplevel_phrase = + Ptop_def of structure + | Ptop_dir of string * directive_argument + +and directive_argument = + Pdir_none + | Pdir_string of string + | Pdir_int of int + | Pdir_ident of Longident.t + | Pdir_bool of bool diff --git a/ocaml-binary-annot/parsing/printast.ml b/ocaml-binary-annot/parsing/printast.ml new file mode 100644 index 0000000000..2b236ae827 --- /dev/null +++ b/ocaml-binary-annot/parsing/printast.ml @@ -0,0 +1,736 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Asttypes;; +open Format;; +open Lexing;; +open Location;; +open Parsetree;; + +let fmt_position f l = + if l.pos_fname = "" && l.pos_lnum = 1 + then fprintf f "%d" l.pos_cnum + else if l.pos_lnum = -1 + then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) +;; + +let fmt_location f loc = + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; +;; + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; +;; + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;; + +let fmt_constant f x = + match x with + | Const_int (i) -> fprintf f "Const_int %d" i; + | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); + | Const_string (s) -> fprintf f "Const_string %S" s; + | Const_float (s) -> fprintf f "Const_float %s" s; + | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; + | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; + | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i; +;; + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable"; + | Mutable -> fprintf f "Mutable"; +;; + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual"; + | Concrete -> fprintf f "Concrete"; +;; + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override"; + | Fresh -> fprintf f "Fresh"; +;; + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec"; + | Recursive -> fprintf f "Rec"; + | Default -> fprintf f "Default"; +;; + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up"; + | Downto -> fprintf f "Down"; +;; + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public"; + | Private -> fprintf f "Private"; +;; + +let line i f s (*...*) = + fprintf f "%s" (String.make (2*i) ' '); + fprintf f s (*...*) +;; + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n"; + | h::t -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n"; +;; + +let option i f ppf x = + match x with + | None -> line i ppf "None\n"; + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x; +;; + +let longident i ppf li = line i ppf "%a\n" fmt_longident li;; +let string i ppf s = line i ppf "\"%s\"\n" s;; +let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; +let label i ppf x = line i ppf "label=\"%s\"\n" x;; + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ptyp_loc; + let i = i+1 in + match x.ptyp_desc with + | Ptyp_any -> line i ppf "Ptyp_any\n"; + | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + string i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ptyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ptyp_constr (li, l) -> + line i ppf "Ptyp_constr %a\n" fmt_longident li; + list i core_type ppf l; + | Ptyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed); + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ptyp_object (l) -> + line i ppf "Ptyp_object\n"; + list i core_field_type ppf l; + | Ptyp_class (li, l, low) -> + line i ppf "Ptyp_class %a\n" fmt_longident li; + list i core_type ppf l; + list i string ppf low + | Ptyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; + core_type i ppf ct; + | Ptyp_package (s, l) -> + line i ppf "Ptyp_package %a\n" fmt_longident s; + list i package_with ppf l + +and package_with i ppf (s, t) = + line i ppf "with type %s\n" s; + core_type i ppf t + +and core_field_type i ppf x = + line i ppf "core_field_type %a\n" fmt_location x.pfield_loc; + let i = i+1 in + match x.pfield_desc with + | Pfield (s, ct) -> + line i ppf "Pfield \"%s\"\n" s; + core_type i ppf ct; + | Pfield_var -> line i ppf "Pfield_var\n"; + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.ppat_loc; + let i = i+1 in + match x.ppat_desc with + | Ppat_any -> line i ppf "Ppat_any\n"; + | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s; + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias \"%s\"\n" s; + pattern i ppf p; + | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Ppat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Ppat_construct (li, po, b) -> + line i ppf "Ppat_construct %a\n" fmt_longident li; + option i pattern ppf po; + bool i ppf b; + | Ppat_variant (l, po) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Ppat_record (l, c) -> + line i ppf "Ppat_record\n"; + list i longident_x_pattern ppf l; + | Ppat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Ppat_or (p1, p2) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + | Ppat_constraint (p, ct) -> + line i ppf "Ppat_constraint"; + pattern i ppf p; + core_type i ppf ct; + | Ppat_type li -> + line i ppf "Ppat_type"; + longident i ppf li + | Ppat_unpack s -> + line i ppf "Ppat_unpack \"%s\"\n" s; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.pexp_loc; + let i = i+1 in + match x.pexp_desc with + | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident li; + | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + expression i ppf e; + | Pexp_function (p, eo, l) -> + line i ppf "Pexp_function \"%s\"\n" p; + option i expression ppf eo; + list i pattern_x_expression_case ppf l; + | Pexp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Pexp_match (e, l) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; + | Pexp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Pexp_construct (li, eo, b) -> + line i ppf "Pexp_construct %a\n" fmt_longident li; + option i expression ppf eo; + bool i ppf b; + | Pexp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Pexp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Pexp_field (e, li) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + longident i ppf li; + | Pexp_setfield (e1, li, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident i ppf li; + expression i ppf e2; + | Pexp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Pexp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Pexp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_for (s, e1, e2, df, e3) -> + line i ppf "Pexp_for \"%s\" %a\n" s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Pexp_constraint (e, cto1, cto2) -> + line i ppf "Pexp_constraint\n"; + expression i ppf e; + option i core_type ppf cto1; + option i core_type ppf cto2; + | Pexp_when (e1, e2) -> + line i ppf "Pexp_when\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_send (e, s) -> + line i ppf "Pexp_send \"%s\"\n" s; + expression i ppf e; + | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li; + | Pexp_setinstvar (s, e) -> + line i ppf "Pexp_setinstvar \"%s\"\n" s; + expression i ppf e; + | Pexp_override (l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Pexp_letmodule (s, me, e) -> + line i ppf "Pexp_letmodule \"%s\"\n" s; + module_expr i ppf me; + expression i ppf e; + | Pexp_assert (e) -> + line i ppf "Pexp_assert"; + expression i ppf e; + | Pexp_assertfalse -> + line i ppf "Pexp_assertfalse"; + | Pexp_lazy (e) -> + line i ppf "Pexp_lazy"; + expression i ppf e; + | Pexp_poly (e, cto) -> + line i ppf "Pexp_poly\n"; + expression i ppf e; + option i core_type ppf cto; + | Pexp_object s -> + line i ppf "Pexp_object"; + class_structure i ppf s + | Pexp_newtype (s, e) -> + line i ppf "Pexp_newtype \"%s\"\n" s; + expression i ppf e + | Pexp_pack me -> + line i ppf "Pexp_pack"; + module_expr i ppf me + | Pexp_open (m, e) -> + line i ppf "Pexp_open \"%a\"\n" fmt_longident m; + expression i ppf e + +and value_description i ppf x = + line i ppf "value_description\n"; + core_type (i+1) ppf x.pval_type; + list (i+1) string ppf x.pval_prim; + +and type_declaration i ppf x = + line i ppf "type_declaration %a\n" fmt_location x.ptype_loc; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) string ppf x.ptype_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.ptype_manifest; + +and type_kind i ppf x = + match x with + | Ptype_abstract -> + line i ppf "Ptype_abstract\n" + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) string_x_core_type_list_x_location ppf l; + | Ptype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; + +and exception_declaration i ppf x = list i core_type ppf x + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.pcty_loc; + let i = i+1 in + match x.pcty_desc with + | Pcty_constr (li, l) -> + line i ppf "Pcty_constr %a\n" fmt_longident li; + list i core_type ppf l; + | Pcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Pcty_fun (l, co, cl) -> + line i ppf "Pcty_fun \"%s\"\n" l; + core_type i ppf co; + class_type i ppf cl; + +and class_signature i ppf (ct, l) = + line i ppf "class_signature\n"; + core_type (i+1) ppf ct; + list (i+1) class_type_field ppf l; + +and class_type_field i ppf x = + match x with + | Pctf_inher (ct) -> + line i ppf "Pctf_inher\n"; + class_type i ppf ct; + | Pctf_val (s, mf, vf, ct, loc) -> + line i ppf + "Pctf_val \"%s\" %a %a %a\n" s + fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; + core_type (i+1) ppf ct; + | Pctf_virt (s, pf, ct, loc) -> + line i ppf + "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Pctf_meth (s, pf, ct, loc) -> + line i ppf + "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Pctf_cstr (ct1, ct2, loc) -> + line i ppf "Pctf_cstr %a\n" fmt_location loc; + core_type i ppf ct1; + core_type i ppf ct2; + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.pci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.pci_params; + line i ppf "pci_name = \"%s\"\n" x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.pci_params; + line i ppf "pci_name = \"%s\"\n" x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.pcl_loc; + let i = i+1 in + match x.pcl_desc with + | Pcl_constr (li, l) -> + line i ppf "Pcl_constr %a\n" fmt_longident li; + list i core_type ppf l; + | Pcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Pcl_fun (l, eo, p, e) -> + line i ppf "Pcl_fun\n"; + label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; + | Pcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Pcl_let (rf, l, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + class_expr i ppf ce; + | Pcl_constraint (ce, ct) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + +and class_structure i ppf (p, l) = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + match x with + | Pcf_inher (ovf, ce, so) -> + line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string ppf so; + | Pcf_valvirt (s, mf, ct, loc) -> + line i ppf "Pcf_valvirt \"%s\" %a %a\n" + s fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; + | Pcf_val (s, mf, ovf, e, loc) -> + line i ppf "Pcf_val \"%s\" %a %a %a\n" + s fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; + expression (i+1) ppf e; + | Pcf_virt (s, pf, ct, loc) -> + line i ppf "Pcf_virt \"%s\" %a %a\n" + s fmt_private_flag pf fmt_location loc; + core_type (i+1) ppf ct; + | Pcf_meth (s, pf, ovf, e, loc) -> + line i ppf "Pcf_meth \"%s\" %a %a %a\n" + s fmt_private_flag pf fmt_override_flag ovf fmt_location loc; + expression (i+1) ppf e; + | Pcf_cstr (ct1, ct2, loc) -> + line i ppf "Pcf_cstr %a\n" fmt_location loc; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pcf_let (rf, l, loc) -> + line i ppf "Pcf_let %a %a\n" fmt_rec_flag rf fmt_location loc; + list (i+1) pattern_x_expression_def ppf l; + | Pcf_init (e) -> + line i ppf "Pcf_init\n"; + expression (i+1) ppf e; + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.pci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + string_list_x_location (i+1) ppf x.pci_params; + line i ppf "pci_name = \"%s\"\n" x.pci_name; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.pci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.pmty_loc; + let i = i+1 in + match x.pmty_desc with + | Pmty_ident (li) -> line i ppf "Pmty_ident %a\n" fmt_longident li; + | Pmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Pmty_functor (s, mt1, mt2) -> + line i ppf "Pmty_functor \"%s\"\n" s; + module_type i ppf mt1; + module_type i ppf mt2; + | Pmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l; + | Pmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m + +and signature i ppf x = list i signature_item ppf x + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.psig_loc; + let i = i+1 in + match x.psig_desc with + | Psig_value (s, vd) -> + line i ppf "Psig_value \"%s\"\n" s; + value_description i ppf vd; + | Psig_type (l) -> + line i ppf "Psig_type\n"; + list i string_x_type_declaration ppf l; + | Psig_exception (s, ed) -> + line i ppf "Psig_exception \"%s\"\n" s; + exception_declaration i ppf ed; + | Psig_module (s, mt) -> + line i ppf "Psig_module \"%s\"\n" s; + module_type i ppf mt; + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i string_x_module_type ppf decls; + | Psig_modtype (s, md) -> + line i ppf "Psig_modtype \"%s\"\n" s; + modtype_declaration i ppf md; + | Psig_open (li) -> line i ppf "Psig_open %a\n" fmt_longident li; + | Psig_include (mt) -> + line i ppf "Psig_include\n"; + module_type i ppf mt; + | Psig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Psig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + +and modtype_declaration i ppf x = + match x with + | Pmodtype_abstract -> line i ppf "Pmodtype_abstract\n"; + | Pmodtype_manifest (mt) -> + line i ppf "Pmodtype_manifest\n"; + module_type (i+1) ppf mt; + +and with_constraint i ppf x = + match x with + | Pwith_type (td) -> + line i ppf "Pwith_type\n"; + type_declaration (i+1) ppf td; + | Pwith_typesubst (td) -> + line i ppf "Pwith_typesubst\n"; + type_declaration (i+1) ppf td; + | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li; + | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li; + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; + let i = i+1 in + match x.pmod_desc with + | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident li; + | Pmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Pmod_functor (s, mt, me) -> + line i ppf "Pmod_functor \"%s\"\n" s; + module_type i ppf mt; + module_expr i ppf me; + | Pmod_apply (me1, me2) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Pmod_constraint (me, mt) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Pmod_unpack (e) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + +and structure i ppf x = list i structure_item ppf x + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.pstr_loc; + let i = i+1 in + match x.pstr_desc with + | Pstr_eval (e) -> + line i ppf "Pstr_eval\n"; + expression i ppf e; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i pattern_x_expression_def ppf l; + | Pstr_primitive (s, vd) -> + line i ppf "Pstr_primitive \"%s\"\n" s; + value_description i ppf vd; + | Pstr_type (l) -> + line i ppf "Pstr_type\n"; + list i string_x_type_declaration ppf l; + | Pstr_exception (s, ed) -> + line i ppf "Pstr_exception \"%s\"\n" s; + exception_declaration i ppf ed; + | Pstr_exn_rebind (s, li) -> + line i ppf "Pstr_exn_rebind \"%s\" %a\n" s fmt_longident li; + | Pstr_module (s, me) -> + line i ppf "Pstr_module \"%s\"\n" s; + module_expr i ppf me; + | Pstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i string_x_modtype_x_module ppf bindings; + | Pstr_modtype (s, mt) -> + line i ppf "Pstr_modtype \"%s\"\n" s; + module_type i ppf mt; + | Pstr_open (li) -> line i ppf "Pstr_open %a\n" fmt_longident li; + | Pstr_class (l) -> + line i ppf "Pstr_class\n"; + list i class_declaration ppf l; + | Pstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf l; + | Pstr_include me -> + line i ppf "Pstr_include"; + module_expr i ppf me + +and string_x_type_declaration i ppf (s, td) = + string i ppf s; + type_declaration (i+1) ppf td; + +and string_x_module_type i ppf (s, mty) = + string i ppf s; + module_type (i+1) ppf mty; + +and string_x_modtype_x_module i ppf (s, mty, modl) = + string i ppf s; + module_type (i+1) ppf mty; + module_expr (i+1) ppf modl; + +and longident_x_with_constraint i ppf (li, wc) = + line i ppf "%a\n" fmt_longident li; + with_constraint (i+1) ppf wc; + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf "<constraint> %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and string_x_core_type_list_x_location i ppf (s, l, loc) = + line i ppf "\"%s\" %a\n" s fmt_location loc; + list (i+1) core_type ppf l; + +and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) = + line i ppf "\"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; + +and string_list_x_location i ppf (l, loc) = + line i ppf "<params> %a\n" fmt_location loc; + list (i+1) string ppf l; + +and longident_x_pattern i ppf (li, p) = + line i ppf "%a\n" fmt_longident li; + pattern (i+1) ppf p; + +and pattern_x_expression_case i ppf (p, e) = + line i ppf "<case>\n"; + pattern (i+1) ppf p; + expression (i+1) ppf e; + +and pattern_x_expression_def i ppf (p, e) = + line i ppf "<def>\n"; + pattern (i+1) ppf p; + expression (i+1) ppf e; + +and string_x_expression i ppf (s, e) = + line i ppf "<override> \"%s\"\n" s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, e) = + line i ppf "%a\n" fmt_longident li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l,e) = + line i ppf "<label> \"%s\"\n" l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x with + Rtag (l, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + list (i+1) core_type ppf ctl + | Rinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct +;; + +let rec toplevel_phrase i ppf x = + match x with + | Ptop_def (s) -> + line i ppf "Ptop_def\n"; + structure (i+1) ppf s; + | Ptop_dir (s, da) -> + line i ppf "Ptop_dir \"%s\"\n" s; + directive_argument i ppf da; + +and directive_argument i ppf x = + match x with + | Pdir_none -> line i ppf "Pdir_none\n" + | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; + | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i; + | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; + | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); +;; + +let interface ppf x = list 0 signature_item ppf x;; + +let implementation ppf x = list 0 structure_item ppf x;; + +let top_phrase ppf x = toplevel_phrase 0 ppf x;; diff --git a/ocaml-binary-annot/parsing/printast.mli b/ocaml-binary-annot/parsing/printast.mli new file mode 100644 index 0000000000..7ea148678d --- /dev/null +++ b/ocaml-binary-annot/parsing/printast.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Parsetree;; +open Format;; + +val interface : formatter -> signature_item list -> unit;; +val implementation : formatter -> structure_item list -> unit;; +val top_phrase : formatter -> toplevel_phrase -> unit;; diff --git a/ocaml-binary-annot/parsing/syntaxerr.ml b/ocaml-binary-annot/parsing/syntaxerr.ml new file mode 100644 index 0000000000..edaabda122 --- /dev/null +++ b/ocaml-binary-annot/parsing/syntaxerr.ml @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Auxiliary type for reporting syntax errors *) + +open Format + +type error = + Unclosed of Location.t * string * Location.t * string + | Applicative_path of Location.t + | Other of Location.t + +exception Error of error +exception Escape_error + +let report_error ppf = function + | Unclosed(opening_loc, opening, closing_loc, closing) -> + if String.length !Location.input_name = 0 + && Location.highlight_locations ppf opening_loc closing_loc + then fprintf ppf "Syntax error: '%s' expected, \ + the highlighted '%s' might be unmatched" closing opening + else begin + fprintf ppf "%aSyntax error: '%s' expected@." + Location.print_error closing_loc closing; + fprintf ppf "%aThis '%s' might be unmatched" + Location.print_error opening_loc opening + end + | Applicative_path loc -> + fprintf ppf "%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set." + Location.print_error loc + | Other loc -> + fprintf ppf "%aSyntax error" Location.print_error loc diff --git a/ocaml-binary-annot/parsing/syntaxerr.mli b/ocaml-binary-annot/parsing/syntaxerr.mli new file mode 100644 index 0000000000..4e9679926a --- /dev/null +++ b/ocaml-binary-annot/parsing/syntaxerr.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Auxiliary type for reporting syntax errors *) + +open Format + +type error = + Unclosed of Location.t * string * Location.t * string + | Applicative_path of Location.t + | Other of Location.t + +exception Error of error +exception Escape_error + +val report_error: formatter -> error -> unit |