diff --git a/bench/good/ocaml.mly b/bench/good/ocaml.mly index 600e08232222d7ef97f439332263a3082b5e7cff..1cc2dea085b170b4cb8c7dd446faf046c76fcf70 100644 --- a/bench/good/ocaml.mly +++ b/bench/good/ocaml.mly @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* Objective Caml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -10,8 +10,6 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly,v 1.121 2004/10/06 13:06:11 garrigue Exp $ */ - /* The parser definition */ %{ @@ -19,40 +17,41 @@ 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() } +open Ast_helper +open Docstrings + +let mktyp d = Typ.mk ~loc:(symbol_rloc()) d +let mkpat d = Pat.mk ~loc:(symbol_rloc()) d +let mkexp d = Exp.mk ~loc:(symbol_rloc()) d +let mkmty d = Mty.mk ~loc:(symbol_rloc()) d +let mksig d = Sig.mk ~loc:(symbol_rloc()) d +let mkmod d = Mod.mk ~loc:(symbol_rloc()) d +let mkstr d = Str.mk ~loc:(symbol_rloc()) d +let mkclass d = Cl.mk ~loc:(symbol_rloc()) d +let mkcty d = Cty.mk ~loc:(symbol_rloc()) d +let mkctf ?attrs ?docs d = + Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d +let mkcf ?attrs ?docs d = + Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d + +let mkrhs rhs pos = mkloc rhs (rhs_loc pos) 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 } + let loc = rhs_loc pos in + Exp.mk ~loc (Pexp_ident(mkloc (Lident name) loc)) + +let mkpatvar name pos = + Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos)) (* Ghost expressions and patterns: - expressions and patterns that do not appear explicitely in the + expressions and patterns that do not appear explicitly 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. + -annot 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. @@ -64,19 +63,17 @@ let mkoperator name pos = 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 ghexp d = Exp.mk ~loc:(symbol_gloc ()) d +let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d +let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d +let ghloc d = { txt = d; loc = symbol_gloc () } +let ghstr d = Str.mk ~loc:(symbol_gloc()) d -let mkassert e = - match e with - | {pexp_desc = Pexp_construct (Lident "false", None, false) } -> - mkexp (Pexp_assertfalse) - | _ -> mkexp (Pexp_assert (e)) -;; +let ghunit () = + ghexp (Pexp_construct (mknoloc (Lident "()"), None)) let mkinfix arg1 name arg2 = - mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2])) + mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2])) let neg_float_string f = if String.length f > 0 && f.[0] = '-' @@ -93,50 +90,68 @@ let mkuminus name arg = 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) -> + | ("-" | "-."), Pexp_constant(Const_float f) -> mkexp(Pexp_constant(Const_float(neg_float_string f))) | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg])) + mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, 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, [Nolabel, arg])) -let rec mktailexp = function +let mkexp_cons consloc args loc = + Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args)) + +let mkpat_cons consloc args loc = + Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args)) + +let rec mktailexp nilloc = function [] -> - ghexp(Pexp_construct(Lident "[]", None, false)) + let loc = { nilloc with loc_ghost = true } in + let nil = { txt = Lident "[]"; loc = loc } in + Exp.mk ~loc (Pexp_construct (nil, None)) | e1 :: el -> - let exp_el = mktailexp el in - let l = {loc_start = e1.pexp_loc.loc_start; + let exp_el = mktailexp nilloc el in + let loc = {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 arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in + mkexp_cons {loc with loc_ghost = true} arg loc -let rec mktailpat = function +let rec mktailpat nilloc = function [] -> - ghpat(Ppat_construct(Lident "[]", None, false)) + let loc = { nilloc with loc_ghost = true } in + let nil = { txt = Lident "[]"; loc = loc } in + Pat.mk ~loc (Ppat_construct (nil, None)) | p1 :: pl -> - let pat_pl = mktailpat pl in - let l = {loc_start = p1.ppat_loc.loc_start; + let pat_pl = mktailpat nilloc pl in + let loc = {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 arg = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in + mkpat_cons {loc with loc_ghost = true} arg loc -let ghstrexp e = - { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} } +let mkstrexp e attrs = + { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } -let array_function str name = - Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)) +let mkexp_constraint e (t1, t2) = + match t1, t2 with + | Some t, None -> ghexp(Pexp_constraint(e, t)) + | _, Some t -> ghexp(Pexp_coerce(e, t1, t)) + | None, None -> assert false -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 array_function par assign= + let op = if assign then par^"<-" else par in + ghloc ( Lident op ) let syntax_error () = raise Syntaxerr.Escape_error @@ -145,44 +160,244 @@ 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 expecting pos nonterm = + raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm))) + +let not_expecting pos nonterm = + raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm))) + +let bigarray_function order assign = + let op = + match order with + | 1 -> ".{}" + | 2 -> ".{,}" + | 3 -> ".{,,}" + | _ -> ".{,..,}" + in + let op= if assign then op^"<-" else op in + ghloc ( Lident op ) let bigarray_untuplify = function - { pexp_desc = Pexp_tuple explist} -> explist + { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist | exp -> [exp] let bigarray_get arr arg = + let get order = bigarray_function order false in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "get")), - ["", arr; "", c1])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 1)), + [Nolabel, arr; Nolabel, c1])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "get")), - ["", arr; "", c1; "", c2])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 2)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "get")), - ["", arr; "", c1; "", c2; "", c3])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 3)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3])) | coords -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")), - ["", arr; "", ghexp(Pexp_array coords)])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 0)), + [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)])) let bigarray_set arr arg newval = + let set order = bigarray_function order true in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "set")), - ["", arr; "", c1; "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 1)), + [Nolabel, arr; Nolabel, c1; Nolabel, newval])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "set")), - ["", arr; "", c1; "", c2; "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 2)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2; + Nolabel, newval])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "set")), - ["", arr; "", c1; "", c2; "", c3; "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 3)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3; + Nolabel, newval])) | coords -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), - ["", arr; - "", ghexp(Pexp_array coords); - "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 0)), + [Nolabel, arr; + Nolabel, ghexp(Pexp_array coords); + Nolabel, 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 pos = + mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos)) + +let pat_of_label lbl pos = + mkpat (Ppat_var (mkrhs (Longident.last lbl) pos)) + +let check_variable vl loc v = + if List.mem v vl then + raise Syntaxerr.(Error(Variable_in_scope(loc,v))) + +let varify_constructors var_names t = + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow (label,core_type,core_type') -> + Ptyp_arrow(label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr( { txt = Lident s }, []) when List.mem s var_names -> + Ptyp_var s + | Ptyp_constr(longident, lst) -> + Ptyp_constr(longident, List.map loop lst) + | Ptyp_object (lst, o) -> + Ptyp_object + (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o) + | Ptyp_class (longident, lst) -> + Ptyp_class (longident, List.map loop lst) + | Ptyp_alias(core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias(loop core_type, string) + | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> + Ptyp_variant(List.map loop_row_field row_field_list, + flag, lbl_lst_option) + | Ptyp_poly(string_lst, core_type) -> + List.iter (check_variable var_names t.ptyp_loc) string_lst; + Ptyp_poly(string_lst, loop core_type) + | Ptyp_package(longident,lst) -> + Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_extension (s, arg) -> + Ptyp_extension (s, arg) + in + {t with ptyp_desc = desc} + and loop_row_field = + function + | Rtag(label,attrs,flag,lst) -> + Rtag(label,attrs,flag,List.map loop lst) + | Rinherit t -> + Rinherit (loop t) + in + loop t + +let mk_newtypes newtypes exp = + List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) + newtypes exp + +let wrap_type_annotation newtypes core_type body = + let exp = mkexp(Pexp_constraint(body,core_type)) in + let exp = mk_newtypes newtypes exp in + (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type))) + +let wrap_exp_attrs body (ext, attrs) = + (* todo: keep exact location for the entire attribute *) + let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in + match ext with + | None -> body + | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []])) + +let mkexp_attrs d attrs = + wrap_exp_attrs (mkexp d) attrs + +let text_str pos = Str.text (rhs_text pos) +let text_sig pos = Sig.text (rhs_text pos) +let text_cstr pos = Cf.text (rhs_text pos) +let text_csig pos = Ctf.text (rhs_text pos) +let text_def pos = [Ptop_def (Str.text (rhs_text pos))] + +let extra_text text pos items = + let pre_extras = rhs_pre_extra_text pos in + let post_extras = rhs_post_extra_text pos in + text pre_extras @ items @ text post_extras + +let extra_str pos items = extra_text Str.text pos items +let extra_sig pos items = extra_text Sig.text pos items +let extra_cstr pos items = extra_text Cf.text pos items +let extra_csig pos items = extra_text Ctf.text pos items +let extra_def pos items = + extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items + +type let_binding = + { lb_pattern: pattern; + lb_expression: expression; + lb_attributes: attributes; + lb_docs: docs Lazy.t; + lb_text: text Lazy.t; + lb_loc: Location.t; } + +type let_bindings = + { lbs_bindings: let_binding list; + lbs_rec: rec_flag; + lbs_extension: string Asttypes.loc option; + lbs_attributes: attributes; + lbs_loc: Location.t } + +let mklb (p, e) attrs = + { lb_pattern = p; + lb_expression = e; + lb_attributes = attrs; + lb_docs = symbol_docs_lazy (); + lb_text = symbol_text_lazy (); + lb_loc = symbol_rloc (); } + +let mklbs (ext, attrs) rf lb = + { lbs_bindings = [lb]; + lbs_rec = rf; + lbs_extension = ext ; + lbs_attributes = attrs; + lbs_loc = symbol_rloc (); } + +let addlb lbs lb = + { lbs with lbs_bindings = lb :: lbs.lbs_bindings } + +let val_of_let_bindings lbs = + let str = + match lbs.lbs_bindings with + | [ {lb_pattern = { ppat_desc = Ppat_any; ppat_loc = _ }; _} as lb ] -> + let exp = wrap_exp_attrs lb.lb_expression + (None, lbs.lbs_attributes) in + mkstr (Pstr_eval (exp, lb.lb_attributes)) + | bindings -> + if lbs.lbs_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "attributes"))); + let bindings = + List.map + (fun lb -> + Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ~docs:(Lazy.force lb.lb_docs) + ~text:(Lazy.force lb.lb_text) + lb.lb_pattern lb.lb_expression) + bindings + in + mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings)) + in + match lbs.lbs_extension with + | None -> str + | Some id -> ghstr (Pstr_extension((id, PStr [str]), [])) + +let expr_of_let_bindings lbs body = + let bindings = + List.map + (fun lb -> + if lb.lb_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lb.lb_loc, "item attribute"))); + Vb.mk ~loc:lb.lb_loc lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) + (lbs.lbs_extension, lbs.lbs_attributes) + +let class_of_let_bindings lbs body = + let bindings = + List.map + (fun lb -> + if lb.lb_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lb.lb_loc, "item attribute"))); + Vb.mk ~loc:lb.lb_loc lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + if lbs.lbs_extension <> None then + raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension"))); + if lbs.lbs_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "attributes"))); + mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body)) + %} /* Tokens */ @@ -193,6 +408,7 @@ let bigarray_set arr arg newval = %token AS %token ASSERT %token BACKQUOTE +%token BANG %token BAR %token BARBAR %token BARRBRACKET @@ -246,11 +462,16 @@ let bigarray_set arr arg newval = %token LBRACKETBAR %token LBRACKETLESS %token LBRACKETGREATER +%token LBRACKETPERCENT +%token LBRACKETPERCENTPERCENT %token LESS %token LESSMINUS %token LET %token LIDENT %token LPAREN +%token LBRACKETAT +%token LBRACKETATAT +%token LBRACKETATATAT %token MATCH %token METHOD %token MINUS @@ -260,17 +481,20 @@ let bigarray_set arr arg newval = %token MUTABLE %token NATIVEINT %token NEW +%token NONREC %token OBJECT %token OF %token OPEN %token OPTLABEL %token OR /* %token PARSER */ +%token PERCENT %token PLUS +%token PLUSDOT +%token PLUSEQ %token PREFIXOP %token PRIVATE %token QUESTION -%token QUESTIONQUESTION %token QUOTE %token RBRACE %token RBRACKET @@ -279,9 +503,10 @@ let bigarray_set arr arg newval = %token SEMI %token SEMISEMI %token SHARP +%token SHARPOP %token SIG %token STAR -%token STRING +%token STRING %token STRUCT %token THEN %token TILDE @@ -296,6 +521,10 @@ let bigarray_set arr arg newval = %token WHEN %token WHILE %token WITH +%token COMMENT +%token DOCSTRING + +%token EOL /* Precedences and associativities. @@ -341,21 +570,26 @@ The precedences must be listed from low to high. %nonassoc below_EQUAL %left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ %right INFIXOP1 /* expr (e OP e OP e) */ +%nonassoc below_LBRACKETAT +%nonassoc LBRACKETAT +%nonassoc LBRACKETATAT %right COLONCOLON /* expr (e :: e :: e) */ -%left INFIXOP2 PLUS MINUS MINUSDOT /* expr (e OP e OP e) */ -%left INFIXOP3 STAR /* expr (e OP e OP e) */ +%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */ +%left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */ %right INFIXOP4 /* expr (e OP e OP e) */ -%nonassoc prec_unary_minus /* unary - */ +%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 */ +%left SHARPOP %nonassoc below_DOT %nonassoc DOT /* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64 +%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64 LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN NEW NATIVEINT PREFIXOP STRING TRUE UIDENT + LBRACKETPERCENT LBRACKETPERCENTPERCENT /* Entry points */ @@ -368,54 +602,109 @@ The precedences must be listed from low to high. %type toplevel_phrase %start use_file /* for the #use directive */ %type use_file - +%start parse_core_type +%type parse_core_type +%start parse_expression +%type parse_expression +%start parse_pattern +%type parse_pattern %% /* Entry points */ implementation: - structure EOF { $1 } + structure EOF { extra_str 1 $1 } ; interface: - signature EOF { List.rev $1 } + signature EOF { extra_sig 1 $1 } ; toplevel_phrase: - top_structure SEMISEMI { Ptop_def $1 } - | seq_expr SEMISEMI { Ptop_def[ghstrexp $1] } + top_structure SEMISEMI { Ptop_def (extra_str 1 $1) } | toplevel_directive SEMISEMI { $1 } | EOF { raise End_of_file } ; top_structure: - structure_item { [$1] } - | structure_item top_structure { $1 :: $2 } + seq_expr post_item_attributes + { (text_str 1) @ [mkstrexp $1 $2] } + | top_structure_tail + { $1 } +; +top_structure_tail: + /* empty */ { [] } + | structure_item top_structure_tail { (text_str 1) @ $1 :: $2 } ; use_file: + use_file_body { extra_def 1 $1 } +; +use_file_body: use_file_tail { $1 } - | seq_expr use_file_tail { Ptop_def[ghstrexp $1] :: $2 } + | seq_expr post_item_attributes use_file_tail + { (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 } ; 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 } + EOF + { [] } + | SEMISEMI EOF + { text_def 1 } + | SEMISEMI seq_expr post_item_attributes use_file_tail + { mark_rhs_docs 2 3; + (text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp $2 $3] :: $4 } + | SEMISEMI structure_item use_file_tail + { (text_def 1) @ (text_def 2) @ Ptop_def[$2] :: $3 } + | SEMISEMI toplevel_directive use_file_tail + { mark_rhs_docs 2 3; + (text_def 1) @ (text_def 2) @ $2 :: $3 } + | structure_item use_file_tail + { (text_def 1) @ Ptop_def[$1] :: $2 } + | toplevel_directive use_file_tail + { mark_rhs_docs 1 1; + (text_def 1) @ $1 :: $2 } +; +parse_core_type: + core_type EOF { $1 } +; +parse_expression: + seq_expr EOF { $1 } +; +parse_pattern: + pattern EOF { $1 } ; /* Module expressions */ +functor_arg: + LPAREN RPAREN + { mkrhs "*" 2, None } + | LPAREN functor_arg_name COLON module_type RPAREN + { mkrhs $2 2, Some $4 } +; + +functor_arg_name: + UIDENT { $1 } + | UNDERSCORE { "_" } +; + +functor_args: + functor_args functor_arg + { $2 :: $1 } + | functor_arg + { [ $1 ] } +; + module_expr: mod_longident - { mkmod(Pmod_ident $1) } + { mkmod(Pmod_ident (mkrhs $1 1)) } | STRUCT structure END - { mkmod(Pmod_structure($2)) } + { mkmod(Pmod_structure(extra_str 2 $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)) } + | FUNCTOR functor_args MINUSGREATER module_expr + { List.fold_left (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) + $4 $2 } | module_expr LPAREN module_expr RPAREN { mkmod(Pmod_apply($1, $3)) } + | module_expr LPAREN RPAREN + { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) } | module_expr LPAREN module_expr error { unclosed "(" 2 ")" 4 } | LPAREN module_expr COLON module_type RPAREN @@ -426,139 +715,242 @@ module_expr: { $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, ghtyp(Ptyp_package $5))))) } + | LPAREN VAL expr COLON package_type COLONGREATER package_type RPAREN + { mkmod(Pmod_unpack( + ghexp(Pexp_coerce($3, Some(ghtyp(Ptyp_package $5)), + ghtyp(Ptyp_package $7))))) } + | LPAREN VAL expr COLONGREATER package_type RPAREN + { mkmod(Pmod_unpack( + ghexp(Pexp_coerce($3, None, 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 } + | module_expr attribute + { Mod.attr $1 $2 } + | extension + { mkmod(Pmod_extension $1) } ; + structure: - structure_tail { $1 } - | seq_expr structure_tail { ghstrexp $1 :: $2 } + seq_expr post_item_attributes structure_tail + { mark_rhs_docs 1 2; + (text_str 1) @ mkstrexp $1 $2 :: $3 } + | structure_tail { $1 } ; 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 } + /* empty */ { [] } + | SEMISEMI structure { (text_str 1) @ $2 } + | structure_item structure_tail { (text_str 1) @ $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 = $3; pval_prim = $5})) } - | 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: + let_bindings + { val_of_let_bindings $1 } + | primitive_declaration + { mkstr (Pstr_primitive $1) } + | value_description + { mkstr (Pstr_primitive $1) } + | type_declarations + { let (nr, l) = $1 in mkstr(Pstr_type (nr, List.rev l)) } + | str_type_extension + { mkstr(Pstr_typext $1) } + | str_exception_declaration + { mkstr(Pstr_exception $1) } + | module_binding + { mkstr(Pstr_module $1) } + | rec_module_bindings + { mkstr(Pstr_recmodule(List.rev $1)) } + | module_type_declaration + { mkstr(Pstr_modtype $1) } + | open_statement { mkstr(Pstr_open $1) } + | class_declarations + { mkstr(Pstr_class (List.rev $1)) } + | class_type_declarations + { mkstr(Pstr_class_type (List.rev $1)) } + | str_include_statement + { mkstr(Pstr_include $1) } + | item_extension post_item_attributes + { mkstr(Pstr_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } + | floating_attribute + { mark_symbol_docs (); + mkstr(Pstr_attribute $1) } +; +str_include_statement: + INCLUDE module_expr post_item_attributes + { Incl.mk $2 ~attrs:$3 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +module_binding_body: 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)) } + | functor_arg module_binding_body + { mkmod(Pmod_functor(fst $1, snd $1, $2)) } ; -module_rec_bindings: - module_rec_binding { [$1] } - | module_rec_bindings AND module_rec_binding { $3 :: $1 } +module_binding: + MODULE UIDENT module_binding_body post_item_attributes + { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +rec_module_bindings: + rec_module_binding { [$1] } + | rec_module_bindings and_module_binding { $2 :: $1 } ; -module_rec_binding: - UIDENT COLON module_type EQUAL module_expr { ($1, $3, $5) } +rec_module_binding: + MODULE REC UIDENT module_binding_body post_item_attributes + { Mb.mk (mkrhs $3 3) $4 ~attrs:$5 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_module_binding: + AND UIDENT module_binding_body post_item_attributes + { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; /* Module types */ module_type: mty_longident - { mkmty(Pmty_ident $1) } + { mkmty(Pmty_ident (mkrhs $1 1)) } | SIG signature END - { mkmty(Pmty_signature(List.rev $2)) } + { mkmty(Pmty_signature (extra_sig 2 $2)) } | SIG signature error { unclosed "sig" 1 "end" 3 } - | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type + | FUNCTOR functor_args MINUSGREATER module_type %prec below_WITH - { mkmty(Pmty_functor($3, $5, $8)) } + { List.fold_left (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) + $4 $2 } | module_type WITH with_constraints { mkmty(Pmty_with($1, List.rev $3)) } + | MODULE TYPE OF module_expr %prec below_LBRACKETAT + { mkmty(Pmty_typeof $4) } +/* | LPAREN MODULE mod_longident RPAREN + { mkmty (Pmty_alias (mkrhs $3 3)) } */ | LPAREN module_type RPAREN { $2 } | LPAREN module_type error { unclosed "(" 1 ")" 3 } + | extension + { mkmty(Pmty_extension $1) } + | module_type attribute + { Mty.attr $1 $2 } ; signature: - /* empty */ { [] } - | signature signature_item { $2 :: $1 } - | signature signature_item SEMISEMI { $2 :: $1 } + /* empty */ { [] } + | SEMISEMI signature { (text_sig 1) @ $2 } + | signature_item signature { (text_sig 1) @ $1 :: $2 } ; signature_item: - VAL val_ident_colon core_type - { mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) } - | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mksig(Psig_value($2, {pval_type = $3; pval_prim = $5})) } - | 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: + value_description + { mksig(Psig_value $1) } + | primitive_declaration + { mksig(Psig_value $1) } + | type_declarations + { let (nr, l) = $1 in mksig(Psig_type (nr, List.rev l)) } + | sig_type_extension + { mksig(Psig_typext $1) } + | sig_exception_declaration + { mksig(Psig_exception $1) } + | module_declaration + { mksig(Psig_module $1) } + | module_alias + { mksig(Psig_module $1) } + | rec_module_declarations + { mksig(Psig_recmodule (List.rev $1)) } + | module_type_declaration + { mksig(Psig_modtype $1) } + | open_statement + { mksig(Psig_open $1) } + | sig_include_statement + { mksig(Psig_include $1) } + | class_descriptions + { mksig(Psig_class (List.rev $1)) } + | class_type_declarations + { mksig(Psig_class_type (List.rev $1)) } + | item_extension post_item_attributes + { mksig(Psig_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } + | floating_attribute + { mark_symbol_docs (); + mksig(Psig_attribute $1) } +; +open_statement: + | OPEN override_flag mod_longident post_item_attributes + { Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +sig_include_statement: + INCLUDE module_type post_item_attributes %prec below_WITH + { Incl.mk $2 ~attrs:$3 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +module_declaration_body: 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 } + | LPAREN UIDENT COLON module_type RPAREN module_declaration_body + { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) } + | LPAREN RPAREN module_declaration_body + { mkmty(Pmty_functor(mkrhs "*" 1, None, $3)) } ; -module_rec_declaration: - UIDENT COLON module_type { ($1, $3) } +module_declaration: + MODULE UIDENT module_declaration_body post_item_attributes + { Md.mk (mkrhs $2 2) $3 ~attrs:$4 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +module_alias: + MODULE UIDENT EQUAL mod_longident post_item_attributes + { Md.mk (mkrhs $2 2) + (Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +rec_module_declarations: + rec_module_declaration { [$1] } + | rec_module_declarations and_module_declaration { $2 :: $1 } +; +rec_module_declaration: + MODULE REC UIDENT COLON module_type post_item_attributes + { Md.mk (mkrhs $3 3) $5 ~attrs:$6 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +and_module_declaration: + AND UIDENT COLON module_type post_item_attributes + { Md.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) + ~text:(symbol_text()) ~docs:(symbol_docs()) } +; +module_type_declaration_body: + /* empty */ { None } + | EQUAL module_type { Some $2 } +; +module_type_declaration: + MODULE TYPE ident module_type_declaration_body post_item_attributes + { Mtd.mk (mkrhs $3 3) ?typ:$4 ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; - /* Class expressions */ class_declarations: - class_declarations AND class_declaration { $3 :: $1 } - | class_declaration { [$1] } + class_declaration { [$1] } + | class_declarations and_class_declaration { $2 :: $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 virtual_flag class_type_parameters LIDENT class_fun_binding + post_item_attributes + { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 ~attrs:$6 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_class_declaration: + AND virtual_flag class_type_parameters LIDENT class_fun_binding + post_item_attributes + { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 + ~attrs:$6 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; class_fun_binding: EQUAL class_expr @@ -569,8 +961,8 @@ 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 () } + /*empty*/ { [] } + | LBRACKET type_parameter_list RBRACKET { List.rev $2 } ; class_fun_def: labeled_simple_pattern MINUSGREATER class_expr @@ -585,16 +977,20 @@ class_expr: { $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)) } + | let_bindings IN class_expr + { class_of_let_bindings $1 $3 } + | class_expr attribute + { Cl.attr $1 $2 } + | extension + { mkclass(Pcl_extension $1) } ; class_simple_expr: LBRACKET core_type_comma_list RBRACKET class_longident - { mkclass(Pcl_constr($4, List.rev $2)) } + { mkclass(Pcl_constr(mkloc $4 (rhs_loc 4), List.rev $2)) } | class_longident - { mkclass(Pcl_constr($1, [])) } + { mkclass(Pcl_constr(mkrhs $1 1, [])) } | OBJECT class_structure END - { mkclass(Pcl_structure($2)) } + { mkclass(Pcl_structure $2) } | OBJECT class_structure error { unclosed "object" 1 "end" 3 } | LPAREN class_expr COLON class_type RPAREN @@ -607,8 +1003,8 @@ class_simple_expr: { unclosed "(" 1 ")" 3 } ; class_structure: - class_self_pattern class_fields - { $1, List.rev $2 } + | class_self_pattern class_fields + { Cstr.mk $1 (extra_cstr 2 (List.rev $2)) } ; class_self_pattern: LPAREN pattern RPAREN @@ -621,45 +1017,66 @@ class_self_pattern: class_fields: /* empty */ { [] } - | class_fields INHERIT class_expr parent_binder - { Pcf_inher ($3, $4) :: $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 } + | class_fields class_field + { $2 :: (text_cstr 2) @ $1 } +; +class_field: + | INHERIT override_flag class_expr parent_binder post_item_attributes + { mkcf (Pcf_inherit ($2, $3, $4)) ~attrs:$5 ~docs:(symbol_docs ()) } + | VAL value post_item_attributes + { mkcf (Pcf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | METHOD method_ post_item_attributes + { mkcf (Pcf_method $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | CONSTRAINT constrain_field post_item_attributes + { mkcf (Pcf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | INITIALIZER seq_expr post_item_attributes + { mkcf (Pcf_initializer $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | item_extension post_item_attributes + { mkcf (Pcf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } + | floating_attribute + { mark_symbol_docs (); + mkcf (Pcf_attribute $1) } ; parent_binder: AS LIDENT { Some $2 } | /* empty */ - {None} + { None } ; value: - mutable_flag label EQUAL seq_expr - { $2, $1, $4, symbol_rloc () } - | mutable_flag label type_constraint EQUAL seq_expr - { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), - symbol_rloc () } -; -virtual_method: - 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 () } -; -concrete_method : - METHOD private_flag label strict_binding - { $3, $2, ghexp(Pexp_poly ($4, None)), symbol_rloc () } - | METHOD private_flag label COLON poly_type EQUAL seq_expr - { $3, $2, ghexp(Pexp_poly($7,Some $5)), symbol_rloc () } - | METHOD private_flag LABEL poly_type EQUAL seq_expr - { $3, $2, ghexp(Pexp_poly($6,Some $4)), symbol_rloc () } +/* TODO: factorize these rules (also with method): */ + override_flag MUTABLE VIRTUAL label COLON core_type + { if $1 = Override then syntax_error (); + mkloc $4 (rhs_loc 4), Mutable, Cfk_virtual $6 } + | VIRTUAL mutable_flag label COLON core_type + { mkrhs $3 3, $2, Cfk_virtual $5 } + | override_flag mutable_flag label EQUAL seq_expr + { mkrhs $3 3, $2, Cfk_concrete ($1, $5) } + | override_flag mutable_flag label type_constraint EQUAL seq_expr + { + let e = mkexp_constraint $6 $4 in + mkrhs $3 3, $2, Cfk_concrete ($1, e) + } +; +method_: +/* TODO: factorize those rules... */ + override_flag PRIVATE VIRTUAL label COLON poly_type + { if $1 = Override then syntax_error (); + mkloc $4 (rhs_loc 4), Private, Cfk_virtual $6 } + | override_flag VIRTUAL private_flag label COLON poly_type + { if $1 = Override then syntax_error (); + mkloc $4 (rhs_loc 4), $3, Cfk_virtual $6 } + | override_flag private_flag label strict_binding + { mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly ($4, None))) } + | override_flag private_flag label COLON poly_type EQUAL seq_expr + { mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly($7, Some $5))) } + | override_flag private_flag label COLON TYPE lident_list + DOT core_type EQUAL seq_expr + { let exp, poly = wrap_type_annotation $6 $8 $10 in + mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly))) } ; /* Class types */ @@ -667,34 +1084,33 @@ concrete_method : class_type: class_signature { $1 } - | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_fun("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Lident "option", [$4]); - ptyp_loc = $4.ptyp_loc}, - $6)) } + | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER + class_type + { mkcty(Pcty_arrow(Optional $2 , $4, $6)) } | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_fun("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Lident "option", [$2]); - ptyp_loc = $2.ptyp_loc}, - $4)) } + { mkcty(Pcty_arrow(Optional $1, $2, $4)) } | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_fun($1, $3, $5)) } + { mkcty(Pcty_arrow(Labelled $1, $3, $5)) } | simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_fun("", $1, $3)) } -; + { mkcty(Pcty_arrow(Nolabel, $1, $3)) } + ; class_signature: LBRACKET core_type_comma_list RBRACKET clty_longident - { mkcty(Pcty_constr ($4, List.rev $2)) } + { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) } | clty_longident - { mkcty(Pcty_constr ($1, [])) } + { mkcty(Pcty_constr (mkrhs $1 1, [])) } | OBJECT class_sig_body END { mkcty(Pcty_signature $2) } | OBJECT class_sig_body error { unclosed "object" 1 "end" 3 } + | class_signature attribute + { Cty.attr $1 $2 } + | extension + { mkcty(Pcty_extension $1) } ; class_sig_body: class_self_type class_sig_fields - { $1, List.rev $2 } + { Csig.mk $1 (extra_csig 2 (List.rev $2)) } ; class_self_type: LPAREN core_type RPAREN @@ -704,44 +1120,73 @@ class_self_type: ; 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 { Pctf_virt $2 :: $1 } - | class_sig_fields method_type { Pctf_meth $2 :: $1 } - | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 } +| class_sig_fields class_sig_field { $2 :: (text_csig 2) @ $1 } +; +class_sig_field: + INHERIT class_signature post_item_attributes + { mkctf (Pctf_inherit $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | VAL value_type post_item_attributes + { mkctf (Pctf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | METHOD private_virtual_flags label COLON poly_type post_item_attributes + { + let (p, v) = $2 in + mkctf (Pctf_method ($3, p, v, $5)) ~attrs:$6 ~docs:(symbol_docs ()) + } + | CONSTRAINT constrain_field post_item_attributes + { mkctf (Pctf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) } + | item_extension post_item_attributes + { mkctf (Pctf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } + | floating_attribute + { mark_symbol_docs (); + mkctf(Pctf_attribute $1) } ; value_type: - mutable_flag label COLON core_type - { $2, $1, Some $4, symbol_rloc () } -; -method_type: - METHOD private_flag label COLON poly_type - { $3, $2, $5, symbol_rloc () } + VIRTUAL mutable_flag label COLON core_type + { $3, $2, Virtual, $5 } + | MUTABLE virtual_flag label COLON core_type + { $3, Mutable, $2, $5 } + | label COLON core_type + { $1, Immutable, Concrete, $3 } ; constrain: - core_type EQUAL core_type { $1, $3, symbol_rloc () } + core_type EQUAL core_type { $1, $3, symbol_rloc() } +; +constrain_field: + core_type EQUAL core_type { $1, $3 } ; class_descriptions: - class_descriptions AND class_description { $3 :: $1 } - | class_description { [$1] } + class_description { [$1] } + | class_descriptions and_class_description { $2 :: $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 virtual_flag class_type_parameters LIDENT COLON class_type + post_item_attributes + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_class_description: + AND virtual_flag class_type_parameters LIDENT COLON class_type + post_item_attributes + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 + ~attrs:$7 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; class_type_declarations: - class_type_declarations AND class_type_declaration { $3 :: $1 } - | class_type_declaration { [$1] } + class_type_declaration { [$1] } + | class_type_declarations and_class_type_declaration { $2 :: $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 ()} } + CLASS TYPE virtual_flag class_type_parameters LIDENT EQUAL + class_signature post_item_attributes + { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:$8 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_class_type_declaration: + AND virtual_flag class_type_parameters LIDENT EQUAL + class_signature post_item_attributes + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 + ~attrs:$7 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; /* Core expressions */ @@ -753,24 +1198,25 @@ seq_expr: ; labeled_simple_pattern: QUESTION LPAREN label_let_pattern opt_default RPAREN - { ("?" ^ fst $3, $4, snd $3) } + { (Optional (fst $3), $4, snd $3) } | QUESTION label_var - { ("?" ^ fst $2, None, snd $2) } + { (Optional (fst $2), None, snd $2) } | OPTLABEL LPAREN let_pattern opt_default RPAREN - { ("?" ^ $1, $4, $3) } + { (Optional $1, $4, $3) } | OPTLABEL pattern_var - { ("?" ^ $1, None, $2) } + { (Optional $1, None, $2) } | TILDE LPAREN label_let_pattern RPAREN - { (fst $3, None, snd $3) } + { (Labelled (fst $3), None, snd $3) } | TILDE label_var - { (fst $2, None, snd $2) } + { (Labelled (fst $2), None, snd $2) } | LABEL simple_pattern - { ($1, None, $2) } + { (Labelled $1, None, $2) } | simple_pattern - { ("", None, $1) } + { (Nolabel, None, $1) } ; pattern_var: - LIDENT { mkpat(Ppat_var $1) } + LIDENT { mkpat(Ppat_var (mkrhs $1 1)) } + | UNDERSCORE { mkpat Ppat_any } ; opt_default: /* empty */ { None } @@ -783,7 +1229,7 @@ label_let_pattern: { let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) } ; label_var: - LIDENT { ($1, mkpat(Ppat_var $1)) } + LIDENT { ($1, mkpat(Ppat_var (mkrhs $1 1))) } ; let_pattern: pattern @@ -796,38 +1242,44 @@ expr: { $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)) } - | 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])) } - | 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 + | let_bindings IN seq_expr + { expr_of_let_bindings $1 $3 } + | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr + { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } + | LET OPEN override_flag ext_attributes mod_longident IN seq_expr + { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 } + | FUNCTION ext_attributes opt_bar match_cases + { mkexp_attrs (Pexp_function(List.rev $4)) $2 } + | FUN ext_attributes labeled_simple_pattern fun_def + { let (l,o,p) = $3 in + mkexp_attrs (Pexp_fun(l, o, p, $4)) $2 } + | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def + { mkexp_attrs (mk_newtypes $5 $7).pexp_desc $2 } + | MATCH ext_attributes seq_expr WITH opt_bar match_cases + { mkexp_attrs (Pexp_match($3, List.rev $6)) $2 } + | TRY ext_attributes seq_expr WITH opt_bar match_cases + { mkexp_attrs (Pexp_try($3, List.rev $6)) $2 } + | TRY ext_attributes 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)) } + { mkexp(Pexp_construct(mkrhs $1 1, Some $2)) } | 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)) } + | IF ext_attributes seq_expr THEN expr ELSE expr + { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 } + | IF ext_attributes seq_expr THEN expr + { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 } + | WHILE ext_attributes seq_expr DO seq_expr DONE + { mkexp_attrs (Pexp_while($3, $5)) $2 } + | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO + seq_expr DONE + { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 } | expr COLONCOLON expr - { mkexp(Pexp_construct(Lident "::", - Some(ghexp(Pexp_tuple[$1;$3])), - false)) } + { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) } + | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN + { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) } | expr INFIXOP0 expr { mkinfix $1 $2 $3 } | expr INFIXOP1 expr @@ -840,12 +1292,18 @@ expr: { mkinfix $1 $2 $3 } | expr PLUS expr { mkinfix $1 "+" $3 } + | expr PLUSDOT expr + { mkinfix $1 "+." $3 } + | expr PLUSEQ expr + { mkinfix $1 "+=" $3 } | expr MINUS expr { mkinfix $1 "-" $3 } | expr MINUSDOT expr { mkinfix $1 "-." $3 } | expr STAR expr { mkinfix $1 "*" $3 } + | expr PERCENT expr + { mkinfix $1 "%" $3 } | expr EQUAL expr { mkinfix $1 "=" $3 } | expr LESS expr @@ -864,58 +1322,70 @@ 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)) } + { mkexp(Pexp_setfield($1, mkrhs $3 3, $5)) } | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), - ["",$1; "",$4; "",$7])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".()" true)), + [Nolabel,$1; Nolabel,$4; Nolabel,$7])) } | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")), - ["",$1; "",$4; "",$7])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".[]" true)), + [Nolabel,$1; Nolabel,$4; Nolabel,$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 } + { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) } + | ASSERT ext_attributes simple_expr %prec below_SHARP + { mkexp_attrs (Pexp_assert $3) $2 } + | LAZY ext_attributes simple_expr %prec below_SHARP + { mkexp_attrs (Pexp_lazy $3) $2 } + | OBJECT ext_attributes class_structure END + { mkexp_attrs (Pexp_object $3) $2 } + | OBJECT ext_attributes class_structure error + { unclosed "object" 1 "end" 4 } + | expr attribute + { Exp.attr $1 $2 } ; simple_expr: val_longident - { mkexp(Pexp_ident $1) } + { mkexp(Pexp_ident (mkrhs $1 1)) } | constant { mkexp(Pexp_constant $1) } | constr_longident %prec prec_constant_constructor - { mkexp(Pexp_construct($1, None, false)) } + { mkexp(Pexp_construct(mkrhs $1 1, None)) } | 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 + | BEGIN ext_attributes seq_expr END + { wrap_exp_attrs (reloc_exp $3) $2 (* check location *) } + | BEGIN ext_attributes END + { mkexp_attrs (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()), + None)) $2 } + | BEGIN ext_attributes 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')) } + { mkexp_constraint $2 $3 } | simple_expr DOT label_longident - { mkexp(Pexp_field($1, $3)) } + { mkexp(Pexp_field($1, mkrhs $3 3)) } + | mod_longident DOT LPAREN seq_expr RPAREN + { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) } + | mod_longident DOT LPAREN RPAREN + { mkexp(Pexp_open(Fresh, mkrhs $1 1, + mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) } + | 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])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".()" false)), + [Nolabel,$1; Nolabel,$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])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".[]" false)), + [Nolabel,$1; Nolabel,$4])) } | simple_expr DOT LBRACKET seq_expr error { unclosed "[" 3 "]" 5 } | simple_expr DOT LBRACE expr RBRACE @@ -923,31 +1393,76 @@ simple_expr: | 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)) } + { let (exten, fields) = $2 in mkexp (Pexp_record(fields, exten)) } | LBRACE record_expr error { unclosed "{" 1 "}" 3 } + | mod_longident DOT LBRACE record_expr RBRACE + { let (exten, fields) = $4 in + let rec_exp = mkexp(Pexp_record(fields, exten)) in + mkexp(Pexp_open(Fresh, mkrhs $1 1, rec_exp)) } + | mod_longident DOT LBRACE record_expr error + { unclosed "{" 3 "}" 5 } | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexp(Pexp_array(List.rev $2)) } + { mkexp (Pexp_array(List.rev $2)) } | LBRACKETBAR expr_semi_list opt_semi error { unclosed "[|" 1 "|]" 4 } | LBRACKETBAR BARRBRACKET - { mkexp(Pexp_array []) } + { mkexp (Pexp_array []) } + | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi BARRBRACKET + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array(List.rev $4)))) } + | mod_longident DOT LBRACKETBAR BARRBRACKET + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array []))) } + | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi error + { unclosed "[|" 3 "|]" 6 } | LBRACKET expr_semi_list opt_semi RBRACKET - { reloc_exp (mktailexp (List.rev $2)) } + { reloc_exp (mktailexp (rhs_loc 4) (List.rev $2)) } | LBRACKET expr_semi_list opt_semi error { unclosed "[" 1 "]" 4 } + | mod_longident DOT LBRACKET expr_semi_list opt_semi RBRACKET + { let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev $4)) in + mkexp(Pexp_open(Fresh, mkrhs $1 1, list_exp)) } + | mod_longident DOT LBRACKET RBRACKET + { mkexp(Pexp_open(Fresh, mkrhs $1 1, + mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) } + | mod_longident DOT LBRACKET expr_semi_list opt_semi error + { unclosed "[" 3 "]" 6 } | PREFIXOP simple_expr - { mkexp(Pexp_apply(mkoperator $1 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 + { mkexp(Pexp_apply(mkoperator $1 1, [Nolabel,$2])) } + | BANG simple_expr + { mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,$2])) } + | NEW ext_attributes class_longident + { mkexp_attrs (Pexp_new(mkrhs $3 3)) $2 } + | LBRACELESS field_expr_list GREATERRBRACE + { mkexp (Pexp_override $2) } + | LBRACELESS field_expr_list error { unclosed "{<" 1 ">}" 4 } | LBRACELESS GREATERRBRACE - { mkexp(Pexp_override []) } + { mkexp (Pexp_override [])} + | mod_longident DOT LBRACELESS field_expr_list GREATERRBRACE + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override $4)))} + | mod_longident DOT LBRACELESS GREATERRBRACE + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))} + | mod_longident DOT LBRACELESS field_expr_list error + { unclosed "{<" 3 ">}" 6 } | simple_expr SHARP label { mkexp(Pexp_send($1, $3)) } + | simple_expr SHARPOP simple_expr + { mkinfix $1 $2 $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), + ghtyp (Ptyp_package $5))) } + | LPAREN MODULE module_expr COLON error + { unclosed "(" 1 ")" 5 } + | mod_longident DOT LPAREN MODULE module_expr COLON package_type RPAREN + { mkexp(Pexp_open(Fresh, mkrhs $1 1, + mkexp (Pexp_constraint (ghexp (Pexp_pack $5), + ghtyp (Ptyp_package $7))))) } + | mod_longident DOT LPAREN MODULE module_expr COLON error + { unclosed "(" 3 ")" 7 } + | extension + { mkexp (Pexp_extension $1) } ; simple_labeled_expr_list: labeled_simple_expr @@ -957,77 +1472,117 @@ simple_labeled_expr_list: ; labeled_simple_expr: simple_expr %prec below_SHARP - { ("", $1) } + { (Nolabel, $1) } | label_expr { $1 } ; label_expr: LABEL simple_expr %prec below_SHARP - { ($1, $2) } + { (Labelled $1, $2) } | TILDE label_ident - { $2 } + { (Labelled (fst $2), snd $2) } | QUESTION label_ident - { ("?" ^ fst $2, snd $2) } + { (Optional (fst $2), snd $2) } | OPTLABEL simple_expr %prec below_SHARP - { ("?" ^ $1, $2) } + { (Optional $1, $2) } ; label_ident: - LIDENT { ($1, mkexp(Pexp_ident(Lident $1))) } + LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) } ; -let_bindings: - let_binding { [$1] } - | let_bindings AND let_binding { $3 :: $1 } +lident_list: + LIDENT { [$1] } + | LIDENT lident_list { $1 :: $2 } ; -let_binding: +let_binding_body: val_ident fun_binding - { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) } + { (mkpatvar $1 1, $2) } + | val_ident COLON typevar_list DOT core_type EQUAL seq_expr + { (ghpat(Ppat_constraint(mkpatvar $1 1, + ghtyp(Ptyp_poly(List.rev $3,$5)))), + $7) } + | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr + { let exp, poly = wrap_type_annotation $4 $6 $8 in + (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) } | pattern EQUAL seq_expr { ($1, $3) } + | simple_pattern_not_ident COLON core_type EQUAL seq_expr + { (ghpat(Ppat_constraint($1, $3)), $5) } +; +let_bindings: + let_binding { $1 } + | let_bindings and_let_binding { addlb $1 $2 } +; +let_binding: + LET ext_attributes rec_flag let_binding_body post_item_attributes + { mklbs $2 $3 (mklb $4 $5) } +; +and_let_binding: + AND let_binding_body post_item_attributes + { mklb $2 $3 } ; fun_binding: strict_binding { $1 } | type_constraint EQUAL seq_expr - { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) } + { mkexp_constraint $3 $1 } ; strict_binding: EQUAL seq_expr { $2 } | labeled_simple_pattern fun_binding - { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) } + { let (l, o, p) = $1 in ghexp(Pexp_fun(l, o, p, $2)) } + | LPAREN TYPE lident_list RPAREN fun_binding + { mk_newtypes $3 $5 } ; match_cases: - pattern match_action { [$1, $2] } - | match_cases BAR pattern match_action { ($3, $4) :: $1 } + match_case { [$1] } + | match_cases BAR match_case { $3 :: $1 } ; -fun_def: - match_action { $1 } - | labeled_simple_pattern fun_def - { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) } +match_case: + pattern MINUSGREATER seq_expr + { Exp.case $1 $3 } + | pattern WHEN seq_expr MINUSGREATER seq_expr + { Exp.case $1 ~guard:$3 $5 } ; -match_action: +fun_def: MINUSGREATER seq_expr { $2 } - | WHEN seq_expr MINUSGREATER seq_expr { mkexp(Pexp_when($2, $4)) } +/* Cf #5939: we used to accept (fun p when e0 -> e) */ + | labeled_simple_pattern fun_def + { + let (l,o,p) = $1 in + ghexp(Pexp_fun(l, o, p, $2)) + } + | LPAREN TYPE lident_list RPAREN fun_def + { mk_newtypes $3 $5 } ; 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) } + simple_expr WITH lbl_expr_list { (Some $1, $3) } + | lbl_expr_list { (None, $1) } ; lbl_expr_list: + lbl_expr { [$1] } + | lbl_expr SEMI lbl_expr_list { $1 :: $3 } + | lbl_expr SEMI { [$1] } +; +lbl_expr: label_longident EQUAL expr - { [$1,$3] } - | lbl_expr_list SEMI label_longident EQUAL expr - { ($3, $5) :: $1 } + { (mkrhs $1 1,$3) } + | label_longident + { (mkrhs $1 1, exp_of_label $1 1) } ; field_expr_list: + field_expr opt_semi { [$1] } + | field_expr SEMI field_expr_list { $1 :: $3 } +; +field_expr: label EQUAL expr - { [$1,$3] } - | field_expr_list SEMI label EQUAL expr - { ($3, $5) :: $1 } + { (mkrhs $1 1, $3) } + | label + { (mkrhs $1 1, exp_of_label (Lident $1) 1) } ; expr_semi_list: expr { [$1] } @@ -1047,40 +1602,58 @@ pattern: simple_pattern { $1 } | pattern AS val_ident - { mkpat(Ppat_alias($1, $3)) } + { mkpat(Ppat_alias($1, mkrhs $3 3)) } + | pattern AS error + { expecting 3 "identifier" } | 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)) } + { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) } | 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)) } + { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) } + | pattern COLONCOLON error + { expecting 3 "pattern" } + | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN + { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) } + | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error + { unclosed "(" 4 ")" 8 } | pattern BAR pattern { mkpat(Ppat_or($1, $3)) } + | pattern BAR error + { expecting 3 "pattern" } + | LAZY simple_pattern + { mkpat(Ppat_lazy $2) } + | EXCEPTION pattern %prec prec_constr_appl + { mkpat(Ppat_exception $2) } + | pattern attribute + { Pat.attr $1 $2 } ; simple_pattern: val_ident %prec below_EQUAL - { mkpat(Ppat_var $1) } + { mkpat(Ppat_var (mkrhs $1 1)) } + | simple_pattern_not_ident { $1 } +; +simple_pattern_not_ident: | UNDERSCORE { mkpat(Ppat_any) } | signed_constant { mkpat(Ppat_constant $1) } - | CHAR DOTDOT CHAR - { mkrangepat $1 $3 } + | signed_constant DOTDOT signed_constant + { mkpat(Ppat_interval ($1, $3)) } | constr_longident - { mkpat(Ppat_construct($1, None, false)) } + { mkpat(Ppat_construct(mkrhs $1 1, None)) } | name_tag { mkpat(Ppat_variant($1, None)) } | SHARP type_longident - { mkpat(Ppat_type $2) } - | LBRACE lbl_pattern_list opt_semi RBRACE - { mkpat(Ppat_record(List.rev $2)) } - | LBRACE lbl_pattern_list opt_semi error - { unclosed "{" 1 "}" 4 } + { mkpat(Ppat_type (mkrhs $2 2)) } + | LBRACE lbl_pattern_list RBRACE + { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) } + | LBRACE lbl_pattern_list error + { unclosed "{" 1 "}" 3 } | LBRACKET pattern_semi_list opt_semi RBRACKET - { reloc_pat (mktailpat (List.rev $2)) } + { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) } | LBRACKET pattern_semi_list opt_semi error { unclosed "[" 1 "]" 4 } | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET @@ -1097,45 +1670,90 @@ simple_pattern: { mkpat(Ppat_constraint($2, $4)) } | LPAREN pattern COLON core_type error { unclosed "(" 1 ")" 5 } + | LPAREN pattern COLON error + { expecting 4 "type" } + | LPAREN MODULE UIDENT RPAREN + { mkpat(Ppat_unpack (mkrhs $3 3)) } + | LPAREN MODULE UIDENT COLON package_type RPAREN + { mkpat(Ppat_constraint(mkpat(Ppat_unpack (mkrhs $3 3)), + ghtyp(Ptyp_package $5))) } + | LPAREN MODULE UIDENT COLON package_type error + { unclosed "(" 1 ")" 6 } + | extension + { mkpat(Ppat_extension $1) } ; pattern_comma_list: pattern_comma_list COMMA pattern { $3 :: $1 } | pattern COMMA pattern { [$3; $1] } + | pattern COMMA error { expecting 3 "pattern" } ; pattern_semi_list: pattern { [$1] } | pattern_semi_list SEMI pattern { $3 :: $1 } ; lbl_pattern_list: - label_longident EQUAL pattern { [($1, $3)] } - | lbl_pattern_list SEMI label_longident EQUAL pattern { ($3, $5) :: $1 } + lbl_pattern { [$1], Closed } + | lbl_pattern SEMI { [$1], Closed } + | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open } + | lbl_pattern SEMI lbl_pattern_list + { let (fields, closed) = $3 in $1 :: fields, closed } +; +lbl_pattern: + label_longident EQUAL pattern + { (mkrhs $1 1,$3) } + | label_longident + { (mkrhs $1 1, pat_of_label $1 1) } +; + +/* Value descriptions */ + +value_description: + VAL val_ident COLON core_type post_item_attributes + { Val.mk (mkrhs $2 2) $4 ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; /* Primitive declarations */ +primitive_declaration_body: + STRING { [fst $1] } + | STRING primitive_declaration_body { fst $1 :: $2 } +; primitive_declaration: - STRING { [$1] } - | STRING primitive_declaration { $1 :: $2 } + EXTERNAL val_ident COLON core_type EQUAL primitive_declaration_body + post_item_attributes + { Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; /* Type declarations */ type_declarations: - type_declaration { [$1] } - | type_declarations AND type_declaration { $3 :: $1 } + type_declaration + { let (nonrec_flag, ty) = $1 in (nonrec_flag, [ty]) } + | type_declarations and_type_declaration + { let (nonrec_flag, tys) = $1 in (nonrec_flag, $2 :: tys) } ; type_declaration: - type_parameters LIDENT type_kind constraints - { let (params, variance) = List.split $1 in - let (kind, manifest) = $3 in - ($2, {ptype_params = params; - ptype_cstrs = List.rev $4; - ptype_kind = kind; - ptype_manifest = manifest; - ptype_variance = variance; - ptype_loc = symbol_rloc()}) } + TYPE nonrec_flag optional_type_parameters LIDENT type_kind constraints + post_item_attributes + { let (kind, priv, manifest) = $5 in + let ty = + Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) ~kind + ~priv ?manifest ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) + in + ($2, ty) } +; +and_type_declaration: + AND optional_type_parameters LIDENT type_kind constraints + post_item_attributes + { let (kind, priv, manifest) = $4 in + Type.mk (mkrhs $3 3) ~params:$2 ~cstrs:(List.rev $5) + ~kind ~priv ?manifest ~attrs:$6 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; constraints: constraints CONSTRAINT constrain { $3 :: $1 } @@ -1143,56 +1761,190 @@ constraints: ; type_kind: /*empty*/ - { (Ptype_abstract, None) } + { (Ptype_abstract, Public, None) } | EQUAL core_type - { (Ptype_abstract, Some $2) } + { (Ptype_abstract, Public, Some $2) } + | EQUAL PRIVATE core_type + { (Ptype_abstract, Private, Some $3) } | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2, Public), None) } + { (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) } + { (Ptype_variant(List.rev $3), Private, None) } + | EQUAL DOTDOT + { (Ptype_open, Public, None) } + | EQUAL private_flag LBRACE label_declarations RBRACE + { (Ptype_record $4, $2, None) } + | EQUAL core_type EQUAL private_flag constructor_declarations + { (Ptype_variant(List.rev $5), $4, Some $2) } + | EQUAL core_type EQUAL DOTDOT + { (Ptype_open, Public, Some $2) } + | EQUAL core_type EQUAL private_flag LBRACE label_declarations RBRACE + { (Ptype_record $6, $4, Some $2) } +; +optional_type_parameters: + /*empty*/ { [] } + | optional_type_parameter { [$1] } + | LPAREN optional_type_parameter_list RPAREN { List.rev $2 } +; +optional_type_parameter: + type_variance optional_type_variable { $2, $1 } +; +optional_type_parameter_list: + optional_type_parameter { [$1] } + | optional_type_parameter_list COMMA optional_type_parameter { $3 :: $1 } +; +optional_type_variable: + QUOTE ident { mktyp(Ptyp_var $2) } + | UNDERSCORE { mktyp(Ptyp_any) } ; + + type_parameters: /*empty*/ { [] } | type_parameter { [$1] } | LPAREN type_parameter_list RPAREN { List.rev $2 } ; type_parameter: - type_variance QUOTE ident { $3, $1 } + type_variance type_variable { $2, $1 } ; type_variance: - /* empty */ { false, false } - | PLUS { true, false } - | MINUS { false, true } + /* empty */ { Invariant } + | PLUS { Covariant } + | MINUS { Contravariant } +; +type_variable: + QUOTE ident { mktyp(Ptyp_var $2) } ; 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 { [$1] } + | bar_constructor_declaration { [$1] } + | constructor_declarations bar_constructor_declaration { $2 :: $1 } ; constructor_declaration: - constr_ident constructor_arguments { ($1, $2, symbol_rloc()) } + | constr_ident generalized_constructor_arguments attributes + { + let args,res = $2 in + Type.constructor (mkrhs $1 1) ~args ?res ~attrs:$3 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) + } +; +bar_constructor_declaration: + | BAR constr_ident generalized_constructor_arguments attributes + { + let args,res = $3 in + Type.constructor (mkrhs $2 2) ~args ?res ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) + } +; +str_exception_declaration: + | sig_exception_declaration { $1 } + | EXCEPTION constr_ident EQUAL constr_longident attributes + post_item_attributes + { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:($5 @ $6) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +sig_exception_declaration: + | EXCEPTION constr_ident generalized_constructor_arguments attributes + post_item_attributes + { let args, res = $3 in + Te.decl (mkrhs $2 2) ~args ?res ~attrs:($4 @ $5) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +generalized_constructor_arguments: + /*empty*/ { (Pcstr_tuple [],None) } + | OF constructor_arguments { ($2,None) } + | COLON constructor_arguments MINUSGREATER simple_core_type + { ($2,Some $4) } + | COLON simple_core_type + { (Pcstr_tuple [],Some $2) } ; + constructor_arguments: - /*empty*/ { [] } - | OF core_type_list { List.rev $2 } + | core_type_list { Pcstr_tuple (List.rev $1) } + | LBRACE label_declarations RBRACE { Pcstr_record $2 } ; label_declarations: label_declaration { [$1] } - | label_declarations SEMI label_declaration { $3 :: $1 } + | label_declaration_semi { [$1] } + | label_declaration_semi label_declarations { $1 :: $2 } ; label_declaration: - mutable_flag label COLON poly_type { ($2, $1, $4, symbol_rloc()) } + mutable_flag label COLON poly_type_no_attr attributes + { + Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) + } +; +label_declaration_semi: + mutable_flag label COLON poly_type_no_attr attributes SEMI attributes + { + let info = + match rhs_info 5 with + | Some _ as info_before_semi -> info_before_semi + | None -> symbol_info () + in + Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7) + ~loc:(symbol_rloc()) ~info + } +; + +/* Type Extensions */ + +str_type_extension: + TYPE nonrec_flag optional_type_parameters type_longident + PLUSEQ private_flag str_extension_constructors post_item_attributes + { if $2 <> Recursive then not_expecting 2 "nonrec flag"; + Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 + ~attrs:$8 ~docs:(symbol_docs ()) } +; +sig_type_extension: + TYPE nonrec_flag optional_type_parameters type_longident + PLUSEQ private_flag sig_extension_constructors post_item_attributes + { if $2 <> Recursive then not_expecting 2 "nonrec flag"; + Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 + ~attrs:$8 ~docs:(symbol_docs ()) } +; +str_extension_constructors: + extension_constructor_declaration { [$1] } + | bar_extension_constructor_declaration { [$1] } + | extension_constructor_rebind { [$1] } + | bar_extension_constructor_rebind { [$1] } + | str_extension_constructors bar_extension_constructor_declaration + { $2 :: $1 } + | str_extension_constructors bar_extension_constructor_rebind + { $2 :: $1 } +; +sig_extension_constructors: + extension_constructor_declaration { [$1] } + | bar_extension_constructor_declaration { [$1] } + | sig_extension_constructors bar_extension_constructor_declaration + { $2 :: $1 } +; +extension_constructor_declaration: + | constr_ident generalized_constructor_arguments attributes + { let args, res = $2 in + Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } +; +bar_extension_constructor_declaration: + | BAR constr_ident generalized_constructor_arguments attributes + { let args, res = $3 in + Te.decl (mkrhs $2 2) ~args ?res ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } +; +extension_constructor_rebind: + | constr_ident EQUAL constr_longident attributes + { Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } +; +bar_extension_constructor_rebind: + | BAR constr_ident EQUAL constr_longident attributes + { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:$5 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; /* "with" constraints (additional type equations over signature components) */ @@ -1202,18 +1954,32 @@ with_constraints: | with_constraints AND with_constraint { $3 :: $1 } ; with_constraint: - TYPE type_parameters label_longident EQUAL 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_variance = variance; - ptype_loc = symbol_rloc()}) } + TYPE type_parameters label_longident with_type_binder core_type_no_attr + constraints + { Pwith_type + (mkrhs $3 3, + (Type.mk (mkrhs (Longident.last $3) 3) + ~params:$2 + ~cstrs:(List.rev $6) + ~manifest:$5 + ~priv:$4 + ~loc:(symbol_rloc()))) } /* used label_longident instead of type_longident to disallow functor applications in type path */ + | TYPE type_parameters label COLONEQUAL core_type_no_attr + { Pwith_typesubst + (Type.mk (mkrhs $3 3) + ~params:$2 + ~manifest:$5 + ~loc:(symbol_rloc())) } | MODULE mod_longident EQUAL mod_ext_longident - { ($2, Pwith_module $4) } + { Pwith_module (mkrhs $2 2, mkrhs $4 4) } + | MODULE UIDENT COLONEQUAL mod_ext_longident + { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) } +; +with_type_binder: + EQUAL { Public } + | EQUAL PRIVATE { Private } ; /* Polymorphic types */ @@ -1224,14 +1990,26 @@ typevar_list: ; poly_type: core_type - { mktyp(Ptyp_poly([], $1)) } + { $1 } | typevar_list DOT core_type { mktyp(Ptyp_poly(List.rev $1, $3)) } ; +poly_type_no_attr: + core_type_no_attr + { $1 } + | typevar_list DOT core_type_no_attr + { mktyp(Ptyp_poly(List.rev $1, $3)) } +; /* Core types */ core_type: + core_type_no_attr + { $1 } + | core_type attribute + { Typ.attr $1 $2 } +; +core_type_no_attr: core_type2 { $1 } | core_type2 AS QUOTE ident @@ -1241,17 +2019,13 @@ core_type2: simple_core_type_or_tuple { $1 } | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Lident "option", [$4]); - ptyp_loc = $4.ptyp_loc}, $6)) } + { mktyp(Ptyp_arrow(Optional $2 , $4, $6)) } | OPTLABEL core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Lident "option", [$2]); - ptyp_loc = $2.ptyp_loc}, $4)) } + { mktyp(Ptyp_arrow(Optional $1 , $2, $4)) } | LIDENT COLON core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow($1, $3, $5)) } + { mktyp(Ptyp_arrow(Labelled $1, $3, $5)) } | core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("", $1, $3)) } + { mktyp(Ptyp_arrow(Nolabel, $1, $3)) } ; simple_core_type: @@ -1260,41 +2034,61 @@ simple_core_type: | 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, [])) } + { mktyp(Ptyp_constr(mkrhs $1 1, [])) } | simple_core_type2 type_longident - { mktyp(Ptyp_constr($2, [$1])) } + { mktyp(Ptyp_constr(mkrhs $2 2, [$1])) } | LPAREN core_type_comma_list RPAREN type_longident - { mktyp(Ptyp_constr($4, List.rev $2)) } + { mktyp(Ptyp_constr(mkrhs $4 4, List.rev $2)) } | LESS meth_list GREATER - { mktyp(Ptyp_object $2) } + { let (f, c) = $2 in mktyp(Ptyp_object (f, c)) } | 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)) } + { mktyp(Ptyp_object ([], Closed)) } + | SHARP class_longident + { mktyp(Ptyp_class(mkrhs $2 2, [])) } + | simple_core_type2 SHARP class_longident + { mktyp(Ptyp_class(mkrhs $3 3, [$1])) } + | LPAREN core_type_comma_list RPAREN SHARP class_longident + { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2)) } | LBRACKET tag_field RBRACKET - { mktyp(Ptyp_variant([$2], true, None)) } + { mktyp(Ptyp_variant([$2], Closed, None)) } +/* PR#3835: this is not LR(1), would need lookahead=2 + | LBRACKET simple_core_type RBRACKET + { mktyp(Ptyp_variant([$2], Closed, None)) } +*/ | LBRACKET BAR row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, true, None)) } + { mktyp(Ptyp_variant(List.rev $3, Closed, None)) } | LBRACKET row_field BAR row_field_list RBRACKET - { mktyp(Ptyp_variant($2 :: List.rev $4, true, None)) } + { mktyp(Ptyp_variant($2 :: List.rev $4, Closed, None)) } | LBRACKETGREATER opt_bar row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, false, None)) } + { mktyp(Ptyp_variant(List.rev $3, Open, None)) } | LBRACKETGREATER RBRACKET - { mktyp(Ptyp_variant([], false, None)) } + { mktyp(Ptyp_variant([], Open, None)) } | LBRACKETLESS opt_bar row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, true, Some [])) } + { mktyp(Ptyp_variant(List.rev $3, Closed, Some [])) } | LBRACKETLESS opt_bar row_field_list GREATER name_tag_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, true, Some (List.rev $5))) } + { mktyp(Ptyp_variant(List.rev $3, Closed, Some (List.rev $5))) } + | LPAREN MODULE package_type RPAREN + { mktyp(Ptyp_package $3) } + | extension + { mktyp (Ptyp_extension $1) } +; +package_type: + mty_longident { (mkrhs $1 1, []) } + | mty_longident WITH package_type_cstrs { (mkrhs $1 1, $3) } +; +package_type_cstr: + TYPE label_longident EQUAL core_type { (mkrhs $2 2, $4) } +; +package_type_cstrs: + package_type_cstr { [$1] } + | package_type_cstr AND package_type_cstrs { $1::$3 } ; row_field_list: row_field { [$1] } @@ -1302,32 +2096,28 @@ row_field_list: ; row_field: tag_field { $1 } - | simple_core_type2 { Rinherit $1 } + | simple_core_type { Rinherit $1 } ; tag_field: - name_tag OF opt_ampersand amper_type_list - { Rtag ($1, $3, List.rev $4) } - | name_tag - { Rtag ($1, true, []) } + name_tag OF opt_ampersand amper_type_list attributes + { Rtag ($1, $5, $3, List.rev $4) } + | name_tag attributes + { Rtag ($1, $2, 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 */ { [] } + core_type_no_attr { [$1] } + | amper_type_list AMPERSAND core_type_no_attr { $3 :: $1 } ; 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 { $1 } | simple_core_type STAR core_type_list { mktyp(Ptyp_tuple($1 :: List.rev $3)) } ; @@ -1340,12 +2130,12 @@ core_type_list: | 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 SEMI meth_list { let (f, c) = $3 in ($1 :: f, c) } + | field opt_semi { [$1], Closed } + | DOTDOT { [], Open } ; field: - label COLON poly_type { mkfield(Pfield($1, $3)) } + label COLON poly_type_no_attr attributes { ($1, $4, $3) } ; label: LIDENT { $1 } @@ -1354,22 +2144,28 @@ label: /* 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 } + INT { Const_int $1 } + | CHAR { Const_char $1 } + | STRING { let (s, d) = $1 in Const_string (s, d) } + | 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) } + 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: @@ -1379,11 +2175,9 @@ ident: val_ident: LIDENT { $1 } | LPAREN operator RPAREN { $2 } -; -val_ident_colon: - LIDENT COLON { $1 } - | LPAREN operator RPAREN COLON { $2 } - | LABEL { $1 } + | LPAREN operator error { unclosed "(" 1 ")" 3 } + | LPAREN error { expecting 2 "operator" } + | LPAREN MODULE error { expecting 3 "module-expr" } ; operator: PREFIXOP { $1 } @@ -1392,7 +2186,10 @@ operator: | INFIXOP2 { $1 } | INFIXOP3 { $1 } | INFIXOP4 { $1 } + | SHARPOP { $1 } + | BANG { "!" } | PLUS { "+" } + | PLUSDOT { "+." } | MINUS { "-" } | MINUSDOT { "-." } | STAR { "*" } @@ -1404,12 +2201,33 @@ operator: | AMPERSAND { "&" } | AMPERAMPER { "&&" } | COLONEQUAL { ":=" } + | PLUSEQ { "+=" } + | PERCENT { "%" } + | index_operator { $1 } +; +index_operator: + DOT index_operator_core opt_assign_arrow { $2^$3 } +; +index_operator_core: + | LPAREN RPAREN { ".()" } + | LBRACKET RBRACKET { ".[]" } + | LBRACE RBRACE { ".{}" } + | LBRACE COMMA RBRACE { ".{,}" } + | LBRACE COMMA COMMA RBRACE { ".{,,}" } + | LBRACE COMMA DOTDOT COMMA RBRACE { ".{,..,}"} +; + +opt_assign_arrow: + { "" } + | LESSMINUS { "<-" } ; + constr_ident: UIDENT { $1 } /* | LBRACKET RBRACKET { "[]" } */ | LPAREN RPAREN { "()" } | COLONCOLON { "::" } +/* | LPAREN COLONCOLON RPAREN { "::" } */ | FALSE { "false" } | TRUE { "true" } ; @@ -1440,7 +2258,7 @@ mod_longident: 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) } + | mod_ext_longident LPAREN mod_ext_longident RPAREN { lapply $1 $3 } ; mty_longident: ident { Lident $1 } @@ -1459,9 +2277,10 @@ class_longident: toplevel_directive: SHARP ident { Ptop_dir($2, Pdir_none) } - | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) } + | SHARP ident STRING { Ptop_dir($2, Pdir_string (fst $3)) } | SHARP ident INT { Ptop_dir($2, Pdir_int $3) } | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident mod_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) } ; @@ -1475,6 +2294,10 @@ rec_flag: /* empty */ { Nonrecursive } | REC { Recursive } ; +nonrec_flag: + /* empty */ { Recursive } + | NONREC { Nonrecursive } +; direction_flag: TO { Upto } | DOWNTO { Downto } @@ -1491,6 +2314,17 @@ virtual_flag: /* empty */ { Concrete } | VIRTUAL { Virtual } ; +private_virtual_flags: + /* empty */ { Public, Concrete } + | PRIVATE { Private, Concrete } + | VIRTUAL { Public, Virtual } + | PRIVATE VIRTUAL { Private, Virtual } + | VIRTUAL PRIVATE { Private, Virtual } +; +override_flag: + /* empty */ { Fresh } + | BANG { Override } +; opt_bar: /* empty */ { () } | BAR { () } @@ -1503,4 +2337,104 @@ subtractive: | MINUS { "-" } | MINUSDOT { "-." } ; +additive: + | PLUS { "+" } + | PLUSDOT { "+." } +; + +/* Attributes and extensions */ + +single_attr_id: + LIDENT { $1 } + | UIDENT { $1 } + | 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" } + | NONREC { "nonrec" } + | OBJECT { "object" } + | OF { "of" } + | OPEN { "open" } + | OR { "or" } + | 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/land/lor/lxor/lsl/lsr/asr are not supported for now */ +; + +attr_id: + single_attr_id { mkloc $1 (symbol_rloc()) } + | single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())} +; +attribute: + LBRACKETAT attr_id payload RBRACKET { ($2, $3) } +; +post_item_attribute: + LBRACKETATAT attr_id payload RBRACKET { ($2, $3) } +; +floating_attribute: + LBRACKETATATAT attr_id payload RBRACKET { ($2, $3) } +; +post_item_attributes: + /* empty */ { [] } + | post_item_attribute post_item_attributes { $1 :: $2 } +; +attributes: + /* empty */{ [] } + | attribute attributes { $1 :: $2 } +; +ext_attributes: + /* empty */ { None, [] } + | attribute attributes { None, $1 :: $2 } + | PERCENT attr_id attributes { Some $2, $3 } +; +extension: + LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) } +; +item_extension: + LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) } +; +payload: + structure { PStr $1 } + | COLON core_type { PTyp $2 } + | QUESTION pattern { PPat ($2, None) } + | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } +; %%