diff options
| author | Alain Frisch <alain@frisch.fr> | 2014-10-03 13:35:02 +0000 |
|---|---|---|
| committer | Alain Frisch <alain@frisch.fr> | 2014-10-03 13:35:02 +0000 |
| commit | b002e8b22e2438c58eed42fb7a7ce292cb71a87e (patch) | |
| tree | 00210c87b7d94999c062205d86b1149f910b2c57 | |
| parent | cf2cdb9fc1305b251fd96d67feb7348c088cd858 (diff) | |
| parent | 7a21fae1a759f7f93f4bb79f091228fb154a9869 (diff) | |
Sync with trunk.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/abstract_intel_emit@15448 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
35 files changed, 651 insertions, 494 deletions
diff --git a/.travis-ci.sh b/.travis-ci.sh index bee3ad19b..d65fcbc63 100644 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -8,6 +8,8 @@ i386) cd camlp4 && ./configure && make && sudo make install git clone git://github.com/ocaml/opam cd opam && ./configure && make lib-ext && make && sudo make install + git config --global user.email "some@name.com" + git config --global user.name "Some Name" opam init -y -a git://github.com/ocaml/opam-repository opam install -y oasis opam pin add -y utop https://github.com/diml/utop @@ -9,8 +9,30 @@ Runtime system: - PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown types {,u}int{32,64}. (Xavier Leroy) + +Standard library: +- PR#6577: improve performance of %L, %l, %n, %S, %C format specifiers + (Alain Frisch) +- PR#6585: fix memory leak in win32unix/createprocess.c + +Type system: +- PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type + constructors (Alain Frisch) +* PR#6465: allow incremental weakening of module aliases (Jacques Garrigue). + This is done by adding equations to submodules when expanding aliases. + In theory this may be incompatible is some corner cases defining a module + type through inference, but no breakage known on published code. +- PR#6593: Functor application in tests/basic-modules fails after commit 15405 + +OCaml 4.02.1: +------------- + +- PR#4099: Bug in Makefile.nt: won't stop on error (George Necula) +- PR#6466: Non-exhaustive matching warning message for open types is confusing - PR#6529: fix quadratic-time algorithm in Consistbl.extract. (Xavier Leroy) +- PR#6554: fix race condition when retrieving backtraces (Jérémie Dimino, + Mark Shinwell). Ocaml 4.02.0: ------------- diff --git a/Makefile.nt b/Makefile.nt index 4346cbb20..810251ea2 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -268,7 +268,9 @@ installbyt: cp expunge $(INSTALL_LIBDIR)/expunge.exe cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools ; $(MAKEREC) install - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i install || exit $$?; \ + done if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) install); \ else :; fi if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKEREC) install); \ @@ -1,4 +1,4 @@ -4.03.0+dev3-2014-08-29 +4.03.0+dev4-2014-09-26 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 773e22cd2..5eb8600cd 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -332,13 +332,37 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) { CAMLparam0(); CAMLlocal1(res); + const int tag = 0; - res = caml_alloc(caml_backtrace_pos, 0); - if(caml_backtrace_buffer != NULL) { + /* Beware: the allocations below may cause finalizers to be run, and another + backtrace---possibly of a different length---to be stashed (for example + if the finalizer raises then catches an exception). We choose to ignore + any such finalizer backtraces and return the original one. */ + + if (caml_backtrace_buffer == NULL || caml_backtrace_pos == 0) { + res = caml_alloc(0, tag); + } + else { + code_t saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE]; + int saved_caml_backtrace_pos; intnat i; - for(i = 0; i < caml_backtrace_pos; i++) - Field(res, i) = Val_Descrptr(caml_backtrace_buffer[i]); + + saved_caml_backtrace_pos = caml_backtrace_pos; + + if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) { + saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE; + } + + memcpy(saved_caml_backtrace_buffer, caml_backtrace_buffer, + saved_caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(saved_caml_backtrace_pos, tag); + for (i = 0; i < saved_caml_backtrace_pos; i++) { + /* [Val_Descrptr] always returns an immediate. */ + Field(res, i) = Val_Descrptr(saved_caml_backtrace_buffer[i]); + } } + CAMLreturn(res); } @@ -355,19 +379,16 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal4(arr, raw_slot, slot, res); + CAMLlocal3(arr, res, backtrace); + intnat i; - arr = caml_alloc(caml_backtrace_pos, 0); - if (caml_backtrace_buffer == NULL) { - Assert(caml_backtrace_pos == 0); - } else { - intnat i; - for(i = 0; i < caml_backtrace_pos; i++) { - raw_slot = Val_Descrptr(caml_backtrace_buffer[i]); - slot = caml_convert_raw_backtrace_slot(raw_slot); - caml_modify(&Field(arr, i), slot); - } + backtrace = caml_get_exception_raw_backtrace(Val_unit); + + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i))); } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 3a04382c5..8282e0114 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex e7af3bb6d..bb4b76145 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 3c88f8eba..01c4739de 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 7e61f0c1b..1ab099da9 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -321,7 +321,7 @@ CAMLprim value caml_gc_get(value v) res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ - Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ diff --git a/driver/pparse.ml b/driver/pparse.ml index 08b9bc736..4b2553f27 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -39,6 +39,10 @@ let remove_preprocessed inputfile = None -> () | Some _ -> Misc.remove_file inputfile + +(* Note: some of the functions here should go to Ast_mapper instead, + which would encapsulate the "binary AST" protocol. *) + let write_ast magic ast = let fn = Filename.temp_file "camlppx" "" in let oc = open_out_bin fn in @@ -87,41 +91,34 @@ let read_ast magic fn = Misc.remove_file fn; raise exn -let apply_rewriters ~tool_name magic ast = - let ctx = Ast_mapper.ppx_context ~tool_name () in +let rewrite magic ast ppxs = + read_ast magic + (List.fold_left (apply_rewriter magic) (write_ast magic ast) + (List.rev ppxs)) + +let apply_rewriters_str ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - let ast = - if magic = Config.ast_impl_magic_number - then Obj.magic (Ast_helper.Str.attribute ctx :: (Obj.magic ast)) - else Obj.magic (Ast_helper.Sig.attribute ctx :: (Obj.magic ast)) - in - let fn = - List.fold_left (apply_rewriter magic) (write_ast magic ast) - (List.rev ppxs) - in - let ast = read_ast magic fn in - let open Parsetree in - if magic = Config.ast_impl_magic_number then - let ast = - match Obj.magic ast with - | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, _)} - :: items -> - items - | items -> items - in - Obj.magic ast - else - let ast = - match Obj.magic ast with - | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, _)} - :: items -> - items - | items -> items - in - Obj.magic ast + let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in + let ast = rewrite Config.ast_impl_magic_number ast ppxs in + Ast_mapper.drop_ppx_context_str ~restore ast +let apply_rewriters_sig ?(restore = true) ~tool_name ast = + match !Clflags.all_ppx with + | [] -> ast + | ppxs -> + let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in + let ast = rewrite Config.ast_intf_magic_number ast ppxs in + Ast_mapper.drop_ppx_context_sig ~restore ast + +let apply_rewriters ?restore ~tool_name magic ast = + if magic = Config.ast_impl_magic_number then + Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast)) + else if magic = Config.ast_intf_magic_number then + Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast)) + else + assert false (* Parse a file or get a dumped syntax tree from it *) @@ -160,7 +157,7 @@ let file ppf ~tool_name inputfile parse_fun ast_magic = with x -> close_in ic; raise x in close_in ic; - apply_rewriters ~tool_name ast_magic ast + apply_rewriters ~restore:false ~tool_name ast_magic ast let report_error ppf = function | CannotRun cmd -> diff --git a/driver/pparse.mli b/driver/pparse.mli index d45adf91d..bcff4e781 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -21,7 +21,14 @@ exception Error of error val preprocess : string -> string val remove_preprocessed : string -> unit val file : formatter -> tool_name:string -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a -val apply_rewriters : tool_name:string -> string -> 'a -> 'a +val apply_rewriters: ?restore:bool -> tool_name:string -> string -> 'a -> 'a + (** If [restore = true] (the default), cookies set by external rewriters will be + kept for later calls. *) + +val apply_rewriters_str: ?restore:bool -> tool_name:string -> Parsetree.structure -> Parsetree.structure +val apply_rewriters_sig: ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature + + val report_error : formatter -> error -> unit diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index 0e1e37a24..3858a39b8 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -53,9 +53,11 @@ value win_create_process_native(value cmd, value cmdline, value env, /* Create the process */ if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL, TRUE, flags, envp, NULL, &si, &pi)) { + caml_stat_free(exefile); win32_maperr(GetLastError()); uerror("create_process", cmd); } + caml_stat_free(exefile); CloseHandle(pi.hThread); /* Return the process handle as pseudo-PID (this is consistent with the wait() emulation in the MSVC C library */ diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index f44b12330..669d01449 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -19,7 +19,6 @@ open Asttypes -open Longident open Parsetree open Ast_helper open Location @@ -625,79 +624,170 @@ let attribute_of_warning loc s = { loc; txt = "ocaml.ppwarning" }, PStr ([Str.eval ~loc (Exp.constant (Const_string (s, None)))]) +module StringMap = Map.Make(struct + type t = string + let compare = compare +end) + +let cookies = ref StringMap.empty + +let get_cookie k = + try Some (StringMap.find k !cookies) + with Not_found -> None + +let set_cookie k v = + cookies := StringMap.add k v !cookies + let tool_name_ref = ref "_none_" let tool_name () = !tool_name_ref -let restore_ppx_context payload = - let fields = - match payload with + +module PpxContext = struct + open Longident + open Asttypes + open Ast_helper + + let lid name = { txt = Lident name; loc = Location.none } + + let make_string x = Exp.constant (Const_string (x, None)) + + let make_bool x = + if x + then Exp.construct (lid "true") None + else Exp.construct (lid "false") None + + let rec make_list f lst = + match lst with + | x :: rest -> + Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) + | [] -> + Exp.construct (lid "[]") None + + let make_pair f1 f2 (x1, x2) = + Exp.tuple [f1 x1; f2 x2] + + let make_option f opt = + match opt with + | Some x -> Exp.construct (lid "Some") (Some (f x)) + | None -> Exp.construct (lid "None") None + + let get_cookies () = + lid "cookies", + make_list (make_pair make_string (fun x -> x)) + (StringMap.bindings !cookies) + + let mk fields = + { txt = "ocaml.ppx.context"; loc = Location.none }, + Parsetree.PStr [Str.eval (Exp.record fields None)] + + let make ~tool_name () = + let fields = + [ + lid "tool_name", make_string tool_name; + lid "include_dirs", make_list make_string !Clflags.include_dirs; + lid "load_path", make_list make_string !Config.load_path; + lid "open_modules", make_list make_string !Clflags.open_modules; + lid "for_package", make_option make_string !Clflags.for_package; + lid "debug", make_bool !Clflags.debug; + get_cookies () + ] + in + mk fields + + let get_fields = function | PStr [{pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> fields | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - in - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax" - name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} -> - false - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" - name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" - name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None + + let restore fields = + let field name payload = + let rec get_string = function + | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax" + name + and get_bool pexp = + match pexp with + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} -> + true + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} -> + false + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" + name + and get_list elem = function + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> + elem exp :: get_list elem rest + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> + [] + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" + name + and get_pair f1 f2 = function + | {pexp_desc = Pexp_tuple [e1; e2]} -> + (f1 e1, f2 e2) + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair syntax" + name + and get_option elem = function + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Some (elem exp) + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + None + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax" + name + in + match name with + | "tool_name" -> + tool_name_ref := get_string payload + | "include_dirs" -> + Clflags.include_dirs := get_list get_string payload + | "load_path" -> + Config.load_path := get_list get_string payload + | "open_modules" -> + Clflags.open_modules := get_list get_string payload + | "for_package" -> + Clflags.for_package := get_option get_string payload + | "debug" -> + Clflags.debug := get_bool payload + | "cookies" -> + let l = get_list (get_pair get_string (fun x -> x)) payload in + cookies := + List.fold_left + (fun s (k, v) -> StringMap.add k v s) StringMap.empty + l | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax" - name + () in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Config.load_path := get_list get_string payload - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields + List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields -let apply ~source ~target mapper = + let update_cookies fields = + let fields = + List.filter + (function ({txt=Lident "cookies"}, _) -> false | _ -> true) + fields + in + fields @ [get_cookies ()] +end + +let ppx_context = PpxContext.make + + +let apply_lazy ~source ~target mapper = let ic = open_in_bin source in let magic = really_input_string ic (String.length Config.ast_impl_magic_number) @@ -711,12 +801,17 @@ let apply ~source ~target mapper = let implem ast = try - begin match ast with - | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ -> - restore_ppx_context x - | _ -> () - end; - mapper.structure mapper ast + let fields, ast = + match ast with + | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let mapper = mapper () in + let ast = mapper.structure mapper ast in + let fields = PpxContext.update_cookies fields in + Str.attribute (PpxContext.mk fields) :: ast with exn -> match error_of_exn exn with | Some error -> @@ -726,12 +821,17 @@ let apply ~source ~target mapper = in let iface ast = try - begin match ast with - | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ -> - restore_ppx_context x - | _ -> () - end; - mapper.signature mapper ast + let fields, ast = + match ast with + | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let mapper = mapper () in + let ast = mapper.signature mapper ast in + let fields = PpxContext.update_cookies fields in + Sig.attribute (PpxContext.mk fields) :: ast with exn -> match error_of_exn exn with | Some error -> @@ -750,19 +850,45 @@ let apply ~source ~target mapper = output_value oc ast; close_out oc +let drop_ppx_context_str ~restore = function + | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let drop_ppx_context_sig ~restore = function + | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let add_ppx_context_str ~tool_name ast = + Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast + +let add_ppx_context_sig ~tool_name ast = + Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast + + +let apply ~source ~target mapper = + apply_lazy ~source ~target (fun () -> mapper) + let run_main mapper = try let a = Sys.argv in let n = Array.length a in if n > 2 then - let mapper = + let mapper () = try mapper (Array.to_list (Array.sub a 1 (n - 3))) with exn -> (* PR #6463 *) let f _ _ = raise exn in {default_mapper with structure = f; signature = f} in - apply ~source:a.(n - 2) ~target:a.(n - 1) mapper + apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper else begin Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!" Sys.executable_name; @@ -774,38 +900,3 @@ let run_main mapper = let register_function = ref (fun _name f -> run_main f) let register name f = !register_function name f - - -let ppx_context ~tool_name () = - let open Longident in - let open Asttypes in - let open Ast_helper in - let lid name = { txt = Lident name; loc = Location.none } in - let make_string x = Exp.constant (Const_string (x, None)) in - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - in - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - in - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - in - { txt = "ocaml.ppx.context"; loc = Location.none }, - Parsetree.PStr [Str.eval ( - Exp.record ([ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string !Config.load_path; - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - ]) None)] diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 786c37d6b..5a57b19da 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -134,8 +134,28 @@ val attribute_of_warning: Location.t -> string -> attribute (** {2 Helper functions to call external mappers} *) -val ppx_context: tool_name:string -> unit -> Parsetree.attribute +val add_ppx_context_str: tool_name:string -> Parsetree.structure -> Parsetree.structure (** Extract information from the current environment and encode it - into an attribute an attribute which can be prepended to - signature/structure items of an AST to pass the information to an - external processor. *) + into an attribute which is prepended to the list of structure + items in order to pass the information to an external + processor. *) + +val add_ppx_context_sig: tool_name:string -> Parsetree.signature -> Parsetree.signature +(** Same as [ad_ppx_context_str] for signatures. *) + +val drop_ppx_context_str: restore:bool -> Parsetree.structure -> Parsetree.structure +(** Drop the ocaml.ppx.context attribute from a structure. If + [restore] is true, also restore the associated data in the current + process. *) + +val drop_ppx_context_sig: restore:bool -> Parsetree.signature -> Parsetree.signature +(** Same as [drop_ppx_context_str] for signatures. *) + +(** {2 Cookies} *) + +(** Cookies are used to pass information from a ppx processor to + a further invocation of itself, when called from the OCaml + toplevel (or other tools that support cookies). *) + +val set_cookie: string -> Parsetree.expression -> unit +val get_cookie: string -> Parsetree.expression option diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 5dda3a7fc..7fb82dbe2 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -1266,10 +1266,15 @@ let fix_int_precision prec str = (* Escape a string according to the OCaml lexing convention. *) let string_to_caml_string str = - String.concat (String.escaped str) ["\""; "\""] - -(* Generate the format_int first argument from an int_conv. *) -let format_of_iconv iconv = match iconv with + let str = String.escaped str in + let l = String.length str in + let res = Bytes.make (l + 2) '\"' in + String.unsafe_blit str 0 res 1 l; + Bytes.unsafe_to_string res + +(* Generate the format_int/int32/nativeint/int64 first argument + from an int_conv. *) +let format_of_iconv = function | Int_d -> "%d" | Int_pd -> "%+d" | Int_sd -> "% d" | Int_i -> "%i" | Int_pi -> "%+i" | Int_si -> "% i" | Int_x -> "%x" | Int_Cx -> "%#x" @@ -1277,17 +1282,29 @@ let format_of_iconv iconv = match iconv with | Int_o -> "%o" | Int_Co -> "%#o" | Int_u -> "%u" -(* Generate the format_int32, format_nativeint and format_int64 first - argument from an int_conv. *) -let format_of_aconv iconv c = - let seps = match iconv with - | Int_d -> ["%";"d"] | Int_pd -> ["%+";"d"] | Int_sd -> ["% ";"d"] - | Int_i -> ["%";"i"] | Int_pi -> ["%+";"i"] | Int_si -> ["% ";"i"] - | Int_x -> ["%";"x"] | Int_Cx -> ["%#";"x"] - | Int_X -> ["%";"X"] | Int_CX -> ["%#";"X"] - | Int_o -> ["%";"o"] | Int_Co -> ["%#";"o"] - | Int_u -> ["%";"u"] - in String.concat (String.make 1 c) seps +let format_of_iconvL = function + | Int_d -> "%Ld" | Int_pd -> "%+Ld" | Int_sd -> "% Ld" + | Int_i -> "%Li" | Int_pi -> "%+Li" | Int_si -> "% Li" + | Int_x -> "%Lx" | Int_Cx -> "%#Lx" + | Int_X -> "%LX" | Int_CX -> "%#LX" + | Int_o -> "%Lo" | Int_Co -> "%#Lo" + | Int_u -> "%Lu" + +let format_of_iconvl = function + | Int_d -> "%ld" | Int_pd -> "%+ld" | Int_sd -> "% ld" + | Int_i -> "%li" | Int_pi -> "%+li" | Int_si -> "% li" + | Int_x -> "%lx" | Int_Cx -> "%#lx" + | Int_X -> "%lX" | Int_CX -> "%#lX" + | Int_o -> "%lo" | Int_Co -> "%#lo" + | Int_u -> "%lu" + +let format_of_iconvn = function + | Int_d -> "%nd" | Int_pd -> "%+nd" | Int_sd -> "% nd" + | Int_i -> "%ni" | Int_pi -> "%+ni" | Int_si -> "% ni" + | Int_x -> "%nx" | Int_Cx -> "%#nx" + | Int_X -> "%nX" | Int_CX -> "%#nX" + | Int_o -> "%no" | Int_Co -> "%#no" + | Int_u -> "%nu" (* Generate the format_float first argument form a float_conv. *) let format_of_fconv fconv prec = @@ -1302,9 +1319,9 @@ let format_of_fconv fconv prec = (* Convert an integer to a string according to a conversion. *) let convert_int iconv n = format_int (format_of_iconv iconv) n -let convert_int32 iconv n = format_int32 (format_of_aconv iconv 'l') n -let convert_nativeint iconv n = format_nativeint (format_of_aconv iconv 'n') n -let convert_int64 iconv n = format_int64 (format_of_aconv iconv 'L') n +let convert_int32 iconv n = format_int32 (format_of_iconvl iconv) n +let convert_nativeint iconv n = format_nativeint (format_of_iconvn iconv) n +let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) n (* Convert a float to string. *) (* Fix special case of "OCaml float format". *) @@ -1327,7 +1344,11 @@ let convert_float fconv prec x = (* Convert a char to a string according to the OCaml lexical convention. *) let format_caml_char c = - String.concat (Char.escaped c) ["'"; "'"] + let str = Char.escaped c in + let l = String.length str in + let res = Bytes.make (l + 2) '\'' in + String.unsafe_blit str 0 res 1 l; + Bytes.unsafe_to_string res (* Convert a format type to string *) let string_of_fmtty fmtty = diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 8cd2a719a..f86a1e687 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -83,7 +83,7 @@ type stat = type control = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing - this parameter will trigger a minor collection. Default: 32k. *) + this parameter will trigger a minor collection. Default: 256k. *) mutable major_heap_increment : int; (** How much to add to the major heap when increasing it. If this @@ -131,7 +131,7 @@ type control = mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime - uses the operating system's stack. Default: 256k. *) + uses the operating system's stack. Default: 1024k. *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 3482e3af3..5eb44c393 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -84,7 +84,9 @@ run-all: run-file: @printf " $(DESC)" @rm -f program program.exe - @$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE) + echo XXXX + $(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE) + echo YYYY @F="`basename $(FILE) .ml`"; \ if [ -f $$F.runner ]; then \ RUNTIME="$(RUNTIME)" sh $$F.runner; \ diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 1ca390f94..33ca1ed8b 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -16,6 +16,7 @@ EXECNAME=program$(EXE) ABCDFILES=backtrace.ml OTHERFILES=backtrace2.ml raw_backtrace.ml \ backtrace_deprecated.ml backtrace_slots.ml +OTHERFILESNOINLINING=backtraces_and_finalizers.ml default: $(MAKE) byte @@ -69,6 +70,16 @@ native: >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ + done; + @for file in $(OTHERFILESNOINLINING); do \ + rm -f program program.exe; \ + $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \ + printf " ... testing '$$file' with ocamlopt:"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + >$$F.native.result 2>&1; \ + $(DIFF) $$F.reference $$F.native.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ done .PHONY: promote diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.ml b/testsuite/tests/backtrace/backtraces_and_finalizers.ml new file mode 100644 index 000000000..22acf1af8 --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.ml @@ -0,0 +1,25 @@ +let () = Printexc.record_backtrace true + +let finaliser _ = try raise Exit with _ -> () + +let create () = + let x = ref () in + Gc.finalise finaliser x; + x + +let f () = raise Exit + +let () = + let minor_size = (Gc.get ()).Gc.minor_heap_size in + for i = 1 to 100 do + Gc.minor (); + try + ignore (create () : unit ref); + f () + with _ -> + for i = 1 to minor_size / 2 - 1 do + ignore (ref ()) + done; + ignore (Printexc.get_backtrace () : string) + done; + Printf.printf "ok\n" diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.reference new file mode 100644 index 000000000..9766475a4 --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/formats-transition/invalid_formats.ml b/testsuite/tests/formats-transition/invalid_formats.ml new file mode 100644 index 000000000..71f796b04 --- /dev/null +++ b/testsuite/tests/formats-transition/invalid_formats.ml @@ -0,0 +1,4 @@ +(* Empty file added to create a conflict with branch 4.02 because + the test only makes sense on 4.02.x and will not work on 4.03+ + When merging, don't forget to remove also the .ml.reference file. + *) diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index 2bb3231de..e6611acbb 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -368,19 +368,7 @@ Error: Unbound module type A module K : sig module E = B module N = E.O end # val x : K.N.t = "foo" # module M : sig type t = A module B : sig type u = B end end -# Characters 53-54: - module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *) - ^ -Error: Signature mismatch: - Modules do not match: - sig type t = M.t = A module B : sig type u = M.B.u = B end end - is not included in - sig type t = M.t = A module B = M.B end - In module B: - Modules do not match: - sig type u = M.B.u = B end - is not included in - (module M.B) +# module P : sig type t = M.t = A module B = M.B end # module P : sig type t = M.t = A module B = M.B end # module type S = sig module M : sig module P : sig end end module Q = M end # module type S = @@ -393,22 +381,5 @@ Error: Signature mismatch: module M : sig module N : sig end module P : sig end end module Q = M end -# Characters 16-17: - module R' : S = R;; (* should be ok *) - ^ -Error: Signature mismatch: - Modules do not match: - sig - module M : sig module N : sig end module P : sig end end - module Q = M - end - is not included in - S - In module Q: - Modules do not match: - sig module N : sig end module P : sig end end - is not included in - sig module N = M.N module P = M.P end - In module Q.N: - Modules do not match: sig end is not included in (module M.N) +# module R' : S # diff --git a/testsuite/typing b/testsuite/typing index cb953d6ac..4357fdf3c 100644 --- a/testsuite/typing +++ b/testsuite/typing @@ -1,3 +1,12 @@ +tests/basic +tests/basic-float +tests/basic-io +tests/basic-io-2 +tests/basic-manyargs +tests/basic-modules +tests/basic-more +tests/basic-multdef +tests/basic-private tests/typing-extensions tests/typing-fstclassmod tests/typing-gadts diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index cf62137c2..220d75967 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -327,7 +327,10 @@ let phrase ppf phr = let phr = match phr with | Ptop_def str -> - Ptop_def (Pparse.apply_rewriters ~tool_name:"ocaml" ast_impl_magic_number str) + let str = + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str + in + Ptop_def str | phr -> phr in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index d1dbeca9d..0d8f2d4c2 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -41,6 +41,7 @@ let file_argument name = let newargs = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in + Compenv.readenv ppf Before_link; if prepare ppf && Toploop.run_script ppf name newargs then exit 0 else exit 2 diff --git a/typing/ctype.ml b/typing/ctype.ml index 78852a439..a7d31e7c8 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -775,7 +775,7 @@ let rec update_level env level ty = if level < get_level env p then raise (Unify [(ty, newvar2 level)]); iter_type_expr (update_level env level) ty end - | Tpackage (p, nl, tl) when level < get_level env p -> + | Tpackage (p, nl, tl) when level < Path.binding_time p -> let p' = normalize_package_path env p in if Path.same p p' then raise (Unify [(ty, newvar2 level)]); log_type ty; ty.desc <- Tpackage (p', nl, tl); @@ -1185,26 +1185,31 @@ let instance_parameterized_type_2 sch_args sch_lst sch = cleanup_types (); (ty_args, ty_lst, ty) +let map_kind f = function + | Type_abstract -> Type_abstract + | Type_open -> Type_open + | Type_variant cl -> + Type_variant ( + List.map + (fun c -> + {c with + cd_args = List.map f c.cd_args; + cd_res = may_map f c.cd_res + }) + cl) + | Type_record (fl, rr) -> + Type_record ( + List.map + (fun l -> + {l with ld_type = f l.ld_type} + ) fl, rr) + + let instance_declaration decl = let decl = {decl with type_params = List.map simple_copy decl.type_params; type_manifest = may_map simple_copy decl.type_manifest; - type_kind = match decl.type_kind with - | Type_abstract -> Type_abstract - | Type_variant cl -> - Type_variant ( - List.map - (fun c -> - {c with cd_args=List.map simple_copy c.cd_args; - cd_res=may_map simple_copy c.cd_res}) - cl) - | Type_record (fl, rr) -> - Type_record ( - List.map - (fun l -> - {l with ld_type = copy l.ld_type} - ) fl, rr) - | Type_open -> Type_open + type_kind = map_kind simple_copy decl.type_kind; } in cleanup_types (); @@ -4325,29 +4330,7 @@ let nondep_type_decl env mid id is_covariant decl = try let params = List.map (nondep_type_rec env mid) decl.type_params in let tk = - try match decl.type_kind with - Type_abstract -> - Type_abstract - | Type_variant cstrs -> - Type_variant - (List.map - (fun c -> - {c with - cd_args = List.map (nondep_type_rec env mid) c.cd_args; - cd_res = may_map (nondep_type_rec env mid) c.cd_res; - } - ) - cstrs) - | Type_record(lbls, rep) -> - Type_record - (List.map - (fun l -> - {l with ld_type = nondep_type_rec env mid l.ld_type} - ) - lbls, - rep) - | Type_open -> - Type_open + try map_kind (nondep_type_rec env mid) decl.type_kind with Not_found when is_covariant -> Type_abstract and tm = try match decl.type_manifest with diff --git a/typing/datarepr.ml b/typing/datarepr.ml index faeb48f0a..4922cbb0d 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -39,7 +39,21 @@ let free_vars ty = unmark_type ty; !ret -let constructor_descrs ty_res cstrs priv = +let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) + +let constructor_args cd_args cd_res = + let arg_vars_set = free_vars (newgenty (Ttuple cd_args)) in + let existentials = + match cd_res with + | None -> [] + | Some type_ret -> + let res_vars = free_vars type_ret in + TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + in + existentials, cd_args + +let constructor_descrs ty_path decl cstrs = + let ty_res = newgenconstr ty_path decl.type_params in let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter (fun {cd_args; cd_res; _} -> @@ -60,25 +74,20 @@ let constructor_descrs ty_res cstrs priv = describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in - let existentials = - match cd_res with - | None -> [] - | Some type_ret -> - let res_vars = free_vars type_ret in - let arg_vars = free_vars (newgenty (Ttuple cd_args)) in - TypeSet.elements (TypeSet.diff arg_vars res_vars) + let existentials, cstr_args = + constructor_args cd_args cd_res in let cstr = { cstr_name = Ident.name cd_id; cstr_res = ty_res; cstr_existentials = existentials; - cstr_args = cd_args; - cstr_arity = List.length cd_args; + cstr_args; + cstr_arity = List.length cstr_args; cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; cstr_normal = !num_normal; - cstr_private = priv; + cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; cstr_attributes = cd_attributes; @@ -90,24 +99,17 @@ let extension_descr path_ext ext = let ty_res = match ext.ext_ret_type with Some type_ret -> type_ret - | None -> - newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) + | None -> newgenconstr ext.ext_type_path ext.ext_type_params in - let tag = Cstr_extension(path_ext, ext.ext_args = []) in - let existentials = - match ext.ext_ret_type with - | None -> [] - | Some type_ret -> - let ret_vars = free_vars type_ret in - let arg_vars = free_vars (newgenty (Ttuple ext.ext_args)) in - TypeSet.elements (TypeSet.diff arg_vars ret_vars) + let existentials, cstr_args = + constructor_args ext.ext_args ext.ext_ret_type in { cstr_name = Path.last path_ext; cstr_res = ty_res; cstr_existentials = existentials; - cstr_args = ext.ext_args; - cstr_arity = List.length ext.ext_args; - cstr_tag = tag; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = Cstr_extension(path_ext, cstr_args = []); cstr_consts = -1; cstr_nonconsts = -1; cstr_private = ext.ext_private; @@ -164,3 +166,15 @@ let rec find_constr tag num_const num_nonconst = function let find_constr_by_tag tag cstrlist = find_constr tag 0 0 cstrlist + +let constructors_of_type ty_path decl = + match decl.type_kind with + | Type_variant cstrs -> constructor_descrs ty_path decl cstrs + | Type_record _ | Type_abstract | Type_open -> [] + +let labels_of_type ty_path decl = + match decl.type_kind with + | Type_record(labels, rep) -> + label_descrs (newgenconstr ty_path decl.type_params) + labels rep decl.type_private + | Type_variant _ | Type_abstract | Type_open -> [] diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 8e298debd..d56446a24 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -13,18 +13,18 @@ (* Compute constructor and label descriptions from type declarations, determining their representation. *) -open Asttypes open Types -val constructor_descrs: - type_expr -> constructor_declaration list -> - private_flag -> (Ident.t * constructor_description) list val extension_descr: Path.t -> extension_constructor -> constructor_description -val label_descrs: - type_expr -> label_declaration list -> - record_representation -> private_flag -> - (Ident.t * label_description) list + +val labels_of_type: + Path.t -> type_declaration -> + (Ident.t * label_description) list +val constructors_of_type: + Path.t -> type_declaration -> + (Ident.t * constructor_description) list + exception Constr_not_found diff --git a/typing/env.ml b/typing/env.ml index a8c6de1a5..5655197a9 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -293,7 +293,7 @@ let current_unit = ref "" type pers_struct = { ps_name: string; - ps_sig: signature; + ps_sig: signature Lazy.t; ps_comps: module_components; ps_crcs: (string * Digest.t option) list; mutable ps_crcs_checked: bool; @@ -348,7 +348,7 @@ let read_pers_struct modname filename = (Mty_signature sign) in let ps = { ps_name = name; - ps_sig = sign; + ps_sig = lazy (Subst.signature Subst.identity sign); ps_comps = comps; ps_crcs = crcs; ps_filename = filename; @@ -489,7 +489,7 @@ let find_module ~alias path env = with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in - md (Mty_signature(ps.ps_sig)) + md (Mty_signature(Lazy.force ps.ps_sig)) else raise Not_found end | Pdot(p, s, pos) -> @@ -1069,28 +1069,6 @@ let rec scrape_alias env ?path mty = let scrape_alias env mty = scrape_alias env mty -(* Compute constructor descriptions *) - -let constructors_of_type ty_path decl = - let handle_variants cstrs = - Datarepr.constructor_descrs - (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - cstrs decl.type_private - in - match decl.type_kind with - | Type_variant cstrs -> handle_variants cstrs - | Type_record _ | Type_abstract | Type_open -> [] - -(* Compute label descriptions *) - -let labels_of_type ty_path decl = - match decl.type_kind with - Type_record(labels, rep) -> - Datarepr.label_descrs - (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - labels rep decl.type_private - | Type_variant _ | Type_abstract | Type_open -> [] - (* Given a signature and a root path, prefix all idents in the signature by the root path and build the corresponding substitution. *) @@ -1209,8 +1187,10 @@ and components_of_module_maker (env, sub, path, mty) = end | Sig_type(id, decl, _) -> let decl' = Subst.type_declaration sub decl in - let constructors = List.map snd (constructors_of_type path decl') in - let labels = List.map snd (labels_of_type path decl') in + let constructors = + List.map snd (Datarepr.constructors_of_type path decl') in + let labels = + List.map snd (Datarepr.labels_of_type path decl') in c.comp_types <- Tbl.add (Ident.name id) ((decl', (constructors, labels)), nopos) @@ -1307,8 +1287,8 @@ and store_type ~check slot id path info env renv = if check then check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; - let constructors = constructors_of_type path info in - let labels = labels_of_type path info in + let constructors = Datarepr.constructors_of_type path info in + let labels = Datarepr.labels_of_type path info in let descrs = (List.map snd constructors, List.map snd labels) in if check && not loc.Location.loc_ghost && @@ -1435,8 +1415,7 @@ let _ = (* Insertion of bindings by identifier *) -let add_functor_arg ?(arg=false) id env = - if not arg then env else +let add_functor_arg id env = {env with functor_args = Ident.add id () env.functor_args; summary = Env_functor_arg (env.summary, id)} @@ -1450,14 +1429,14 @@ let add_type ~check id info env = and add_extension ~check id ext env = store_extension ~check None id (Pident id) ext env env -and add_module_declaration ?arg id md env = +and add_module_declaration ?(arg=false) id md env = let path = (*match md.md_type with Mty_alias path -> normalize_path env path | _ ->*) Pident id in let env = store_module None id path md env env in - add_functor_arg ?arg id env + if arg then add_functor_arg id env else env and add_modtype id info env = store_modtype None id (Pident id) info env env @@ -1508,7 +1487,7 @@ let add_item comp env = Sig_value(id, decl) -> add_value id decl env | Sig_type(id, decl, _) -> add_type ~check:false id decl env | Sig_typext(id, ext, _) -> add_extension ~check:false id ext env - | Sig_module(id, md, _) -> add_module_declaration id md env + | Sig_module(id, md, _) -> add_module_declaration id md env | Sig_modtype(id, decl) -> add_modtype id decl env | Sig_class(id, decl, _) -> add_class id decl env | Sig_class_type(id, decl, _) -> add_cltype id decl env @@ -1553,7 +1532,8 @@ let open_signature slot root sg env0 = let open_pers_signature name env = let ps = find_pers_struct name in - open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env + open_signature None (Pident(Ident.create_persistent name)) + (Lazy.force ps.ps_sig) env let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost @@ -1590,7 +1570,7 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = let read_signature modname filename = let ps = read_pers_struct modname filename in check_consistency ps; - ps.ps_sig + Lazy.force ps.ps_sig (* Return the CRC of the interface of the given compilation unit *) @@ -1636,7 +1616,7 @@ let save_signature_with_imports sg modname filename imports = (Pident(Ident.create_persistent modname)) (Mty_signature sg) in let ps = { ps_name = modname; - ps_sig = sg; + ps_sig = lazy (Subst.signature Subst.identity sg); ps_comps = comps; ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; @@ -1710,7 +1690,7 @@ let fold_modules f lid env acc = None -> acc | Some ps -> f name (Pident(Ident.create_persistent name)) - (md (Mty_signature ps.ps_sig)) acc) + (md (Mty_signature (Lazy.force ps.ps_sig))) acc) persistent_structures acc | Some l -> diff --git a/typing/env.mli b/typing/env.mli index ed2f6f1c5..4ab08e83a 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -61,6 +61,7 @@ val find_type_expansion_opt: (* Find the manifest type information associated to a type for the sake of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> module_type +val add_functor_arg: Ident.t -> t -> t val is_functor_arg: Path.t -> t -> bool val normalize_path: Location.t option -> t -> Path.t -> Path.t (* Normalize the path to a concrete value or module. diff --git a/typing/includecore.ml b/typing/includecore.ml index 88fad1e5b..ee247adad 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -154,7 +154,7 @@ let report_type_mismatch first second decl ppf = if err = Manifest then () else Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) -let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = +let rec compare_variants env params1 params2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] | [], c::_ -> [Field_missing (true, c.Types.cd_id)] @@ -173,15 +173,14 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = | _ -> if Misc.for_all2 (fun ty1 ty2 -> - Ctype.equal env true (ty1::decl1.type_params) - (ty2::decl2.type_params)) + Ctype.equal env true (ty1::params1) (ty2::params2)) (arg1) (arg2) then - compare_variants env decl1 decl2 (n+1) rem1 rem2 + compare_variants env params1 params2 (n+1) rem1 rem2 else [Field_type cstr1] -let rec compare_records env decl1 decl2 n labels1 labels2 = +let rec compare_records env params1 params2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], l::_ -> [Field_missing (true, l.ld_id)] @@ -191,9 +190,9 @@ let rec compare_records env decl1 decl2 n labels1 labels2 = if Ident.name lab1 <> Ident.name lab2 then [Field_names (n, lab1, lab2)] else if mut1 <> mut2 then [Field_mutable lab1] else - if Ctype.equal env true (arg1::decl1.type_params) - (arg2::decl2.type_params) - then compare_records env decl1 decl2 (n+1) rem1 rem2 + if Ctype.equal env true (arg1::params1) + (arg2::params2) + then compare_records env params1 params2 (n+1) rem1 rem2 else [Field_type lab1] let type_declarations ?(equality = false) env name decl1 id decl2 = @@ -215,9 +214,10 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = in mark cstrs1 usage name decl1; if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; - compare_variants env decl1 decl2 1 cstrs1 cstrs2 + compare_variants env decl1.type_params decl2.type_params 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - let err = compare_records env decl1 decl2 1 labels1 labels2 in + let err = compare_records env decl1.type_params decl2.type_params + 1 labels1 labels2 in if err <> [] || rep1 = rep2 then err else [Record_representation (rep2 = Record_float)] | (Type_open, Type_open) -> [] diff --git a/typing/includemod.ml b/typing/includemod.ml index 223214f36..3eb26fbd6 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -379,9 +379,11 @@ and signature_components env cxt subst = function extension_constructors env cxt subst id1 ext1 ext2; (pos, Tcoerce_none) :: signature_components env cxt subst rem | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> + let p1 = Pident id1 in let cc = modtypes env (Module id1::cxt) subst - (Mtype.strengthen env mty1.md_type (Pident id1)) mty2.md_type in + (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1) + mty2.md_type in (pos, cc) :: signature_components env cxt subst rem | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; @@ -418,7 +420,10 @@ and check_modtype_equiv env cxt mty1 mty2 = modtypes env cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () - | (_, _) -> raise(Error [cxt, env, Modtype_permutation]) + | (c1, c2) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion c1 print_coercion c2; *) + raise(Error [cxt, env, Modtype_permutation]) (* Simplified inclusion check between module types (for Env) *) diff --git a/typing/mtype.ml b/typing/mtype.ml index dd766a913..19253a10e 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -33,18 +33,18 @@ let freshen mty = let rec strengthen env mty p = match scrape env mty with Mty_signature sg -> - Mty_signature(strengthen_sig env sg p) + Mty_signature(strengthen_sig env sg p 0) | Mty_functor(param, arg, res) when !Clflags.applicative_functors && Ident.name param <> "*" -> Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty -and strengthen_sig env sg p = +and strengthen_sig env sg p pos = match sg with [] -> [] | (Sig_value(id, desc) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p (pos+1) | Sig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with @@ -59,13 +59,18 @@ and strengthen_sig env sg p = else { decl with type_manifest = manif } in - Sig_type(id, newdecl, rs) :: strengthen_sig env rem p + Sig_type(id, newdecl, rs) :: strengthen_sig env rem p pos | (Sig_typext(id, ext, es) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p (pos+1) | Sig_module(id, md, rs) :: rem -> - let str = strengthen_decl env md (Pdot(p, Ident.name id, nopos)) in + let str = + if Env.is_functor_arg p env then + strengthen_decl env md (Pdot(p, Ident.name id, pos)) + else + {md with md_type = Mty_alias (Pdot(p, Ident.name id, pos))} + in Sig_module(id, str, rs) - :: strengthen_sig (Env.add_module_declaration id md env) rem p + :: strengthen_sig (Env.add_module_declaration id md env) rem p (pos+1) (* Need to add the module in case it defines manifest module types *) | Sig_modtype(id, decl) :: rem -> let newdecl = @@ -76,12 +81,12 @@ and strengthen_sig env sg p = decl in Sig_modtype(id, newdecl) :: - strengthen_sig (Env.add_modtype id decl env) rem p + strengthen_sig (Env.add_modtype id decl env) rem p pos (* Need to add the module type in case it is manifest *) | (Sig_class(id, decl, rs) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p (pos+1) | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p pos and strengthen_decl env md p = {md with md_type = strengthen env md.md_type p} diff --git a/typing/subst.ml b/typing/subst.ml index 2e84be01f..5b1b0c67f 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -184,6 +184,27 @@ let type_expr s ty = cleanup_types (); ty' +let label_declaration s l = + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_type = typexp s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + } + +let constructor_arguments s args = + List.map (typexp s) args + +let constructor_declaration s c = + { + cd_id = c.cd_id; + cd_args = constructor_arguments s c.cd_args; + cd_res = may_map (typexp s) c.cd_res; + cd_loc = loc s c.cd_loc; + cd_attributes = attrs s c.cd_attributes; + } + let type_declaration s decl = let decl = { type_params = List.map (typexp s) decl.type_params; @@ -192,31 +213,9 @@ let type_declaration s decl = begin match decl.type_kind with Type_abstract -> Type_abstract | Type_variant cstrs -> - Type_variant - (List.map - (fun c -> - { - cd_id = c.cd_id; - cd_args = List.map (typexp s) c.cd_args; - cd_res = may_map (typexp s) c.cd_res; - cd_loc = loc s c.cd_loc; - cd_attributes = attrs s c.cd_attributes; - } - ) - cstrs) + Type_variant (List.map (constructor_declaration s) cstrs) | Type_record(lbls, rep) -> - Type_record - (List.map (fun l -> - { - ld_id = l.ld_id; - ld_mutable = l.ld_mutable; - ld_type = typexp s l.ld_type; - ld_loc = loc s l.ld_loc; - ld_attributes = attrs s l.ld_attributes; - } - ) - lbls, - rep) + Type_record (List.map (label_declaration s) lbls, rep) | Type_open -> Type_open end; type_manifest = @@ -303,7 +302,7 @@ let extension_constructor s ext = let ext = { ext_type_path = type_path s ext.ext_type_path; ext_type_params = List.map (typexp s) ext.ext_type_params; - ext_args = List.map (typexp s) ext.ext_args; + ext_args = constructor_arguments s ext.ext_args; ext_ret_type = may_map (typexp s) ext.ext_ret_type; ext_private = ext.ext_private; ext_attributes = ext.ext_attributes; diff --git a/typing/typemod.ml b/typing/typemod.ml index 94f8c621a..f6ea9d192 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -138,6 +138,10 @@ let make p n i = let open Variance in set May_pos p (set May_neg n (set May_weak n (set Inj i null))) +let ensure_functor_arg p env = + if Env.is_functor_arg p env then env else + Env.add_functor_arg (Path.head p) env + let merge_constraint initial_env loc sg constr = let lid = match constr with @@ -212,6 +216,7 @@ let merge_constraint initial_env loc sg constr = when Ident.name id = s -> let path, md' = Typetexp.find_module initial_env loc lid'.txt in let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in + let env = ensure_functor_arg path env in let newmd = Mtype.strengthen_decl env md'' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); (Pident id, lid, Twith_module (path, lid')), @@ -219,6 +224,7 @@ let merge_constraint initial_env loc sg constr = | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) when Ident.name id = s -> let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let env = ensure_functor_arg path env in let newmd = Mtype.strengthen_decl env md' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); real_id := Some id; @@ -431,16 +437,30 @@ let check cl loc set_ref name = then raise(Error(loc, Env.empty, Repeated_name(cl, name))) else set_ref := StringSet.add name !set_ref -let check_name cl set_ref name = - check cl name.loc set_ref name.txt +type names = + { + types: StringSet.t ref; + modules: StringSet.t ref; + modtypes: StringSet.t ref; + } -let check_sig_item type_names module_names modtype_names loc = function - Sig_type(id, _, _) -> - check "type" loc type_names (Ident.name id) - | Sig_module(id, _, _) -> - check "module" loc module_names (Ident.name id) - | Sig_modtype(id, _) -> - check "module type" loc modtype_names (Ident.name id) +let new_names () = + { + types = ref StringSet.empty; + modules = ref StringSet.empty; + modtypes = ref StringSet.empty; + } + + +let check_name check names name = check names name.loc name.txt +let check_type names loc s = check "type" loc names.types s +let check_module names loc s = check "module" loc names.modules s +let check_modtype names loc s = check "module type" loc names.modtypes s + +let check_sig_item names loc = function + | Sig_type(id, _, _) -> check_type names loc (Ident.name id) + | Sig_module(id, _, _) -> check_module names loc (Ident.name id) + | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id) | _ -> () let rec remove_duplicates val_ids ext_ids = function @@ -542,9 +562,7 @@ let rec transl_modtype env smty = and transl_signature env sg = - let type_names = ref StringSet.empty - and module_names = ref StringSet.empty - and modtype_names = ref StringSet.empty in + let names = new_names () in let rec transl_sig env sg = Ctype.init_def(Ident.current_time()); match sg with @@ -562,8 +580,7 @@ and transl_signature env sg = final_env | Psig_type sdecls -> List.iter - (fun decl -> - check_name "type" type_names decl.ptype_name) + (fun decl -> check_name check_type names decl.ptype_name) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in @@ -600,7 +617,7 @@ and transl_signature env sg = Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem), final_env | Psig_module pmd -> - check_name "module" module_names pmd.pmd_name; + check_name check_module names pmd.pmd_name; let tmty = transl_modtype env pmd.pmd_type in let md = { md_type=tmty.mty_type; @@ -619,7 +636,7 @@ and transl_signature env sg = final_env | Psig_recmodule sdecls -> List.iter - (fun pmd -> check_name "module" module_names pmd.pmd_name) + (fun pmd -> check_name check_module names pmd.pmd_name) sdecls; let (decls, newenv) = transl_recmodule_modtypes item.psig_loc env sdecls in @@ -635,7 +652,7 @@ and transl_signature env sg = final_env | Psig_modtype pmtd -> let newenv, mtd, sg = - transl_modtype_decl modtype_names env item.psig_loc pmtd + transl_modtype_decl names env item.psig_loc pmtd in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype mtd) env loc :: trem, @@ -652,10 +669,7 @@ and transl_signature env sg = let mty = tmty.mty_type in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in - List.iter - (check_sig_item type_names module_names modtype_names - item.psig_loc) - sg; + List.iter (check_sig_item names item.psig_loc) sg; let newenv = Env.add_signature sg env in let incl = { incl_mod = tmty; @@ -671,7 +685,7 @@ and transl_signature env sg = final_env | Psig_class cl -> List.iter - (fun {pci_name = name} -> check_name "type" type_names name) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, newenv) = Typeclass.class_descriptions env cl in let (trem, rem, final_env) = transl_sig newenv srem in @@ -693,7 +707,7 @@ and transl_signature env sg = final_env | Psig_class_type cl -> List.iter - (fun {pci_name = name} -> check_name "type" type_names name) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, newenv) = Typeclass.class_type_declarations env cl in let (trem,rem, final_env) = transl_sig newenv srem in @@ -725,9 +739,9 @@ and transl_signature env sg = ((Cmt_format.Partial_signature sg) :: previous_saved_types); sg -and transl_modtype_decl modtype_names env loc +and transl_modtype_decl names env loc {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = - check_name "module type" modtype_names pmtd_name; + check_name check_modtype names pmtd_name; let tmty = Misc.may_map (transl_modtype env) pmtd_type in let decl = { @@ -812,22 +826,31 @@ and transl_recmodule_modtypes loc env sdecls = keep only the last (rightmost) one. *) let simplify_signature sg = - let rec simplif val_names ext_names res = function - [] -> res - | (Sig_value(id, descr) as component) :: sg -> - let name = Ident.name id in - simplif (StringSet.add name val_names) ext_names - (if StringSet.mem name val_names then res else component :: res) - sg - | (Sig_typext(id, ext, es) as component) :: sg -> - let name = Ident.name id in - simplif val_names (StringSet.add name ext_names) - (if StringSet.mem name ext_names then res else component :: res) - sg - | component :: sg -> - simplif val_names ext_names (component :: res) sg + let rec aux = function + | [] -> [], StringSet.empty, StringSet.empty + | (Sig_value(id, descr) as component) :: sg -> + let (sg, val_names, ext_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name val_names then k + else (component :: sg, StringSet.add name val_names, ext_names) + | (Sig_typext(id, ext, es) as component) :: sg -> + let (sg, val_names, ext_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name ext_names then + (* #6510 *) + match es, sg with + | Text_first, Sig_typext(id2, ext2, Text_next) :: rest -> + (Sig_typext(id2, ext2, Text_first) :: rest, + val_names, ext_names) + | _ -> k + else + (component :: sg, val_names, StringSet.add name ext_names) + | component :: sg -> + let (sg, val_names, ext_names) = aux sg in + (component :: sg, val_names, ext_names) in - simplif StringSet.empty StringSet.empty [] (List.rev sg) + let (sg, _, _) = aux sg in + sg (* Try to convert a module expression to a module path. *) @@ -919,8 +942,10 @@ let check_recmodule_inclusion env bindings = the number of mutually recursive declarations. *) let subst_and_strengthen env s id mty = - Mtype.strengthen env (Subst.modtype s mty) - (Subst.module_path s (Pident id)) in + let p = Subst.module_path s (Pident id) in + let env = ensure_functor_arg p env in + Mtype.strengthen env (Subst.modtype s mty) p + in let rec check_incl first_time n env s = if n > 0 then begin @@ -1191,9 +1216,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = raise (Error_forward (Typetexp.error_of_extension ext)) and type_structure ?(toplevel = false) funct_body anchor env sstr scope = - let type_names = ref StringSet.empty - and module_names = ref StringSet.empty - and modtype_names = ref StringSet.empty in + let names = new_names () in let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = match desc with @@ -1227,7 +1250,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv | Pstr_type sdecls -> List.iter - (fun decl -> check_name "type" type_names decl.ptype_name) + (fun decl -> check_name check_type names decl.ptype_name) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in Tstr_type decls, @@ -1251,7 +1274,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; } -> - check_name "module" module_names name; + check_name check_module names name; let modl = type_module ~alias:true true funct_body (anchor_submodule name.txt anchor) env smodl in @@ -1288,7 +1311,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = sbind in List.iter - (fun (name, _, _, _, _) -> check_name "module" module_names name) + (fun (name, _, _, _, _) -> check_name check_module names name) sbind; let (decls, newenv) = transl_recmodule_modtypes loc env @@ -1335,7 +1358,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_modtype pmtd -> (* check that it is non-abstract *) let newenv, mtd, sg = - transl_modtype_decl modtype_names env loc pmtd + transl_modtype_decl names env loc pmtd in Tstr_modtype mtd, [sg], newenv | Pstr_open sod -> @@ -1343,7 +1366,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = Tstr_open od, [], newenv | Pstr_class cl -> List.iter - (fun {pci_name = name} -> check_name "type" type_names name) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, new_env) = Typeclass.class_declarations env cl in Tstr_class @@ -1370,7 +1393,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = new_env | Pstr_class_type cl -> List.iter - (fun {pci_name = name} -> check_name "type" type_names name) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, new_env) = Typeclass.class_type_declarations env cl in Tstr_class_type @@ -1395,29 +1418,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity (extract_sig_open env smodl.pmod_loc modl.mod_type) in - let sg = - match modl.mod_desc with - Tmod_ident (p, _) when not (Env.is_functor_arg p env) -> - Env.add_required_global (Path.head p); - let pos = ref 0 in - List.map - (function - | Sig_module (id, md, rs) -> - let n = !pos in incr pos; - Sig_module (id, {md with md_type = - Mty_alias (Pdot(p,Ident.name id,n))}, - rs) - | Sig_value (_, {val_kind=Val_reg}) - | Sig_typext _ | Sig_class _ as it -> - incr pos; it - | Sig_value _ | Sig_type _ | Sig_modtype _ - | Sig_class_type _ as it -> - it) - sg - | _ -> sg - in - List.iter - (check_sig_item type_names module_names modtype_names loc) sg; + List.iter (check_sig_item names loc) sg; let new_env = Env.add_signature sg env in let incl = { incl_mod = modl; @@ -1480,49 +1481,6 @@ and normalize_signature_item env = function | Sig_module(id, md, _) -> normalize_modtype env md.md_type | _ -> () -(* Simplify multiple specifications of a value or an extension in a signature. - (Other signature components, e.g. types, modules, etc, are checked for - name uniqueness.) If multiple specifications with the same name, - keep only the last (rightmost) one. *) - -let rec simplify_modtype mty = - match mty with - Mty_ident path -> mty - | Mty_alias path -> mty - | Mty_functor(id, arg, res) -> Mty_functor(id, arg, simplify_modtype res) - | Mty_signature sg -> Mty_signature(simplify_signature sg) - -and simplify_signature sg = - let rec aux = function - | [] -> [], StringSet.empty, StringSet.empty - | (Sig_value(id, descr) as component) :: sg -> - let (sg, val_names, ext_names) as k = aux sg in - let name = Ident.name id in - if StringSet.mem name val_names then k - else (component :: sg, StringSet.add name val_names, ext_names) - | (Sig_typext(id, ext, es) as component) :: sg -> - let (sg, val_names, ext_names) as k = aux sg in - let name = Ident.name id in - if StringSet.mem name ext_names then - (* #6510 *) - match es, sg with - | Text_first, Sig_typext(id2, ext2, Text_next) :: rest -> - (Sig_typext(id2, ext2, Text_first) :: rest, - val_names, ext_names) - | _ -> k - else - (component :: sg, val_names, StringSet.add name ext_names) - | Sig_module(id, md, rs) :: sg -> - let (sg, val_names, ext_names) = aux sg in - let md = {md with md_type = simplify_modtype md.md_type} in - (Sig_module(id, md, rs) :: sg, val_names, ext_names) - | component :: sg -> - let (sg, val_names, ext_names) = aux sg in - (component :: sg, val_names, ext_names) - in - let (sg, _, _) = aux sg in - sg - (* Extract the module type of a module expression *) let type_module_type_of env smod = |