diff --git a/ast/ast_helper.ml b/ast/ast_helper.ml deleted file mode 100644 index 5163f985..00000000 --- a/ast/ast_helper.ml +++ /dev/null @@ -1,562 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments *) - -open Import -open Asttypes -open Parsetree -open Docstrings - -type lid = Longident.t loc -type str = string loc -type loc = Location.t -type attrs = attribute list - -let default_loc = ref Location.none - -let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - -module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) -end - -module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - 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 = Longident.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 loop_object_field 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 (fun v -> - check_variable var_names t.ptyp_loc v.txt) 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) - and loop_object_field = - function - | Otag(label, attrs, t) -> - Otag(label, attrs, loop t) - | Oinherit t -> - Oinherit (loop t) - in - loop t - -end - -module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) -end - -module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } -end - -module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) -end - -module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) -end - -module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c)) -end - -module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c)) -end - -module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - -end - -module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - -end - -module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } -end - -module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } -end - -module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } -end - -module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } -end - -module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } -end - -module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - -end - -module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } -end - -module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } -end - -module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - -end - -(** Type extensions *) -module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - -end - -module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } -end - -module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } -end diff --git a/ast/ast_helper.mli b/ast/ast_helper.mli deleted file mode 100644 index 74bb4abb..00000000 --- a/ast/ast_helper.mli +++ /dev/null @@ -1,443 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments *) - -open Import -open Asttypes -open Docstrings -open Parsetree - -type lid = Longident.t loc -type str = string loc -type loc = Location.t -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end diff --git a/ast/docstrings.ml b/ast/docstrings.ml deleted file mode 100644 index 5e75ff2a..00000000 --- a/ast/docstrings.ml +++ /dev/null @@ -1,353 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Import -open Location - -(* Docstrings *) - -(* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) -type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - -(* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) -type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - -(* List of docstrings *) - -let docstrings : docstring list ref = ref [] - -(* Warn for unused and ambiguous docstrings *) - -let warn_bad_docstrings () = - if Warnings.is_active (Warnings.Bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Warnings.Bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Warnings.Bad_docstring false)) - (List.rev !docstrings) -end - -(* Docstring constructors and destructors *) - -let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - -let register ds = - docstrings := ds :: !docstrings - -let docstring_body ds = ds.ds_body - -let docstring_loc ds = ds.ds_loc - -(* Docstrings attached to items *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -let empty_docs = { docs_pre = None; docs_post = None } - -let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - -let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - -let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - -(* Docstrings attached to constructors or fields *) - -type info = docstring option - -let empty_info = None - -let info_attr = docs_attr - -let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - -(* Docstrings not attached to a specific item *) - -type text = docstring list - -let empty_text = [] -let empty_text_lazy = lazy [] - -let text_loc = {txt = "ocaml.text"; loc = Location.none} - -let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - -let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -(* Find the first non-info docstring in a list, attach it and return it *) -let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - -(* Find all the non-info docstrings in a list, attach them and return them *) -let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - -(* "Associate" all the docstrings in a list *) -let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - -(* Map from positions to pre docstrings *) - -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - -let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - -(* Map from positions to post docstrings *) - -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - -let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - -let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - -(* Map from positions to floating docstrings *) - -let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - -let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - -let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Maps from positions to extra docstrings *) - -let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - -let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - -let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Docstrings from parser actions *) - -let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - -let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - -let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - -let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - -let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - -let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - - -(* (Re)Initialise all comment state *) - -let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table diff --git a/ast/docstrings.mli b/ast/docstrings.mli deleted file mode 100644 index bedb108b..00000000 --- a/ast/docstrings.mli +++ /dev/null @@ -1,162 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Import - -(** Documentation comments *) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text diff --git a/ast/dune b/ast/dune index 1ed8f935..17c4ec09 100644 --- a/ast/dune +++ b/ast/dune @@ -8,37 +8,18 @@ ocaml-migrate-parsetree) (flags (:standard -open Ocaml_shadow -safe-string) -w -9-27-32) (modules - ast_helper ast - clflags_helper - docstrings import - lexer + lexer_helper location_helper - parse - parser pprintast ppxlib_ast - syntaxerr warn) (lint (pps ppxlib_traverse -deriving-keep-w32=impl))) -(ocamllex lexer) -(ocamlyacc parser0) - ;; This is to make the code compatible with different versions of ;; OCaml (rule (targets location_helper.ml clflags_helper.ml) (deps gen-compiler_specifics) (action (run %{ocaml} %{deps} %{ocaml_version} %{targets}))) - -(rule - (targets parser.ml) - (deps parser0.ml) - (action (with-stdout-to %{targets} (echo "open Import\n%{read:parser0.ml}")))) - -(rule - (targets parser.mli) - (deps parser0.mli) - (action (with-stdout-to %{targets} (echo "open Import\n%{read:parser0.mli}")))) diff --git a/ast/import.ml b/ast/import.ml index d979268f..2f3b34d4 100644 --- a/ast/import.ml +++ b/ast/import.ml @@ -101,15 +101,46 @@ module Selected_ast = Select_ast(Ocaml) (* Modules from migrate_parsetree *) module Parsetree = Selected_ast.Ast.Parsetree module Asttypes = Selected_ast.Ast.Asttypes +module Ast_helper = Selected_ast.Ast.Ast_helper +module Docstrings = Selected_ast.Ast.Docstrings + module Location = struct include Ocaml_common.Location include Location_helper end -module Clflags = struct - include Ocaml_common.Clflags - include Clflags_helper +module Lexer = struct + include Ocaml_common.Lexer + include Lexer_helper +end + +module Syntaxerr = struct + include Ocaml_common.Syntaxerr +end + +module Parse = struct + include Ocaml_common.Parse + module Of_ocaml = Migrate_parsetree.Versions.Convert(Ocaml)(Js) + let implementation lexbuf = implementation lexbuf |> Of_ocaml.copy_structure + let interface lexbuf = interface lexbuf |> Of_ocaml.copy_signature + let toplevel_phrase lexbuf = toplevel_phrase lexbuf |> Of_ocaml.copy_toplevel_phrase + let use_file lexbuf = use_file lexbuf |> List.map Of_ocaml.copy_toplevel_phrase + let core_type lexbuf = core_type lexbuf |> Of_ocaml.copy_core_type + let expression lexbuf = expression lexbuf |> Of_ocaml.copy_expression + let pattern lexbuf = pattern lexbuf |> Of_ocaml.copy_pattern +end + +module Parser = struct + include Ocaml_common.Parser + module Of_ocaml = Migrate_parsetree.Versions.Convert(Ocaml)(Js) + let use_file lexer lexbuf = use_file lexer lexbuf |> List.map Of_ocaml.copy_toplevel_phrase + let toplevel_phrase lexer lexbuf = toplevel_phrase lexer lexbuf |> Of_ocaml.copy_toplevel_phrase + let parse_pattern lexer lexbuf = parse_pattern lexer lexbuf |> Of_ocaml.copy_pattern + let parse_expression lexer lexbuf = parse_expression lexer lexbuf |> Of_ocaml.copy_expression + let parse_core_type lexer lexbuf = parse_core_type lexer lexbuf |> Of_ocaml.copy_core_type + let interface lexer lexbuf = interface lexer lexbuf |> Of_ocaml.copy_signature + let implementation lexer lexbuf = implementation lexer lexbuf |> Of_ocaml.copy_structure end (* Modules imported directly from the compiler *) diff --git a/ast/lexer.mll b/ast/lexer.mll deleted file mode 100644 index 741779fc..00000000 --- a/ast/lexer.mll +++ /dev/null @@ -1,832 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* The lexer definition *) - -{ -open Import -open Lexing -open Misc -open Parser - -type error = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Keyword_as_label of string - | Invalid_literal of string - | Invalid_directive of string * string option -;; - -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; - "nonrec", NONREC; - "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; - - "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) - "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) - "mod", INFIXOP3("mod"); - "land", INFIXOP3("land"); - "lsl", INFIXOP4("lsl"); - "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr") -] - -module Buffer = struct (* Imported for compatibility with 4.04.x *) - [@@@warning "-32"] - let add_utf_8_uchar b u = match Uchar.to_int u with - | u when u < 0 -> assert false - | u when u <= 0x007F -> - Buffer.add_char b (Char.unsafe_chr u) - | u when u <= 0x07FF -> - Buffer.add_char b (Char.unsafe_chr (0xC0 lor (u lsr 6))); - Buffer.add_char b (Char.unsafe_chr (0x80 lor (u land 0x3F))); - | u when u <= 0xFFFF -> - Buffer.add_char b (Char.unsafe_chr (0xE0 lor (u lsr 12))); - Buffer.add_char b (Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F))); - Buffer.add_char b (Char.unsafe_chr (0x80 lor (u land 0x3F))); - | u when u <= 0x10FFFF -> - Buffer.add_char b (Char.unsafe_chr (0xF0 lor (u lsr 18))); - Buffer.add_char b (Char.unsafe_chr (0x80 lor ((u lsr 12) land 0x3F))); - Buffer.add_char b (Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F))); - Buffer.add_char b (Char.unsafe_chr (0x80 lor (u land 0x3F))); - | _ -> assert false - include Buffer -end - -(* To buffer string literals *) - -let string_buffer = Buffer.create 256 -let reset_string_buffer () = Buffer.reset string_buffer -let get_stored_string () = Buffer.contents string_buffer - -let store_string_char c = Buffer.add_char string_buffer c -let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u -let store_string s = Buffer.add_string string_buffer s -let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) - -(* 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 <> [];; -let is_in_string = ref false -let in_string () = !is_in_string -let print_warnings = ref true - -(* Escaped chars are interpreted in strings unless they are in comments. *) -let store_escaped_char lexbuf c = - if in_comment () then store_lexeme lexbuf else store_string_char c - -let store_escaped_uchar lexbuf u = - if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u - -let with_comment_buffer comment lexbuf = - let start_loc = Location.curr lexbuf in - comment_start_loc := [start_loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in - s, loc - -(* To translate escape sequences *) - -let hex_digit_value d = (* assert (d in '0'..'9' 'a'..'f' 'A'..'F') *) - let d = Char.code d in - if d >= 97 then d - 87 else - if d >= 65 then d - 55 else - d - 48 - -let hex_num_value lexbuf ~first ~last = - let rec loop acc i = match i > last with - | true -> acc - | false -> - let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in - loop (16 * acc + value) (i + 1) - in - loop 0 first - -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_octal_code lexbuf i = - let c = 64 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + - 8 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in - Char.chr c - -let char_for_hexadecimal_code lexbuf i = - let byte = hex_num_value lexbuf ~first:i ~last:(i+1) in - Char.chr byte - -let uchar_for_uchar_escape lexbuf = - let err e = - raise - (Error (Illegal_escape (Lexing.lexeme lexbuf ^ e), Location.curr lexbuf)) - in - let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in - let first = 3 (* skip opening \u{ *) in - let last = len - 2 (* skip closing } *) in - let digit_count = last - first + 1 in - match digit_count > 6 with - | true -> err ", too many digits, expected 1 to 6 hexadecimal digits" - | false -> - let cp = hex_num_value lexbuf ~first ~last in - if Uchar.is_valid cp then Uchar.unsafe_of_int cp else - err (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value") - -(* recover the name from a LABEL or OPTLABEL token *) - -let get_label_name lexbuf = - 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)); - name -;; - -(* 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; - } -;; - -let preprocessor = ref None - -let escaped_newlines = ref false - -(* Warn about Latin-1 characters used in idents *) - -let warn_latin1 lexbuf = - Location.deprecated (Location.curr lexbuf)"ISO-Latin1 characters in identifiers" - -let handle_docstrings = ref true -let comment_list = ref [] - -let add_comment com = - comment_list := com :: !comment_list - -let add_docstring_comment ds = - let com = - ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds) - in - add_comment com - -let comments () = List.rev !comment_list - -(* 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 (_, loc) -> - fprintf ppf "This comment contains an unterminated string literal@.\ - %aString literal begins here" - Location.print_error loc - | Keyword_as_label kwd -> - fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd - | Invalid_literal s -> - fprintf ppf "Invalid literal %s" s - | Invalid_directive (dir, explanation) -> - fprintf ppf "Invalid lexer directive %S" dir; - begin match explanation with - | None -> () - | Some expl -> fprintf ppf ": %s" expl - end - -let () = - Location.register_error_of_exn - (function - | Error (err, loc) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) - -} - -let newline = ('\013'* '\010') -let blank = [' ' '\009' '\012'] -let lowercase = ['a'-'z' '_'] -let uppercase = ['A'-'Z'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] -let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar_latin1 = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let symbolchar = - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let dotsymbolchar = - ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '~'] -let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* -let hex_digit = - ['0'-'9' 'A'-'F' 'a'-'f'] -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' '_']* )? -let hex_float_literal = - '0' ['x' 'X'] - ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* - ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? - (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? -let literal_modifier = ['G'-'Z' 'g'-'z'] - -rule token = parse - | "\\" newline { - if not !escaped_newlines then - raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)); - update_loc lexbuf None 1 false 0; - token lexbuf } - | newline - { update_loc lexbuf None 1 false 0; - EOL } - | blank + - { token lexbuf } - | "_" - { UNDERSCORE } - | "~" - { TILDE } - | "~" lowercase identchar * ':' - { LABEL (get_label_name lexbuf) } - | "~" lowercase_latin1 identchar_latin1 * ':' - { warn_latin1 lexbuf; LABEL (get_label_name lexbuf) } - | "?" - { QUESTION } - | "?" lowercase identchar * ':' - { OPTLABEL (get_label_name lexbuf) } - | "?" lowercase_latin1 identchar_latin1 * ':' - { warn_latin1 lexbuf; OPTLABEL (get_label_name lexbuf) } - | lowercase identchar * - { let s = Lexing.lexeme lexbuf in - try Hashtbl.find keyword_table s - with Not_found -> LIDENT s } - | lowercase_latin1 identchar_latin1 * - { warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) } - | uppercase identchar * - { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) - | uppercase_latin1 identchar_latin1 * - { warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) } - | int_literal { INT (Lexing.lexeme lexbuf, None) } - | (int_literal as lit) (literal_modifier as modif) - { INT (lit, Some modif) } - | float_literal | hex_float_literal - { FLOAT (Lexing.lexeme lexbuf, None) } - | ((float_literal | hex_float_literal) as lit) (literal_modifier as modif) - { FLOAT (lit, Some modif) } - | (float_literal | hex_float_literal | int_literal) identchar+ - { raise (Error(Invalid_literal (Lexing.lexeme lexbuf), - Location.curr lexbuf)) } - | "\"" - { reset_string_buffer(); - is_in_string := true; - let string_start = lexbuf.lex_start_p in - string_start_loc := Location.curr lexbuf; - string lexbuf; - is_in_string := false; - lexbuf.lex_start_p <- string_start; - STRING (get_stored_string(), None) } - | "{" lowercase* "|" - { reset_string_buffer(); - let delim = Lexing.lexeme lexbuf in - let delim = String.sub delim 1 (String.length delim - 2) in - is_in_string := true; - let string_start = lexbuf.lex_start_p in - string_start_loc := Location.curr lexbuf; - quoted_string delim lexbuf; - is_in_string := false; - lexbuf.lex_start_p <- string_start; - STRING (get_stored_string(), Some delim) } - | "\'" 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) } - | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { CHAR(char_for_octal_code lexbuf 3) } - | "\'\\" '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)) - } - | "(*" - { let s, loc = with_comment_buffer comment lexbuf in - COMMENT (s, loc) } - | "(**" - { let s, loc = with_comment_buffer comment lexbuf in - if !handle_docstrings then - DOCSTRING (Docstrings.docstring s loc) - else - COMMENT ("*" ^ s, loc) - } - | "(**" (('*'+) as stars) - { let s, loc = - with_comment_buffer - (fun lexbuf -> - store_string ("*" ^ stars); - comment lexbuf) - lexbuf - in - COMMENT (s, loc) } - | "(*)" - { if !print_warnings then - Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; - let s, loc = with_comment_buffer comment lexbuf in - COMMENT (s, loc) } - | "(*" (('*'*) as stars) "*)" - { if !handle_docstrings && stars="" then - (* (**) is an empty docstring *) - DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf)) - else - COMMENT (stars, Location.curr 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 - } - | "#" - { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in - if not (at_beginning_of_line lexbuf.lex_start_p) - then HASH - else try directive lexbuf with Failure _ -> HASH - } - | "&" { AMPERSAND } - | "&&" { AMPERAMPER } - | "`" { BACKQUOTE } - | "\'" { QUOTE } - | "(" { LPAREN } - | ")" { RPAREN } - | "*" { STAR } - | "," { COMMA } - | "->" { MINUSGREATER } - | "." { DOT } - | ".." { DOTDOT } - | "." (dotsymbolchar symbolchar* as s) { DOTOP s } - | ":" { COLON } - | "::" { COLONCOLON } - | ":=" { COLONEQUAL } - | ":>" { COLONGREATER } - | ";" { SEMI } - | ";;" { SEMISEMI } - | "<" { LESS } - | "<-" { LESSMINUS } - | "=" { EQUAL } - | "[" { LBRACKET } - | "[|" { LBRACKETBAR } - | "[<" { LBRACKETLESS } - | "[>" { LBRACKETGREATER } - | "]" { RBRACKET } - | "{" { LBRACE } - | "{<" { LBRACELESS } - | "|" { BAR } - | "||" { BARBAR } - | "|]" { BARRBRACKET } - | ">" { GREATER } - | ">]" { GREATERRBRACKET } - | "}" { RBRACE } - | ">}" { GREATERRBRACE } - | "[@" { LBRACKETAT } - | "[@@" { LBRACKETATAT } - | "[@@@" { LBRACKETATATAT } - | "[%" { LBRACKETPERCENT } - | "[%%" { LBRACKETPERCENTPERCENT } - | "!" { BANG } - | "!=" { INFIXOP0 "!=" } - | "+" { PLUS } - | "+." { PLUSDOT } - | "+=" { PLUSEQ } - | "-" { 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) } - | '%' { PERCENT } - | ['*' '/' '%'] symbolchar * - { INFIXOP3(Lexing.lexeme lexbuf) } - | '#' (symbolchar | '#') + - { HASHOP(Lexing.lexeme lexbuf) } - | eof { EOF } - | _ - { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)) - } - -and directive = parse - | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive) - [^ '\010' '\013'] * - { - match int_of_string num with - | exception _ -> - (* PR#7165 *) - let loc = Location.curr lexbuf in - let explanation = "line number out of range" in - let error = Invalid_directive ("#" ^ directive, Some explanation) in - raise (Error (error, loc)) - | line_num -> - (* Documentation says that the line number should be - positive, but we have never guarded against this and it - might have useful hackish uses. *) - update_loc lexbuf (Some name) (line_num - 1) true 0; - token lexbuf - } -and comment = parse - "(*" - { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; - store_lexeme lexbuf; - comment lexbuf - } - | "*)" - { match !comment_start_loc with - | [] -> assert false - | [_] -> comment_start_loc := []; Location.curr lexbuf - | _ :: l -> comment_start_loc := l; - store_lexeme lexbuf; - comment lexbuf - } - | "\"" - { - string_start_loc := Location.curr lexbuf; - store_string_char '\"'; - is_in_string := true; - begin try string lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), - loc)) - end; - is_in_string := false; - store_string_char '\"'; - comment lexbuf } - | "{" lowercase* "|" - { - let delim = Lexing.lexeme lexbuf in - let delim = String.sub delim 1 (String.length delim - 2) in - string_start_loc := Location.curr lexbuf; - store_lexeme lexbuf; - is_in_string := true; - begin try quoted_string delim lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), - loc)) - end; - is_in_string := false; - store_string_char '|'; - store_string delim; - store_string_char '}'; - comment lexbuf } - - | "\'\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - store_lexeme lexbuf; - comment lexbuf - } - | "\'" [^ '\\' '\'' '\010' '\013' ] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | eof - { match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_comment start, loc)) - } - | newline - { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - comment lexbuf - } - | _ - { store_lexeme lexbuf; comment lexbuf } - -and string = parse - '\"' - { () } - | '\\' newline ([' ' '\t'] * as space) - { update_loc lexbuf None 1 false (String.length space); - if in_comment () then store_lexeme lexbuf; - string lexbuf - } - | '\\' ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] - { store_escaped_char lexbuf - (char_for_backslash(Lexing.lexeme_char lexbuf 1)); - string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); - string lexbuf } - | '\\' 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] - { store_escaped_char lexbuf (char_for_octal_code lexbuf 2); - string lexbuf } - | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] - { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); - string lexbuf } - | '\\' 'u' '{' hex_digit+ '}' - { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); - string lexbuf } - | '\\' _ - { if not (in_comment ()) then 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; - end; - store_lexeme lexbuf; - string lexbuf - } - | newline - { if not (in_comment ()) then - Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; - update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - string lexbuf - } - | eof - { is_in_string := false; - raise (Error (Unterminated_string, !string_start_loc)) } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - -and quoted_string delim = parse - | newline - { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - quoted_string delim lexbuf - } - | eof - { is_in_string := false; - raise (Error (Unterminated_string, !string_start_loc)) } - | "|" lowercase* "}" - { - let edelim = Lexing.lexeme lexbuf in - let edelim = String.sub edelim 1 (String.length edelim - 2) in - if delim = edelim then () - else (store_lexeme lexbuf; quoted_string delim lexbuf) - } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - quoted_string delim lexbuf } - -and skip_hash_bang = parse - | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" - { update_loc lexbuf None 3 false 0 } - | "#!" [^ '\n']* '\n' - { update_loc lexbuf None 1 false 0 } - | "" { () } - -{ - - let token_with_comments lexbuf = - match !preprocessor with - | None -> token lexbuf - | Some (_init, preprocess) -> preprocess token lexbuf - - type newline_state = - | NoLine (* There have been no blank lines yet. *) - | NewLine - (* There have been no blank lines, and the previous - token was a newline. *) - | BlankLine (* There have been blank lines. *) - - type doc_state = - | Initial (* There have been no docstrings yet *) - | After of docstring list - (* There have been docstrings, none of which were - preceded by a blank line *) - | Before of docstring list * docstring list * docstring list - (* There have been docstrings, some of which were - preceded by a blank line *) - - and docstring = Docstrings.docstring - - let token lexbuf = - let post_pos = lexeme_end_p lexbuf in - let attach lines docs pre_pos = - let open Docstrings in - match docs, lines with - | Initial, _ -> () - | After a, (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_pre_docstrings pre_pos a; - | After a, BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_pre_extra_docstrings pre_pos (List.rev a) - | Before(a, f, b), (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos (List.rev f); - set_pre_extra_docstrings pre_pos (List.rev a); - set_pre_docstrings pre_pos b - | Before(a, f, b), BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos - (List.rev_append f (List.rev b)); - set_pre_extra_docstrings pre_pos (List.rev a) - in - let rec loop lines docs lexbuf = - match token_with_comments lexbuf with - | COMMENT (s, loc) -> - add_comment (s, loc); - let lines' = - match lines with - | NoLine -> NoLine - | NewLine -> NoLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | EOL -> - let lines' = - match lines with - | NoLine -> NewLine - | NewLine -> BlankLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | DOCSTRING doc -> - Docstrings.register doc; - add_docstring_comment doc; - let docs' = - if Docstrings.docstring_body doc = "/*" then - match docs with - | Initial -> Before([], [doc], []) - | After a -> Before (a, [doc], []) - | Before(a, f, b) -> Before(a, doc :: b @ f, []) - else - match docs, lines with - | Initial, (NoLine | NewLine) -> After [doc] - | Initial, BlankLine -> Before([], [], [doc]) - | After a, (NoLine | NewLine) -> After (doc :: a) - | After a, BlankLine -> Before (a, [], [doc]) - | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) - | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) - in - loop NoLine docs' lexbuf - | tok -> - attach lines docs (lexeme_start_p lexbuf); - tok - in - loop NoLine Initial lexbuf - - let init () = - is_in_string := false; - comment_start_loc := []; - comment_list := []; - match !preprocessor with - | None -> () - | Some (init, _preprocess) -> init () - - let set_preprocessor init preprocess = - escaped_newlines := true; - preprocessor := Some (init, preprocess) - -} diff --git a/ast/lexer_helper.ml b/ast/lexer_helper.ml new file mode 100644 index 00000000..3a36a9f2 --- /dev/null +++ b/ast/lexer_helper.ml @@ -0,0 +1,63 @@ +open Ocaml_common.Parser + +let keyword_table = + Ocaml_common.Misc.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; + "nonrec", NONREC; + "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; + + "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) + "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) + "mod", INFIXOP3("mod"); + "land", INFIXOP3("land"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +] diff --git a/ast/parse.ml b/ast/parse.ml deleted file mode 100644 index 0c0a2e82..00000000 --- a/ast/parse.ml +++ /dev/null @@ -1,69 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Import - -(* Entry points in the parser *) - -(* 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 - Docstrings.init (); - Lexer.init (); - let ast = parsing_fun Lexer.token lexbuf in - Parsing.clear_parser(); - Docstrings.warn_bad_docstrings (); - ast - with - | Lexer.Error(Lexer.Illegal_character _, _) as err - when !Location.input_name = "//toplevel//"-> - skip_phrase lexbuf; - raise err - | Syntaxerr.Error _ as err - when !Location.input_name = "//toplevel//" -> - maybe_skip_phrase lexbuf; - raise err - | Parsing.Parse_error | Syntaxerr.Escape_error -> - let loc = Location.curr lexbuf in - if !Location.input_name = "//toplevel//" - 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 -and core_type = wrap Parser.parse_core_type -and expression = wrap Parser.parse_expression -and pattern = wrap Parser.parse_pattern diff --git a/ast/parse.mli b/ast/parse.mli deleted file mode 100644 index 1a6ba1a0..00000000 --- a/ast/parse.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Entry points in the parser *) - -open Import - -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 -val core_type : Lexing.lexbuf -> Parsetree.core_type -val expression : Lexing.lexbuf -> Parsetree.expression -val pattern : Lexing.lexbuf -> Parsetree.pattern diff --git a/ast/parser0.mly b/ast/parser0.mly deleted file mode 100644 index 0fd47326..00000000 --- a/ast/parser0.mly +++ /dev/null @@ -1,2656 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* 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 GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* The parser definition */ - -%{ -open Import -open Location -open Asttypes -open Longident -open Parsetree -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 ?attrs d = Mty.mk ~loc:(symbol_rloc()) ?attrs d -let mksig d = Sig.mk ~loc:(symbol_rloc()) d -let mkmod ?attrs d = Mod.mk ~loc:(symbol_rloc()) ?attrs d -let mkstr d = Str.mk ~loc:(symbol_rloc()) d -let mkclass ?attrs d = Cl.mk ~loc:(symbol_rloc()) ?attrs d -let mkcty ?attrs d = Cty.mk ~loc:(symbol_rloc()) ?attrs 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 = - 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 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 - -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. - - 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 = 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 ghsig d = Sig.mk ~loc:(symbol_gloc()) d - -let mkinfix arg1 name arg2 = - mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2])) - -let neg_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(Pconst_integer (n,m)) -> - mkexp(Pexp_constant(Pconst_integer(neg_string n,m))) - | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> - mkexp(Pexp_constant(Pconst_float(neg_string f, m))) - | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) - -let mkuplus name arg = - let desc = arg.pexp_desc in - match name, desc with - | "+", Pexp_constant(Pconst_integer _) - | ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc - | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) - -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 - [] -> - 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 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 = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in - mkexp_cons {loc with loc_ghost = true} arg loc - -let rec mktailpat nilloc = function - [] -> - 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 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 = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - mkpat_cons {loc with loc_ghost = true} arg loc - -let mkstrexp e attrs = - { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } - -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 mkexp_opt_constraint e = function - | None -> e - | Some constraint_ -> mkexp_constraint e constraint_ - -let mkpat_opt_constraint p = function - | None -> p - | Some typ -> mkpat (Ppat_constraint(p, typ)) - -let array_function str name = - ghloc (Ldot(Lident str, (if Clflags.is_unsafe () then "unsafe_" ^ name else name))) - -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 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 str name = - ghloc (Ldot(Ldot(Lident "Bigarray", str), name)) - -let bigarray_untuplify = function - { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist - | exp -> [exp] - -let bigarray_get arr arg = - let get = if Clflags.is_unsafe () then "unsafe_get" else "get" in - match bigarray_untuplify arg with - [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)), - [Nolabel, arr; Nolabel, c1])) - | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)), - [Nolabel, arr; Nolabel, c1; Nolabel, c2])) - | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)), - [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3])) - | coords -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")), - [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)])) - -let bigarray_set arr arg newval = - let set = if Clflags.is_unsafe () then "unsafe_set" else "set" in - match bigarray_untuplify arg with - [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)), - [Nolabel, arr; Nolabel, c1; Nolabel, newval])) - | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)), - [Nolabel, arr; Nolabel, c1; - Nolabel, c2; Nolabel, newval])) - | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)), - [Nolabel, arr; Nolabel, c1; - Nolabel, c2; Nolabel, c3; Nolabel, newval])) - | coords -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), - [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 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, Typ.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 wrap_typ_attrs typ (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in - match ext with - | None -> typ - | Some id -> ghtyp(Ptyp_extension (id, PTyp typ)) - -let mktyp_attrs d attrs = - wrap_typ_attrs (mktyp d) attrs - -let wrap_pat_attrs pat (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in - match ext with - | None -> pat - | Some id -> ghpat(Ppat_extension (id, PPat (pat, None))) - -let mkpat_attrs d attrs = - wrap_pat_attrs (mkpat d) attrs - -let wrap_class_attrs body attrs = - {body with pcl_attributes = attrs @ body.pcl_attributes} -let wrap_class_type_attrs body attrs = - {body with pcty_attributes = attrs @ body.pcty_attributes} -let wrap_mod_attrs body attrs = - {body with pmod_attributes = attrs @ body.pmod_attributes} -let wrap_mty_attrs body attrs = - {body with pmty_attributes = attrs @ body.pmty_attributes} - -let wrap_str_ext body ext = - match ext with - | None -> body - | Some id -> ghstr(Pstr_extension ((id, PStr [body]), [])) - -let mkstr_ext d ext = - wrap_str_ext (mkstr d) ext - -let wrap_sig_ext body ext = - match ext with - | None -> body - | Some id -> ghsig(Psig_extension ((id, PSig [body]), [])) - -let mksig_ext d ext = - wrap_sig_ext (mksig d) ext - -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 = - match items with - | [] -> - let post = rhs_post_text pos in - let post_extras = rhs_post_extra_text pos in - text post @ text post_extras - | _ :: _ -> - 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 - -let extra_rhs_core_type ct ~pos = - let docs = rhs_info pos in - { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } - -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_loc: Location.t } - -let mklb first (p, e) attrs = - { lb_pattern = p; - lb_expression = e; - lb_attributes = attrs; - lb_docs = symbol_docs_lazy (); - lb_text = if first then empty_text_lazy - else symbol_text_lazy (); - lb_loc = symbol_rloc (); } - -let mklbs ext rf lb = - { lbs_bindings = [lb]; - lbs_rec = rf; - lbs_extension = ext ; - lbs_loc = symbol_rloc (); } - -let addlb lbs lb = - { lbs with lbs_bindings = lb :: lbs.lbs_bindings } - -let val_of_let_bindings lbs = - 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) - lbs.lbs_bindings - in - let str = 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 -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) - (lbs.lbs_extension, []) - -let class_of_let_bindings lbs body = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - 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"))); - mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body)) - - -(* Alternatively, we could keep the generic module type in the Parsetree - and extract the package type during type-checking. In that case, - the assertions below should be turned into explicit checks. *) -let package_type_of_module_type pmty = - let err loc s = - raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) - in - let map_cstr = function - | Pwith_type (lid, ptyp) -> - let loc = ptyp.ptype_loc in - if ptyp.ptype_params <> [] then - err loc "parametrized types are not supported"; - if ptyp.ptype_cstrs <> [] then - err loc "constrained types are not supported"; - if ptyp.ptype_private <> Public then - err loc "private types are not supported"; - - (* restrictions below are checked by the 'with_constraint' rule *) - assert (ptyp.ptype_kind = Ptype_abstract); - assert (ptyp.ptype_attributes = []); - let ty = - match ptyp.ptype_manifest with - | Some ty -> ty - | None -> assert false - in - (lid, ty) - | _ -> - err pmty.pmty_loc "only 'with type t =' constraints are supported" - in - match pmty with - | {pmty_desc = Pmty_ident lid} -> (lid, []) - | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> - (lid, List.map map_cstr cstrs) - | _ -> - err pmty.pmty_loc - "only module type identifier and 'with type' constraints are supported" - - -%} - -/* 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 -%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 FLOAT -%token FOR -%token FUN -%token FUNCTION -%token FUNCTOR -%token GREATER -%token GREATERRBRACE -%token GREATERRBRACKET -%token IF -%token IN -%token INCLUDE -%token INFIXOP0 -%token INFIXOP1 -%token INFIXOP2 -%token INFIXOP3 -%token INFIXOP4 -%token DOTOP -%token INHERIT -%token INITIALIZER -%token INT -%token LABEL -%token LAZY -%token LBRACE -%token LBRACELESS -%token LBRACKET -%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 -%token MINUSDOT -%token MINUSGREATER -%token MODULE -%token MUTABLE -%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 QUOTE -%token RBRACE -%token RBRACKET -%token REC -%token RPAREN -%token SEMI -%token SEMISEMI -%token HASH -%token HASHOP -%token SIG -%token STAR -%token STRING -%token STRUCT -%token THEN -%token TILDE -%token TO -%token TRUE -%token TRY -%token TYPE -%token UIDENT -%token UNDERSCORE -%token VAL -%token VIRTUAL -%token WHEN -%token WHILE -%token WITH -%token COMMENT -%token DOCSTRING - -%token EOL - -/* 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) */ -%nonassoc below_LBRACKETAT -%nonassoc LBRACKETAT -%nonassoc LBRACKETATAT -%right COLONCOLON /* expr (e :: e :: 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 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_HASH -%nonassoc HASH /* simple_expr/toplevel_directive */ -%left HASHOP -%nonassoc below_DOT -%nonassoc DOT DOTOP -/* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT - LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN - NEW PREFIXOP STRING TRUE UIDENT - LBRACKETPERCENT LBRACKETPERCENTPERCENT - - -/* Entry points */ - -%start implementation /* for implementation files */ -%type implementation -%start interface /* for interface files */ -%type interface -%start toplevel_phrase /* for interactive use */ -%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 { extra_str 1 $1 } -; -interface: - signature EOF { extra_sig 1 $1 } -; -toplevel_phrase: - top_structure SEMISEMI { Ptop_def (extra_str 1 $1) } - | toplevel_directive SEMISEMI { $1 } - | EOF { raise End_of_file } -; -top_structure: - 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 EOF { extra_def 1 $1 } -; -use_file_body: - use_file_tail { $1 } - | seq_expr post_item_attributes use_file_tail - { (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 } -; -use_file_tail: - /* empty */ - { [] } - | SEMISEMI use_file_body - { $2 } - | 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 (mkrhs $1 1)) } - | STRUCT attributes structure END - { mkmod ~attrs:$2 (Pmod_structure(extra_str 3 $3)) } - | STRUCT attributes structure error - { unclosed "struct" 1 "end" 4 } - | FUNCTOR attributes functor_args MINUSGREATER module_expr - { let modexp = - List.fold_left - (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) - $5 $3 - in wrap_mod_attrs modexp $2 } - | module_expr paren_module_expr - { mkmod(Pmod_apply($1, $2)) } - | module_expr LPAREN RPAREN - { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) } - | paren_module_expr - { $1 } - | module_expr attribute - { Mod.attr $1 $2 } - | extension - { mkmod(Pmod_extension $1) } -; - -paren_module_expr: - 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 attributes expr RPAREN - { mkmod ~attrs:$3 (Pmod_unpack $4)} - | LPAREN VAL attributes expr COLON package_type RPAREN - { mkmod ~attrs:$3 - (Pmod_unpack( - ghexp(Pexp_constraint($4, ghtyp(Ptyp_package $6))))) } - | LPAREN VAL attributes expr COLON package_type COLONGREATER package_type - RPAREN - { mkmod ~attrs:$3 - (Pmod_unpack( - ghexp(Pexp_coerce($4, Some(ghtyp(Ptyp_package $6)), - ghtyp(Ptyp_package $8))))) } - | LPAREN VAL attributes expr COLONGREATER package_type RPAREN - { mkmod ~attrs:$3 - (Pmod_unpack( - ghexp(Pexp_coerce($4, None, ghtyp(Ptyp_package $6))))) } - | LPAREN VAL attributes expr COLON error - { unclosed "(" 1 ")" 6 } - | LPAREN VAL attributes expr COLONGREATER error - { unclosed "(" 1 ")" 6 } - | LPAREN VAL attributes expr error - { unclosed "(" 1 ")" 5 } -; - -structure: - 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 structure { (text_str 1) @ $2 } - | structure_item structure_tail { (text_str 1) @ $1 :: $2 } -; -structure_item: - let_bindings - { val_of_let_bindings $1 } - | primitive_declaration - { let (body, ext) = $1 in mkstr_ext (Pstr_primitive body) ext } - | value_description - { let (body, ext) = $1 in mkstr_ext (Pstr_primitive body) ext } - | type_declarations - { let (nr, l, ext ) = $1 in mkstr_ext (Pstr_type (nr, List.rev l)) ext } - | str_type_extension - { let (l, ext) = $1 in mkstr_ext (Pstr_typext l) ext } - | str_exception_declaration - { let (l, ext) = $1 in mkstr_ext (Pstr_exception l) ext } - | module_binding - { let (body, ext) = $1 in mkstr_ext (Pstr_module body) ext } - | rec_module_bindings - { let (l, ext) = $1 in mkstr_ext (Pstr_recmodule(List.rev l)) ext } - | module_type_declaration - { let (body, ext) = $1 in mkstr_ext (Pstr_modtype body) ext } - | open_statement - { let (body, ext) = $1 in mkstr_ext (Pstr_open body) ext } - | class_declarations - { let (l, ext) = $1 in mkstr_ext (Pstr_class (List.rev l)) ext } - | class_type_declarations - { let (l, ext) = $1 in mkstr_ext (Pstr_class_type (List.rev l)) ext } - | str_include_statement - { let (body, ext) = $1 in mkstr_ext (Pstr_include body) ext } - | 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 ext_attributes module_expr post_item_attributes - { let (ext, attrs) = $2 in - Incl.mk $3 ~attrs:(attrs@$4) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -module_binding_body: - EQUAL module_expr - { $2 } - | COLON module_type EQUAL module_expr - { mkmod(Pmod_constraint($4, $2)) } - | functor_arg module_binding_body - { mkmod(Pmod_functor(fst $1, snd $1, $2)) } -; -module_binding: - MODULE ext_attributes UIDENT module_binding_body post_item_attributes - { let (ext, attrs) = $2 in - Mb.mk (mkrhs $3 3) $4 ~attrs:(attrs@$5) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; -rec_module_bindings: - rec_module_binding { let (b, ext) = $1 in ([b], ext) } - | rec_module_bindings and_module_binding - { let (l, ext) = $1 in ($2 :: l, ext) } -; -rec_module_binding: - MODULE ext_attributes REC UIDENT module_binding_body post_item_attributes - { let (ext, attrs) = $2 in - Mb.mk (mkrhs $4 4) $5 ~attrs:(attrs@$6) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; -and_module_binding: - AND attributes UIDENT module_binding_body post_item_attributes - { Mb.mk (mkrhs $3 3) $4 ~attrs:($2@$5) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; - -/* Module types */ - -module_type: - mty_longident - { mkmty(Pmty_ident (mkrhs $1 1)) } - | SIG attributes signature END - { mkmty ~attrs:$2 (Pmty_signature (extra_sig 3 $3)) } - | SIG attributes signature error - { unclosed "sig" 1 "end" 4 } - | FUNCTOR attributes functor_args MINUSGREATER module_type - %prec below_WITH - { let mty = - List.fold_left - (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) - $5 $3 - in wrap_mty_attrs mty $2 } - | module_type MINUSGREATER module_type - %prec below_WITH - { mkmty(Pmty_functor(mknoloc "_", Some $1, $3)) } - | module_type WITH with_constraints - { mkmty(Pmty_with($1, List.rev $3)) } - | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT - { mkmty ~attrs:$4 (Pmty_typeof $5) } -/* | 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 */ { [] } - | SEMISEMI signature { (text_sig 1) @ $2 } - | signature_item signature { (text_sig 1) @ $1 :: $2 } -; -signature_item: - value_description - { let (body, ext) = $1 in mksig_ext (Psig_value body) ext } - | primitive_declaration - { let (body, ext) = $1 in mksig_ext (Psig_value body) ext} - | type_declarations - { let (nr, l, ext) = $1 in mksig_ext (Psig_type (nr, List.rev l)) ext } - | sig_type_extension - { let (l, ext) = $1 in mksig_ext (Psig_typext l) ext } - | sig_exception_declaration - { let (l, ext) = $1 in mksig_ext (Psig_exception l) ext } - | module_declaration - { let (body, ext) = $1 in mksig_ext (Psig_module body) ext } - | module_alias - { let (body, ext) = $1 in mksig_ext (Psig_module body) ext } - | rec_module_declarations - { let (l, ext) = $1 in mksig_ext (Psig_recmodule (List.rev l)) ext } - | module_type_declaration - { let (body, ext) = $1 in mksig_ext (Psig_modtype body) ext } - | open_statement - { let (body, ext) = $1 in mksig_ext (Psig_open body) ext } - | sig_include_statement - { let (body, ext) = $1 in mksig_ext (Psig_include body) ext } - | class_descriptions - { let (l, ext) = $1 in mksig_ext (Psig_class (List.rev l)) ext } - | class_type_declarations - { let (l, ext) = $1 in mksig_ext (Psig_class_type (List.rev l)) ext } - | 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 ext_attributes mod_longident post_item_attributes - { let (ext, attrs) = $3 in - Opn.mk (mkrhs $4 4) ~override:$2 ~attrs:(attrs@$5) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext} -; -sig_include_statement: - INCLUDE ext_attributes module_type post_item_attributes %prec below_WITH - { let (ext, attrs) = $2 in - Incl.mk $3 ~attrs:(attrs@$4) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext} -; -module_declaration_body: - COLON module_type - { $2 } - | 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_declaration: - MODULE ext_attributes UIDENT module_declaration_body post_item_attributes - { let (ext, attrs) = $2 in - Md.mk (mkrhs $3 3) $4 ~attrs:(attrs@$5) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -module_alias: - MODULE ext_attributes UIDENT EQUAL mod_longident post_item_attributes - { let (ext, attrs) = $2 in - Md.mk (mkrhs $3 3) - (Mty.alias ~loc:(rhs_loc 5) (mkrhs $5 5)) ~attrs:(attrs@$6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -rec_module_declarations: - rec_module_declaration - { let (body, ext) = $1 in ([body], ext) } - | rec_module_declarations and_module_declaration - { let (l, ext) = $1 in ($2 :: l, ext) } -; -rec_module_declaration: - MODULE ext_attributes REC UIDENT COLON module_type post_item_attributes - { let (ext, attrs) = $2 in - Md.mk (mkrhs $4 4) $6 ~attrs:(attrs@$7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext} -; -and_module_declaration: - AND attributes UIDENT COLON module_type post_item_attributes - { Md.mk (mkrhs $3 3) $5 ~attrs:($2@$6) ~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 ext_attributes ident module_type_declaration_body - post_item_attributes - { let (ext, attrs) = $3 in - Mtd.mk (mkrhs $4 4) ?typ:$5 ~attrs:(attrs@$6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -/* Class expressions */ - -class_declarations: - class_declaration - { let (body, ext) = $1 in ([body], ext) } - | class_declarations and_class_declaration - { let (l, ext) = $1 in ($2 :: l, ext) } -; -class_declaration: - CLASS ext_attributes virtual_flag class_type_parameters LIDENT - class_fun_binding post_item_attributes - { let (ext, attrs) = $2 in - Ci.mk (mkrhs $5 5) $6 ~virt:$3 ~params:$4 ~attrs:(attrs@$7) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; -and_class_declaration: - AND attributes virtual_flag class_type_parameters LIDENT class_fun_binding - post_item_attributes - { Ci.mk (mkrhs $5 5) $6 ~virt:$3 ~params:$4 - ~attrs:($2@$7) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; -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*/ { [] } - | LBRACKET type_parameter_list RBRACKET { List.rev $2 } -; -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 attributes class_fun_def - { wrap_class_attrs $3 $2 } - | class_simple_expr simple_labeled_expr_list - { mkclass(Pcl_apply($1, List.rev $2)) } - | let_bindings IN class_expr - { class_of_let_bindings $1 $3 } - | LET OPEN override_flag attributes mod_longident IN class_expr - { wrap_class_attrs (mkclass(Pcl_open($3, mkrhs $5 5, $7))) $4 } - | 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(mkloc $4 (rhs_loc 4), List.rev $2)) } - | class_longident - { mkclass(Pcl_constr(mkrhs $1 1, [])) } - | OBJECT attributes class_structure END - { mkclass ~attrs:$2 (Pcl_structure $3) } - | OBJECT attributes class_structure error - { unclosed "object" 1 "end" 4 } - | 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 - { Cstr.mk $1 (extra_cstr 2 (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 class_field - { $2 :: (text_cstr 2) @ $1 } -; -class_field: - | INHERIT override_flag attributes class_expr parent_binder - post_item_attributes - { mkcf (Pcf_inherit ($2, $4, $5)) ~attrs:($3@$6) ~docs:(symbol_docs ()) } - | VAL value post_item_attributes - { let v, attrs = $2 in - mkcf (Pcf_val v) ~attrs:(attrs@$3) ~docs:(symbol_docs ()) } - | METHOD method_ post_item_attributes - { let meth, attrs = $2 in - mkcf (Pcf_method meth) ~attrs:(attrs@$3) ~docs:(symbol_docs ()) } - | CONSTRAINT attributes constrain_field post_item_attributes - { mkcf (Pcf_constraint $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | INITIALIZER attributes seq_expr post_item_attributes - { mkcf (Pcf_initializer $3) ~attrs:($2@$4) ~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 (mkrhs $2 2) } - | /* empty */ - { None } -; -value: -/* TODO: factorize these rules (also with method): */ - override_flag attributes MUTABLE VIRTUAL label COLON core_type - { if $1 = Override then syntax_error (); - (mkloc $5 (rhs_loc 5), Mutable, Cfk_virtual $7), $2 } - | override_flag attributes VIRTUAL mutable_flag label COLON core_type - { if $1 = Override then syntax_error (); - (mkrhs $5 5, $4, Cfk_virtual $7), $2 } - | override_flag attributes mutable_flag label EQUAL seq_expr - { (mkrhs $4 4, $3, Cfk_concrete ($1, $6)), $2 } - | override_flag attributes mutable_flag label type_constraint EQUAL seq_expr - { - let e = mkexp_constraint $7 $5 in - (mkrhs $4 4, $3, Cfk_concrete ($1, e)), $2 - } -; -method_: -/* TODO: factorize those rules... */ - override_flag attributes PRIVATE VIRTUAL label COLON poly_type - { if $1 = Override then syntax_error (); - (mkloc $5 (rhs_loc 5), Private, Cfk_virtual $7), $2 } - | override_flag attributes VIRTUAL private_flag label COLON poly_type - { if $1 = Override then syntax_error (); - (mkloc $5 (rhs_loc 5), $4, Cfk_virtual $7), $2 } - | override_flag attributes private_flag label strict_binding - { (mkloc $4 (rhs_loc 4), $3, - Cfk_concrete ($1, ghexp(Pexp_poly ($5, None)))), $2 } - | override_flag attributes private_flag label COLON poly_type EQUAL seq_expr - { (mkloc $4 (rhs_loc 4), $3, - Cfk_concrete ($1, ghexp(Pexp_poly($8, Some $6)))), $2 } - | override_flag attributes private_flag label COLON TYPE lident_list - DOT core_type EQUAL seq_expr - { let exp, poly = wrap_type_annotation $7 $9 $11 in - (mkloc $4 (rhs_loc 4), $3, - Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly)))), $2 } -; - -/* Class types */ - -class_type: - class_signature - { $1 } - | 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_arrow(Optional $1, $2, $4)) } - | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_arrow(Labelled $1, $3, $5)) } - | simple_core_type_or_tuple MINUSGREATER class_type - { mkcty(Pcty_arrow(Nolabel, $1, $3)) } - ; -class_signature: - LBRACKET core_type_comma_list RBRACKET clty_longident - { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) } - | clty_longident - { mkcty(Pcty_constr (mkrhs $1 1, [])) } - | OBJECT attributes class_sig_body END - { mkcty ~attrs:$2 (Pcty_signature $3) } - | OBJECT attributes class_sig_body error - { unclosed "object" 1 "end" 4 } - | class_signature attribute - { Cty.attr $1 $2 } - | extension - { mkcty(Pcty_extension $1) } - | LET OPEN override_flag attributes mod_longident IN class_signature - { wrap_class_type_attrs (mkcty(Pcty_open($3, mkrhs $5 5, $7))) $4 } -; -class_sig_body: - class_self_type class_sig_fields - { Csig.mk $1 (extra_csig 2 (List.rev $2)) } -; -class_self_type: - LPAREN core_type RPAREN - { $2 } - | /* empty */ - { mktyp(Ptyp_any) } -; -class_sig_fields: - /* empty */ { [] } -| class_sig_fields class_sig_field { $2 :: (text_csig 2) @ $1 } -; -class_sig_field: - INHERIT attributes class_signature post_item_attributes - { mkctf (Pctf_inherit $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | VAL attributes value_type post_item_attributes - { mkctf (Pctf_val $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | METHOD attributes private_virtual_flags label COLON poly_type - post_item_attributes - { - let (p, v) = $3 in - mkctf (Pctf_method (mkrhs $4 4, p, v, $6)) ~attrs:($2@$7) ~docs:(symbol_docs ()) - } - | CONSTRAINT attributes constrain_field post_item_attributes - { mkctf (Pctf_constraint $3) ~attrs:($2@$4) ~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: - VIRTUAL mutable_flag label COLON core_type - { mkrhs $3 3, $2, Virtual, $5 } - | MUTABLE virtual_flag label COLON core_type - { mkrhs $3 3, Mutable, $2, $5 } - | label COLON core_type - { mkrhs $1 1, Immutable, Concrete, $3 } -; -constrain: - core_type EQUAL core_type { $1, $3, symbol_rloc() } -; -constrain_field: - core_type EQUAL core_type { $1, $3 } -; -class_descriptions: - class_description - { let (body, ext) = $1 in ([body],ext) } - | class_descriptions and_class_description - { let (l, ext) = $1 in ($2 :: l, ext) } -; -class_description: - CLASS ext_attributes virtual_flag class_type_parameters LIDENT COLON - class_type post_item_attributes - { let (ext, attrs) = $2 in - Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs @ $8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; -and_class_description: - AND attributes virtual_flag class_type_parameters LIDENT COLON class_type - post_item_attributes - { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 - ~attrs:($2@$8) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; -class_type_declarations: - class_type_declaration - { let (body, ext) = $1 in ([body],ext) } - | class_type_declarations and_class_type_declaration - { let (l, ext) = $1 in ($2 :: l, ext) } -; -class_type_declaration: - CLASS TYPE ext_attributes virtual_flag class_type_parameters LIDENT EQUAL - class_signature post_item_attributes - { let (ext, attrs) = $3 in - Ci.mk (mkrhs $6 6) $8 ~virt:$4 ~params:$5 ~attrs:(attrs@$9) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext} -; -and_class_type_declaration: - AND attributes virtual_flag class_type_parameters LIDENT EQUAL - class_signature post_item_attributes - { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 - ~attrs:($2@$8) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; - -/* Core expressions */ - -seq_expr: - | expr %prec below_SEMI { $1 } - | expr SEMI { $1 } - | expr SEMI seq_expr { mkexp(Pexp_sequence($1, $3)) } - | expr SEMI PERCENT attr_id seq_expr - { let seq = mkexp(Pexp_sequence ($1, $5)) in - let payload = PStr [mkstrexp seq []] in - mkexp (Pexp_extension ($4, payload)) } -; -labeled_simple_pattern: - QUESTION LPAREN label_let_pattern opt_default RPAREN - { (Optional (fst $3), $4, snd $3) } - | QUESTION label_var - { (Optional (fst $2), None, snd $2) } - | OPTLABEL LPAREN let_pattern opt_default RPAREN - { (Optional $1, $4, $3) } - | OPTLABEL pattern_var - { (Optional $1, None, $2) } - | TILDE LPAREN label_let_pattern RPAREN - { (Labelled (fst $3), None, snd $3) } - | TILDE label_var - { (Labelled (fst $2), None, snd $2) } - | LABEL simple_pattern - { (Labelled $1, None, $2) } - | simple_pattern - { (Nolabel, None, $1) } -; -pattern_var: - LIDENT { mkpat(Ppat_var (mkrhs $1 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 (mkrhs $1 1))) } -; -let_pattern: - pattern - { $1 } - | pattern COLON core_type - { mkpat(Ppat_constraint($1, $3)) } -; -expr: - simple_expr %prec below_HASH - { $1 } - | simple_expr simple_labeled_expr_list - { mkexp(Pexp_apply($1, List.rev $2)) } - | 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 EXCEPTION ext_attributes let_exception_declaration IN seq_expr - { mkexp_attrs (Pexp_letexception($4, $6)) $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_HASH - { mkexp(Pexp_construct(mkrhs $1 1, Some $2)) } - | name_tag simple_expr %prec below_HASH - { mkexp(Pexp_variant($1, Some $2)) } - | 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_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) } - | 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 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 - { 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, mkrhs $3 3, $5)) } - | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), - [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")), - [Nolabel,$1; Nolabel,$4; Nolabel,$7])) } - | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr - { bigarray_set $1 $4 $7 } - | simple_expr DOTOP LBRACKET expr RBRACKET LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) } - | simple_expr DOTOP LPAREN expr RPAREN LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) } - | simple_expr DOTOP LBRACE expr RBRACE LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) } - | simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3,"." ^ $4 ^ "[]<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) } - | simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) } - | simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) } - | label LESSMINUS expr - { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) } - | ASSERT ext_attributes simple_expr %prec below_HASH - { mkexp_attrs (Pexp_assert $3) $2 } - | LAZY ext_attributes simple_expr %prec below_HASH - { 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 } - | UNDERSCORE - { not_expecting 1 "wildcard \"_\"" } -; -simple_expr: - val_longident - { mkexp(Pexp_ident (mkrhs $1 1)) } - | constant - { mkexp(Pexp_constant $1) } - | constr_longident %prec prec_constant_constructor - { 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 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" 4 } - | LPAREN seq_expr type_constraint RPAREN - { mkexp_constraint $2 $3 } - | simple_expr DOT label_longident - { 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")), - [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")), - [Nolabel,$1; Nolabel,$4])) } - | simple_expr DOT LBRACKET seq_expr error - { unclosed "[" 3 "]" 5 } - | simple_expr DOTOP LBRACKET expr RBRACKET - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) } - | simple_expr DOTOP LBRACKET expr error - { unclosed "[" 3 "]" 5 } - | simple_expr DOTOP LPAREN expr RPAREN - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) } - | simple_expr DOTOP LPAREN expr error - { unclosed "(" 3 ")" 5 } - | simple_expr DOTOP LBRACE expr RBRACE - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) } - | simple_expr DOTOP LBRACE expr error - { unclosed "{" 3 "}" 5 } - | simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "[]")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) } - | simple_expr DOT mod_longident DOTOP LBRACKET expr error - { unclosed "[" 5 "]" 7 } - | simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) } - | simple_expr DOT mod_longident DOTOP LPAREN expr error - { unclosed "(" 5 ")" 7 } - | simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) } - | simple_expr DOT mod_longident DOTOP LBRACE expr error - { unclosed "{" 5 "}" 7 } - | 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 } - | 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)) } - | LBRACKETBAR expr_semi_list opt_semi error - { unclosed "[|" 1 "|]" 4 } - | LBRACKETBAR BARRBRACKET - { 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 (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, [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 ">}" 3 } - | LBRACELESS GREATERRBRACE - { 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 ">}" 5 } - | simple_expr HASH label - { mkexp(Pexp_send($1, mkrhs $3 3)) } - | simple_expr HASHOP simple_expr - { mkinfix $1 $2 $3 } - | LPAREN MODULE ext_attributes module_expr RPAREN - { mkexp_attrs (Pexp_pack $4) $3 } - | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN - { mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $4), - ghtyp (Ptyp_package $6))) - $3 } - | LPAREN MODULE ext_attributes module_expr COLON error - { unclosed "(" 1 ")" 6 } - | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON - package_type RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, - mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $6), - ghtyp (Ptyp_package $8))) - $5 )) } - | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON error - { unclosed "(" 3 ")" 8 } - | extension - { mkexp (Pexp_extension $1) } -; -simple_labeled_expr_list: - labeled_simple_expr - { [$1] } - | simple_labeled_expr_list labeled_simple_expr - { $2 :: $1 } -; -labeled_simple_expr: - simple_expr %prec below_HASH - { (Nolabel, $1) } - | label_expr - { $1 } -; -label_expr: - LABEL simple_expr %prec below_HASH - { (Labelled $1, $2) } - | TILDE label_ident - { (Labelled (fst $2), snd $2) } - | QUESTION label_ident - { (Optional (fst $2), snd $2) } - | OPTLABEL simple_expr %prec below_HASH - { (Optional $1, $2) } -; -label_ident: - LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) } -; -lident_list: - LIDENT { [mkrhs $1 1] } - | LIDENT lident_list { mkrhs $1 1 :: $2 } -; -let_binding_body: - val_ident fun_binding - { (mkpatvar $1 1, $2) } - /* Intentionally left out, as part of the fix for PR#7344 - (commit fd0dc6a0fbf73323c37a73ea7e8ffc150059d6ff) - | val_ident type_constraint EQUAL seq_expr - { let v = mkpatvar $1 1 in (* PR#7344 *) - let t = - match $2 with - Some t, None -> t - | _, Some t -> t - | _ -> assert false - in - (ghpat(Ppat_constraint(v, ghtyp(Ptyp_poly([],t)))), - mkexp_constraint $4 $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_no_exn 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 - { let (ext, attr) = $2 in - mklbs ext $3 (mklb true $4 (attr@$5)) } -; -and_let_binding: - AND attributes let_binding_body post_item_attributes - { mklb false $3 ($2@$4) } -; -fun_binding: - strict_binding - { $1 } - | type_constraint EQUAL seq_expr - { mkexp_constraint $3 $1 } -; -strict_binding: - EQUAL seq_expr - { $2 } - | labeled_simple_pattern fun_binding - { 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: - match_case { [$1] } - | match_cases BAR match_case { $3 :: $1 } -; -match_case: - pattern MINUSGREATER seq_expr - { Exp.case $1 $3 } - | pattern WHEN seq_expr MINUSGREATER seq_expr - { Exp.case $1 ~guard:$3 $5 } - | pattern MINUSGREATER DOT - { Exp.case $1 (Exp.unreachable ~loc:(rhs_loc 3) ())} -; -fun_def: - MINUSGREATER seq_expr - { $2 } - | COLON simple_core_type MINUSGREATER seq_expr - { mkexp (Pexp_constraint ($4, $2)) } -/* 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 { (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 opt_type_constraint EQUAL expr - { (mkrhs $1 1, mkexp_opt_constraint $4 $2) } - | label_longident opt_type_constraint - { (mkrhs $1 1, mkexp_opt_constraint (exp_of_label $1 1) $2) } -; -field_expr_list: - field_expr opt_semi { [$1] } - | field_expr SEMI field_expr_list { $1 :: $3 } -; -field_expr: - label EQUAL expr - { (mkrhs $1 1, $3) } - | label - { (mkrhs $1 1, exp_of_label (Lident $1) 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() } -; -opt_type_constraint: - type_constraint { Some $1 } - | /* empty */ { None } -; - -/* Patterns */ - -pattern: - | pattern AS val_ident - { 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)) } - | pattern COLONCOLON pattern - { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) } - | pattern COLONCOLON error - { expecting 3 "pattern" } - | pattern BAR pattern - { mkpat(Ppat_or($1, $3)) } - | pattern BAR error - { expecting 3 "pattern" } - | EXCEPTION ext_attributes pattern %prec prec_constr_appl - { mkpat_attrs (Ppat_exception $3) $2} - | pattern attribute - { Pat.attr $1 $2 } - | pattern_gen { $1 } -; -pattern_no_exn: - | pattern_no_exn AS val_ident - { mkpat(Ppat_alias($1, mkrhs $3 3)) } - | pattern_no_exn AS error - { expecting 3 "identifier" } - | pattern_no_exn_comma_list %prec below_COMMA - { mkpat(Ppat_tuple(List.rev $1)) } - | pattern_no_exn COLONCOLON pattern - { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) } - | pattern_no_exn COLONCOLON error - { expecting 3 "pattern" } - | pattern_no_exn BAR pattern - { mkpat(Ppat_or($1, $3)) } - | pattern_no_exn BAR error - { expecting 3 "pattern" } - | pattern_no_exn attribute - { Pat.attr $1 $2 } - | pattern_gen { $1 } -; -pattern_gen: - simple_pattern - { $1 } - | constr_longident pattern %prec prec_constr_appl - { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) } - | name_tag pattern %prec prec_constr_appl - { mkpat(Ppat_variant($1, Some $2)) } - | LAZY ext_attributes simple_pattern - { mkpat_attrs (Ppat_lazy $3) $2} -; -simple_pattern: - val_ident %prec below_EQUAL - { 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) } - | signed_constant DOTDOT signed_constant - { mkpat(Ppat_interval ($1, $3)) } - | constr_longident - { mkpat(Ppat_construct(mkrhs $1 1, None)) } - | name_tag - { mkpat(Ppat_variant($1, None)) } - | HASH type_longident - { mkpat(Ppat_type (mkrhs $2 2)) } - | simple_delimited_pattern - { $1 } - | mod_longident DOT simple_delimited_pattern - { mkpat @@ Ppat_open(mkrhs $1 1, $3) } - | mod_longident DOT LBRACKET RBRACKET - { mkpat @@ Ppat_open(mkrhs $1 1, mkpat @@ - Ppat_construct ( mkrhs (Lident "[]") 4, None)) } - | mod_longident DOT LPAREN RPAREN - { mkpat @@ Ppat_open( mkrhs $1 1, mkpat @@ - Ppat_construct ( mkrhs (Lident "()") 4, None) ) } - | mod_longident DOT LPAREN pattern RPAREN - { mkpat @@ Ppat_open (mkrhs $1 1, $4)} - | mod_longident DOT LPAREN pattern error - {unclosed "(" 3 ")" 5 } - | mod_longident DOT LPAREN error - { expecting 4 "pattern" } - | 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 pattern COLON error - { expecting 4 "type" } - | LPAREN MODULE ext_attributes UIDENT RPAREN - { mkpat_attrs (Ppat_unpack (mkrhs $4 4)) $3 } - | LPAREN MODULE ext_attributes UIDENT COLON package_type RPAREN - { mkpat_attrs - (Ppat_constraint(mkpat(Ppat_unpack (mkrhs $4 4)), - ghtyp(Ptyp_package $6))) - $3 } - | LPAREN MODULE ext_attributes UIDENT COLON package_type error - { unclosed "(" 1 ")" 7 } - | extension - { mkpat(Ppat_extension $1) } -; - -simple_delimited_pattern: - | 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 (rhs_loc 4) (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 } - -pattern_comma_list: - pattern_comma_list COMMA pattern { $3 :: $1 } - | pattern COMMA pattern { [$3; $1] } - | pattern COMMA error { expecting 3 "pattern" } -; -pattern_no_exn_comma_list: - pattern_no_exn_comma_list COMMA pattern { $3 :: $1 } - | pattern_no_exn COMMA pattern { [$3; $1] } - | pattern_no_exn COMMA error { expecting 3 "pattern" } -; -pattern_semi_list: - pattern { [$1] } - | pattern_semi_list SEMI pattern { $3 :: $1 } -; -lbl_pattern_list: - 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 opt_pattern_type_constraint EQUAL pattern - { (mkrhs $1 1, mkpat_opt_constraint $4 $2) } - | label_longident opt_pattern_type_constraint - { (mkrhs $1 1, mkpat_opt_constraint (pat_of_label $1 1) $2) } -; -opt_pattern_type_constraint: - COLON core_type { Some $2 } - | /* empty */ { None } -; - -/* Value descriptions */ - -value_description: - VAL ext_attributes val_ident COLON core_type post_item_attributes - { let (ext, attrs) = $2 in - Val.mk (mkrhs $3 3) $5 ~attrs:(attrs@$6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; - -/* Primitive declarations */ - -primitive_declaration_body: - STRING { [fst $1] } - | STRING primitive_declaration_body { fst $1 :: $2 } -; -primitive_declaration: - EXTERNAL ext_attributes val_ident COLON core_type EQUAL - primitive_declaration_body post_item_attributes - { let (ext, attrs) = $2 in - Val.mk (mkrhs $3 3) $5 ~prim:$7 ~attrs:(attrs@$8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; - -/* Type declarations */ - -type_declarations: - type_declaration - { let (nonrec_flag, ty, ext) = $1 in (nonrec_flag, [ty], ext) } - | type_declarations and_type_declaration - { let (nonrec_flag, tys, ext) = $1 in (nonrec_flag, $2 :: tys, ext) } -; - -type_declaration: - TYPE ext_attributes nonrec_flag optional_type_parameters LIDENT - type_kind constraints post_item_attributes - { let (kind, priv, manifest) = $6 in - let (ext, attrs) = $2 in - let ty = - Type.mk (mkrhs $5 5) ~params:$4 ~cstrs:(List.rev $7) ~kind - ~priv ?manifest ~attrs:(attrs@$8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - in - ($3, ty, ext) } -; -and_type_declaration: - AND attributes optional_type_parameters LIDENT type_kind constraints - post_item_attributes - { let (kind, priv, manifest) = $5 in - Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) - ~kind ~priv ?manifest ~attrs:($2@$7) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; -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 DOTDOT - { (Ptype_open, Public, None) } - | EQUAL PRIVATE DOTDOT - { (Ptype_open, Private, 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 private_flag DOTDOT - { (Ptype_open, $4, 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_parameter: - type_variance type_variable { $2, $1 } -; -type_variance: - /* 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: - | BAR { [ ] } - | constructor_declaration { [$1] } - | bar_constructor_declaration { [$1] } - | constructor_declarations bar_constructor_declaration { $2 :: $1 } -; -constructor_declaration: - | 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 ext_attributes constr_ident EQUAL constr_longident attributes - post_item_attributes - { let (ext,attrs) = $2 in - Te.rebind (mkrhs $3 3) (mkrhs $5 5) ~attrs:(attrs @ $6 @ $7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -sig_exception_declaration: - | EXCEPTION ext_attributes constr_ident generalized_constructor_arguments - attributes post_item_attributes - { let args, res = $4 in - let (ext,attrs) = $2 in - Te.decl (mkrhs $3 3) ~args ?res ~attrs:(attrs @ $5 @ $6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -let_exception_declaration: - constr_ident generalized_constructor_arguments attributes - { let args, res = $2 in - Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 ~loc:(symbol_rloc()) } -; -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: - | core_type_list { Pcstr_tuple (List.rev $1) } - | LBRACE label_declarations RBRACE { Pcstr_record $2 } -; -label_declarations: - label_declaration { [$1] } - | label_declaration_semi { [$1] } - | label_declaration_semi label_declarations { $1 :: $2 } -; -label_declaration: - 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 ext_attributes nonrec_flag optional_type_parameters type_longident - PLUSEQ private_flag str_extension_constructors post_item_attributes - { let (ext, attrs) = $2 in - if $3 <> Recursive then not_expecting 3 "nonrec flag"; - Te.mk (mkrhs $5 5) (List.rev $8) ~params:$4 ~priv:$7 - ~attrs:(attrs@$9) ~docs:(symbol_docs ()) - , ext } -; -sig_type_extension: - TYPE ext_attributes nonrec_flag optional_type_parameters type_longident - PLUSEQ private_flag sig_extension_constructors post_item_attributes - { let (ext, attrs) = $2 in - if $3 <> Recursive then not_expecting 3 "nonrec flag"; - Te.mk (mkrhs $5 5) (List.rev $8) ~params:$4 ~priv:$7 - ~attrs:(attrs @ $9) ~docs:(symbol_docs ()) - , ext } -; -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) */ - -with_constraints: - with_constraint { [$1] } - | with_constraints AND with_constraint { $3 :: $1 } -; -with_constraint: - TYPE optional_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 optional_type_parameters label_longident COLONEQUAL core_type_no_attr - { Pwith_typesubst - (mkrhs $3 3, - (Type.mk (mkrhs (Longident.last $3) 3) - ~params:$2 - ~manifest:$5 - ~loc:(symbol_rloc()))) } - | MODULE mod_longident EQUAL mod_ext_longident - { Pwith_module (mkrhs $2 2, mkrhs $4 4) } - | MODULE mod_longident COLONEQUAL mod_ext_longident - { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) } -; -with_type_binder: - EQUAL { Public } - | EQUAL PRIVATE { Private } -; - -/* Polymorphic types */ - -typevar_list: - QUOTE ident { [mkrhs $2 2] } - | typevar_list QUOTE ident { mkrhs $3 3 :: $1 } -; -poly_type: - core_type - { $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 %prec MINUSGREATER - { $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 - { let param = extra_rhs_core_type $4 ~pos:4 in - mktyp (Ptyp_arrow(Optional $2 , param, $6)) } - | OPTLABEL core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $2 ~pos:2 in - mktyp(Ptyp_arrow(Optional $1 , param, $4)) - } - | LIDENT COLON core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $3 ~pos:3 in - mktyp(Ptyp_arrow(Labelled $1, param, $5)) } - | core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $1 ~pos:1 in - mktyp(Ptyp_arrow(Nolabel, param, $3)) } -; - -simple_core_type: - simple_core_type2 %prec below_HASH - { $1 } - | LPAREN core_type_comma_list RPAREN %prec below_HASH - { 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(mkrhs $1 1, [])) } - | simple_core_type2 type_longident - { mktyp(Ptyp_constr(mkrhs $2 2, [$1])) } - | LPAREN core_type_comma_list RPAREN type_longident - { mktyp(Ptyp_constr(mkrhs $4 4, List.rev $2)) } - | LESS meth_list GREATER - { let (f, c) = $2 in mktyp(Ptyp_object (f, c)) } - | LESS GREATER - { mktyp(Ptyp_object ([], Closed)) } - | HASH class_longident - { mktyp(Ptyp_class(mkrhs $2 2, [])) } - | simple_core_type2 HASH class_longident - { mktyp(Ptyp_class(mkrhs $3 3, [$1])) } - | LPAREN core_type_comma_list RPAREN HASH class_longident - { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2)) } - | LBRACKET tag_field RBRACKET - { 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, Closed, None)) } - | LBRACKET row_field BAR row_field_list RBRACKET - { mktyp(Ptyp_variant($2 :: List.rev $4, Closed, None)) } - | LBRACKETGREATER opt_bar row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, Open, None)) } - | LBRACKETGREATER RBRACKET - { mktyp(Ptyp_variant([], Open, None)) } - | LBRACKETLESS opt_bar row_field_list RBRACKET - { 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, Closed, Some (List.rev $5))) } - | LPAREN MODULE ext_attributes package_type RPAREN - { mktyp_attrs (Ptyp_package $4) $3 } - | extension - { mktyp (Ptyp_extension $1) } -; -package_type: - module_type { package_type_of_module_type $1 } -; -row_field_list: - row_field { [$1] } - | row_field_list BAR row_field { $3 :: $1 } -; -row_field: - tag_field { $1 } - | simple_core_type { Rinherit $1 } -; -tag_field: - name_tag OF opt_ampersand amper_type_list attributes - { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $5, - $3, List.rev $4) } - | name_tag attributes - { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $2, true, []) } -; -opt_ampersand: - AMPERSAND { true } - | /* empty */ { false } -; -amper_type_list: - 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 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 { let (f, c) = $2 in ($1 :: f, c) } - | inherit_field_semi meth_list { let (f, c) = $2 in ($1 :: f, c) } - | field_semi { [$1], Closed } - | field { [$1], Closed } - | inherit_field_semi { [$1], Closed } - | simple_core_type { [Oinherit $1], Closed } - | DOTDOT { [], Open } -; -field: - label COLON poly_type_no_attr attributes - { Otag (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) } -; - -field_semi: - label COLON poly_type_no_attr attributes SEMI attributes - { let info = - match rhs_info 4 with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info () - in - ( Otag (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3)) } -; - -inherit_field_semi: - simple_core_type SEMI { Oinherit $1 } - -label: - LIDENT { $1 } -; - -/* Constants */ - -constant: - | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char $1 } - | STRING { let (s, d) = $1 in Pconst_string (s, d) } - | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } -; -signed_constant: - constant { $1 } - | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) } - | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) } - | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) } - | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) } -; - -/* Identifiers and long identifiers */ - -ident: - UIDENT { $1 } - | LIDENT { $1 } -; -val_ident: - LIDENT { $1 } - | LPAREN operator RPAREN { $2 } - | LPAREN operator error { unclosed "(" 1 ")" 3 } - | LPAREN error { expecting 2 "operator" } - | LPAREN MODULE error { expecting 3 "module-expr" } -; -operator: - PREFIXOP { $1 } - | INFIXOP0 { $1 } - | INFIXOP1 { $1 } - | INFIXOP2 { $1 } - | INFIXOP3 { $1 } - | INFIXOP4 { $1 } - | DOTOP LPAREN RPAREN { "."^ $1 ^"()" } - | DOTOP LPAREN RPAREN LESSMINUS { "."^ $1 ^ "()<-" } - | DOTOP LBRACKET RBRACKET { "."^ $1 ^"[]" } - | DOTOP LBRACKET RBRACKET LESSMINUS { "."^ $1 ^ "[]<-" } - | DOTOP LBRACE RBRACE { "."^ $1 ^"{}" } - | DOTOP LBRACE RBRACE LESSMINUS { "."^ $1 ^ "{}<-" } - | HASHOP { $1 } - | BANG { "!" } - | PLUS { "+" } - | PLUSDOT { "+." } - | MINUS { "-" } - | MINUSDOT { "-." } - | STAR { "*" } - | EQUAL { "=" } - | LESS { "<" } - | GREATER { ">" } - | OR { "or" } - | BARBAR { "||" } - | AMPERSAND { "&" } - | AMPERAMPER { "&&" } - | COLONEQUAL { ":=" } - | PLUSEQ { "+=" } - | PERCENT { "%" } -; -constr_ident: - UIDENT { $1 } - | LBRACKET RBRACKET { "[]" } - | LPAREN RPAREN { "()" } - | 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 } - | mod_longident DOT LPAREN COLONCOLON RPAREN { Ldot($1,"::") } - | LBRACKET RBRACKET { Lident "[]" } - | LPAREN RPAREN { Lident "()" } - | LPAREN COLONCOLON 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: - HASH ident { Ptop_dir($2, Pdir_none) } - | HASH ident STRING { Ptop_dir($2, Pdir_string (fst $3)) } - | HASH ident INT { let (n, m) = $3 in - Ptop_dir($2, Pdir_int (n ,m)) } - | HASH ident val_longident { Ptop_dir($2, Pdir_ident $3) } - | HASH ident mod_longident { Ptop_dir($2, Pdir_ident $3) } - | HASH ident FALSE { Ptop_dir($2, Pdir_bool false) } - | HASH ident TRUE { Ptop_dir($2, Pdir_bool true) } -; - -/* Miscellaneous */ - -name_tag: - BACKQUOTE ident { $2 } -; -rec_flag: - /* empty */ { Nonrecursive } - | REC { Recursive } -; -nonrec_flag: - /* empty */ { Recursive } - | NONREC { Nonrecursive } -; -direction_flag: - TO { Upto } - | DOWNTO { Downto } -; -private_flag: - /* empty */ { Public } - | PRIVATE { Private } -; -mutable_flag: - /* empty */ { Immutable } - | MUTABLE { Mutable } -; -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 { () } -; -opt_semi: - | /* empty */ { () } - | SEMI { () } -; -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 signature { PSig $2 } - | COLON core_type { PTyp $2 } - | QUESTION pattern { PPat ($2, None) } - | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } -; -%% diff --git a/ast/pprintast.ml b/ast/pprintast.ml index a3fd10b2..f37c106a 100644 --- a/ast/pprintast.ml +++ b/ast/pprintast.ml @@ -256,11 +256,8 @@ and core_type ctxt f x = (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s - (* Intentionally left out, as part of the fix for PR#7344 - (commit c15ad73e56c54663c9cb6f7cac4241bb3c4e3cb8) | Ptyp_poly ([], ct) -> core_type ctxt f ct - *) | Ptyp_poly (sl, ct) -> pp f "@[<2>%a%a@]" (fun f l -> @@ -1176,20 +1173,17 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = if x.pexp_attributes <> [] then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else match is_desugared_gadt p x with - (* Intentionally left out, as part of the fix for PR#7344 - (commit c15ad73e56c54663c9cb6f7cac4241bb3c4e3cb8) | Some (p, [], ct, e) -> pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e - *) | Some (p, tyvars, ct, e) -> begin pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e end | None -> begin - match x, p with - | _, {ppat_desc=Ppat_constraint(p ,ty); + match p with + | {ppat_desc=Ppat_constraint(p ,ty); ppat_attributes=[]} -> (* special case for the first*) begin match ty with | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> @@ -1199,10 +1193,7 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty (expression ctxt) x end - | {pexp_desc=Pexp_constraint (x, ty)}, _ -> (* XXX: this case is janestreet only *) - pp f "%a@;:@;%a@;=@;%a" (pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - | _, {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x diff --git a/ast/syntaxerr.ml b/ast/syntaxerr.ml deleted file mode 100644 index 85cf1d80..00000000 --- a/ast/syntaxerr.ml +++ /dev/null @@ -1,88 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Auxiliary type for reporting syntax errors *) - -open Import - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - -exception Error of error -exception Escape_error - -let make_error ~loc ?(sub = []) msg = - Selected_ast.Ast.Ast_mapper.make_error_of_message ~loc msg ~sub - -let prepare_error = function - | Unclosed(opening_loc, opening, closing_loc, closing) -> - make_error - ~loc:closing_loc - ~sub:[ - opening_loc, (Printf.sprintf - "This '%s' might be unmatched" opening) - ] - (Printf.sprintf "Syntax error: '%s' expected" closing) - | Expecting (loc, nonterm) -> - make_error ~loc (Printf.sprintf "Syntax error: %s expected." nonterm) - | Not_expecting (loc, nonterm) -> - make_error ~loc (Printf.sprintf "Syntax error: %s not expected." nonterm) - | Applicative_path loc -> - make_error ~loc - "Syntax error: applicative paths of the form F(X).t \ - are not supported when the option -no-app-func is set." - | Variable_in_scope (loc, var) -> - make_error ~loc - (Printf.sprintf "In this scoped type, variable '%s \ - is reserved for the local type %s." - var var) - | Other loc -> - make_error ~loc "Syntax error" - | Ill_formed_ast (loc, s) -> - make_error ~loc (Printf.sprintf "broken invariant in parsetree: %s" s) - | Invalid_package_type (loc, s) -> - make_error ~loc (Printf.sprintf "invalid package type: %s" s) - -let () = - Location.register_error_of_exn - (function - | Error err -> Some (prepare_error err) - | _ -> None - ) - - -let report_error ppf err = - Selected_ast.Ast.Ast_mapper.print_error ppf (prepare_error err) - -let location_of_error = function - | Unclosed(l,_,_,_) - | Applicative_path l - | Variable_in_scope(l,_) - | Other l - | Not_expecting (l, _) - | Ill_formed_ast (l, _) - | Invalid_package_type (l, _) - | Expecting (l, _) -> l - - -let ill_formed_ast loc s = - raise (Error (Ill_formed_ast (loc, s))) diff --git a/ast/syntaxerr.mli b/ast/syntaxerr.mli deleted file mode 100644 index a1384620..00000000 --- a/ast/syntaxerr.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* 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 GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Auxiliary type for reporting syntax errors *) - -open Import -open Format - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - -exception Error of error -exception Escape_error - -val report_error: formatter -> error -> unit - (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *) - -val location_of_error: error -> Location.t -val ill_formed_ast: Location.t -> string -> 'a