From 157233fc9cdabda06bc92273f41215dff343a155 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Tue, 3 Sep 2024 15:36:14 +0200 Subject: [PATCH] OCaml 5.3 support --- rtop/dune | 6 + rtop/{reason_utop.ml => reason_utop.cppo.ml} | 26 +- src/reason-parser/ocaml_util.cppo.ml | 12 +- src/vendored-omp/src/ast_53.ml | 207 ++++++++ src/vendored-omp/src/caml_format_doc.cppo.ml | 486 ++++++++++++++++++ src/vendored-omp/src/config/gen.ml | 1 + src/vendored-omp/src/dune | 6 + src/vendored-omp/src/locations.ml | 21 +- .../src/migrate_parsetree_52_53.ml | 1 + .../src/migrate_parsetree_52_53_migrate.ml | 382 ++++++++++++++ .../src/migrate_parsetree_53_52.ml | 1 + .../src/migrate_parsetree_53_52_migrate.ml | 387 ++++++++++++++ .../src/migrate_parsetree_versions.ml | 10 + .../src/migrate_parsetree_versions.mli | 2 + src/vendored-omp/tools/dune | 4 +- src/vendored-omp/tools/gencopy.ml | 45 +- test/lib/outcometreePrinter.cppo.ml | 13 +- 17 files changed, 1561 insertions(+), 49 deletions(-) rename rtop/{reason_utop.ml => reason_utop.cppo.ml} (85%) create mode 100644 src/vendored-omp/src/ast_53.ml create mode 100644 src/vendored-omp/src/caml_format_doc.cppo.ml create mode 100644 src/vendored-omp/src/migrate_parsetree_52_53.ml create mode 100644 src/vendored-omp/src/migrate_parsetree_52_53_migrate.ml create mode 100644 src/vendored-omp/src/migrate_parsetree_53_52.ml create mode 100644 src/vendored-omp/src/migrate_parsetree_53_52_migrate.ml diff --git a/rtop/dune b/rtop/dune index a4d0a88e1..45431d1d4 100644 --- a/rtop/dune +++ b/rtop/dune @@ -17,6 +17,12 @@ (action (run cppo -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) +(rule + (targets reason_utop.ml) + (deps reason_utop.cppo.ml) + (action + (run cppo -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) + (executable (name rtop) (public_name rtop) diff --git a/rtop/reason_utop.ml b/rtop/reason_utop.cppo.ml similarity index 85% rename from rtop/reason_utop.ml rename to rtop/reason_utop.cppo.ml index f3fc02fd1..76c4aa064 100644 --- a/rtop/reason_utop.ml +++ b/rtop/reason_utop.cppo.ml @@ -64,19 +64,31 @@ let init_reason () = (* Printing in Reason syntax *) let open Reason_toolchain.From_current in - let wrap f g fmt x = g fmt (f x) in + let wrap f g fmt x = + g fmt (f x) + in +#if OCAML_VERSION >= (5,3,0) + let wrap_doc f g fmt x = + let doc_f = + Format_doc.deprecated_printer (fun fmt -> Format.fprintf fmt "%a" g (f x)) + in + doc_f fmt +#else + let wrap_doc = wrap +#endif + in Toploop.print_out_value := wrap copy_out_value Reason_oprint.print_out_value; - Toploop.print_out_type := wrap copy_out_type Reason_oprint.print_out_type; + Toploop.print_out_type := wrap_doc copy_out_type Reason_oprint.print_out_type; Toploop.print_out_class_type := - wrap copy_out_class_type Reason_oprint.print_out_class_type; + wrap_doc copy_out_class_type Reason_oprint.print_out_class_type; Toploop.print_out_module_type := - wrap copy_out_module_type Reason_oprint.print_out_module_type; + wrap_doc copy_out_module_type Reason_oprint.print_out_module_type; Toploop.print_out_type_extension := - wrap copy_out_type_extension Reason_oprint.print_out_type_extension; + wrap_doc copy_out_type_extension Reason_oprint.print_out_type_extension; Toploop.print_out_sig_item := - wrap copy_out_sig_item Reason_oprint.print_out_sig_item; + wrap_doc copy_out_sig_item Reason_oprint.print_out_sig_item; Toploop.print_out_signature := - wrap (List.map copy_out_sig_item) Reason_oprint.print_out_signature; + wrap_doc (List.map copy_out_sig_item) Reason_oprint.print_out_signature; Toploop.print_out_phrase := wrap copy_out_phrase Reason_oprint.print_out_phrase; let current_show_fn = diff --git a/src/reason-parser/ocaml_util.cppo.ml b/src/reason-parser/ocaml_util.cppo.ml index ab7aa25c7..89f640210 100644 --- a/src/reason-parser/ocaml_util.cppo.ml +++ b/src/reason-parser/ocaml_util.cppo.ml @@ -12,7 +12,17 @@ let print_loc ppf loc = let print_error loc f ppf x = -#if OCAML_VERSION >= (4,8,0) +#if OCAML_VERSION >= (5,3,0) + let error = + let f (fmt: Format_doc.formatter) err = + let doc_f = + Format_doc.deprecated_printer (fun fmt -> Format.fprintf fmt "%a" f err) + in + doc_f fmt + in + Location.error_of_printer ~loc f x in + Location.print_report ppf error +#elif OCAML_VERSION >= (4,8,0) let error = Location.error_of_printer ~loc f x in Location.print_report ppf error #else diff --git a/src/vendored-omp/src/ast_53.ml b/src/vendored-omp/src/ast_53.ml new file mode 100644 index 000000000..95cba9c39 --- /dev/null +++ b/src/vendored-omp/src/ast_53.ml @@ -0,0 +1,207 @@ +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.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 (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive + + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto + + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public + + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable + + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete + + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh + + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open + + type label = string + + type arg_label (*IF_CURRENT = Asttypes.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 (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | NoVariance + + type injectivity (*IF_CURRENT = Asttypes.injectivity *) = + | Injective + | NoInjectivity +end + +module Type_immediacy = struct + type t (*IF_CURRENT = Type_immediacy.t *) = + | Unknown + | Always + | Always_on_64bits +end + +module Outcometree = struct + (* Module [Outcometree]: results displayed by the toplevel *) + + (* These types represent messages that the toplevel displays as normal + results or errors. The real displaying is customisable using the hooks: + [Toploop.print_out_value] + [Toploop.print_out_type] + [Toploop.print_out_sig_item] + [Toploop.print_out_phrase] *) + + (** An [out_name] is a string representation of an identifier which can be + rewritten on the fly to avoid name collisions *) + type out_name (*IF_CURRENT = Outcometree.out_name *) = { mutable printed_name: string } + + type out_ident (*IF_CURRENT = Outcometree.out_ident *) = + | Oide_apply of out_ident * out_ident + | Oide_dot of out_ident * string + | Oide_ident of out_name + + type out_string (*IF_CURRENT = Outcometree.out_string *) = + | Ostr_string + | Ostr_bytes + + type out_attribute (*IF_CURRENT = Outcometree.out_attribute *) = + { oattr_name: string } + + type out_value (*IF_CURRENT = Outcometree.out_value *) = + | Oval_array of out_value list + | Oval_char of char + | Oval_constr of out_ident * out_value list + | Oval_ellipsis + | Oval_float of float + | Oval_int of int + | Oval_int32 of int32 + | Oval_int64 of int64 + | Oval_nativeint of nativeint + | Oval_list of out_value list + | Oval_printer of (Caml_format_doc.formatter -> unit) + | Oval_record of (out_ident * out_value) list + | Oval_string of string * int * out_string (* string, size-to-print, kind *) + | Oval_stuff of string + | Oval_tuple of out_value list + | Oval_variant of string * out_value option + | Oval_lazy of out_value + + type out_type_param (*IF_CURRENT = Outcometree.out_type_param *) = { + ot_non_gen: bool; + ot_name: string; + ot_variance: Asttypes.variance * Asttypes.injectivity + } + + type out_type (*IF_CURRENT = Outcometree.out_type *) = + | Otyp_abstract + | Otyp_open + | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} + | Otyp_arrow of Asttypes.arg_label * out_type * out_type + | Otyp_class of out_ident * out_type list + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of { fields: (string * out_type) list; open_row:bool} + | Otyp_record of out_label list + | Otyp_stuff of string + | Otyp_sum of out_constructor list + | Otyp_tuple of out_type list + | Otyp_var of bool * string + | Otyp_variant of out_variant * bool * (string list) option + | Otyp_poly of string list * out_type + | Otyp_module of out_ident * (string * out_type) list + | Otyp_attribute of out_type * out_attribute + + and out_label (*IF_CURRENT = Outcometree.out_label *) = { + olab_name: string; + olab_mut: Asttypes.mutable_flag; + olab_type: out_type; + } + + and out_constructor (*IF_CURRENT = Outcometree.out_constructor *) = { + ocstr_name: string; + ocstr_args: out_type list; + ocstr_return_type: out_type option; + } + + and out_variant (*IF_CURRENT = Outcometree.out_variant *) = + | Ovar_fields of (string * bool * out_type list) list + | Ovar_typ of out_type + + type out_class_type (*IF_CURRENT = Outcometree.out_class_type *) = + | Octy_constr of out_ident * out_type list + | Octy_arrow of Asttypes.arg_label * out_type * out_class_type + | Octy_signature of out_type option * out_class_sig_item list + and out_class_sig_item (*IF_CURRENT = Outcometree.out_class_sig_item *) = + | Ocsg_constraint of out_type * out_type + | Ocsg_method of string * bool * bool * out_type + | Ocsg_value of string * bool * bool * out_type + + type out_module_type (*IF_CURRENT = Outcometree.out_module_type *) = + | Omty_abstract + | Omty_functor of (string option * out_module_type) option * out_module_type + | Omty_ident of out_ident + | Omty_signature of out_sig_item list + | Omty_alias of out_ident + and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) = + | Osig_class of + bool * string * out_type_param list * out_class_type * + out_rec_status + | Osig_class_type of + bool * string * out_type_param list * out_class_type * + out_rec_status + | Osig_typext of out_extension_constructor * out_ext_status + | Osig_modtype of string * out_module_type + | Osig_module of string * out_module_type * out_rec_status + | Osig_type of out_type_decl * out_rec_status + | Osig_value of out_val_decl + | Osig_ellipsis + and out_type_decl (*IF_CURRENT = Outcometree.out_type_decl *) = + { otype_name: string; + otype_params: out_type_param list; + otype_type: out_type; + otype_private: Asttypes.private_flag; + otype_immediate: Type_immediacy.t; + otype_unboxed: bool; + otype_cstrs: (out_type * out_type) list } + and out_extension_constructor (*IF_CURRENT = Outcometree.out_extension_constructor *) = + { oext_name: string; + oext_type_name: string; + oext_type_params: string list; + oext_args: out_type list; + oext_ret_type: out_type option; + oext_private: Asttypes.private_flag } + and out_type_extension (*IF_CURRENT = Outcometree.out_type_extension *) = + { otyext_name: string; + otyext_params: string list; + otyext_constructors: out_constructor list; + otyext_private: Asttypes.private_flag } + and out_val_decl (*IF_CURRENT = Outcometree.out_val_decl *) = + { oval_name: string; + oval_type: out_type; + oval_prims: string list; + oval_attributes: out_attribute list } + and out_rec_status (*IF_CURRENT = Outcometree.out_rec_status *) = + | Orec_not + | Orec_first + | Orec_next + and out_ext_status (*IF_CURRENT = Outcometree.out_ext_status *) = + | Oext_first + | Oext_next + | Oext_exception + + type out_phrase (*IF_CURRENT = Outcometree.out_phrase *) = + | Ophr_eval of out_value * out_type + | Ophr_signature of (out_sig_item * out_value option) list + | Ophr_exception of (exn * out_value) +end diff --git a/src/vendored-omp/src/caml_format_doc.cppo.ml b/src/vendored-omp/src/caml_format_doc.cppo.ml new file mode 100644 index 000000000..5394b227b --- /dev/null +++ b/src/vendored-omp/src/caml_format_doc.cppo.ml @@ -0,0 +1,486 @@ +#if OCAML_VERSION >= (5,3,0) +include Format_doc + +#else +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 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. *) +(* *) +(**************************************************************************) + +module Doc = struct + + type box_type = + | H + | V + | HV + | HoV + | B + + type stag = Format.stag + + type element = + | Text of string + | With_size of int + | Open_box of { kind: box_type ; indent:int } + | Close_box + | Open_tag of Format.stag + | Close_tag + | Open_tbox + | Tab_break of { width : int; offset : int } + | Set_tab + | Close_tbox + | Simple_break of { spaces : int; indent: int } + | Break of { fits : string * int * string as 'a; breaks : 'a } + | Flush of { newline:bool } + | Newline + | If_newline + + | Deprecated of (Format.formatter -> unit) + + type t = { rev:element list } [@@unboxed] + + let empty = { rev = [] } + + let to_list doc = List.rev doc.rev + let add doc x = { rev = x :: doc.rev } + let fold f acc doc = List.fold_left f acc (to_list doc) + let append left right = { rev = right.rev @ left.rev } + + let format_open_box_gen ppf kind indent = + match kind with + | H-> Format.pp_open_hbox ppf () + | V -> Format.pp_open_vbox ppf indent + | HV -> Format.pp_open_hvbox ppf indent + | HoV -> Format.pp_open_hovbox ppf indent + | B -> Format.pp_open_box ppf indent + + let interpret_elt ppf = function + | Text x -> Format.pp_print_string ppf x + | Open_box { kind; indent } -> format_open_box_gen ppf kind indent + | Close_box -> Format.pp_close_box ppf () + | Open_tag tag -> Format.pp_open_stag ppf tag + | Close_tag -> Format.pp_close_stag ppf () + | Open_tbox -> Format.pp_open_tbox ppf () + | Tab_break {width;offset} -> Format.pp_print_tbreak ppf width offset + | Set_tab -> Format.pp_set_tab ppf () + | Close_tbox -> Format.pp_close_tbox ppf () + | Simple_break {spaces;indent} -> Format.pp_print_break ppf spaces indent + | Break {fits;breaks} -> Format.pp_print_custom_break ppf ~fits ~breaks + | Flush {newline=true} -> Format.pp_print_newline ppf () + | Flush {newline=false} -> Format.pp_print_flush ppf () + | Newline -> Format.pp_force_newline ppf () + | If_newline -> Format.pp_print_if_newline ppf () + | With_size _ -> () + | Deprecated pr -> pr ppf + + let rec interpret ppf = function + | [] -> () + | With_size size :: Text text :: l -> + Format.pp_print_as ppf size text; + interpret ppf l + | x :: l -> + interpret_elt ppf x; + interpret ppf l + + let format ppf doc = interpret ppf (to_list doc) + + + + let open_box kind indent doc = add doc (Open_box {kind;indent}) + let close_box doc = add doc Close_box + + let string s doc = add doc (Text s) + let bytes b doc = add doc (Text (Bytes.to_string b)) + let with_size size doc = add doc (With_size size) + + let int n doc = add doc (Text (string_of_int n)) + let float f doc = add doc (Text (string_of_float f)) + let char c doc = add doc (Text (String.make 1 c)) + let bool c doc = add doc (Text (Bool.to_string c)) + + let break ~spaces ~indent doc = add doc (Simple_break {spaces; indent}) + let space doc = break ~spaces:1 ~indent:0 doc + let cut = break ~spaces:0 ~indent:0 + + let custom_break ~fits ~breaks doc = add doc (Break {fits;breaks}) + + let force_newline doc = add doc Newline + let if_newline doc = add doc If_newline + + let flush doc = add doc (Flush {newline=false}) + let force_stop doc = add doc (Flush {newline=true}) + + let open_tbox doc = add doc Open_tbox + let set_tab doc = add doc Set_tab + let tab_break ~width ~offset doc = add doc (Tab_break {width;offset}) + let tab doc = tab_break ~width:0 ~offset:0 doc + let close_tbox doc = add doc Close_tbox + + let open_tag stag doc = add doc (Open_tag stag) + let close_tag doc = add doc Close_tag + + let iter ?(sep=Fun.id) ~iter:iterator elt l doc = + let first = ref true in + let rdoc = ref doc in + let print x = + if !first then (first := false; rdoc := elt x !rdoc) + else rdoc := !rdoc |> sep |> elt x + in + iterator print l; + !rdoc + + let rec list ?(sep=Fun.id) elt l doc = match l with + | [] -> doc + | [a] -> elt a doc + | a :: ((_ :: _) as q) -> + doc |> elt a |> sep |> list ~sep elt q + + let array ?sep elt a doc = iter ?sep ~iter:Array.iter elt a doc + let seq ?sep elt s doc = iter ?sep ~iter:Seq.iter elt s doc + + let option ?(none=Fun.id) elt o doc = match o with + | None -> none doc + | Some x -> elt x doc + + let either ~left ~right x doc = match x with + | Either.Left x -> left x doc + | Either.Right x -> right x doc + + let result ~ok ~error x doc = match x with + | Ok x -> ok x doc + | Error x -> error x doc + + (* To format free-flowing text *) + let rec subtext len left right s doc = + let flush doc = + doc |> string (String.sub s left (right - left)) + in + let after_flush doc = subtext len (right+1) (right+1) s doc in + if right = len then + if left <> len then flush doc else doc + else + match s.[right] with + | '\n' -> + doc |> flush |> force_newline |> after_flush + | ' ' -> + doc |> flush |> space |> after_flush + (* there is no specific support for '\t' + as it is unclear what a right semantics would be *) + | _ -> subtext len left (right + 1) s doc + + let text s doc = + subtext (String.length s) 0 0 s doc + + type ('a,'b) fmt = ('a, t, t, 'b) format4 + type printer0 = t -> t + type 'a printer = 'a -> printer0 + + let output_formatting_lit fmting_lit doc = + let open CamlinternalFormatBasics in + match fmting_lit with + | Close_box -> close_box doc + | Close_tag -> close_tag doc + | Break (_, width, offset) -> break ~spaces:width ~indent:offset doc + | FFlush -> flush doc + | Force_newline -> force_newline doc + | Flush_newline -> force_stop doc + | Magic_size (_, n) -> with_size n doc + | Escaped_at -> char '@' doc + | Escaped_percent -> char '%' doc + | Scan_indic c -> doc |> char '@' |> char c + + let to_string doc = + let b = Buffer.create 20 in + let convert = function + | Text s -> Buffer.add_string b s + | _ -> () + in + fold (fun () x -> convert x) () doc; + Buffer.contents b + + let box_type = + let open CamlinternalFormatBasics in + function + | Pp_fits -> H + | Pp_hbox -> H + | Pp_vbox -> V + | Pp_hovbox -> HoV + | Pp_hvbox -> HV + | Pp_box -> B + + let rec compose_acc acc doc = + let open CamlinternalFormat in + match acc with + | CamlinternalFormat.Acc_formatting_lit (p, f) -> + doc |> compose_acc p |> output_formatting_lit f + | Acc_formatting_gen (p, Acc_open_tag acc') -> + let tag = to_string (compose_acc acc' empty) in + let doc = compose_acc p doc in + doc |> open_tag (Format.String_tag tag) + | Acc_formatting_gen (p, Acc_open_box acc') -> + let doc = compose_acc p doc in + let box = to_string (compose_acc acc' empty) in + let (indent, bty) = CamlinternalFormat.open_box_of_string box in + doc |> open_box (box_type bty) indent + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> + doc |> compose_acc p |> string s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> doc |> compose_acc p |> char c + | Acc_delay (p, f) -> doc |> compose_acc p |> f + | Acc_flush p -> doc |> compose_acc p |> flush + | Acc_invalid_arg (_p, msg) -> invalid_arg msg; + | End_of_acc -> doc + + let kprintf k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc doc -> doc |> compose_acc acc |> k ) + End_of_acc fmt + + let printf doc = kprintf Fun.id doc + let kmsg k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> k (compose_acc acc empty)) + End_of_acc fmt + + let msg fmt = kmsg Fun.id fmt + +end + +(** Compatibility interface *) + +type doc = Doc.t +type t = doc +type formatter = doc ref +type 'a printer = formatter -> 'a -> unit + +let formatter d = d + +(** {1 Primitive functions }*) + +let pp_print_string ppf s = ppf := Doc.string s !ppf + +let pp_print_as ppf size s = + ppf := !ppf |> Doc.with_size size |> Doc.string s + +let pp_print_substring ~pos ~len ppf s = + ppf := Doc.string (String.sub s pos len) !ppf + +let pp_print_substring_as ~pos ~len ppf size s = + ppf := + !ppf + |> Doc.with_size size + |> Doc.string (String.sub s pos len) + +let pp_print_bytes ppf s = ppf := Doc.string (Bytes.to_string s) !ppf +let pp_print_text ppf s = ppf := Doc.text s !ppf +let pp_print_char ppf c = ppf := Doc.char c !ppf +let pp_print_int ppf c = ppf := Doc.int c !ppf +let pp_print_float ppf f = ppf := Doc.float f !ppf +let pp_print_bool ppf b = ppf := Doc.bool b !ppf +let pp_print_nothing _ _ = () + +let pp_close_box ppf () = ppf := Doc.close_box !ppf +let pp_close_stag ppf () = ppf := Doc.close_tag !ppf + +let pp_print_break ppf spaces indent = ppf := Doc.break ~spaces ~indent !ppf + +let pp_print_custom_break ppf ~fits ~breaks = + ppf := Doc.custom_break ~fits ~breaks !ppf + +let pp_print_space ppf () = pp_print_break ppf 1 0 +let pp_print_cut ppf () = pp_print_break ppf 0 0 + +let pp_print_flush ppf () = ppf := Doc.flush !ppf +let pp_force_newline ppf () = ppf := Doc.force_newline !ppf +let pp_print_newline ppf () = ppf := Doc.force_stop !ppf +let pp_print_if_newline ppf () =ppf := Doc.if_newline !ppf + +let pp_open_stag ppf stag = ppf := !ppf |> Doc.open_tag stag + +let pp_open_box_gen ppf indent bxty = + let box_type = Doc.box_type bxty in + ppf := !ppf |> Doc.open_box box_type indent + +let pp_open_box ppf indent = pp_open_box_gen ppf indent Pp_box + + +let pp_open_tbox ppf () = ppf := !ppf |> Doc.open_tbox + +let pp_close_tbox ppf () = ppf := !ppf |> Doc.close_tbox + +let pp_set_tab ppf () = ppf := !ppf |> Doc.set_tab + +let pp_print_tab ppf () = ppf := !ppf |> Doc.tab + +let pp_print_tbreak ppf width offset = + ppf := !ppf |> Doc.tab_break ~width ~offset + +let pp_doc ppf doc = ppf := Doc.append !ppf doc + +module Driver = struct + (* Interpret a formatting entity on a formatter. *) + let output_formatting_lit ppf + (fmting_lit:CamlinternalFormatBasics.formatting_lit) + = match fmting_lit with + | Close_box -> pp_close_box ppf () + | Close_tag -> pp_close_stag ppf () + | Break (_, width, offset) -> pp_print_break ppf width offset + | FFlush -> pp_print_flush ppf () + | Force_newline -> pp_force_newline ppf () + | Flush_newline -> pp_print_newline ppf () + | Magic_size (_, _) -> () + | Escaped_at -> pp_print_char ppf '@' + | Escaped_percent -> pp_print_char ppf '%' + | Scan_indic c -> pp_print_char ppf '@'; pp_print_char ppf c + + + + let compute_tag output tag_acc = + let buf = Buffer.create 16 in + let buf_fmt = Format.formatter_of_buffer buf in + let ppf = ref Doc.empty in + output ppf tag_acc; + pp_print_flush ppf (); + Doc.format buf_fmt !ppf; + let len = Buffer.length buf in + if len < 2 then Buffer.contents buf + else Buffer.sub buf 1 (len - 2) + + (* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in an output_stream. *) + (* Differ from Printf.output_acc by the interpretation of formatting. *) + (* Used as a continuation of CamlinternalFormat.make_printf. *) + let rec output_acc ppf (acc: _ CamlinternalFormat.acc) = + match acc with + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + output_acc ppf p; + pp_print_as ppf size s; + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + output_acc ppf p; + pp_print_as ppf size (String.make 1 c); + | Acc_formatting_lit (p, f) -> + output_acc ppf p; + output_formatting_lit ppf f; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + output_acc ppf p; + pp_open_stag ppf (Format.String_tag (compute_tag output_acc acc')) + | Acc_formatting_gen (p, Acc_open_box acc') -> + output_acc ppf p; + let (indent, bty) = + let box_info = compute_tag output_acc acc' in + CamlinternalFormat.open_box_of_string box_info + in + pp_open_box_gen ppf indent bty + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c; + | Acc_delay (p, f) -> output_acc ppf p; f ppf; + | Acc_flush p -> output_acc ppf p; pp_print_flush ppf (); + | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg; + | End_of_acc -> () +end + +let kfprintf k ppf (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> Driver.output_acc ppf acc; k ppf) + End_of_acc fmt +let fprintf doc fmt = kfprintf ignore doc fmt + + +let kdprintf k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> k (fun ppf -> Driver.output_acc ppf acc)) + End_of_acc fmt + +let dprintf fmt = kdprintf (fun i -> i) fmt + +let doc_printf fmt = + let ppf = ref Doc.empty in + kfprintf (fun _ -> let doc = !ppf in ppf := Doc.empty; doc) ppf fmt + +let kdoc_printf k fmt = + let ppf = ref Doc.empty in + kfprintf (fun ppf -> + let doc = !ppf in + ppf := Doc.empty; + k doc + ) + ppf fmt + +let doc_printer f x doc = + let r = ref doc in + f r x; + !r + +type 'a format_printer = Format.formatter -> 'a -> unit + +let format_printer f ppf x = + let doc = doc_printer f x Doc.empty in + Doc.format ppf doc +let compat = format_printer +let compat1 f p1 = compat (f p1) +let compat2 f p1 p2 = compat (f p1 p2) + +let kasprintf k fmt = + kdoc_printf (fun doc -> k (Format.asprintf "%a" Doc.format doc)) fmt +let asprintf fmt = kasprintf Fun.id fmt + +let pp_print_iter ?(pp_sep=pp_print_cut) iter elt ppf c = + let sep = doc_printer pp_sep () in + ppf:= Doc.iter ~sep ~iter (doc_printer elt) c !ppf + +let pp_print_list ?(pp_sep=pp_print_cut) elt ppf l = + ppf := Doc.list ~sep:(doc_printer pp_sep ()) (doc_printer elt) l !ppf + +let pp_print_array ?pp_sep elt ppf a = + pp_print_iter ?pp_sep Array.iter elt ppf a +let pp_print_seq ?pp_sep elt ppf s = pp_print_iter ?pp_sep Seq.iter elt ppf s + +let pp_print_option ?(none=fun _ () -> ()) elt ppf o = + ppf := Doc.option ~none:(doc_printer none ()) (doc_printer elt) o !ppf + +let pp_print_result ~ok ~error ppf r = + ppf := Doc.result ~ok:(doc_printer ok) ~error:(doc_printer error) r !ppf + +let pp_print_either ~left ~right ppf e = + ppf := Doc.either ~left:(doc_printer left) ~right:(doc_printer right) e !ppf + +let comma ppf () = fprintf ppf ",@ " + +let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = + let left_column_size = + List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in + let lines_nb = List.length lines in + let ellipsed_first, ellipsed_last = + match max_lines with + | Some max_lines when lines_nb > max_lines -> + let printed_lines = max_lines - 1 in (* the ellipsis uses one line *) + let lines_before = printed_lines / 2 + printed_lines mod 2 in + let lines_after = printed_lines / 2 in + (lines_before, lines_nb - lines_after - 1) + | _ -> (-1, -1) + in + fprintf ppf "@["; + List.iteri (fun k (line_l, line_r) -> + if k = ellipsed_first then fprintf ppf "...@,"; + if ellipsed_first <= k && k <= ellipsed_last then () + else fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r + ) lines; + fprintf ppf "@]" + +let deprecated_printer pr ppf = ppf := Doc.add !ppf (Doc.Deprecated pr) +#endif diff --git a/src/vendored-omp/src/config/gen.ml b/src/vendored-omp/src/config/gen.ml index 4922a5b0a..8e66db1be 100644 --- a/src/vendored-omp/src/config/gen.ml +++ b/src/vendored-omp/src/config/gen.ml @@ -26,6 +26,7 @@ let () = | (5, 0) -> "500" | (5, 1) -> "51" | (5, 2) -> "52" + | (5, 3) -> "53" | _ -> Printf.eprintf "Unknown OCaml version %s\n" ocaml_version_str; exit 1); diff --git a/src/vendored-omp/src/dune b/src/vendored-omp/src/dune index 078482fee..442c5c634 100644 --- a/src/vendored-omp/src/dune +++ b/src/vendored-omp/src/dune @@ -18,6 +18,12 @@ ; (lint_flags --null)) ) +(rule + (targets caml_format_doc.ml) + (deps caml_format_doc.cppo.ml) + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) + ; Not needed for reason repo (vendored) ; (library ; (name reason.migrate_parsetree_driver_main) diff --git a/src/vendored-omp/src/locations.ml b/src/vendored-omp/src/locations.ml index 24afce5fb..14880558d 100644 --- a/src/vendored-omp/src/locations.ml +++ b/src/vendored-omp/src/locations.ml @@ -5,7 +5,9 @@ type old_location_error (*IF_NOT_AT_LEAST 408 = Location.error *) = { if_highlight: string; } -type location_msg = (Format.formatter -> unit) Location.loc +type location_msg = + (*IF_AT_LEAST 53 Format_doc.t Location.loc *) + (*IF_NOT_AT_LEAST 53 (Format.formatter -> unit) Location.loc *) type location_report_kind (*IF_AT_LEAST 408 = Location.report_kind *) = | Report_error @@ -18,6 +20,7 @@ type location_report (*IF_AT_LEAST 408 = Location.report *) = { kind : location_report_kind; main : location_msg; sub : location_msg list; + (*IF_AT_LEAST 53 footnote: Format_doc.t option *) } type location_error (*IF_AT_LEAST 408 = Location.error *) (*IF_NOT_AT_LEAST 408 = old_location_error *) @@ -44,7 +47,8 @@ let extension_of_error ~mk_pstr ~mk_extension ~mk_string_constant (error : locat let extension_of_report ({kind; main; sub} : location_report) = if kind <> Report_error then raise (Invalid_argument "extension_of_error: expected kind Report_error"); - let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in + (*IF_AT_LEAST 53 let str_of_pp pp_msg = Format.asprintf "%a" Format_doc.Doc.format pp_msg in *) + (*IF_NOT_AT_LEAST 53 let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in *) let extension_of_sub (sub : location_msg) = { Location.loc = sub.loc; txt = "ocaml.error" }, mk_pstr ([mk_string_constant (str_of_pp sub.txt)]) @@ -71,7 +75,8 @@ let _get_error_message_old location_error = let _get_error_message_new location_error = let buff = Buffer.create 128 in let ppf = Format.formatter_of_buffer buff in - location_error.main.txt ppf; + (*IF_AT_LEAST 53 Format_doc.Doc.format ppf location_error.main.txt; *) + (*IF_NOT_AT_LEAST 53 location_error.main.txt ppf; *) Format.pp_print_flush ppf (); Buffer.contents buff @@ -83,7 +88,8 @@ let _set_error_message_old location_error msg = { location_error with msg; } let _set_error_message_new location_error msg = - let txt ppf = Format.pp_print_string ppf msg in + (*IF_AT_LEAST 53 let txt = Format_doc.Doc.msg "%s" msg in *) + (*IF_NOT_AT_LEAST 53 let txt ppf = Format.pp_print_string ppf msg in *) let main = { location_error.main with txt; } in { location_error with main } @@ -96,11 +102,14 @@ let make_error_of_message_old ~loc msg ~sub = { loc; msg; sub; if_highlight = msg; } let make_error_of_message_new ~loc msg ~sub = - let mk_txt x ppf = Format.pp_print_string ppf x in + (*IF_AT_LEAST 53 let mk_txt x = Format_doc.Doc.msg "%s" x in *) + (*IF_NOT_AT_LEAST 53 let mk_txt x ppf = Format.pp_print_string ppf x in *) let mk loc x = { Location.loc; txt = mk_txt x; } in { kind = Report_error; main = mk loc msg; - sub = List.map (fun (loc, msg) -> mk loc msg) sub; } + sub = List.map (fun (loc, msg) -> mk loc msg) sub; + (*IF_AT_LEAST 53 footnote = None *) + } let make_error_of_message ~loc msg ~sub = (*IF_NOT_AT_LEAST 408 make_error_of_message_old ~loc msg ~sub*) diff --git a/src/vendored-omp/src/migrate_parsetree_52_53.ml b/src/vendored-omp/src/migrate_parsetree_52_53.ml new file mode 100644 index 000000000..61a90c796 --- /dev/null +++ b/src/vendored-omp/src/migrate_parsetree_52_53.ml @@ -0,0 +1 @@ +include Migrate_parsetree_52_53_migrate diff --git a/src/vendored-omp/src/migrate_parsetree_52_53_migrate.ml b/src/vendored-omp/src/migrate_parsetree_52_53_migrate.ml new file mode 100644 index 000000000..0cab7d9f2 --- /dev/null +++ b/src/vendored-omp/src/migrate_parsetree_52_53_migrate.ml @@ -0,0 +1,382 @@ +module From = Ast_52 +module To = Ast_53 +let rec (copy_out_type_extension : + Ast_52.Outcometree.out_type_extension -> + Ast_53.Outcometree.out_type_extension) + = + fun + { Ast_52.Outcometree.otyext_name = otyext_name; + Ast_52.Outcometree.otyext_params = otyext_params; + Ast_52.Outcometree.otyext_constructors = otyext_constructors; + Ast_52.Outcometree.otyext_private = otyext_private } + -> + { + Ast_53.Outcometree.otyext_name = otyext_name; + Ast_53.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_53.Outcometree.otyext_constructors = + (List.map (fun x -> copy_out_constructor x) otyext_constructors); + Ast_53.Outcometree.otyext_private = (copy_private_flag otyext_private) + } +and (copy_out_phrase : + Ast_52.Outcometree.out_phrase -> Ast_53.Outcometree.out_phrase) + = + function + | Ast_52.Outcometree.Ophr_eval (x0, x1) -> + Ast_53.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_52.Outcometree.Ophr_signature x0 -> + Ast_53.Outcometree.Ophr_signature + (List.map + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), + (Option.map (fun x -> copy_out_value x) x1))) x0) + | Ast_52.Outcometree.Ophr_exception x0 -> + Ast_53.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) +and (copy_out_sig_item : + Ast_52.Outcometree.out_sig_item -> Ast_53.Outcometree.out_sig_item) + = + function + | Ast_52.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_53.Outcometree.Osig_class + (x0, x1, (List.map (fun x -> copy_out_type_param x) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_52.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_53.Outcometree.Osig_class_type + (x0, x1, (List.map (fun x -> copy_out_type_param x) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_52.Outcometree.Osig_typext (x0, x1) -> + Ast_53.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_52.Outcometree.Osig_modtype (x0, x1) -> + Ast_53.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_52.Outcometree.Osig_module (x0, x1, x2) -> + Ast_53.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_52.Outcometree.Osig_type (x0, x1) -> + Ast_53.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_52.Outcometree.Osig_value x0 -> + Ast_53.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_52.Outcometree.Osig_ellipsis -> Ast_53.Outcometree.Osig_ellipsis +and (copy_out_val_decl : + Ast_52.Outcometree.out_val_decl -> Ast_53.Outcometree.out_val_decl) + = + fun + { Ast_52.Outcometree.oval_name = oval_name; + Ast_52.Outcometree.oval_type = oval_type; + Ast_52.Outcometree.oval_prims = oval_prims; + Ast_52.Outcometree.oval_attributes = oval_attributes } + -> + { + Ast_53.Outcometree.oval_name = oval_name; + Ast_53.Outcometree.oval_type = (copy_out_type oval_type); + Ast_53.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_53.Outcometree.oval_attributes = + (List.map (fun x -> copy_out_attribute x) oval_attributes) + } +and (copy_out_type_decl : + Ast_52.Outcometree.out_type_decl -> Ast_53.Outcometree.out_type_decl) + = + fun + { Ast_52.Outcometree.otype_name = otype_name; + Ast_52.Outcometree.otype_params = otype_params; + Ast_52.Outcometree.otype_type = otype_type; + Ast_52.Outcometree.otype_private = otype_private; + Ast_52.Outcometree.otype_immediate = otype_immediate; + Ast_52.Outcometree.otype_unboxed = otype_unboxed; + Ast_52.Outcometree.otype_cstrs = otype_cstrs } + -> + { + Ast_53.Outcometree.otype_name = otype_name; + Ast_53.Outcometree.otype_params = + (List.map (fun x -> copy_out_type_param x) otype_params); + Ast_53.Outcometree.otype_type = (copy_out_type otype_type); + Ast_53.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_53.Outcometree.otype_immediate = + (copy_Type_immediacy_t otype_immediate); + Ast_53.Outcometree.otype_unboxed = otype_unboxed; + Ast_53.Outcometree.otype_cstrs = + (List.map + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) + } +and (copy_Type_immediacy_t : + Ast_52.Type_immediacy.t -> Ast_53.Type_immediacy.t) + = + function + | Ast_52.Type_immediacy.Unknown -> Ast_53.Type_immediacy.Unknown + | Ast_52.Type_immediacy.Always -> Ast_53.Type_immediacy.Always + | Ast_52.Type_immediacy.Always_on_64bits -> + Ast_53.Type_immediacy.Always_on_64bits +and (copy_out_module_type : + Ast_52.Outcometree.out_module_type -> + Ast_53.Outcometree.out_module_type) + = + function + | Ast_52.Outcometree.Omty_abstract -> Ast_53.Outcometree.Omty_abstract + | Ast_52.Outcometree.Omty_functor (x0, x1) -> + Ast_53.Outcometree.Omty_functor + ((Option.map + (fun x -> + let (x0, x1) = x in + ((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0), + (copy_out_module_type x1)) + | Ast_52.Outcometree.Omty_ident x0 -> + Ast_53.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_52.Outcometree.Omty_signature x0 -> + Ast_53.Outcometree.Omty_signature + (List.map (fun x -> copy_out_sig_item x) x0) + | Ast_52.Outcometree.Omty_alias x0 -> + Ast_53.Outcometree.Omty_alias (copy_out_ident x0) +and (copy_out_ext_status : + Ast_52.Outcometree.out_ext_status -> Ast_53.Outcometree.out_ext_status) + = + function + | Ast_52.Outcometree.Oext_first -> Ast_53.Outcometree.Oext_first + | Ast_52.Outcometree.Oext_next -> Ast_53.Outcometree.Oext_next + | Ast_52.Outcometree.Oext_exception -> Ast_53.Outcometree.Oext_exception +and (copy_out_extension_constructor : + Ast_52.Outcometree.out_extension_constructor -> + Ast_53.Outcometree.out_extension_constructor) + = + fun + { Ast_52.Outcometree.oext_name = oext_name; + Ast_52.Outcometree.oext_type_name = oext_type_name; + Ast_52.Outcometree.oext_type_params = oext_type_params; + Ast_52.Outcometree.oext_args = oext_args; + Ast_52.Outcometree.oext_ret_type = oext_ret_type; + Ast_52.Outcometree.oext_private = oext_private } + -> + { + Ast_53.Outcometree.oext_name = oext_name; + Ast_53.Outcometree.oext_type_name = oext_type_name; + Ast_53.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_53.Outcometree.oext_args = + (List.map (fun x -> copy_out_type x) oext_args); + Ast_53.Outcometree.oext_ret_type = + (Option.map (fun x -> copy_out_type x) oext_ret_type); + Ast_53.Outcometree.oext_private = (copy_private_flag oext_private) + } +and (copy_private_flag : + Ast_52.Asttypes.private_flag -> Ast_53.Asttypes.private_flag) + = + function + | Ast_52.Asttypes.Private -> Ast_53.Asttypes.Private + | Ast_52.Asttypes.Public -> Ast_53.Asttypes.Public +and (copy_out_rec_status : + Ast_52.Outcometree.out_rec_status -> Ast_53.Outcometree.out_rec_status) + = + function + | Ast_52.Outcometree.Orec_not -> Ast_53.Outcometree.Orec_not + | Ast_52.Outcometree.Orec_first -> Ast_53.Outcometree.Orec_first + | Ast_52.Outcometree.Orec_next -> Ast_53.Outcometree.Orec_next +and (copy_out_class_type : + Ast_52.Outcometree.out_class_type -> Ast_53.Outcometree.out_class_type) + = + function + | Ast_52.Outcometree.Octy_constr (x0, x1) -> + Ast_53.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1)) + | Ast_52.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_53.Outcometree.Octy_arrow + ((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2)) + | Ast_52.Outcometree.Octy_signature (x0, x1) -> + Ast_53.Outcometree.Octy_signature + ((Option.map (fun x -> copy_out_type x) x0), + (List.map (fun x -> copy_out_class_sig_item x) x1)) +and (copy_out_class_sig_item : + Ast_52.Outcometree.out_class_sig_item -> + Ast_53.Outcometree.out_class_sig_item) + = + function + | Ast_52.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_53.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_52.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_53.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_52.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_53.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) +and (copy_out_type_param : + Ast_52.Outcometree.out_type_param -> Ast_53.Outcometree.out_type_param) + = + fun + { Ast_52.Outcometree.ot_non_gen = ot_non_gen; + Ast_52.Outcometree.ot_name = ot_name; + Ast_52.Outcometree.ot_variance = ot_variance } + -> + { + Ast_53.Outcometree.ot_non_gen = ot_non_gen; + Ast_53.Outcometree.ot_name = ot_name; + Ast_53.Outcometree.ot_variance = + (let (x0, x1) = ot_variance in + ((copy_variance x0), (copy_injectivity x1))) + } +and (copy_injectivity : + Ast_52.Asttypes.injectivity -> Ast_53.Asttypes.injectivity) + = + function + | Ast_52.Asttypes.Injective -> Ast_53.Asttypes.Injective + | Ast_52.Asttypes.NoInjectivity -> Ast_53.Asttypes.NoInjectivity +and (copy_variance : Ast_52.Asttypes.variance -> Ast_53.Asttypes.variance) = + function + | Ast_52.Asttypes.Covariant -> Ast_53.Asttypes.Covariant + | Ast_52.Asttypes.Contravariant -> Ast_53.Asttypes.Contravariant + | Ast_52.Asttypes.NoVariance -> Ast_53.Asttypes.NoVariance +and (copy_out_type : + Ast_52.Outcometree.out_type -> Ast_53.Outcometree.out_type) + = + function + | Ast_52.Outcometree.Otyp_abstract -> Ast_53.Outcometree.Otyp_abstract + | Ast_52.Outcometree.Otyp_open -> Ast_53.Outcometree.Otyp_open + | Ast_52.Outcometree.Otyp_alias {non_gen; aliased; alias} -> + Ast_53.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type aliased); alias} + | Ast_52.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_53.Outcometree.Otyp_arrow + ((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2)) + | Ast_52.Outcometree.Otyp_class (x0, x1) -> + Ast_53.Outcometree.Otyp_class + ((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1)) + | Ast_52.Outcometree.Otyp_constr (x0, x1) -> + Ast_53.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1)) + | Ast_52.Outcometree.Otyp_manifest (x0, x1) -> + Ast_53.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_52.Outcometree.Otyp_object { fields; open_row } -> + Ast_53.Outcometree.Otyp_object + { fields = + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) + fields)); + open_row } + | Ast_52.Outcometree.Otyp_record x0 -> + Ast_53.Outcometree.Otyp_record + (List.map + (fun x -> let (x0, x1, x2) = x in + { Ast_53.Outcometree.olab_name = x0 + ; olab_mut = if x1 then Mutable else Immutable + ; olab_type = (copy_out_type x2)}) x0) + | Ast_52.Outcometree.Otyp_stuff x0 -> Ast_53.Outcometree.Otyp_stuff x0 + | Ast_52.Outcometree.Otyp_sum x0 -> + Ast_53.Outcometree.Otyp_sum + (List.map (fun x -> copy_out_constructor x) x0) + | Ast_52.Outcometree.Otyp_tuple x0 -> + Ast_53.Outcometree.Otyp_tuple (List.map (fun x -> copy_out_type x) x0) + | Ast_52.Outcometree.Otyp_var (x0, x1) -> + Ast_53.Outcometree.Otyp_var (x0, x1) + | Ast_52.Outcometree.Otyp_variant (x0, x1, x2) -> + Ast_53.Outcometree.Otyp_variant + ((copy_out_variant x0), x1, + (Option.map (fun x -> List.map (fun x -> x) x) x2)) + | Ast_52.Outcometree.Otyp_poly (x0, x1) -> + Ast_53.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_52.Outcometree.Otyp_module (x0, x1) -> + Ast_53.Outcometree.Otyp_module + ((copy_out_ident x0), + (List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) + x1)) + | Ast_52.Outcometree.Otyp_attribute (x0, x1) -> + Ast_53.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) +and (copy_out_attribute : + Ast_52.Outcometree.out_attribute -> Ast_53.Outcometree.out_attribute) + = + fun { Ast_52.Outcometree.oattr_name = oattr_name } -> + { Ast_53.Outcometree.oattr_name = oattr_name } +and (copy_out_variant : + Ast_52.Outcometree.out_variant -> Ast_53.Outcometree.out_variant) + = + function + | Ast_52.Outcometree.Ovar_fields x0 -> + Ast_53.Outcometree.Ovar_fields + (List.map + (fun x -> + let (x0, x1, x2) = x in + (x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0) + | Ast_52.Outcometree.Ovar_typ x0 -> + Ast_53.Outcometree.Ovar_typ (copy_out_type x0) +and (copy_out_constructor : + Ast_52.Outcometree.out_constructor -> + Ast_53.Outcometree.out_constructor) + = + fun + { Ast_52.Outcometree.ocstr_name = ocstr_name; + Ast_52.Outcometree.ocstr_args = ocstr_args; + Ast_52.Outcometree.ocstr_return_type = ocstr_return_type } + -> + { + Ast_53.Outcometree.ocstr_name = ocstr_name; + Ast_53.Outcometree.ocstr_args = + (List.map (fun x -> copy_out_type x) ocstr_args); + Ast_53.Outcometree.ocstr_return_type = + (Option.map (fun x -> copy_out_type x) ocstr_return_type) + } +and (copy_arg_label : Ast_52.Asttypes.arg_label -> Ast_53.Asttypes.arg_label) + = + function + | Ast_52.Asttypes.Nolabel -> Ast_53.Asttypes.Nolabel + | Ast_52.Asttypes.Labelled x0 -> Ast_53.Asttypes.Labelled x0 + | Ast_52.Asttypes.Optional x0 -> Ast_53.Asttypes.Optional x0 +and (copy_out_value : + Ast_52.Outcometree.out_value -> Ast_53.Outcometree.out_value) + = + function + | Ast_52.Outcometree.Oval_array x0 -> + Ast_53.Outcometree.Oval_array (List.map (fun x -> copy_out_value x) x0) + | Ast_52.Outcometree.Oval_char x0 -> Ast_53.Outcometree.Oval_char x0 + | Ast_52.Outcometree.Oval_constr (x0, x1) -> + Ast_53.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1)) + | Ast_52.Outcometree.Oval_ellipsis -> Ast_53.Outcometree.Oval_ellipsis + | Ast_52.Outcometree.Oval_float x0 -> Ast_53.Outcometree.Oval_float x0 + | Ast_52.Outcometree.Oval_int x0 -> Ast_53.Outcometree.Oval_int x0 + | Ast_52.Outcometree.Oval_int32 x0 -> Ast_53.Outcometree.Oval_int32 x0 + | Ast_52.Outcometree.Oval_int64 x0 -> Ast_53.Outcometree.Oval_int64 x0 + | Ast_52.Outcometree.Oval_nativeint x0 -> + Ast_53.Outcometree.Oval_nativeint x0 + | Ast_52.Outcometree.Oval_list x0 -> + Ast_53.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0) + | Ast_52.Outcometree.Oval_printer x0 -> + Ast_53.Outcometree.Oval_printer (Caml_format_doc.deprecated_printer x0) + | Ast_52.Outcometree.Oval_record x0 -> + Ast_53.Outcometree.Oval_record + (List.map + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_52.Outcometree.Oval_string (x0, x1, x2) -> + Ast_53.Outcometree.Oval_string (x0, x1, (copy_out_string x2)) + | Ast_52.Outcometree.Oval_stuff x0 -> Ast_53.Outcometree.Oval_stuff x0 + | Ast_52.Outcometree.Oval_tuple x0 -> + Ast_53.Outcometree.Oval_tuple (List.map (fun x -> copy_out_value x) x0) + | Ast_52.Outcometree.Oval_variant (x0, x1) -> + Ast_53.Outcometree.Oval_variant + (x0, (Option.map (fun x -> copy_out_value x) x1)) + | Ast_52.Outcometree.Oval_lazy x0 -> + Ast_53.Outcometree.Oval_lazy (copy_out_value x0) +and (copy_out_string : + Ast_52.Outcometree.out_string -> Ast_53.Outcometree.out_string) + = + function + | Ast_52.Outcometree.Ostr_string -> Ast_53.Outcometree.Ostr_string + | Ast_52.Outcometree.Ostr_bytes -> Ast_53.Outcometree.Ostr_bytes +and (copy_out_ident : + Ast_52.Outcometree.out_ident -> Ast_53.Outcometree.out_ident) + = + function + | Ast_52.Outcometree.Oide_apply (x0, x1) -> + Ast_53.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_52.Outcometree.Oide_dot (x0, x1) -> + Ast_53.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_52.Outcometree.Oide_ident x0 -> + Ast_53.Outcometree.Oide_ident (copy_out_name x0) +and (copy_out_name : + Ast_52.Outcometree.out_name -> Ast_53.Outcometree.out_name) + = + fun { Ast_52.Outcometree.printed_name = printed_name } -> + { Ast_53.Outcometree.printed_name = printed_name } diff --git a/src/vendored-omp/src/migrate_parsetree_53_52.ml b/src/vendored-omp/src/migrate_parsetree_53_52.ml new file mode 100644 index 000000000..125cc82a6 --- /dev/null +++ b/src/vendored-omp/src/migrate_parsetree_53_52.ml @@ -0,0 +1 @@ +include Migrate_parsetree_53_52_migrate diff --git a/src/vendored-omp/src/migrate_parsetree_53_52_migrate.ml b/src/vendored-omp/src/migrate_parsetree_53_52_migrate.ml new file mode 100644 index 000000000..f106f1c9b --- /dev/null +++ b/src/vendored-omp/src/migrate_parsetree_53_52_migrate.ml @@ -0,0 +1,387 @@ +module From = Ast_53 +module To = Ast_52 +let rec (copy_out_type_extension : + Ast_53.Outcometree.out_type_extension -> + Ast_52.Outcometree.out_type_extension) + = + fun + { Ast_53.Outcometree.otyext_name = otyext_name; + Ast_53.Outcometree.otyext_params = otyext_params; + Ast_53.Outcometree.otyext_constructors = otyext_constructors; + Ast_53.Outcometree.otyext_private = otyext_private } + -> + { + Ast_52.Outcometree.otyext_name = otyext_name; + Ast_52.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_52.Outcometree.otyext_constructors = + (List.map (fun x -> copy_out_constructor x) otyext_constructors); + Ast_52.Outcometree.otyext_private = (copy_private_flag otyext_private) + } +and (copy_out_phrase : + Ast_53.Outcometree.out_phrase -> Ast_52.Outcometree.out_phrase) + = + function + | Ast_53.Outcometree.Ophr_eval (x0, x1) -> + Ast_52.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_53.Outcometree.Ophr_signature x0 -> + Ast_52.Outcometree.Ophr_signature + (List.map + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), + (Option.map (fun x -> copy_out_value x) x1))) x0) + | Ast_53.Outcometree.Ophr_exception x0 -> + Ast_52.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) +and (copy_out_sig_item : + Ast_53.Outcometree.out_sig_item -> Ast_52.Outcometree.out_sig_item) + = + function + | Ast_53.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_52.Outcometree.Osig_class + (x0, x1, (List.map (fun x -> copy_out_type_param x) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_53.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_52.Outcometree.Osig_class_type + (x0, x1, (List.map (fun x -> copy_out_type_param x) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_53.Outcometree.Osig_typext (x0, x1) -> + Ast_52.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_53.Outcometree.Osig_modtype (x0, x1) -> + Ast_52.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_53.Outcometree.Osig_module (x0, x1, x2) -> + Ast_52.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_53.Outcometree.Osig_type (x0, x1) -> + Ast_52.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_53.Outcometree.Osig_value x0 -> + Ast_52.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_53.Outcometree.Osig_ellipsis -> Ast_52.Outcometree.Osig_ellipsis +and (copy_out_val_decl : + Ast_53.Outcometree.out_val_decl -> Ast_52.Outcometree.out_val_decl) + = + fun + { Ast_53.Outcometree.oval_name = oval_name; + Ast_53.Outcometree.oval_type = oval_type; + Ast_53.Outcometree.oval_prims = oval_prims; + Ast_53.Outcometree.oval_attributes = oval_attributes } + -> + { + Ast_52.Outcometree.oval_name = oval_name; + Ast_52.Outcometree.oval_type = (copy_out_type oval_type); + Ast_52.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_52.Outcometree.oval_attributes = + (List.map (fun x -> copy_out_attribute x) oval_attributes) + } +and (copy_out_type_decl : + Ast_53.Outcometree.out_type_decl -> Ast_52.Outcometree.out_type_decl) + = + fun + { Ast_53.Outcometree.otype_name = otype_name; + Ast_53.Outcometree.otype_params = otype_params; + Ast_53.Outcometree.otype_type = otype_type; + Ast_53.Outcometree.otype_private = otype_private; + Ast_53.Outcometree.otype_immediate = otype_immediate; + Ast_53.Outcometree.otype_unboxed = otype_unboxed; + Ast_53.Outcometree.otype_cstrs = otype_cstrs } + -> + { + Ast_52.Outcometree.otype_name = otype_name; + Ast_52.Outcometree.otype_params = + (List.map (fun x -> copy_out_type_param x) otype_params); + Ast_52.Outcometree.otype_type = (copy_out_type otype_type); + Ast_52.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_52.Outcometree.otype_immediate = + (copy_Type_immediacy_t otype_immediate); + Ast_52.Outcometree.otype_unboxed = otype_unboxed; + Ast_52.Outcometree.otype_cstrs = + (List.map + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) + } +and (copy_Type_immediacy_t : + Ast_53.Type_immediacy.t -> Ast_52.Type_immediacy.t) + = + function + | Ast_53.Type_immediacy.Unknown -> Ast_52.Type_immediacy.Unknown + | Ast_53.Type_immediacy.Always -> Ast_52.Type_immediacy.Always + | Ast_53.Type_immediacy.Always_on_64bits -> + Ast_52.Type_immediacy.Always_on_64bits +and (copy_out_module_type : + Ast_53.Outcometree.out_module_type -> + Ast_52.Outcometree.out_module_type) + = + function + | Ast_53.Outcometree.Omty_abstract -> Ast_52.Outcometree.Omty_abstract + | Ast_53.Outcometree.Omty_functor (x0, x1) -> + Ast_52.Outcometree.Omty_functor + ((Option.map + (fun x -> + let (x0, x1) = x in + ((Option.map (fun x -> x) x0), (copy_out_module_type x1))) x0), + (copy_out_module_type x1)) + | Ast_53.Outcometree.Omty_ident x0 -> + Ast_52.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_53.Outcometree.Omty_signature x0 -> + Ast_52.Outcometree.Omty_signature + (List.map (fun x -> copy_out_sig_item x) x0) + | Ast_53.Outcometree.Omty_alias x0 -> + Ast_52.Outcometree.Omty_alias (copy_out_ident x0) +and (copy_out_ext_status : + Ast_53.Outcometree.out_ext_status -> Ast_52.Outcometree.out_ext_status) + = + function + | Ast_53.Outcometree.Oext_first -> Ast_52.Outcometree.Oext_first + | Ast_53.Outcometree.Oext_next -> Ast_52.Outcometree.Oext_next + | Ast_53.Outcometree.Oext_exception -> Ast_52.Outcometree.Oext_exception +and (copy_out_extension_constructor : + Ast_53.Outcometree.out_extension_constructor -> + Ast_52.Outcometree.out_extension_constructor) + = + fun + { Ast_53.Outcometree.oext_name = oext_name; + Ast_53.Outcometree.oext_type_name = oext_type_name; + Ast_53.Outcometree.oext_type_params = oext_type_params; + Ast_53.Outcometree.oext_args = oext_args; + Ast_53.Outcometree.oext_ret_type = oext_ret_type; + Ast_53.Outcometree.oext_private = oext_private } + -> + { + Ast_52.Outcometree.oext_name = oext_name; + Ast_52.Outcometree.oext_type_name = oext_type_name; + Ast_52.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_52.Outcometree.oext_args = + (List.map (fun x -> copy_out_type x) oext_args); + Ast_52.Outcometree.oext_ret_type = + (Option.map (fun x -> copy_out_type x) oext_ret_type); + Ast_52.Outcometree.oext_private = (copy_private_flag oext_private) + } +and (copy_private_flag : + Ast_53.Asttypes.private_flag -> Ast_52.Asttypes.private_flag) + = + function + | Ast_53.Asttypes.Private -> Ast_52.Asttypes.Private + | Ast_53.Asttypes.Public -> Ast_52.Asttypes.Public +and (copy_out_rec_status : + Ast_53.Outcometree.out_rec_status -> Ast_52.Outcometree.out_rec_status) + = + function + | Ast_53.Outcometree.Orec_not -> Ast_52.Outcometree.Orec_not + | Ast_53.Outcometree.Orec_first -> Ast_52.Outcometree.Orec_first + | Ast_53.Outcometree.Orec_next -> Ast_52.Outcometree.Orec_next +and (copy_out_class_type : + Ast_53.Outcometree.out_class_type -> Ast_52.Outcometree.out_class_type) + = + function + | Ast_53.Outcometree.Octy_constr (x0, x1) -> + Ast_52.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1)) + | Ast_53.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_52.Outcometree.Octy_arrow + ((copy_arg_label x0), (copy_out_type x1), (copy_out_class_type x2)) + | Ast_53.Outcometree.Octy_signature (x0, x1) -> + Ast_52.Outcometree.Octy_signature + ((Option.map (fun x -> copy_out_type x) x0), + (List.map (fun x -> copy_out_class_sig_item x) x1)) +and (copy_out_class_sig_item : + Ast_53.Outcometree.out_class_sig_item -> + Ast_52.Outcometree.out_class_sig_item) + = + function + | Ast_53.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_52.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_53.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_52.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_53.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_52.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) +and (copy_out_type_param : + Ast_53.Outcometree.out_type_param -> Ast_52.Outcometree.out_type_param) + = + fun + { Ast_53.Outcometree.ot_non_gen = ot_non_gen; + Ast_53.Outcometree.ot_name = ot_name; + Ast_53.Outcometree.ot_variance = ot_variance } + -> + { + Ast_52.Outcometree.ot_non_gen = ot_non_gen; + Ast_52.Outcometree.ot_name = ot_name; + Ast_52.Outcometree.ot_variance = + (let (x0, x1) = ot_variance in + ((copy_variance x0), (copy_injectivity x1))) + } +and (copy_injectivity : + Ast_53.Asttypes.injectivity -> Ast_52.Asttypes.injectivity) + = + function + | Ast_53.Asttypes.Injective -> Ast_52.Asttypes.Injective + | Ast_53.Asttypes.NoInjectivity -> Ast_52.Asttypes.NoInjectivity +and (copy_variance : Ast_53.Asttypes.variance -> Ast_52.Asttypes.variance) = + function + | Ast_53.Asttypes.Covariant -> Ast_52.Asttypes.Covariant + | Ast_53.Asttypes.Contravariant -> Ast_52.Asttypes.Contravariant + | Ast_53.Asttypes.NoVariance -> Ast_52.Asttypes.NoVariance +and (copy_out_type : + Ast_53.Outcometree.out_type -> Ast_52.Outcometree.out_type) + = + function + | Ast_53.Outcometree.Otyp_abstract -> Ast_52.Outcometree.Otyp_abstract + | Ast_53.Outcometree.Otyp_open -> Ast_52.Outcometree.Otyp_open + | Ast_53.Outcometree.Otyp_alias {non_gen; aliased; alias} -> + Ast_52.Outcometree.Otyp_alias {non_gen; aliased=(copy_out_type aliased); alias} + | Ast_53.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_52.Outcometree.Otyp_arrow + ((copy_arg_label x0), (copy_out_type x1), (copy_out_type x2)) + | Ast_53.Outcometree.Otyp_class (x0, x1) -> + Ast_52.Outcometree.Otyp_class + ((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1)) + | Ast_53.Outcometree.Otyp_constr (x0, x1) -> + Ast_52.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map (fun x -> copy_out_type x) x1)) + | Ast_53.Outcometree.Otyp_manifest (x0, x1) -> + Ast_52.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_53.Outcometree.Otyp_object { fields; open_row } -> + Ast_52.Outcometree.Otyp_object + { fields = + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) + fields)); + open_row } + | Ast_53.Outcometree.Otyp_record x0 -> + Ast_52.Outcometree.Otyp_record + (List.map (fun (x: Ast_53.Outcometree.out_label) -> + (x.olab_name, x.olab_mut = Mutable, copy_out_type x.olab_type)) x0) + | Ast_53.Outcometree.Otyp_stuff x0 -> Ast_52.Outcometree.Otyp_stuff x0 + | Ast_53.Outcometree.Otyp_sum x0 -> + Ast_52.Outcometree.Otyp_sum + (List.map (fun x -> copy_out_constructor x) x0) + | Ast_53.Outcometree.Otyp_tuple x0 -> + Ast_52.Outcometree.Otyp_tuple (List.map (fun x -> copy_out_type x) x0) + | Ast_53.Outcometree.Otyp_var (x0, x1) -> + Ast_52.Outcometree.Otyp_var (x0, x1) + | Ast_53.Outcometree.Otyp_variant (x0, x1, x2) -> + Ast_52.Outcometree.Otyp_variant + ((copy_out_variant x0), x1, + (Option.map (fun x -> List.map (fun x -> x) x) x2)) + | Ast_53.Outcometree.Otyp_poly (x0, x1) -> + Ast_52.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_53.Outcometree.Otyp_module (x0, x1) -> + Ast_52.Outcometree.Otyp_module + ((copy_out_ident x0), + (List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) + x1)) + | Ast_53.Outcometree.Otyp_attribute (x0, x1) -> + Ast_52.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) +and (copy_out_attribute : + Ast_53.Outcometree.out_attribute -> Ast_52.Outcometree.out_attribute) + = + fun { Ast_53.Outcometree.oattr_name = oattr_name } -> + { Ast_52.Outcometree.oattr_name = oattr_name } +and (copy_out_variant : + Ast_53.Outcometree.out_variant -> Ast_52.Outcometree.out_variant) + = + function + | Ast_53.Outcometree.Ovar_fields x0 -> + Ast_52.Outcometree.Ovar_fields + (List.map + (fun x -> + let (x0, x1, x2) = x in + (x0, x1, (List.map (fun x -> copy_out_type x) x2))) x0) + | Ast_53.Outcometree.Ovar_typ x0 -> + Ast_52.Outcometree.Ovar_typ (copy_out_type x0) +and (copy_out_constructor : + Ast_53.Outcometree.out_constructor -> + Ast_52.Outcometree.out_constructor) + = + fun + { Ast_53.Outcometree.ocstr_name = ocstr_name; + Ast_53.Outcometree.ocstr_args = ocstr_args; + Ast_53.Outcometree.ocstr_return_type = ocstr_return_type } + -> + { + Ast_52.Outcometree.ocstr_name = ocstr_name; + Ast_52.Outcometree.ocstr_args = + (List.map (fun x -> copy_out_type x) ocstr_args); + Ast_52.Outcometree.ocstr_return_type = + (Option.map (fun x -> copy_out_type x) ocstr_return_type) + } +and (copy_mutable_flag : + Ast_53.Asttypes.mutable_flag -> Ast_52.Asttypes.mutable_flag) + = + function + | Ast_53.Asttypes.Immutable -> Ast_52.Asttypes.Immutable + | Ast_53.Asttypes.Mutable -> Ast_52.Asttypes.Mutable +and (copy_arg_label : Ast_53.Asttypes.arg_label -> Ast_52.Asttypes.arg_label) + = + function + | Ast_53.Asttypes.Nolabel -> Ast_52.Asttypes.Nolabel + | Ast_53.Asttypes.Labelled x0 -> Ast_52.Asttypes.Labelled x0 + | Ast_53.Asttypes.Optional x0 -> Ast_52.Asttypes.Optional x0 +and (copy_out_value : + Ast_53.Outcometree.out_value -> Ast_52.Outcometree.out_value) + = + function + | Ast_53.Outcometree.Oval_array x0 -> + Ast_52.Outcometree.Oval_array (List.map (fun x -> copy_out_value x) x0) + | Ast_53.Outcometree.Oval_char x0 -> Ast_52.Outcometree.Oval_char x0 + | Ast_53.Outcometree.Oval_constr (x0, x1) -> + Ast_52.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map (fun x -> copy_out_value x) x1)) + | Ast_53.Outcometree.Oval_ellipsis -> Ast_52.Outcometree.Oval_ellipsis + | Ast_53.Outcometree.Oval_float x0 -> Ast_52.Outcometree.Oval_float x0 + | Ast_53.Outcometree.Oval_int x0 -> Ast_52.Outcometree.Oval_int x0 + | Ast_53.Outcometree.Oval_int32 x0 -> Ast_52.Outcometree.Oval_int32 x0 + | Ast_53.Outcometree.Oval_int64 x0 -> Ast_52.Outcometree.Oval_int64 x0 + | Ast_53.Outcometree.Oval_nativeint x0 -> + Ast_52.Outcometree.Oval_nativeint x0 + | Ast_53.Outcometree.Oval_list x0 -> + Ast_52.Outcometree.Oval_list (List.map (fun x -> copy_out_value x) x0) + | Ast_53.Outcometree.Oval_printer x0 -> + Ast_52.Outcometree.Oval_printer (fun fmt -> + let f = Caml_format_doc.compat (fun fmt () -> x0 fmt) in + f fmt ()) + | Ast_53.Outcometree.Oval_record x0 -> + Ast_52.Outcometree.Oval_record + (List.map + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_53.Outcometree.Oval_string (x0, x1, x2) -> + Ast_52.Outcometree.Oval_string (x0, x1, (copy_out_string x2)) + | Ast_53.Outcometree.Oval_stuff x0 -> Ast_52.Outcometree.Oval_stuff x0 + | Ast_53.Outcometree.Oval_tuple x0 -> + Ast_52.Outcometree.Oval_tuple (List.map (fun x -> copy_out_value x) x0) + | Ast_53.Outcometree.Oval_variant (x0, x1) -> + Ast_52.Outcometree.Oval_variant + (x0, (Option.map (fun x -> copy_out_value x) x1)) + | Ast_53.Outcometree.Oval_lazy x0 -> + Ast_52.Outcometree.Oval_lazy (copy_out_value x0) +and (copy_out_string : + Ast_53.Outcometree.out_string -> Ast_52.Outcometree.out_string) + = + function + | Ast_53.Outcometree.Ostr_string -> Ast_52.Outcometree.Ostr_string + | Ast_53.Outcometree.Ostr_bytes -> Ast_52.Outcometree.Ostr_bytes +and (copy_out_ident : + Ast_53.Outcometree.out_ident -> Ast_52.Outcometree.out_ident) + = + function + | Ast_53.Outcometree.Oide_apply (x0, x1) -> + Ast_52.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_53.Outcometree.Oide_dot (x0, x1) -> + Ast_52.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_53.Outcometree.Oide_ident x0 -> + Ast_52.Outcometree.Oide_ident (copy_out_name x0) +and (copy_out_name : + Ast_53.Outcometree.out_name -> Ast_52.Outcometree.out_name) + = + fun { Ast_53.Outcometree.printed_name = printed_name } -> + { Ast_52.Outcometree.printed_name = printed_name } diff --git a/src/vendored-omp/src/migrate_parsetree_versions.ml b/src/vendored-omp/src/migrate_parsetree_versions.ml index bde5b6506..19da8365d 100644 --- a/src/vendored-omp/src/migrate_parsetree_versions.ml +++ b/src/vendored-omp/src/migrate_parsetree_versions.ml @@ -507,6 +507,13 @@ module OCaml_52 = struct let string_version = "5.2" end let ocaml_52 : OCaml_52.types ocaml_version = (module OCaml_52) +module OCaml_53 = struct + module Ast = Ast_53 + include Make_witness(Ast_53) + let version = 530 + let string_version = "5.3" +end +let ocaml_53 : OCaml_53.types ocaml_version = (module OCaml_53) (*$*) let all_versions : (module OCaml_version) list = [ @@ -528,6 +535,7 @@ let all_versions : (module OCaml_version) list = [ (module OCaml_500 : OCaml_version); (module OCaml_51 : OCaml_version); (module OCaml_52 : OCaml_version); + (module OCaml_53 : OCaml_version); (*$*) ] @@ -566,6 +574,8 @@ include Register_migration(OCaml_500)(OCaml_51) (Migrate_parsetree_500_51)(Migrate_parsetree_51_500) include Register_migration(OCaml_51)(OCaml_52) (Migrate_parsetree_51_52)(Migrate_parsetree_52_51) +include Register_migration(OCaml_52)(OCaml_53) + (Migrate_parsetree_52_53)(Migrate_parsetree_53_52) (*$*) module OCaml_current = OCaml_OCAML_VERSION diff --git a/src/vendored-omp/src/migrate_parsetree_versions.mli b/src/vendored-omp/src/migrate_parsetree_versions.mli index 679e630fe..c25dc47ca 100644 --- a/src/vendored-omp/src/migrate_parsetree_versions.mli +++ b/src/vendored-omp/src/migrate_parsetree_versions.mli @@ -165,6 +165,8 @@ module OCaml_51 : OCaml_version with module Ast = Ast_51 val ocaml_51 : OCaml_51.types ocaml_version module OCaml_52 : OCaml_version with module Ast = Ast_52 val ocaml_52 : OCaml_52.types ocaml_version +module OCaml_53 : OCaml_version with module Ast = Ast_53 +val ocaml_53 : OCaml_53.types ocaml_version (*$*) (* An alias to the current compiler version *) diff --git a/src/vendored-omp/tools/dune b/src/vendored-omp/tools/dune index bd8744eff..8f5ec0f6b 100644 --- a/src/vendored-omp/tools/dune +++ b/src/vendored-omp/tools/dune @@ -17,9 +17,7 @@ (executable (name gencopy) (enabled_if - (and - (>= %{ocaml_version} 5.0) - (< %{ocaml_version} 5.1))) + (>= %{ocaml_version} 5.2)) (modules gencopy) (libraries compiler-libs.common compiler-libs.bytecomp) (flags :standard -w -3)) diff --git a/src/vendored-omp/tools/gencopy.ml b/src/vendored-omp/tools/gencopy.ml index 4e2684722..3961e52a4 100644 --- a/src/vendored-omp/tools/gencopy.ml +++ b/src/vendored-omp/tools/gencopy.ml @@ -68,10 +68,15 @@ module Main : sig end = struct Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body let func ?loc ?attrs l = - Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) + Exp.function_ ?loc ?attrs [] + None + (Pfunction_cases ((List.map (fun (p, e) -> Exp.case p e) l), Location.none, [])) let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = - Exp.fun_ ?loc ?attrs label default pat exp + Exp.function_ ?loc ?attrs + [ { pparam_loc = Location.none; pparam_desc = (Pparam_val (label, default, pat)) } ] + None + (Pfunction_body exp) let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) @@ -198,8 +203,8 @@ module Main : sig end = struct failwith "Inline records are not yet supported." in concrete (func (List.map case l)) - | Type_abstract, Some t -> concrete (tyexpr_fun env t) - | Type_abstract, None -> failwith ("Abstract type " ^ ty) + | Type_abstract _, Some t -> concrete (tyexpr_fun env t) + | Type_abstract _, None -> failwith ("Abstract type " ^ ty) | Type_open, _ -> Format.eprintf "** Open types are not yet supported %s@." ty; () @@ -254,36 +259,15 @@ module Main : sig end = struct (* (fun x -> x) ====> *) let open Ast_mapper in let super = default_mapper in - let expr this e = - let e = super.expr this e in - let open Longident in - let open Parsetree in - match e.pexp_desc with - | Pexp_fun - ( Asttypes.Nolabel, - None, - { ppat_desc = Ppat_var { txt = id; _ }; _ }, - { pexp_desc = - Pexp_apply - ( f, - [ ( Asttypes.Nolabel, - { pexp_desc = Pexp_ident { txt = Lident id2; _ }; _ } - ) - ] ) - ; _ - } ) - when id = id2 -> - f - | _ -> e - in let value_binding this (vb : Parsetree.value_binding) = let pvb_pat = this.pat this vb.pvb_pat in let pvb_expr = super.expr this vb.pvb_expr in let pvb_attributes = this.attributes this vb.pvb_attributes in let pvb_loc = this.location this vb.pvb_loc in - { Parsetree.pvb_loc; pvb_attributes; pvb_expr; pvb_pat } + let pvb_constraint = vb.pvb_constraint in + { Parsetree.pvb_loc; pvb_attributes; pvb_expr; pvb_pat; pvb_constraint } in - { super with expr; value_binding } + { super with value_binding } let add_mapping s = let i = @@ -300,7 +284,7 @@ module Main : sig end = struct [ ( "-I", String (fun s -> - Load_path.add_dir (Misc.expand_directory Config.standard_library s) + Load_path.add_dir ~hidden:false (Misc.expand_directory Config.standard_library s) ), " Add to the list of include directories" ); ( "-map", @@ -312,7 +296,7 @@ module Main : sig end = struct let usage = Printf.sprintf "%s [options] \n" Sys.argv.(0) let main () = - Load_path.init ~auto_include:Compmisc.auto_include [ Config.standard_library ]; + Load_path.init ~auto_include:Compmisc.auto_include ~visible:[ Config.standard_library ] ~hidden:[]; Arg.parse (Arg.align args) gen usage; let from_, to_ = match !module_mapping with @@ -348,4 +332,3 @@ end (* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_500:Ast_414 Ast_500.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_500_414_migrate.ml *) (* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_414:Ast_500 Ast_414.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_414_500_migrate.ml *) - diff --git a/test/lib/outcometreePrinter.cppo.ml b/test/lib/outcometreePrinter.cppo.ml index 9cebda7b3..358b91106 100644 --- a/test/lib/outcometreePrinter.cppo.ml +++ b/test/lib/outcometreePrinter.cppo.ml @@ -33,7 +33,12 @@ let main () = #else Compmisc.init_path false; #endif + +#if OCAML_VERSION >= (5,3,0) + Env.set_current_unit (Unit_info.make ~source_file:filename Impl modulename); +#else Env.set_unit_name modulename; +#endif let ast = impl lexbuf in let ast = Reason_toolchain.To_current.copy_structure ast in @@ -44,14 +49,20 @@ let main () = let (typedtree, _) = #endif Typemod.type_implementation -#if OCAML_VERSION >= (5,2,0) +#if OCAML_VERSION >= (5,3,0) + (Unit_info.make ~source_file:modulename Impl modulename) +#elif OCAML_VERSION >= (5,2,0) (Unit_info.make ~source_file:modulename modulename) #else modulename modulename modulename #endif env ast in +#if OCAML_VERSION >= (5,3,0) + let tree = Out_type.tree_of_signature typedtree.Typedtree.str_type in +#else let tree = Printtyp.tree_of_signature typedtree.Typedtree.str_type in +#endif let phrase = (Reason_omp.Ast_414.Outcometree.Ophr_signature (List.map (fun item -> (ConvertBack.copy_out_sig_item item, None)) tree) ) in