From f137332fdb7376f742f1c3c184764cb562ea931e Mon Sep 17 00:00:00 2001 From: Chet Murthy Date: Wed, 29 Apr 2020 11:38:50 -0700 Subject: [PATCH 07/10] start on 4.11.0 --- lib/versdep.ml | 19 +- main/ast2pt.ml | 4 +- main/ast2pt.mli | 3 + ocaml_src/lib/versdep/4.11.0.ml | 808 +++++++++++++++++++ ocaml_src/main/ast2pt.ml | 4 +- ocaml_stuff/4.11.0/parsing/.depend | 4 + ocaml_stuff/4.11.0/parsing/.gitignore | 1 + ocaml_stuff/4.11.0/parsing/Makefile | 19 + ocaml_stuff/4.11.0/parsing/asttypes.mli | 63 ++ ocaml_stuff/4.11.0/parsing/location.mli | 287 +++++++ ocaml_stuff/4.11.0/parsing/longident.mli | 60 ++ ocaml_stuff/4.11.0/parsing/parsetree.mli | 970 +++++++++++++++++++++++ ocaml_stuff/4.11.0/utils/.depend | 2 + ocaml_stuff/4.11.0/utils/.gitignore | 1 + ocaml_stuff/4.11.0/utils/Makefile | 27 + ocaml_stuff/4.11.0/utils/pconfig.ml | 2 + ocaml_stuff/4.11.0/utils/pconfig.mli | 2 + ocaml_stuff/4.11.0/utils/warnings.mli | 140 ++++ 18 files changed, 2407 insertions(+), 9 deletions(-) create mode 100644 ocaml_src/lib/versdep/4.11.0.ml create mode 100644 ocaml_stuff/4.11.0/parsing/.depend create mode 100644 ocaml_stuff/4.11.0/parsing/.gitignore create mode 100644 ocaml_stuff/4.11.0/parsing/Makefile create mode 100644 ocaml_stuff/4.11.0/parsing/asttypes.mli create mode 100644 ocaml_stuff/4.11.0/parsing/location.mli create mode 100644 ocaml_stuff/4.11.0/parsing/longident.mli create mode 100644 ocaml_stuff/4.11.0/parsing/parsetree.mli create mode 100644 ocaml_stuff/4.11.0/utils/.depend create mode 100644 ocaml_stuff/4.11.0/utils/.gitignore create mode 100644 ocaml_stuff/4.11.0/utils/Makefile create mode 100644 ocaml_stuff/4.11.0/utils/pconfig.ml create mode 100644 ocaml_stuff/4.11.0/utils/pconfig.mli create mode 100644 ocaml_stuff/4.11.0/utils/warnings.mli diff --git a/lib/versdep.ml b/lib/versdep.ml index b766160a..1481e265 100644 --- a/lib/versdep.ml +++ b/lib/versdep.ml @@ -583,14 +583,19 @@ value ocaml_pconst_float s = ELSE Pconst_float s None END ; -value ocaml_const_string s = +value ocaml_const_string s loc = IFDEF OCAML_VERSION < OCAML_4_02_0 THEN Const_string s - ELSE Const_string s None END + ELSIFDEF OCAML_VERSION < OCAML_4_11_0 THEN + Const_string s None + ELSE + Const_string s loc None + END ; -value ocaml_pconst_string s so = +value ocaml_pconst_string s loc so = IFDEF OCAML_VERSION < OCAML_4_02_0 THEN Const_string s ELSIFDEF OCAML_VERSION < OCAML_4_03_0 THEN Const_string s so - ELSE Pconst_string s so END + ELSIFDEF OCAML_VERSION < OCAML_4_11_0 THEN Pconst_string s so + ELSE Pconst_string s loc so END ; value pconst_of_const = @@ -617,7 +622,11 @@ value pconst_of_const = fun [ Const_int i -> ocaml_pconst_int i | Const_char c -> ocaml_pconst_char c - | Const_string s so -> ocaml_pconst_string s so + | IFDEF OCAML_VERSION < OCAML_4_11_0 THEN + Const_string s so -> ocaml_pconst_string s so + ELSE + Const_string s loc so -> ocaml_pconst_string s loc so + END | Const_float s -> ocaml_pconst_float s | Const_int32 i32 -> Pconst_integer (Int32.to_string i32) (Some 'l') | Const_int64 i64 -> Pconst_integer (Int64.to_string i64) (Some 'L') diff --git a/main/ast2pt.ml b/main/ast2pt.ml index b280ac19..4b97a074 100644 --- a/main/ast2pt.ml +++ b/main/ast2pt.ml @@ -607,7 +607,7 @@ value rec patt = | PaStr loc s → mkpat loc (Ppat_constant - (ocaml_pconst_string (string_of_string_token loc (uv s)) None)) + (ocaml_pconst_string (string_of_string_token loc (uv s)) (mkloc loc) None)) | PaTup loc pl → mkpat loc (Ppat_tuple (List.map patt (uv pl))) | PaTyc loc p t → mkpat loc (Ppat_constraint (patt p) (ctyp t)) | PaTyp loc sl → @@ -1045,7 +1045,7 @@ value rec expr = | ExStr loc s → mkexp loc (Pexp_constant - (ocaml_pconst_string (string_of_string_token loc (uv s)) None)) + (ocaml_pconst_string (string_of_string_token loc (uv s)) (mkloc loc) None)) | ExTry loc e pel → mkexp loc (Pexp_try (expr e) (List.map mkpwe (uv pel))) | ExTup loc el → mkexp loc (Pexp_tuple (List.map expr (uv el))) | ExTyc loc e t → diff --git a/main/ast2pt.mli b/main/ast2pt.mli index 949af7d7..80b54dc3 100644 --- a/main/ast2pt.mli +++ b/main/ast2pt.mli @@ -15,3 +15,6 @@ value mkloc : Ploc.t -> Location.t; (** Convert a Camlp5 location into an OCaml location. *) value fast : ref bool; (** Flag to generate fast (unsafe) access to arrays. Default: False. *) +value ctyp : MLast.ctyp -> Parsetree.core_type ; +value expr : MLast.expr -> Parsetree.expression ; +value patt : MLast.patt -> Parsetree.pattern ; diff --git a/ocaml_src/lib/versdep/4.11.0.ml b/ocaml_src/lib/versdep/4.11.0.ml new file mode 100644 index 00000000..bb7124dd --- /dev/null +++ b/ocaml_src/lib/versdep/4.11.0.ml @@ -0,0 +1,808 @@ +(* camlp5r pa_macro.cmo *) +(* versdep.ml,v *) +(* Copyright (c) INRIA 2007-2017 *) + +open Parsetree;; +open Longident;; +open Asttypes;; + +type ('a, 'b) choice = + Left of 'a + | Right of 'b +;; + +let option_map f x = + match x with + Some x -> Some (f x) + | None -> None +;; +let mustSome symbol = + function + Some x -> x + | None -> failwith ("Some: " ^ symbol) +;; + +let ocaml_name = "ocaml";; + +let sys_ocaml_version = Sys.ocaml_version;; + +let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) = + let loc_at n lnum bolp = + {Lexing.pos_fname = if lnum = -1 then "" else fname; + Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n} + in + {Location.loc_start = loc_at bp lnum bolp; + Location.loc_end = loc_at ep lnuml bolpl; + Location.loc_ghost = bp = 0 && ep = 0} +;; + +let loc_none = + let loc = + {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; + Lexing.pos_cnum = -1} + in + {Location.loc_start = loc; Location.loc_end = loc; + Location.loc_ghost = true} +;; + +let mkloc loc txt = {Location.txt = txt; Location.loc = loc};; +let mknoloc txt = mkloc loc_none txt;; + +let ocaml_id_or_li_of_string_list loc sl = + let mkli s = + let rec loop f = + function + i :: il -> loop (fun s -> Ldot (f i, s)) il + | [] -> f s + in + loop (fun s -> Lident s) + in + match List.rev sl with + [] -> None + | s :: sl -> Some (mkli s (List.rev sl)) +;; + +let list_map_check f l = + let rec loop rev_l = + function + x :: l -> + begin match f x with + Some s -> loop (s :: rev_l) l + | None -> None + end + | [] -> Some (List.rev rev_l) + in + loop [] l +;; + +let labelled lab = + if lab = "" then Nolabel + else if lab.[0] = '?' then + Optional (String.sub lab 1 (String.length lab - 1)) + else Labelled lab +;; + +(* *) + +let ocaml_value_description vn t p = + {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc; + pval_name = mkloc t.ptyp_loc vn; pval_attributes = []} +;; + +let ocaml_class_type_field loc ctfd = + {pctf_desc = ctfd; pctf_loc = loc; pctf_attributes = []} +;; + +let ocaml_class_field loc cfd = + {pcf_desc = cfd; pcf_loc = loc; pcf_attributes = []} +;; + +let ocaml_mktyp loc x = + {ptyp_desc = x; ptyp_loc = loc; ptyp_loc_stack = []; ptyp_attributes = []} +;; +let ocaml_mkpat loc x = + {ppat_desc = x; ppat_loc = loc; ppat_loc_stack = []; ppat_attributes = []} +;; +let ocaml_mkexp loc x = + {pexp_desc = x; pexp_loc = loc; pexp_loc_stack = []; pexp_attributes = []} +;; +let ocaml_mkmty loc x = + {pmty_desc = x; pmty_loc = loc; pmty_attributes = []} +;; +let ocaml_mkmod loc x = + {pmod_desc = x; pmod_loc = loc; pmod_attributes = []} +;; +let ocaml_mkfield loc (lab, x) fl = + {pof_desc = Otag (mkloc loc lab, x); pof_loc = loc; pof_attributes = []} :: + fl +;; +let ocaml_mkfield_var loc = [];; + +let variance_of_bool_bool = + function + false, true -> Contravariant + | true, false -> Covariant + | _ -> Invariant +;; + +let ocaml_type_declaration tn params cl tk pf tm loc variance = + match list_map_check (fun s_opt -> s_opt) params with + Some params -> + let _ = + if List.length params <> List.length variance then + failwith "internal error: ocaml_type_declaration" + in + let params = + List.map2 + (fun os va -> + ocaml_mktyp loc (Ptyp_var os), variance_of_bool_bool va) + params variance + in + Right + {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; + ptype_private = pf; ptype_manifest = tm; ptype_loc = loc; + ptype_name = mkloc loc tn; ptype_attributes = []} + | None -> Left "no '_' type param in this ocaml version" +;; + +let ocaml_class_type = + Some (fun d loc -> {pcty_desc = d; pcty_loc = loc; pcty_attributes = []}) +;; + +let ocaml_class_expr = + Some (fun d loc -> {pcl_desc = d; pcl_loc = loc; pcl_attributes = []}) +;; + +let ocaml_class_structure p cil = {pcstr_self = p; pcstr_fields = cil};; + +let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);; + + +let ocaml_pmty_functor sloc mt1 mt2 = + let mt1 = + match mt1 with + None -> Unit + | Some (idopt, mt) -> Named (mknoloc idopt, mt) + in + Pmty_functor (mt1, mt2) +;; + +let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);; + +let ocaml_pmty_with mt lcl = + let lcl = List.map snd lcl in Pmty_with (mt, lcl) +;; + +let ocaml_ptype_abstract = Ptype_abstract;; + +let ocaml_ptype_record ltl priv = + Ptype_record + (List.map + (fun (s, mf, ct, loc) -> + {pld_name = mkloc loc s; pld_mutable = mf; pld_type = ct; + pld_loc = loc; pld_attributes = []}) + ltl) +;; + +let ocaml_ptype_variant ctl priv = + try + let ctl = + List.map + (fun (c, tl, rto, loc) -> + if rto <> None then raise Exit + else + let tl = Pcstr_tuple tl in + {pcd_name = mkloc loc c; pcd_args = tl; pcd_res = None; + pcd_loc = loc; pcd_attributes = []}) + ctl + in + Some (Ptype_variant ctl) + with Exit -> None +;; + +let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (labelled lab, t1, t2);; + +let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl);; + +let ocaml_ptyp_constr loc li tl = Ptyp_constr (mkloc loc li, tl);; + +let ocaml_ptyp_object loc ml is_open = + Ptyp_object (ml, (if is_open then Open else Closed)) +;; + +let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);; + +let ocaml_ptyp_poly = + Some + (fun loc cl t -> + match cl with + [] -> t.ptyp_desc + | _ -> Ptyp_poly (List.map (mkloc loc) cl, t)) +;; + +let ocaml_ptyp_variant loc catl clos sl_opt = + let catl = + List.map + (fun c -> + let d = + match c with + Left (c, a, tl) -> Rtag (mkloc loc c, a, tl) + | Right t -> Rinherit t + in + {prf_desc = d; prf_loc = loc; prf_attributes = []}) + catl + in + let clos = if clos then Closed else Open in + Some (Ptyp_variant (catl, clos, sl_opt)) +;; + +let ocaml_package_type li ltl = + mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl +;; + +let ocaml_pconst_char c = Pconst_char c;; +let ocaml_pconst_int i = Pconst_integer (string_of_int i, None);; +let ocaml_pconst_float s = Pconst_float (s, None);; + +let ocaml_const_string s = Const_string (s, None);; +let ocaml_pconst_string s so = Pconst_string (s, so);; + +let pconst_of_const = + function + Const_int i -> ocaml_pconst_int i + | Const_char c -> ocaml_pconst_char c + | Const_string (s, so) -> ocaml_pconst_string s so + | Const_float s -> ocaml_pconst_float s + | Const_int32 i32 -> Pconst_integer (Int32.to_string i32, Some 'l') + | Const_int64 i64 -> Pconst_integer (Int64.to_string i64, Some 'L') + | Const_nativeint ni -> Pconst_integer (Nativeint.to_string ni, Some 'n') +;; + +let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));; + +let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));; + +let ocaml_const_nativeint = + Some (fun s -> Const_nativeint (Nativeint.of_string s)) +;; + +let ocaml_pexp_apply f lel = + Pexp_apply (f, List.map (fun (l, e) -> labelled l, e) lel) +;; + +let ocaml_pexp_assertfalse fname loc = + Pexp_assert + (ocaml_mkexp loc (Pexp_construct (mkloc loc (Lident "false"), None))) +;; + +let ocaml_pexp_assert fname loc e = Pexp_assert e;; + +let ocaml_pexp_constraint e ot1 ot2 = + match ot2 with + Some t2 -> Pexp_coerce (e, ot1, t2) + | None -> + match ot1 with + Some t1 -> Pexp_constraint (e, t1) + | None -> failwith "internal error: ocaml_pexp_constraint" +;; + +let ocaml_pexp_construct loc li po chk_arity = + Pexp_construct (mkloc loc li, po) +;; + +let ocaml_pexp_construct_args = + function + Pexp_construct (li, po) -> Some (li.txt, li.loc, po, 0) + | _ -> None +;; + +let mkexp_ocaml_pexp_construct_arity loc li_loc li al = + let a = ocaml_mkexp loc (Pexp_tuple al) in + {pexp_desc = ocaml_pexp_construct li_loc li (Some a) true; pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = + [{attr_name = mkloc loc "ocaml.explicit_arity"; attr_payload = PStr []; + attr_loc = loc}]} +;; + +let ocaml_pexp_field loc e li = Pexp_field (e, mkloc loc li);; + +let ocaml_pexp_for i e1 e2 df e = + Pexp_for (ocaml_mkpat loc_none (Ppat_var (mknoloc i)), e1, e2, df, e) +;; + +let ocaml_case (p, wo, loc, e) = {pc_lhs = p; pc_guard = wo; pc_rhs = e};; + +let ocaml_pexp_function lab eo pel = + match pel with + [{pc_lhs = p; pc_guard = None; pc_rhs = e}] -> + Pexp_fun (labelled lab, eo, p, e) + | pel -> + if lab = "" && eo = None then Pexp_function pel + else failwith "internal error: bad ast in ocaml_pexp_function" +;; + +let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);; + +let ocaml_pexp_ident loc li = Pexp_ident (mkloc loc li);; + +let ocaml_pexp_letmodule = + Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e)) +;; + +let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);; + +let ocaml_pexp_newtype = Some (fun loc s e -> Pexp_newtype (mkloc loc s, e));; + +let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);; + +let ocaml_pexp_open = + Some + (fun li e -> + Pexp_open + ({popen_expr = + {pmod_desc = Pmod_ident (mknoloc li); pmod_loc = loc_none; + pmod_attributes = []}; + popen_override = Fresh; popen_loc = loc_none; + popen_attributes = []}, + e)) +;; + +let ocaml_pexp_override sel = + let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel +;; + +let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option = + Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt))) +;; + +let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));; + +let ocaml_pexp_record lel eo = + let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in + Pexp_record (lel, eo) +;; + +let ocaml_pexp_send loc e s = Pexp_send (e, mkloc loc s);; + +let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);; + +let ocaml_pexp_variant = + let pexp_variant_pat = + function + Pexp_variant (lab, eo) -> Some (lab, eo) + | _ -> None + in + let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in + Some (pexp_variant_pat, pexp_variant) +;; + +let ocaml_value_binding loc p e = + {pvb_pat = p; pvb_expr = e; pvb_loc = loc; pvb_attributes = []} +;; + +let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);; + +let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);; + +let ocaml_ppat_construct loc li po chk_arity = + Ppat_construct (mkloc loc li, po) +;; + +let ocaml_ppat_construct_args = + function + Ppat_construct (li, po) -> Some (li.txt, li.loc, po, 0) + | _ -> None +;; + +let mkpat_ocaml_ppat_construct_arity loc li_loc li al = + let a = ocaml_mkpat loc (Ppat_tuple al) in + {ppat_desc = ocaml_ppat_construct li_loc li (Some a) true; ppat_loc = loc; + ppat_loc_stack = []; + ppat_attributes = + [{attr_name = mkloc loc "ocaml.explicit_arity"; attr_payload = PStr []; + attr_loc = loc}]} +;; + +let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);; + +let ocaml_ppat_record lpl is_closed = + let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in + Ppat_record (lpl, (if is_closed then Closed else Open)) +;; + +let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));; + +let ocaml_ppat_unpack = + Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt)) +;; + +let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);; + +let ocaml_ppat_variant = + let ppat_variant_pat = + function + Ppat_variant (lab, po) -> Some (lab, po) + | _ -> None + in + let ppat_variant (lab, po) = Ppat_variant (lab, po) in + Some (ppat_variant_pat, ppat_variant) +;; + +let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);; + +let ocaml_psig_exception loc s ed = + Psig_exception + {ptyexn_constructor = + {pext_name = mkloc loc s; pext_kind = Pext_decl (Pcstr_tuple ed, None); + pext_loc = loc; pext_attributes = []}; + ptyexn_attributes = []; ptyexn_loc = loc} +;; + +let ocaml_psig_include loc mt = + Psig_include {pincl_mod = mt; pincl_loc = loc; pincl_attributes = []} +;; + +let ocaml_psig_module loc (s : string option) mt = + Psig_module + {pmd_name = mkloc loc s; pmd_type = mt; pmd_attributes = []; + pmd_loc = loc} +;; + +let ocaml_psig_modtype loc s mto = + let pmtd = + {pmtd_name = mkloc loc s; pmtd_type = mto; pmtd_attributes = []; + pmtd_loc = loc} + in + Psig_modtype pmtd +;; + +let ocaml_psig_open loc li = + Psig_open + {popen_expr = mknoloc li; popen_override = Fresh; popen_loc = loc; + popen_attributes = []} +;; + +let ocaml_psig_recmodule = + let f ntl = + let ntl = + List.map + (fun (s, mt) -> + {pmd_name = mknoloc s; pmd_type = mt; pmd_attributes = []; + pmd_loc = loc_none}) + ntl + in + Psig_recmodule ntl + in + Some f +;; + +let ocaml_psig_type stl = + let stl = List.map (fun (s, t) -> t) stl in Psig_type (Recursive, stl) +;; + +let ocaml_psig_value s vd = Psig_value vd;; + +let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);; + +let ocaml_pstr_eval e = Pstr_eval (e, []);; + +let ocaml_pstr_exception loc s ed = + Pstr_exception + {ptyexn_constructor = + {pext_name = mkloc loc s; pext_kind = Pext_decl (Pcstr_tuple ed, None); + pext_loc = loc; pext_attributes = []}; + ptyexn_attributes = []; ptyexn_loc = loc} +;; + +let ocaml_pstr_exn_rebind = + Some + (fun loc s li -> + Pstr_exception + {ptyexn_constructor = + {pext_name = mkloc loc s; pext_kind = Pext_rebind (mkloc loc li); + pext_loc = loc; pext_attributes = []}; + ptyexn_attributes = []; ptyexn_loc = loc}) +;; + +let ocaml_pstr_include = + Some + (fun loc me -> + Pstr_include {pincl_mod = me; pincl_loc = loc; pincl_attributes = []}) +;; + +let ocaml_pstr_modtype loc s mt = + let pmtd = + {pmtd_name = mkloc loc s; pmtd_type = Some mt; pmtd_attributes = []; + pmtd_loc = loc} + in + Pstr_modtype pmtd +;; + +let ocaml_pstr_module loc (s : string option) me = + let mb = + {pmb_name = mkloc loc s; pmb_expr = me; pmb_attributes = []; + pmb_loc = loc} + in + Pstr_module mb +;; + +let ocaml_pstr_open loc li = + Pstr_open + {popen_expr = + {pmod_desc = Pmod_ident (mknoloc li); pmod_loc = loc_none; + pmod_attributes = []}; + popen_override = Fresh; popen_loc = loc; popen_attributes = []} +;; + +let ocaml_pstr_primitive s vd = Pstr_primitive vd;; + +let ocaml_pstr_recmodule = + let f nel = + Pstr_recmodule + (List.map + (fun ((s : string option), mt, me) -> + {pmb_name = mknoloc s; pmb_expr = me; pmb_attributes = []; + pmb_loc = loc_none}) + nel) + in + Some f +;; + +let ocaml_pstr_type is_nonrec stl = + let stl = List.map (fun (s, t) -> t) stl in + Pstr_type ((if is_nonrec then Nonrecursive else Recursive), stl) +;; + +let ocaml_class_infos = + Some + (fun virt (sl, sloc) name expr loc variance -> + let _ = + if List.length sl <> List.length variance then + failwith "internal error: ocaml_class_infos" + in + let params = + List.map2 + (fun os va -> + ocaml_mktyp loc (Ptyp_var os), variance_of_bool_bool va) + sl variance + in + {pci_virt = virt; pci_params = params; pci_name = mkloc loc name; + pci_expr = expr; pci_loc = loc; pci_attributes = []}) +;; + +let ocaml_pmod_constraint loc me mt = + ocaml_mkmod loc (Pmod_constraint (me, mt)) +;; + +let ocaml_pmod_ident li = Pmod_ident (mknoloc li);; + +let ocaml_pmod_functor mt me = + let mt = + match mt with + None -> Unit + | Some (idopt, mt) -> Named (mknoloc idopt, mt) + in + Pmod_functor (mt, me) +;; + +let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option = + Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt))) +;; + +let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constraint (t1, t2));; + +let ocaml_pcf_inher loc ce pb = + Pcf_inherit (Fresh, ce, option_map (mkloc loc) pb) +;; + +let ocaml_pcf_init = Some (fun e -> Pcf_initializer e);; + +let ocaml_pcf_meth (s, pf, ovf, e, loc) = + let pf = if pf then Private else Public in + let ovf = if ovf then Override else Fresh in + Pcf_method (mkloc loc s, pf, Cfk_concrete (ovf, e)) +;; + +let ocaml_pcf_val (s, mf, ovf, e, loc) = + let mf = if mf then Mutable else Immutable in + let ovf = if ovf then Override else Fresh in + Pcf_val (mkloc loc s, mf, Cfk_concrete (ovf, e)) +;; + +let ocaml_pcf_valvirt = + let ocaml_pcf (s, mf, t, loc) = + let mf = if mf then Mutable else Immutable in + Pcf_val (mkloc loc s, mf, Cfk_virtual t) + in + Some ocaml_pcf +;; + +let ocaml_pcf_virt (s, pf, t, loc) = + Pcf_method (mkloc loc s, pf, Cfk_virtual t) +;; + +let ocaml_pcl_apply = + Some + (fun ce lel -> Pcl_apply (ce, List.map (fun (l, e) -> labelled l, e) lel)) +;; + +let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));; + +let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));; + +let ocaml_pcl_fun = + Some (fun lab ceo p ce -> Pcl_fun (labelled lab, ceo, p, ce)) +;; + +let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));; + +let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);; + +let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_constraint (t1, t2));; + +let ocaml_pctf_inher ct = Pctf_inherit ct;; + +let ocaml_pctf_meth (s, pf, t, loc) = + Pctf_method (mkloc loc s, pf, Concrete, t) +;; + +let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (mkloc loc s, mf, Concrete, t);; + +let ocaml_pctf_virt (s, pf, t, loc) = + Pctf_method (mkloc loc s, pf, Virtual, t) +;; + +let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));; + +let ocaml_pcty_fun = + Some (fun lab t ot ct -> Pcty_arrow (labelled lab, t, ct)) +;; + +let ocaml_pcty_signature = + let f (t, ctfl) = + let cs = {pcsig_self = t; pcsig_fields = ctfl} in Pcty_signature cs + in + Some f +;; + +let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);; +let ocaml_pdir_int i s = Pdir_int (i, None);; +let ocaml_pdir_some x = Some x;; +let ocaml_pdir_none = None;; +let ocaml_ptop_dir loc s da = + Ptop_dir + {pdir_name = mkloc loc s; + pdir_arg = + begin match da with + Some da -> Some {pdira_desc = da; pdira_loc = loc} + | None -> None + end; + pdir_loc = loc} +;; + +let ocaml_pwith_modsubst = + Some (fun loc me -> Pwith_modsubst (mkloc loc (Lident ""), mkloc loc me)) +;; + +let ocaml_pwith_type loc (i, td) = Pwith_type (mkloc loc i, td);; + +let ocaml_pwith_module loc mname me = + Pwith_module (mkloc loc mname, mkloc loc me) +;; + +let ocaml_pwith_typesubst = + Some (fun loc td -> Pwith_typesubst (mkloc loc (Lident ""), td)) +;; + +let module_prefix_can_be_in_first_record_label_only = true;; + +let split_or_patterns_with_bindings = false;; + +let has_records_with_with = true;; + +(* *) + +let jocaml_pstr_def : (_ -> _) option = None;; + +let jocaml_pexp_def : (_ -> _ -> _) option = None;; + +let jocaml_pexp_par : (_ -> _ -> _) option = None;; + +let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;; + +let jocaml_pexp_spawn : (_ -> _) option = None;; + +let arg_rest = + function + Arg.Rest r -> Some r + | _ -> None +;; + +let arg_set_string = + function + Arg.Set_string r -> Some r + | _ -> None +;; + +let arg_set_int = + function + Arg.Set_int r -> Some r + | _ -> None +;; + +let arg_set_float = + function + Arg.Set_float r -> Some r + | _ -> None +;; + +let arg_symbol = + function + Arg.Symbol (s, f) -> Some (s, f) + | _ -> None +;; + +let arg_tuple = + function + Arg.Tuple t -> Some t + | _ -> None +;; + +let arg_bool = + function + Arg.Bool f -> Some f + | _ -> None +;; + +let char_escaped = Char.escaped;; + +let hashtbl_mem = Hashtbl.mem;; + +let list_rev_append = List.rev_append;; + +let list_rev_map = List.rev_map;; + +let list_sort = List.sort;; + +let pervasives_set_binary_mode_out = set_binary_mode_out;; + +let printf_ksprintf = Printf.ksprintf;; + +let char_uppercase = Char.uppercase_ascii;; + +let bytes_modname = "Bytes";; + +let bytes_of_string s = Bytes.of_string s;; + +let bytes_to_string s = Bytes.to_string s;; + +let string_capitalize = String.capitalize_ascii;; + +let string_contains = String.contains;; + +let string_cat s1 s2 = Bytes.cat s1 s2;; + +let string_copy = Bytes.copy;; + +let string_create = Bytes.create;; + +let string_get = Bytes.get;; + +let string_index = Bytes.index;; + +let string_length = Bytes.length;; + +let string_lowercase = String.lowercase_ascii;; + +let string_unsafe_set = Bytes.unsafe_set;; + +let string_uncapitalize = String.uncapitalize_ascii;; + +let string_uppercase = String.uppercase_ascii;; + +let string_set = Bytes.set;; + +let string_sub = Bytes.sub;; + +let array_create = Array.make;; diff --git a/ocaml_src/main/ast2pt.ml b/ocaml_src/main/ast2pt.ml index d854c8bb..87b34922 100644 --- a/ocaml_src/main/ast2pt.ml +++ b/ocaml_src/main/ast2pt.ml @@ -629,7 +629,7 @@ let rec patt = | PaStr (loc, s) -> mkpat loc (Ppat_constant - (ocaml_pconst_string (string_of_string_token loc (uv s)) None)) + (ocaml_pconst_string (string_of_string_token loc (uv s)) (mkloc loc) None)) | PaTup (loc, pl) -> mkpat loc (Ppat_tuple (List.map patt (uv pl))) | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint (patt p, ctyp t)) | PaTyp (loc, sl) -> @@ -1225,7 +1225,7 @@ let rec expr = | ExStr (loc, s) -> mkexp loc (Pexp_constant - (ocaml_pconst_string (string_of_string_token loc (uv s)) None)) + (ocaml_pconst_string (string_of_string_token loc (uv s)) (mkloc loc) None)) | ExTry (loc, e, pel) -> mkexp loc (Pexp_try (expr e, List.map mkpwe (uv pel))) | ExTup (loc, el) -> mkexp loc (Pexp_tuple (List.map expr (uv el))) diff --git a/ocaml_stuff/4.11.0/parsing/.depend b/ocaml_stuff/4.11.0/parsing/.depend new file mode 100644 index 00000000..c589fb6e --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/.depend @@ -0,0 +1,4 @@ +asttypes.cmi : location.cmi +location.cmi : ../utils/warnings.cmi +longident.cmi : +parsetree.cmi : longident.cmi location.cmi asttypes.cmi diff --git a/ocaml_stuff/4.11.0/parsing/.gitignore b/ocaml_stuff/4.11.0/parsing/.gitignore new file mode 100644 index 00000000..8e6c39c2 --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/.gitignore @@ -0,0 +1 @@ +*.cm[oi] diff --git a/ocaml_stuff/4.11.0/parsing/Makefile b/ocaml_stuff/4.11.0/parsing/Makefile new file mode 100644 index 00000000..6d08a199 --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/Makefile @@ -0,0 +1,19 @@ +# Makefile,v + +FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi +INCL=-I ../utils + +all: $(FILES) + +clean: + rm -f *.cmi + +depend: + ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend + +.SUFFIXES: .mli .cmi + +.mli.cmi: + $(OCAMLN)c $(INCL) -c $< + +include .depend diff --git a/ocaml_stuff/4.11.0/parsing/asttypes.mli b/ocaml_stuff/4.11.0/parsing/asttypes.mli new file mode 100644 index 00000000..353d7776 --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/asttypes.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Auxiliary AST types used by parsetree and typedtree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type constant = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + +type rec_flag = Nonrecursive | Recursive + +type direction_flag = Upto | Downto + +(* Order matters, used in polymorphic comparison *) +type private_flag = Private | Public + +type mutable_flag = Immutable | Mutable + +type virtual_flag = Virtual | Concrete + +type override_flag = Override | Fresh + +type closed_flag = Closed | Open + +type label = string + +type arg_label = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) + +type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; +} + + +type variance = + | Covariant + | Contravariant + | Invariant diff --git a/ocaml_stuff/4.11.0/parsing/location.mli b/ocaml_stuff/4.11.0/parsing/location.mli new file mode 100644 index 00000000..ecf39b21 --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/location.mli @@ -0,0 +1,287 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** {1 Source code locations (ranges of positions), used in parsetree} + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Format + +type t = Warnings.loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +(** Note on the use of Lexing.position in this module. + If [pos_fname = ""], then use [!input_name] instead. + If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and + re-parse the file to get the line and character numbers. + Else all fields are correct. +*) + +val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) + +val is_none : t -> bool +(** True for [Location.none], false any other location *) + +val in_file : string -> t +(** Return an empty ghost range located in a given file. *) + +val init : Lexing.lexbuf -> string -> unit +(** Set the file name and line number of the [lexbuf] to be the start + of the named file. *) + +val curr : Lexing.lexbuf -> t +(** Get the location of the current token from the [lexbuf]. *) + +val symbol_rloc: unit -> t +val symbol_gloc: unit -> t + +(** [rhs_loc n] returns the location of the symbol at position [n], starting + at 1, in the current parser rule. *) +val rhs_loc: int -> t + +val rhs_interval: int -> int -> t + +val get_pos_info: Lexing.position -> string * int * int +(** file, line, char *) + +type 'a loc = { + txt : 'a; + loc : t; +} + +val mknoloc : 'a -> 'a loc +val mkloc : 'a -> t -> 'a loc + + +(** {1 Input info} *) + +val input_name: string ref +val input_lexbuf: Lexing.lexbuf option ref + +(* This is used for reporting errors coming from the toplevel. + + When running a toplevel session (i.e. when [!input_name] is "//toplevel//"), + [!input_phrase_buffer] should be [Some buf] where [buf] contains the last + toplevel phrase. *) +val input_phrase_buffer: Buffer.t option ref + + +(** {1 Toplevel-specific functions} *) + +val echo_eof: unit -> unit +val reset: unit -> unit + + +(** {1 Printing locations} *) + +val rewrite_absolute_path: string -> string + (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP + variable (https://reproducible-builds.org/specs/build-path-prefix-map/) + if it is set. *) + +val absolute_path: string -> string + +val show_filename: string -> string + (** In -absname mode, return the absolute path for this filename. + Otherwise, returns the filename unchanged. *) + +val print_filename: formatter -> string -> unit + +val print_loc: formatter -> t -> unit +val print_locs: formatter -> t list -> unit + + +(** {1 Toplevel-specific location highlighting} *) + +val highlight_terminfo: + Lexing.lexbuf -> formatter -> t list -> unit + + +(** {1 Reporting errors and warnings} *) + +(** {2 The type of reports and report printers} *) + +type msg = (Format.formatter -> unit) loc + +val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a + +type report_kind = + | Report_error + | Report_warning of string + | Report_warning_as_error of string + | Report_alert of string + | Report_alert_as_error of string + +type report = { + kind : report_kind; + main : msg; + sub : msg list; +} + +type report_printer = { + (* The entry point *) + pp : report_printer -> + Format.formatter -> report -> unit; + + pp_report_kind : report_printer -> report -> + Format.formatter -> report_kind -> unit; + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> + Format.formatter -> (Format.formatter -> unit) -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> + Format.formatter -> msg -> unit; + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> + Format.formatter -> (Format.formatter -> unit) -> unit; +} +(** A printer for [report]s, defined using open-recursion. + The goal is to make it easy to define new printers by re-using code from + existing ones. +*) + +(** {2 Report printers used in the compiler} *) + +val batch_mode_printer: report_printer + +val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer + +val best_toplevel_printer: unit -> report_printer +(** Detects the terminal capabilities and selects an adequate printer *) + +(** {2 Printing a [report]} *) + +val print_report: formatter -> report -> unit +(** Display an error or warning report. *) + +val report_printer: (unit -> report_printer) ref +(** Hook for redefining the printer of reports. + + The hook is a [unit -> report_printer] and not simply a [report_printer]: + this is useful so that it can detect the type of the output (a file, a + terminal, ...) and select a printer accordingly. *) + +val default_report_printer: unit -> report_printer +(** Original report printer for use in hooks. *) + + +(** {1 Reporting warnings} *) + +(** {2 Converting a [Warnings.t] into a [report]} *) + +val report_warning: t -> Warnings.t -> report option +(** [report_warning loc w] produces a report for the given warning [w], or + [None] if the warning is not to be printed. *) + +val warning_reporter: (t -> Warnings.t -> report option) ref +(** Hook for intercepting warnings. *) + +val default_warning_reporter: t -> Warnings.t -> report option +(** Original warning reporter for use in hooks. *) + +(** {2 Printing warnings} *) + +val formatter_for_warnings : formatter ref + +val print_warning: t -> formatter -> Warnings.t -> unit +(** Prints a warning. This is simply the composition of [report_warning] and + [print_report]. *) + +val prerr_warning: t -> Warnings.t -> unit +(** Same as [print_warning], but uses [!formatter_for_warnings] as output + formatter. *) + +(** {1 Reporting alerts} *) + +(** {2 Converting an [Alert.t] into a [report]} *) + +val report_alert: t -> Warnings.alert -> report option +(** [report_alert loc w] produces a report for the given alert [w], or + [None] if the alert is not to be printed. *) + +val alert_reporter: (t -> Warnings.alert -> report option) ref +(** Hook for intercepting alerts. *) + +val default_alert_reporter: t -> Warnings.alert -> report option +(** Original alert reporter for use in hooks. *) + +(** {2 Printing alerts} *) + +val print_alert: t -> formatter -> Warnings.alert -> unit +(** Prints an alert. This is simply the composition of [report_alert] and + [print_report]. *) + +val prerr_alert: t -> Warnings.alert -> unit +(** Same as [print_alert], but uses [!formatter_for_warnings] as output + formatter. *) + +val deprecated: ?def:t -> ?use:t -> t -> string -> unit +(** Prints a deprecation alert. *) + +val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit +(** Prints an arbitrary alert. *) + + +(** {1 Reporting errors} *) + +type error = report +(** An [error] is a [report] which [report_kind] must be [Report_error]. *) + +val error: ?loc:t -> ?sub:msg list -> string -> error + +val errorf: ?loc:t -> ?sub:msg list -> + ('a, Format.formatter, unit, error) format4 -> 'a + +val error_of_printer: ?loc:t -> ?sub:msg list -> + (formatter -> 'a -> unit) -> 'a -> error + +val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error + + +(** {1 Automatically reporting errors for raised exceptions} *) + +val register_error_of_exn: (exn -> error option) -> unit +(** Each compiler module which defines a custom type of exception + which can surface as a user-visible error should register + a "printer" for this exception using [register_error_of_exn]. + The result of the printer is an [error] value containing + a location, a message, and optionally sub-messages (each of them + being located as well). *) + +val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option + +exception Error of error +(** Raising [Error e] signals an error [e]; the exception will be caught and the + error will be printed. *) + +exception Already_displayed_error +(** Raising [Already_displayed_error] signals an error which has already been + printed. The exception will be caught, but nothing will be printed *) + +val raise_errorf: ?loc:t -> ?sub:msg list -> + ('a, Format.formatter, unit, 'b) format4 -> 'a + +val report_exception: formatter -> exn -> unit +(** Reraise the exception if it is unknown. *) diff --git a/ocaml_stuff/4.11.0/parsing/longident.mli b/ocaml_stuff/4.11.0/parsing/longident.mli new file mode 100644 index 00000000..07086301 --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/longident.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Long identifiers, used in parsetree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +val flatten: t -> string list +val unflatten: string list -> t option +(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is + the long identifier created by concatenating the elements of [l] + with [Ldot]. + [unflatten []] is [None]. +*) + +val last: t -> string +val parse: string -> t +[@@deprecated "this function may misparse its input,\n\ +use \"Parse.longident\" or \"Longident.unflatten\""] +(** + + This function is broken on identifiers that are not just "Word.Word.word"; + for example, it returns incorrect results on infix operators + and extended module paths. + + If you want to generate long identifiers that are a list of + dot-separated identifiers, the function {!unflatten} is safer and faster. + {!unflatten} is available since OCaml 4.06.0. + + If you want to parse any identifier correctly, use the long-identifiers + functions from the {!Parse} module, in particular {!Parse.longident}. + They are available since OCaml 4.11, and also provide proper + input-location support. + +*) + + + +(** To print a longident, see {!Pprintast.longident}, using + {!Format.asprintf} to convert to a string. *) diff --git a/ocaml_stuff/4.11.0/parsing/parsetree.mli b/ocaml_stuff/4.11.0/parsing/parsetree.mli new file mode 100644 index 00000000..0712f87c --- /dev/null +++ b/ocaml_stuff/4.11.0/parsing/parsetree.mli @@ -0,0 +1,970 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree produced by parsing + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes + +type constant = + Pconst_integer of string * char option + (* 3 3l 3L 3n + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes except 'l', 'L' and 'n' are rejected by the typechecker + *) + | Pconst_char of char + (* 'c' *) + | Pconst_string of string * Location.t * string option + (* "constant" + {delim|other constant|delim} + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + +type location_stack = Location.t list + +(** {1 Extension points} *) + +type attribute = { + attr_name : string loc; + attr_payload : payload; + attr_loc : Location.t; + } + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + +and extension = string loc * payload + (* [%id ARG] + [%%id ARG] + + Sub-language placeholder -- rejected by the typechecker. + *) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (* : SIG *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + +(** {1 Core language} *) + +(* Type expressions *) + +and core_type = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_loc_stack: location_stack; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and core_type_desc = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of Longident.t loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string loc list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension + (* [%id] *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + +and row_field = { + prf_desc : row_field_desc; + prf_loc : Location.t; + prf_attributes : attributes; +} + +and row_field_desc = + | Rtag of label loc * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 'bool' field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + *) + | Rinherit of core_type + (* [ T ] *) + +and object_field = { + pof_desc : object_field_desc; + pof_loc : Location.t; + pof_attributes : attributes; +} + +and object_field_desc = + | Otag of label loc * core_type + | Oinherit of core_type + +(* Patterns *) + +and pattern = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_loc_stack: location_stack; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and pattern_desc = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of Longident.t loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string option loc + (* (module P) Some "P" + (module _) None + + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension + (* [%id] *) + | Ppat_open of Longident.t loc * pattern + (* M.(P) *) + +(* Value expressions *) + +and expression = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: location_stack; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and expression_desc = + | Pexp_ident of Longident.t loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * case list + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * case list + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 + *) + | Pexp_field of expression * Longident.t loc + (* E.l *) + | Pexp_setfield of expression * Longident.t loc * expression + (* E1.l <- E2 *) + | Pexp_array of expression list + (* [| E1; ...; En |] *) + | Pexp_ifthenelse of expression * expression * expression option + (* if E1 then E2 else E3 *) + | Pexp_sequence of expression * expression + (* E1; E2 *) + | Pexp_while of expression * expression + (* while E1 do E2 done *) + | Pexp_for of + pattern * expression * expression * direction_flag * expression + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * label loc + (* E # m *) + | Pexp_new of Longident.t loc + (* new M.c *) + | Pexp_setinstvar of label loc * expression + (* x <- 2 *) + | Pexp_override of (label loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string option loc * module_expr * expression + (* let module M = ME in E *) + | Pexp_letexception of extension_constructor * expression + (* let exception C in E *) + | Pexp_assert of expression + (* assert E + Note: "assert false" is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression + (* lazy E *) + | Pexp_poly of expression * core_type option + (* Used for method bodies. + + Can only be used as the expression under Cfk_concrete + for methods (not values). *) + | Pexp_object of class_structure + (* object ... end *) + | Pexp_newtype of string loc * expression + (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of open_declaration * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_letop of letop + (* let* P = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension + (* [%id] *) + | Pexp_unreachable + (* . *) + +and case = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + +and letop = + { + let_ : binding_op; + ands : binding_op list; + body : expression; + } + +and binding_op = + { + pbop_op : string loc; + pbop_pat : pattern; + pbop_exp : expression; + pbop_loc : Location.t; + } + +(* Value descriptions *) + +and value_description = + { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_loc: Location.t; + } + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + +(* Type declarations *) + +and type_declaration = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; + } + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + +and type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + | Ptype_record of label_declaration list + (* Invariant: non-empty list *) + | Ptype_open + +and label_declaration = + { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (* l : T [@id1] [@id2] *) + } + +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. +*) + +and constructor_declaration = + { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) + } + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) + +and type_extension = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* + type t += ... +*) + +and extension_constructor = + { + pext_name: string loc; + pext_kind : extension_constructor_kind; + pext_loc : Location.t; + pext_attributes: attributes; (* C of ... [@id1] [@id2] *) + } + +(* exception E *) +and type_exception = + { + ptyexn_constructor: extension_constructor; + ptyexn_loc: Location.t; + ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + +and extension_constructor_kind = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + +(** {1 Class language} *) + +(* Type expressions for the class language *) + +and class_type = + { + pcty_desc: class_type_desc; + pcty_loc: Location.t; + pcty_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and class_type_desc = + | Pcty_constr of Longident.t loc * core_type list + (* c + ['a1, ..., 'an] c *) + | Pcty_signature of class_signature + (* object ... end *) + | Pcty_arrow of arg_label * core_type * class_type + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension + (* [%id] *) + | Pcty_open of open_description * class_type + (* let open M in CT *) + +and class_signature = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } +(* object('selfpat) ... end + object ... end (self = Ptyp_any) + *) + +and class_type_field = + { + pctf_desc: class_type_field_desc; + pctf_loc: Location.t; + pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + +and class_type_field_desc = + | Pctf_inherit of class_type + (* inherit CT *) + | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) + (* val x: T *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a Ptyp_poly. + *) + | Pctf_constraint of (core_type * core_type) + (* constraint T1 = T2 *) + | Pctf_attribute of attribute + (* [@@@id] *) + | Pctf_extension of extension + (* [%%id] *) + +and 'a class_infos = + { + pci_virt: virtual_flag; + pci_params: (core_type * variance) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. +*) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(* Value expressions for the class language *) + +and class_expr = + { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and class_expr_desc = + | Pcl_constr of Longident.t loc * core_type list + (* c + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* CE ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pcl_let of rec_flag * value_binding list * class_expr + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension + (* [%id] *) + | Pcl_open of open_description * class_expr + (* let open M in CE *) + + +and class_structure = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } +(* object(selfpat) ... end + object ... end (self = Ppat_any) + *) + +and class_field = + { + pcf_desc: class_field_desc; + pcf_loc: Location.t; + pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + +and class_field_desc = + | Pcf_inherit of override_flag * class_expr * string loc option + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a Ptyp_poly) + *) + | Pcf_constraint of (core_type * core_type) + (* constraint T1 = T2 *) + | Pcf_initializer of expression + (* initializer E *) + | Pcf_attribute of attribute + (* [@@@id] *) + | Pcf_extension of extension + (* [%%id] *) + +and class_field_kind = + | Cfk_virtual of core_type + | Cfk_concrete of override_flag * expression + +and class_declaration = class_expr class_infos + +(** {1 Module language} *) + +(* Type expressions for the module language *) + +and module_type = + { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and module_type_desc = + | Pmty_ident of Longident.t loc + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of functor_parameter * module_type + (* functor(X : MT1) -> MT2 *) + | Pmty_with of module_type * with_constraint list + (* MT with ... *) + | Pmty_typeof of module_expr + (* module type of ME *) + | Pmty_extension of extension + (* [%id] *) + | Pmty_alias of Longident.t loc + (* (module M) *) + +and functor_parameter = + | Unit + (* () *) + | Named of string option loc * module_type + (* (X : MT) Some X, MT + (_ : MT) None, MT *) + +and signature = signature_item list + +and signature_item = + { + psig_desc: signature_item_desc; + psig_loc: Location.t; + } + +and signature_item_desc = + | Psig_value of value_description + (* + val x: T + external x: T = "s1" ... "sn" + *) + | Psig_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Psig_typesubst of type_declaration list + (* type t1 := ... and ... and tn := ... *) + | Psig_typext of type_extension + (* type t1 += ... *) + | Psig_exception of type_exception + (* exception C of T *) + | Psig_module of module_declaration + (* module X = M + module X : MT *) + | Psig_modsubst of module_substitution + (* module X := M *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + module type S *) + | Psig_open of open_description + (* open X *) + | Psig_include of include_description + (* include MT *) + | Psig_class of class_description list + (* class c1 : ... and ... and cn : ... *) + | Psig_class_type of class_type_declaration list + (* class type ct1 = ... and ... and ctn = ... *) + | Psig_attribute of attribute + (* [@@@id] *) + | Psig_extension of extension * attributes + (* [%%id] *) + +and module_declaration = + { + pmd_name: string option loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; + } +(* S : MT *) + +and module_substitution = + { + pms_name: string loc; + pms_manifest: Longident.t loc; + pms_attributes: attributes; (* ... [@@id1] [@@id2] *) + pms_loc: Location.t; + } + +and module_type_declaration = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_loc: Location.t; + } +(* S = MT + S (abstract module type declaration, pmtd_type = None) +*) + +and 'a open_infos = + { + popen_expr: 'a; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } +(* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + +and open_description = Longident.t loc open_infos +(* open M.N + open M(N).O *) + +and open_declaration = module_expr open_infos +(* open M.N + open M(N).O + open struct ... end *) + +and 'a include_infos = + { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; + } + +and include_description = module_type include_infos +(* include MT *) + +and include_declaration = module_expr include_infos +(* include ME *) + +and with_constraint = + | Pwith_type of Longident.t loc * type_declaration + (* with type X.t = ... + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc + (* with module X.Y = Z *) + | Pwith_typesubst of Longident.t loc * type_declaration + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc + (* with module X.Y := Z *) + +(* Value expressions for the module language *) + +and module_expr = + { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and module_expr_desc = + | Pmod_ident of Longident.t loc + (* X *) + | Pmod_structure of structure + (* struct ... end *) + | Pmod_functor of functor_parameter * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | Pmod_constraint of module_expr * module_type + (* (ME : MT) *) + | Pmod_unpack of expression + (* (val E) *) + | Pmod_extension of extension + (* [%id] *) + +and structure = structure_item list + +and structure_item = + { + pstr_desc: structure_item_desc; + pstr_loc: Location.t; + } + +and structure_item_desc = + | Pstr_eval of expression * attributes + (* E *) + | Pstr_value of rec_flag * value_binding list + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) + | Pstr_primitive of value_description + (* val x: T + external x: T = "s1" ... "sn" *) + | Pstr_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension + (* type t1 += ... *) + | Pstr_exception of type_exception + (* exception C of T + exception C = M.X *) + | Pstr_module of module_binding + (* module X = ME *) + | Pstr_recmodule of module_binding list + (* module rec X1 = ME1 and ... and Xn = MEn *) + | Pstr_modtype of module_type_declaration + (* module type S = MT *) + | Pstr_open of open_declaration + (* open X *) + | Pstr_class of class_declaration list + (* class c1 = ... and ... and cn = ... *) + | Pstr_class_type of class_type_declaration list + (* class type ct1 = ... and ... and ctn = ... *) + | Pstr_include of include_declaration + (* include ME *) + | Pstr_attribute of attribute + (* [@@@id] *) + | Pstr_extension of extension * attributes + (* [%%id] *) + +and value_binding = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; + } + +and module_binding = + { + pmb_name: string option loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } +(* X = ME *) + +(** {1 Toplevel} *) + +(* Toplevel phrases *) + +type toplevel_phrase = + | Ptop_def of structure + | Ptop_dir of toplevel_directive + (* #use, #load ... *) + +and toplevel_directive = + { + pdir_name : string loc; + pdir_arg : directive_argument option; + pdir_loc : Location.t; + } + +and directive_argument = + { + pdira_desc : directive_argument_desc; + pdira_loc : Location.t; + } + +and directive_argument_desc = + | Pdir_string of string + | Pdir_int of string * char option + | Pdir_ident of Longident.t + | Pdir_bool of bool diff --git a/ocaml_stuff/4.11.0/utils/.depend b/ocaml_stuff/4.11.0/utils/.depend new file mode 100644 index 00000000..b261ffe0 --- /dev/null +++ b/ocaml_stuff/4.11.0/utils/.depend @@ -0,0 +1,2 @@ +pconfig.cmo: pconfig.cmi +pconfig.cmx: pconfig.cmi diff --git a/ocaml_stuff/4.11.0/utils/.gitignore b/ocaml_stuff/4.11.0/utils/.gitignore new file mode 100644 index 00000000..23e90de9 --- /dev/null +++ b/ocaml_stuff/4.11.0/utils/.gitignore @@ -0,0 +1 @@ +*.cm[oix] diff --git a/ocaml_stuff/4.11.0/utils/Makefile b/ocaml_stuff/4.11.0/utils/Makefile new file mode 100644 index 00000000..f4ea2816 --- /dev/null +++ b/ocaml_stuff/4.11.0/utils/Makefile @@ -0,0 +1,27 @@ +# Makefile,v + +FILES=warnings.cmi pconfig.cmo +INCL= + +all: $(FILES) + +opt: pconfig.cmx + +clean: + rm -f *.cm[oix] *.o + +depend: + ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend + +.SUFFIXES: .mli .cmi .ml .cmo .cmx + +.mli.cmi: + $(OCAMLN)c $(INCL) -c $< + +.ml.cmo: + $(OCAMLN)c $(INCL) -c $< + +.ml.cmx: + $(OCAMLN)opt $(INCL) -c $< + +include .depend diff --git a/ocaml_stuff/4.11.0/utils/pconfig.ml b/ocaml_stuff/4.11.0/utils/pconfig.ml new file mode 100644 index 00000000..cc05fde1 --- /dev/null +++ b/ocaml_stuff/4.11.0/utils/pconfig.ml @@ -0,0 +1,2 @@ +let ast_impl_magic_number = "Caml1999M027" +let ast_intf_magic_number = "Caml1999N027" diff --git a/ocaml_stuff/4.11.0/utils/pconfig.mli b/ocaml_stuff/4.11.0/utils/pconfig.mli new file mode 100644 index 00000000..6a2af67d --- /dev/null +++ b/ocaml_stuff/4.11.0/utils/pconfig.mli @@ -0,0 +1,2 @@ +val ast_impl_magic_number : string +val ast_intf_magic_number : string diff --git a/ocaml_stuff/4.11.0/utils/warnings.mli b/ocaml_stuff/4.11.0/utils/warnings.mli new file mode 100644 index 00000000..b80ab34c --- /dev/null +++ b/ocaml_stuff/4.11.0/utils/warnings.mli @@ -0,0 +1,140 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 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. *) +(* *) +(**************************************************************************) + +(** Warning definitions + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +type t = + | Comment_start (* 1 *) + | Comment_not_end (* 2 *) +(*| Deprecated --> alert "deprecated" *) (* 3 *) + | Fragile_match of string (* 4 *) + | Partial_application (* 5 *) + | Labels_omitted of string list (* 6 *) + | Method_override of string list (* 7 *) + | Partial_match of string (* 8 *) + | Non_closed_record_pattern of string (* 9 *) + | Statement_type (* 10 *) + | Unused_match (* 11 *) + | Unused_pat (* 12 *) + | Instance_variable_override of string list (* 13 *) + | Illegal_backslash (* 14 *) + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) + | Not_principal of string (* 18 *) + | Without_principality of string (* 19 *) + | Unused_argument (* 20 *) + | Nonreturning_statement (* 21 *) + | Preprocessor of string (* 22 *) + | Useless_record_with (* 23 *) + | Bad_module_name of string (* 24 *) + | All_clauses_guarded (* 8, used to be 25 *) + | Unused_var of string (* 26 *) + | Unused_var_strict of string (* 27 *) + | Wildcard_arg_to_constant_constr (* 28 *) + | Eol_in_string (* 29 *) + | Duplicate_definitions of string * string * string * string (* 30 *) + | Multiple_definition of string * string * string (* 31 *) + | Unused_value_declaration of string (* 32 *) + | Unused_open of string (* 33 *) + | Unused_type_declaration of string (* 34 *) + | Unused_for_index of string (* 35 *) + | Unused_ancestor of string (* 36 *) + | Unused_constructor of string * bool * bool (* 37 *) + | Unused_extension of string * bool * bool * bool (* 38 *) + | Unused_rec_flag (* 39 *) + | Name_out_of_scope of string * string list * bool (* 40 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) + | Disambiguated_name of string (* 42 *) + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string (* 46 *) + | Attribute_payload of string * string (* 47 *) + | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string * string option (* 49 *) + | Bad_docstring of bool (* 50 *) + | Expect_tailcall (* 51 *) + | Fragile_literal_pattern (* 52 *) + | Misplaced_attribute of string (* 53 *) + | Duplicated_attribute of string (* 54 *) + | Inlining_impossible of string (* 55 *) + | Unreachable_case (* 56 *) + | Ambiguous_pattern of string list (* 57 *) + | No_cmx_file of string (* 58 *) + | Assignment_to_non_mutable_value (* 59 *) + | Unused_module of string (* 60 *) + | Unboxable_type_in_prim_decl of string (* 61 *) + | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) + | Unsafe_without_parsing (* 64 *) + | Redefining_unit of string (* 65 *) + | Unused_open_bang of string (* 66 *) + | Unused_functor_parameter of string (* 67 *) +;; + +type alert = {kind:string; message:string; def:loc; use:loc} + +val parse_options : bool -> string -> unit;; + +val parse_alert_option: string -> unit + (** Disable/enable alerts based on the parameter to the -alert + command-line option. Raises [Arg.Bad] if the string is not a + valid specification. + *) + +val without_warnings : (unit -> 'a) -> 'a + (** Run the thunk with all warnings and alerts disabled. *) + +val is_active : t -> bool;; +val is_error : t -> bool;; + +val defaults_w : string;; +val defaults_warn_error : string;; + +type reporting_information = + { id : string + ; message : string + ; is_error : bool + ; sub_locs : (loc * string) list; + } + +val report : t -> [ `Active of reporting_information | `Inactive ] +val report_alert : alert -> [ `Active of reporting_information | `Inactive ] + +exception Errors;; + +val check_fatal : unit -> unit;; +val reset_fatal: unit -> unit + +val help_warnings: unit -> unit + +type state +val backup: unit -> state +val restore: state -> unit +val mk_lazy: (unit -> 'a) -> 'a Lazy.t + (** Like [Lazy.of_fun], but the function is applied with + the warning/alert settings at the time [mk_lazy] is called. *) -- 2.24.1