diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d7bf0316ed..a19f176af3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -186,7 +186,7 @@ jobs: - name: Install OPAM dependencies if: steps.cache-opam-env.outputs.cache-hit != 'true' - run: opam install . --deps-only + run: opam install . --deps-only --with-test - name: Cache OPAM environment if: steps.cache-opam-env.outputs.cache-hit != 'true' diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 0000000000..1d8e67f541 --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1,19 @@ +compiler/js_parser/** +compiler/ml/cmt_format.ml +compiler/ml/pprintast.ml +compiler/core/js_name_of_module_id.ml +compiler/core/js_pass_debug.ml +compiler/core/lam_util.ml +compiler/core/lam_compile_main.ml +compiler/ext/bs_hash_stubs.ml +compiler/ext/js_reserved_map.ml +compiler/ext/ext_string.ml +compiler/ext/ext_string.mli +compiler/ext/ext_sys.ml +compiler/ext/hash.cppo.ml +compiler/ext/hash_set.cppo.ml +compiler/ext/map.cppo.ml +compiler/ext/ordered_hash_map.cppo.ml +compiler/ext/set.cppo.ml +compiler/ext/vec.cppo.ml +compiler/syntax/compiler-libs-406/* diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index ebdb715c32..ee774b79fe 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -17,7 +17,7 @@ Happy hacking! - [NodeJS v18](https://nodejs.org/) - C compiler toolchain (usually installed with `xcode` on Mac) - Rust toolchain (required to build rewatch; follow the instructions at https://www.rust-lang.org/tools/install) -- `opam` (OCaml Package Manager) +- `opam` (OCaml Package Manager) v2.2.0 - VSCode (+ [OCaml Platform Extension](https://marketplace.visualstudio.com/items?itemName=ocamllabs.ocaml-platform)) ## Cloning the Git Repo @@ -49,10 +49,7 @@ opam init opam switch create 5.2.0 # can also create local switch with opam switch create # Install dev dependencies from OPAM -opam install . --deps-only - -# For IDE support, install the OCaml language server -opam install ocaml-lsp-server +opam install . --deps-only --with-test --with-dev-setup -y ``` #### npm install diff --git a/compiler/bsb/.ocamlformat b/compiler/bsb/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/bsb/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/bsb/bsb_arg.ml b/compiler/bsb/bsb_arg.ml index 2e5e4cf272..b0adc252f6 100644 --- a/compiler/bsb/bsb_arg.ml +++ b/compiler/bsb/bsb_arg.ml @@ -63,11 +63,11 @@ let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) = buf +> String.make (!max_col + 4) ' '); match String.index_from_opt doc !cur '\n' with | None -> - buf +> String.sub doc !cur (String.length doc - !cur); - cur := doc_length + buf +> String.sub doc !cur (String.length doc - !cur); + cur := doc_length | Some new_line_pos -> - buf +> String.sub doc !cur (new_line_pos - !cur); - cur := new_line_pos + 1 + buf +> String.sub doc !cur (new_line_pos - !cur); + cur := new_line_pos + 1 done; buf +> "\n"))) @@ -75,17 +75,17 @@ let stop_raise ~usage ~(error : error) (speclist : t) = let b = Ext_buffer.create 200 in (match error with | Unknown ("-help" | "--help" | "-h") -> - usage_b b ~usage speclist; - Ext_buffer.output_buffer stdout b; - exit 0 + usage_b b ~usage speclist; + Ext_buffer.output_buffer stdout b; + exit 0 | Unknown s -> - b +> "Unknown option \""; - b +> s; - b +> "\".\n" + b +> "Unknown option \""; + b +> s; + b +> "\".\n" | Missing s -> - b +> "Option \""; - b +> s; - b +> "\" needs an argument.\n"); + b +> "Option \""; + b +> s; + b +> "\" needs an argument.\n"); usage_b b ~usage speclist; bad_arg (Ext_buffer.contents b) @@ -99,20 +99,20 @@ let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) if s <> "" && s.[0] = '-' then match Ext_spec.assoc3 speclist s with | Some action -> ( - match action with - | Unit r -> ( - match r with - | Unit_set r -> r.contents <- true - | Unit_call f -> f ()) - | String f -> ( - if !current >= finish then - stop_raise ~usage ~error:(Missing s) speclist - else - let arg = argv.(!current) in - incr current; - match f with - | String_call f -> f arg - | String_set u -> u.contents <- arg)) + match action with + | Unit r -> ( + match r with + | Unit_set r -> r.contents <- true + | Unit_call f -> f ()) + | String f -> ( + if !current >= finish then + stop_raise ~usage ~error:(Missing s) speclist + else + let arg = argv.(!current) in + incr current; + match f with + | String_call f -> f arg + | String_set u -> u.contents <- arg)) | None -> stop_raise ~usage ~error:(Unknown s) speclist else rev_list := s :: !rev_list done; diff --git a/compiler/bsb/bsb_build_util.ml b/compiler/bsb/bsb_build_util.ml index 9982b5b65b..36f5c9a935 100644 --- a/compiler/bsb/bsb_build_util.ml +++ b/compiler/bsb/bsb_build_util.ml @@ -24,7 +24,7 @@ let flag_concat flag xs = String.concat Ext_string.single_space - (Ext_list.flat_map xs (fun x -> [ flag; x ])) + (Ext_list.flat_map xs (fun x -> [flag; x])) let ( // ) = Ext_path.combine @@ -42,11 +42,11 @@ let pp_flag (xs : string) = "-pp " ^ Ext_filename.maybe_quote xs let include_dirs dirs = String.concat Ext_string.single_space - (Ext_list.flat_map dirs (fun x -> [ "-I"; Ext_filename.maybe_quote x ])) + (Ext_list.flat_map dirs (fun x -> ["-I"; Ext_filename.maybe_quote x])) let include_dirs_by dirs fn = String.concat Ext_string.single_space - (Ext_list.flat_map dirs (fun x -> [ "-I"; Ext_filename.maybe_quote (fn x) ])) + (Ext_list.flat_map dirs (fun x -> ["-I"; Ext_filename.maybe_quote (fn x)])) (* we use lazy $src_root_dir *) @@ -64,7 +64,7 @@ let convert_and_resolve_path : string -> string -> string = else failwith ("Unknown OS :" ^ Sys.os_type) (* we only need convert the path in the beginning *) -type result = { path : string; checked : bool } +type result = {path: string; checked: bool} (* Magic path resolution: foo => foo @@ -78,7 +78,7 @@ let resolve_bsb_magic_file ~cwd ~desc p : result = let no_slash = Ext_string.no_slash_idx p in if no_slash < 0 then (* Single file FIXME: better error message for "" input *) - { path = p; checked = false } + {path = p; checked = false} else let first_char = String.unsafe_get p 0 in if Filename.is_relative p && first_char <> '.' then @@ -91,13 +91,13 @@ let resolve_bsb_magic_file ~cwd ~desc p : result = (* let p = if Ext_sys.is_windows_or_cygwin then Ext_string.replace_slash_backward p else p in *) let package_dir = Bsb_pkg.resolve_bs_package ~cwd package_name in let path = package_dir // relative_path in - if Sys.file_exists path then { path; checked = true } + if Sys.file_exists path then {path; checked = true} else ( Bsb_log.error "@{Could not resolve @} %s in %s@." p cwd; failwith (p ^ " not found when resolving " ^ desc)) else (* relative path [./x/y]*) - { path = convert_and_resolve_path cwd p; checked = true } + {path = convert_and_resolve_path cwd p; checked = true} (** converting a file from Linux path format to Windows *) @@ -121,7 +121,9 @@ let rec mkp dir = let get_list_string_acc (s : Ext_json_types.t array) acc = Ext_array.to_list_map_acc s acc (fun x -> - match x with Str x -> Some x.str | _ -> None) + match x with + | Str x -> Some x.str + | _ -> None) let get_list_string s = get_list_string_acc s [] @@ -130,7 +132,7 @@ let ( |? ) m (key, cb) = m |> Ext_json.test key cb type top = Expect_none | Expect_name of string -type package_context = { proj_dir : string; top : top; is_pinned: bool } +type package_context = {proj_dir: string; top: top; is_pinned: bool} (** TODO: check duplicate package name @@ -146,79 +148,82 @@ type package_context = { proj_dir : string; top : top; is_pinned: bool } let pp_packages_rev ppf lst = Ext_list.rev_iter lst (fun s -> Format.fprintf ppf "%s " s) -let extract_pinned_dependencies (map : Ext_json_types.t Map_string.t) : Set_string.t = +let extract_pinned_dependencies (map : Ext_json_types.t Map_string.t) : + Set_string.t = match Map_string.find_opt map Bsb_build_schemas.pinned_dependencies with | None -> Set_string.empty - | Some (Arr { content }) -> - Set_string.of_list (get_list_string content) + | Some (Arr {content}) -> Set_string.of_list (get_list_string content) | Some config -> Bsb_exception.config_error config "expect an array of string" let rec walk_all_deps_aux (visited : string Hash_string.t) (paths : string list) ~(top : top) (dir : string) (queue : _ Queue.t) ~pinned_dependencies = - match Bsb_config_load.load_json ~per_proj_dir:dir ~warn_legacy_config:false with - | _, Obj { map; loc } -> - let cur_package_name = - match Map_string.find_opt map Bsb_build_schemas.name with - | Some (Str { str; loc }) -> - (match top with - | Expect_none -> () - | Expect_name s -> - if s <> str then - Bsb_exception.errorf ~loc - "package name is expected to be %s but got %s" s str); - str - | Some _ | None -> - Bsb_exception.errorf ~loc "package name missing in %s/bsconfig.json" - dir + match + Bsb_config_load.load_json ~per_proj_dir:dir ~warn_legacy_config:false + with + | _, Obj {map; loc} -> + let cur_package_name = + match Map_string.find_opt map Bsb_build_schemas.name with + | Some (Str {str; loc}) -> + (match top with + | Expect_none -> () + | Expect_name s -> + if s <> str then + Bsb_exception.errorf ~loc + "package name is expected to be %s but got %s" s str); + str + | Some _ | None -> + Bsb_exception.errorf ~loc "package name missing in %s/bsconfig.json" dir + in + if Ext_list.mem_string paths cur_package_name then ( + Bsb_log.error "@{Cyclic dependencies in package stack@}@."; + exit 2); + let package_stacks = cur_package_name :: paths in + Bsb_log.info "@{Package stack:@} %a @." pp_packages_rev package_stacks; + if Hash_string.mem visited cur_package_name then + Bsb_log.info "@{Visited before@} %s@." cur_package_name + else + let explore_deps (deps : string) pinned_dependencies = + map + |? ( deps, + `Arr + (fun (new_packages : Ext_json_types.t array) -> + Ext_array.iter new_packages (fun js -> + match js with + | Str {str = new_package} -> + let package_dir = + Bsb_pkg.resolve_bs_package ~cwd:dir + (Bsb_pkg_types.string_as_package new_package) + in + walk_all_deps_aux visited package_stacks + ~top:(Expect_name new_package) package_dir queue + ~pinned_dependencies + | _ -> Bsb_exception.errorf ~loc "%s expect an array" deps)) + ) + |> ignore in - if Ext_list.mem_string paths cur_package_name then ( - Bsb_log.error "@{Cyclic dependencies in package stack@}@."; - exit 2); - let package_stacks = cur_package_name :: paths in - Bsb_log.info "@{Package stack:@} %a @." pp_packages_rev - package_stacks; - if Hash_string.mem visited cur_package_name then - Bsb_log.info "@{Visited before@} %s@." cur_package_name - else - let explore_deps (deps : string) pinned_dependencies = - map - |? ( deps, - `Arr - (fun (new_packages : Ext_json_types.t array) -> - Ext_array.iter new_packages (fun js -> - match js with - | Str { str = new_package } -> - let package_dir = - Bsb_pkg.resolve_bs_package ~cwd:dir - (Bsb_pkg_types.string_as_package new_package) - in - walk_all_deps_aux visited package_stacks - ~top:(Expect_name new_package) package_dir queue - ~pinned_dependencies - | _ -> - Bsb_exception.errorf ~loc "%s expect an array" deps)) - ) - |> ignore - in - let is_pinned = match top with + let is_pinned = + match top with | Expect_name n when Set_string.mem pinned_dependencies n -> true | _ -> false - in - let pinned_dependencies = match is_pinned with + in + let pinned_dependencies = + match is_pinned with | true -> - let transitive_pinned_dependencies = extract_pinned_dependencies map + let transitive_pinned_dependencies = + extract_pinned_dependencies map in Set_string.union transitive_pinned_dependencies pinned_dependencies | false -> pinned_dependencies - in - explore_deps Bsb_build_schemas.bs_dependencies pinned_dependencies; - (match top with - | Expect_none -> explore_deps Bsb_build_schemas.bs_dev_dependencies pinned_dependencies - | Expect_name _ when is_pinned -> - explore_deps Bsb_build_schemas.bs_dev_dependencies pinned_dependencies - | Expect_name _ -> ()); - Queue.add { top; proj_dir = dir; is_pinned } queue; - Hash_string.add visited cur_package_name dir + in + explore_deps Bsb_build_schemas.bs_dependencies pinned_dependencies; + (match top with + | Expect_none -> + explore_deps Bsb_build_schemas.bs_dev_dependencies pinned_dependencies + | Expect_name _ when is_pinned -> + explore_deps Bsb_build_schemas.bs_dev_dependencies pinned_dependencies + | Expect_name _ -> ()); + Queue.add {top; proj_dir = dir; is_pinned} queue; + Hash_string.add visited cur_package_name dir | _ -> () let walk_all_deps dir ~pinned_dependencies : package_context Queue.t = diff --git a/compiler/bsb/bsb_build_util.mli b/compiler/bsb/bsb_build_util.mli index 9ee9e8d058..a0f2aa6375 100644 --- a/compiler/bsb/bsb_build_util.mli +++ b/compiler/bsb/bsb_build_util.mli @@ -74,7 +74,7 @@ val get_list_string : Ext_json_types.t array -> string list type top = Expect_none | Expect_name of string -type result = { path : string; checked : bool } +type result = {path: string; checked: bool} (* [resolve_bsb_magic_file] returns a tuple (path,checked) @@ -82,9 +82,9 @@ type result = { path : string; checked : bool } *) val resolve_bsb_magic_file : cwd:string -> desc:string -> string -> result -type package_context = { proj_dir : string; top : top; is_pinned: bool } +type package_context = {proj_dir: string; top: top; is_pinned: bool} -val extract_pinned_dependencies: Ext_json_types.t Map_string.t -> Set_string.t +val extract_pinned_dependencies : Ext_json_types.t Map_string.t -> Set_string.t val walk_all_deps : string -> pinned_dependencies:Set_string.t -> package_context Queue.t diff --git a/compiler/bsb/bsb_clean.ml b/compiler/bsb/bsb_clean.ml index 32c67dc17d..1225da39ce 100644 --- a/compiler/bsb/bsb_clean.ml +++ b/compiler/bsb/bsb_clean.ml @@ -31,7 +31,7 @@ let ninja_clean proj_dir = let cwd = proj_dir // lib_artifacts_dir in if Sys.file_exists cwd then let eid = - Bsb_unix.run_command_execv { cmd; args = [| cmd; "-t"; "clean" |]; cwd } + Bsb_unix.run_command_execv {cmd; args = [|cmd; "-t"; "clean"|]; cwd} in if eid <> 0 then Bsb_log.warn "@{Failed@}@." with e -> Bsb_log.warn "@{Failed@}: %s @." (Printexc.to_string e) diff --git a/compiler/bsb/bsb_config.ml b/compiler/bsb/bsb_config.ml index 3c3d7d510e..6a1f586f98 100644 --- a/compiler/bsb/bsb_config.ml +++ b/compiler/bsb/bsb_config.ml @@ -35,7 +35,7 @@ let lib_es6 = lib_lit // "es6" let lib_es6_global = lib_lit // "es6_global" -let all_lib_artifacts = [ lib_js; lib_ocaml; lib_bs; lib_es6; lib_es6_global ] +let all_lib_artifacts = [lib_js; lib_ocaml; lib_bs; lib_es6; lib_es6_global] let rev_lib_bs = ".." // ".." @@ -46,7 +46,11 @@ let rev_lib_bs = ".." // ".." *) let lib_bs_prefix_of_format (x : Ext_module_system.t) = ".." - // match x with Commonjs -> "js" | Esmodule -> "es6" | Es6_global -> "es6_global" + // + match x with + | Commonjs -> "js" + | Esmodule -> "es6" + | Es6_global -> "es6_global" (* lib/js, lib/es6, lib/es6_global *) let top_prefix_of_format (x : Ext_module_system.t) = diff --git a/compiler/bsb/bsb_config.mli b/compiler/bsb/bsb_config.mli index c5df914df1..bcd6104c9a 100644 --- a/compiler/bsb/bsb_config.mli +++ b/compiler/bsb/bsb_config.mli @@ -32,11 +32,9 @@ val lib_js : string val lib_bs : string -val lib_es6 : string -[@@ocaml.deprecated "will be removed in v12"] +val lib_es6 : string [@@ocaml.deprecated "will be removed in v12"] -val lib_es6_global : string -[@@ocaml.deprecated "will be removed in v12"] +val lib_es6_global : string [@@ocaml.deprecated "will be removed in v12"] val lib_ocaml : string diff --git a/compiler/bsb/bsb_config_load.ml b/compiler/bsb/bsb_config_load.ml index 0255663763..be46965801 100644 --- a/compiler/bsb/bsb_config_load.ml +++ b/compiler/bsb/bsb_config_load.ml @@ -1,24 +1,26 @@ let ( // ) = Ext_path.combine -let load_json ~(per_proj_dir : string) ~(warn_legacy_config : bool) - : string * Ext_json_types.t = +let load_json ~(per_proj_dir : string) ~(warn_legacy_config : bool) : + string * Ext_json_types.t = let filename, abs, in_chan = let filename = Literals.rescript_json in - let abs = (per_proj_dir // filename) in - match open_in abs - with + let abs = per_proj_dir // filename in + match open_in abs with | in_chan -> (filename, abs, in_chan) - | exception e -> + | exception e -> ( let filename = Literals.bsconfig_json in - let abs = (per_proj_dir // filename) in - match open_in abs - with + let abs = per_proj_dir // filename in + match open_in abs with | in_chan -> (filename, abs, in_chan) - | exception _ -> raise e (* forward error from rescript.json *) + | exception _ -> raise e (* forward error from rescript.json *)) in if warn_legacy_config && filename = Literals.bsconfig_json then - print_endline "Warning: bsconfig.json is deprecated. Migrate it to rescript.json\n"; - match Ext_json_parse.parse_json_from_chan abs in_chan - with - | v -> close_in in_chan ; (filename, v) - | exception e -> close_in in_chan ; raise e + print_endline + "Warning: bsconfig.json is deprecated. Migrate it to rescript.json\n"; + match Ext_json_parse.parse_json_from_chan abs in_chan with + | v -> + close_in in_chan; + (filename, v) + | exception e -> + close_in in_chan; + raise e diff --git a/compiler/bsb/bsb_config_parse.ml b/compiler/bsb/bsb_config_parse.ml index bb5848a6b9..df1923ce4e 100644 --- a/compiler/bsb/bsb_config_parse.ml +++ b/compiler/bsb/bsb_config_parse.ml @@ -44,23 +44,23 @@ let extract_package_name_and_namespace (map : json_map) : string * string option = let package_name = match map.?(Bsb_build_schemas.name) with - | Some (Str { str = "_" } as config) -> - Bsb_exception.config_error config "_ is a reserved package name" - | Some (Str { str = name }) -> name + | Some (Str {str = "_"} as config) -> + Bsb_exception.config_error config "_ is a reserved package name" + | Some (Str {str = name}) -> name | Some config -> - Bsb_exception.config_error config "name expect a string field" + Bsb_exception.config_error config "name expect a string field" | None -> Bsb_exception.invalid_spec "field name is required" in let namespace = match map.?(Bsb_build_schemas.namespace) with | None | Some (False _) -> None | Some (True _) -> - Some (Ext_namespace.namespace_of_package_name package_name) - | Some (Str { str }) -> - (*TODO : check the validity of namespace *) - Some (Ext_namespace.namespace_of_package_name str) + Some (Ext_namespace.namespace_of_package_name package_name) + | Some (Str {str}) -> + (*TODO : check the validity of namespace *) + Some (Ext_namespace.namespace_of_package_name str) | Some x -> - Bsb_exception.config_error x "namespace field expects string or boolean" + Bsb_exception.config_error x "namespace field expects string or boolean" in (package_name, namespace) @@ -87,12 +87,12 @@ let extract_gentype_config (map : json_map) : Bsb_config_types.gentype_config = | None -> false | Some (Obj _) -> true | Some config -> - Bsb_exception.config_error config "gentypeconfig expect an object" + Bsb_exception.config_error config "gentypeconfig expect an object" let extract_string (map : json_map) (field : string) cb = match map.?(field) with | None -> None - | Some (Str { str }) -> cb str + | Some (Str {str}) -> cb str | Some config -> Bsb_exception.config_error config (field ^ " expect a string") let extract_boolean (map : json_map) (field : string) (default : bool) : bool = @@ -101,85 +101,85 @@ let extract_boolean (map : json_map) (field : string) (default : bool) : bool = | Some (True _) -> true | Some (False _) -> false | Some config -> - Bsb_exception.config_error config (field ^ " expect a boolean") + Bsb_exception.config_error config (field ^ " expect a boolean") let extract_warning (map : json_map) = match map.?(Bsb_build_schemas.warnings) with | None -> Bsb_warning.use_default - | Some (Obj { map }) -> Bsb_warning.from_map map + | Some (Obj {map}) -> Bsb_warning.from_map map | Some config -> Bsb_exception.config_error config "expect an object" let extract_ignored_dirs (map : json_map) : Set_string.t = match map.?(Bsb_build_schemas.ignored_dirs) with | None -> Set_string.empty - | Some (Arr { content }) -> - Set_string.of_list (Bsb_build_util.get_list_string content) + | Some (Arr {content}) -> + Set_string.of_list (Bsb_build_util.get_list_string content) | Some config -> Bsb_exception.config_error config "expect an array of string" let extract_generators (map : json_map) = let generators = ref Map_string.empty in (match map.?(Bsb_build_schemas.generators) with | None -> () - | Some (Arr { content = s }) -> - generators := - Ext_array.fold_left s Map_string.empty (fun acc json -> - match json with - | Obj { map = m; loc } -> ( - match - (m.?(Bsb_build_schemas.name), m.?(Bsb_build_schemas.command)) - with - | Some (Str { str = name }), Some (Str { str = command }) -> - Map_string.add acc name command - | _, _ -> - Bsb_exception.errorf ~loc - {| generators exepect format like { "name" : "cppo", "command" : "cppo $in -o $out"} |} - ) - | _ -> acc) + | Some (Arr {content = s}) -> + generators := + Ext_array.fold_left s Map_string.empty (fun acc json -> + match json with + | Obj {map = m; loc} -> ( + match + (m.?(Bsb_build_schemas.name), m.?(Bsb_build_schemas.command)) + with + | Some (Str {str = name}), Some (Str {str = command}) -> + Map_string.add acc name command + | _, _ -> + Bsb_exception.errorf ~loc + {| generators exepect format like { "name" : "cppo", "command" : "cppo $in -o $out"} |} + ) + | _ -> acc) | Some config -> - Bsb_exception.config_error config - (Bsb_build_schemas.generators ^ " expect an array field")); + Bsb_exception.config_error config + (Bsb_build_schemas.generators ^ " expect an array field")); !generators let extract_dependencies (map : json_map) cwd (field : string) : Bsb_config_types.dependencies = match map.?(field) with | None -> [] - | Some (Arr { content = s }) -> - Ext_list.map (Bsb_build_util.get_list_string s) (fun s -> - resolve_package cwd (Bsb_pkg_types.string_as_package s)) + | Some (Arr {content = s}) -> + Ext_list.map (Bsb_build_util.get_list_string s) (fun s -> + resolve_package cwd (Bsb_pkg_types.string_as_package s)) | Some config -> Bsb_exception.config_error config (field ^ " expect an array") (* return an empty array if not found *) let extract_string_list (map : json_map) (field : string) : string list = match map.?(field) with | None -> [] - | Some (Arr { content = s }) -> Bsb_build_util.get_list_string s + | Some (Arr {content = s}) -> Bsb_build_util.get_list_string s | Some config -> Bsb_exception.config_error config (field ^ " expect an array") let extract_ppx (map : json_map) (field : string) ~(cwd : string) : Bsb_config_types.ppx list = match map.?(field) with | None -> [] - | Some (Arr { content }) -> - let resolve s = - if s = "" then - Bsb_exception.invalid_spec "invalid ppx, empty string found" - else - (Bsb_build_util.resolve_bsb_magic_file ~cwd - ~desc:Bsb_build_schemas.ppx_flags s) - .path - in - Ext_array.to_list_f content (fun x -> - match x with - | Str x -> { Bsb_config_types.name = resolve x.str; args = [] } - | Arr { content } -> ( - let xs = Bsb_build_util.get_list_string content in - match xs with - | [] -> Bsb_exception.config_error x " empty array is not allowed" - | name :: args -> { Bsb_config_types.name = resolve name; args }) - | config -> - Bsb_exception.config_error config - (field ^ "expect each item to be either string or array")) + | Some (Arr {content}) -> + let resolve s = + if s = "" then + Bsb_exception.invalid_spec "invalid ppx, empty string found" + else + (Bsb_build_util.resolve_bsb_magic_file ~cwd + ~desc:Bsb_build_schemas.ppx_flags s) + .path + in + Ext_array.to_list_f content (fun x -> + match x with + | Str x -> {Bsb_config_types.name = resolve x.str; args = []} + | Arr {content} -> ( + let xs = Bsb_build_util.get_list_string content in + match xs with + | [] -> Bsb_exception.config_error x " empty array is not allowed" + | name :: args -> {Bsb_config_types.name = resolve name; args}) + | config -> + Bsb_exception.config_error config + (field ^ "expect each item to be either string or array")) | Some config -> Bsb_exception.config_error config (field ^ " expect an array") let extract_js_post_build (map : json_map) cwd : string option = @@ -203,12 +203,9 @@ let extract_js_post_build (map : json_map) cwd : string option = (** ATT: make sure such function is re-entrant. With a given [cwd] it works anywhere*) -let interpret_json - ~(filename : string) - ~(json : Ext_json_types.t) - ~(package_kind : Bsb_package_kind.t) - ~(per_proj_dir : string) - : Bsb_config_types.t = +let interpret_json ~(filename : string) ~(json : Ext_json_types.t) + ~(package_kind : Bsb_package_kind.t) ~(per_proj_dir : string) : + Bsb_config_types.t = (* we should not resolve it too early, since it is external configuration, no {!Bsb_build_util.convert_and_resolve_path} *) @@ -223,64 +220,62 @@ let interpret_json 1. if [build.ninja] does use [ninja] we need set a variable 2. we need store it so that we can call ninja correctly *) - match json - with - | Obj { map } -> ( - let package_name, namespace = extract_package_name_and_namespace map in - let gentype_config = extract_gentype_config map in + match json with + | Obj {map} -> ( + let package_name, namespace = extract_package_name_and_namespace map in + let gentype_config = extract_gentype_config map in - (* This line has to be before any calls to Bsb_global_backend.backend, because it'll read the entries - array from the bsconfig and set the backend_ref to the first entry, if any. *) - - let pp_flags : string option = - extract_string map Bsb_build_schemas.pp_flags (fun p -> - if p = "" then - Bsb_exception.invalid_spec "invalid pp, empty string found" - else - Some - (Bsb_build_util.resolve_bsb_magic_file ~cwd:per_proj_dir - ~desc:Bsb_build_schemas.pp_flags p) - .path) - in - let bs_dependencies = - extract_dependencies map per_proj_dir Bsb_build_schemas.bs_dependencies + (* This line has to be before any calls to Bsb_global_backend.backend, because it'll read the entries + array from the bsconfig and set the backend_ref to the first entry, if any. *) + let pp_flags : string option = + extract_string map Bsb_build_schemas.pp_flags (fun p -> + if p = "" then + Bsb_exception.invalid_spec "invalid pp, empty string found" + else + Some + (Bsb_build_util.resolve_bsb_magic_file ~cwd:per_proj_dir + ~desc:Bsb_build_schemas.pp_flags p) + .path) + in + let bs_dependencies = + extract_dependencies map per_proj_dir Bsb_build_schemas.bs_dependencies + in + let bs_dev_dependencies = + match package_kind with + | Toplevel | Pinned_dependency _ -> + extract_dependencies map per_proj_dir + Bsb_build_schemas.bs_dev_dependencies + | Dependency _ -> [] + in + let pinned_dependencies = Bsb_build_util.extract_pinned_dependencies map in + match map.?(Bsb_build_schemas.sources) with + | Some sources -> + let cut_generators = + extract_boolean map Bsb_build_schemas.cut_generators false in - let bs_dev_dependencies = - match package_kind with - | Toplevel | Pinned_dependency _ -> - extract_dependencies map per_proj_dir - Bsb_build_schemas.bs_dev_dependencies - | Dependency _ -> [] + let groups = + Bsb_parse_sources.scan ~ignored_dirs:(extract_ignored_dirs map) + ~package_kind ~root:per_proj_dir ~cut_generators + (* ~namespace *) + sources in - let pinned_dependencies = Bsb_build_util.extract_pinned_dependencies map in - match map.?(Bsb_build_schemas.sources) with - | Some sources -> - let cut_generators = - extract_boolean map Bsb_build_schemas.cut_generators false - in - let groups = - Bsb_parse_sources.scan ~ignored_dirs:(extract_ignored_dirs map) - ~package_kind ~root:per_proj_dir ~cut_generators - (* ~namespace *) - sources - in - let bsc_flags = extract_string_list map Bsb_build_schemas.bsc_flags in - let jsx = Bsb_jsx.from_map map in - { - pinned_dependencies; - gentype_config; - package_name; - namespace; - warning = extract_warning map; - external_includes = - extract_string_list map Bsb_build_schemas.bs_external_includes; - bsc_flags; - ppx_files = - extract_ppx map ~cwd:per_proj_dir Bsb_build_schemas.ppx_flags; - pp_file = pp_flags; - bs_dependencies; - bs_dev_dependencies; - (* + let bsc_flags = extract_string_list map Bsb_build_schemas.bsc_flags in + let jsx = Bsb_jsx.from_map map in + { + pinned_dependencies; + gentype_config; + package_name; + namespace; + warning = extract_warning map; + external_includes = + extract_string_list map Bsb_build_schemas.bs_external_includes; + bsc_flags; + ppx_files = + extract_ppx map ~cwd:per_proj_dir Bsb_build_schemas.ppx_flags; + pp_file = pp_flags; + bs_dependencies; + bs_dev_dependencies; + (* reference for quoting {[ let tmpfile = Filename.temp_file "ocamlpp" "" in @@ -289,28 +284,29 @@ let interpret_json in ]} *) - js_post_build_cmd = extract_js_post_build map per_proj_dir; - package_specs = - (match package_kind with - | Toplevel -> Bsb_package_specs.from_map ~cwd:per_proj_dir map - | Pinned_dependency x | Dependency x -> x.package_specs); - file_groups = groups; - files_to_install = Queue.create (); - jsx; - generators = extract_generators map; - cut_generators; - filename; - } - | None -> - Bsb_exception.invalid_spec ("no sources specified in " ^ filename)) + js_post_build_cmd = extract_js_post_build map per_proj_dir; + package_specs = + (match package_kind with + | Toplevel -> Bsb_package_specs.from_map ~cwd:per_proj_dir map + | Pinned_dependency x | Dependency x -> x.package_specs); + file_groups = groups; + files_to_install = Queue.create (); + jsx; + generators = extract_generators map; + cut_generators; + filename; + } + | None -> Bsb_exception.invalid_spec ("no sources specified in " ^ filename) + ) | _ -> Bsb_exception.invalid_spec (filename ^ " expect a json object {}") let deps_from_bsconfig () = let cwd = Bsb_global_paths.cwd in - match Bsb_config_load.load_json ~per_proj_dir:cwd ~warn_legacy_config:false + match + Bsb_config_load.load_json ~per_proj_dir:cwd ~warn_legacy_config:false with - | _, Obj { map } -> - ( Bsb_package_specs.from_map ~cwd map, - Bsb_jsx.from_map map, - Bsb_build_util.extract_pinned_dependencies map ) + | _, Obj {map} -> + ( Bsb_package_specs.from_map ~cwd map, + Bsb_jsx.from_map map, + Bsb_build_util.extract_pinned_dependencies map ) | _, _ -> assert false diff --git a/compiler/bsb/bsb_config_types.ml b/compiler/bsb/bsb_config_types.ml index 6088383560..eef34c0bb5 100644 --- a/compiler/bsb/bsb_config_types.ml +++ b/compiler/bsb/bsb_config_types.ml @@ -22,44 +22,40 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type dependency = { - package_name : Bsb_pkg_types.t; - package_install_path : string; -} +type dependency = {package_name: Bsb_pkg_types.t; package_install_path: string} type dependencies = dependency list type gentype_config = bool type command = string -type ppx = { name : string; args : string list } +type ppx = {name: string; args: string list} type t = { - package_name : string; + package_name: string; (* [captial-package] *) - namespace : string option; + namespace: string option; (* CapitalPackage *) - external_includes : string list; - bsc_flags : string list; - ppx_files : ppx list; - pp_file : string option; - bs_dependencies : dependencies; - bs_dev_dependencies : dependencies; - pinned_dependencies : Set_string.t; - warning : Bsb_warning.t; + external_includes: string list; + bsc_flags: string list; + ppx_files: ppx list; + pp_file: string option; + bs_dependencies: dependencies; + bs_dev_dependencies: dependencies; + pinned_dependencies: Set_string.t; + warning: Bsb_warning.t; (*TODO: maybe we should always resolve rescript so that we can calculate correct relative path in [.merlin] *) - js_post_build_cmd : string option; - package_specs : Bsb_package_specs.t; - file_groups : Bsb_file_groups.t; - files_to_install : Bsb_db.module_info Queue.t; + js_post_build_cmd: string option; + package_specs: Bsb_package_specs.t; + file_groups: Bsb_file_groups.t; + files_to_install: Bsb_db.module_info Queue.t; jsx: Bsb_jsx.t; (* whether apply PPX transform or not*) - generators : command Map_string.t; - cut_generators : bool; + generators: command Map_string.t; + cut_generators: bool; (* note when used as a dev mode, we will always ignore it *) - gentype_config : gentype_config; - + gentype_config: gentype_config; filename: string; } diff --git a/compiler/bsb/bsb_db_encode.ml b/compiler/bsb/bsb_db_encode.ml index 50d00e55df..083e0188ef 100644 --- a/compiler/bsb/bsb_db_encode.ml +++ b/compiler/bsb/bsb_db_encode.ml @@ -61,7 +61,7 @@ let encode_single (db : Bsb_db.map) (buf : Ext_buffer.t) = Ext_buffer.add_string_char buf (string_of_int len) '\n'; if len <> 0 then ( let mapping = Hash_string.create 50 in - Map_string.iter db (fun name { dir } -> + Map_string.iter db (fun name {dir} -> Ext_buffer.add_string_char buf name '\n'; if not (Hash_string.mem mapping dir) then Hash_string.add mapping dir (Hash_string.length mapping)); diff --git a/compiler/bsb/bsb_db_util.ml b/compiler/bsb/bsb_db_util.ml index 542b1456c5..94b54d18ef 100644 --- a/compiler/bsb/bsb_db_util.ml +++ b/compiler/bsb/bsb_db_util.ml @@ -39,13 +39,12 @@ let sanity_check (map : t) = (* invariant check: ml and mli should have the same case, same path *) -let check (x : module_info) name_sans_extension case - (module_info : Bsb_db.info) = +let check (x : module_info) name_sans_extension case (module_info : Bsb_db.info) + = let x_ml_info = x.info in if x.name_sans_extension <> name_sans_extension - || x.case <> case - || x_ml_info = module_info || x_ml_info = Impl_intf + || x.case <> case || x_ml_info = module_info || x_ml_info = Impl_intf then Bsb_exception.invalid_spec (Printf.sprintf @@ -78,8 +77,7 @@ let add_basename ~(dir : string) (map : t) ?error_on_invalid_suffix basename : t let file_suffix = Ext_filename.get_extension_maybe basename in (match () with | _ when file_suffix = Literals.suffix_res -> () - | _ when file_suffix = Literals.suffix_resi -> - info := Intf + | _ when file_suffix = Literals.suffix_resi -> info := Intf | _ -> invalid_suffix := true); let info = !info in let invalid_suffix = !invalid_suffix in @@ -90,14 +88,14 @@ let add_basename ~(dir : string) (map : t) ?error_on_invalid_suffix basename : t else match Ext_filename.as_module ~basename:(Filename.basename basename) with | None -> - Bsb_log.warn warning_unused_file basename dir; - map - | Some { module_name; case } -> - let name_sans_extension = - Filename.concat dir (Ext_filename.chop_extension_maybe basename) - in - let dir = Filename.dirname name_sans_extension in - Map_string.adjust map module_name (fun opt_module_info -> - match opt_module_info with - | None -> { dir; name_sans_extension; info; case } - | Some x -> check x name_sans_extension case info) + Bsb_log.warn warning_unused_file basename dir; + map + | Some {module_name; case} -> + let name_sans_extension = + Filename.concat dir (Ext_filename.chop_extension_maybe basename) + in + let dir = Filename.dirname name_sans_extension in + Map_string.adjust map module_name (fun opt_module_info -> + match opt_module_info with + | None -> {dir; name_sans_extension; info; case} + | Some x -> check x name_sans_extension case info) diff --git a/compiler/bsb/bsb_exception.ml b/compiler/bsb/bsb_exception.ml index 007221c966..31db204b29 100644 --- a/compiler/bsb/bsb_exception.ml +++ b/compiler/bsb/bsb_exception.ml @@ -40,45 +40,47 @@ let package_not_found ~pkg ~json = error (Package_not_found (pkg, json)) let print (fmt : Format.formatter) (x : error) = match x with | Conflict_module (modname, dir1, dir2) -> - Format.fprintf fmt - "@{Error:@} %s found in two directories: (%s, %s)\n\ - File names must be unique per project" modname dir1 dir2 + Format.fprintf fmt + "@{Error:@} %s found in two directories: (%s, %s)\n\ + File names must be unique per project" modname dir1 dir2 | Not_consistent modname -> - Format.fprintf fmt - "@{Error:@} %s has implementation/interface in non-consistent \ - syntax(reason/ocaml)" - modname + Format.fprintf fmt + "@{Error:@} %s has implementation/interface in non-consistent \ + syntax(reason/ocaml)" + modname | No_implementation modname -> - Format.fprintf fmt - "@{Error:@} %s does not have implementation file" modname + Format.fprintf fmt "@{Error:@} %s does not have implementation file" + modname | Package_not_found (name, json_opt) -> - let in_json = - match json_opt with None -> Ext_string.empty | Some x -> " in " ^ x - in - let name = Bsb_pkg_types.to_string name in - if Ext_string.equal name !Bs_version.package_name then - Format.fprintf fmt - "File \"bsconfig.json\", line 1\n\ - @{Error:@} package @{%s@} is not found %s\n\ - It's the basic, required package. If you have it installed globally,\n\ - Please run `npm link rescript` to make it available" name in_json - else - Format.fprintf fmt - "File \"bsconfig.json\", line 1\n\ - @{Error:@} package @{%s@} not found or built %s\n\ - - Did you install it?" name in_json - | Json_config (pos, s) -> + let in_json = + match json_opt with + | None -> Ext_string.empty + | Some x -> " in " ^ x + in + let name = Bsb_pkg_types.to_string name in + if Ext_string.equal name !Bs_version.package_name then Format.fprintf fmt - "File %S, line %d:\n\ - @{Error:@} %s \n\ - For more details, please check out the schema at \ - https://rescript-lang.org/docs/manual/latest/build-configuration-schema" - pos.pos_fname pos.pos_lnum s + "File \"bsconfig.json\", line 1\n\ + @{Error:@} package @{%s@} is not found %s\n\ + It's the basic, required package. If you have it installed globally,\n\ + Please run `npm link rescript` to make it available" name in_json + else + Format.fprintf fmt + "File \"bsconfig.json\", line 1\n\ + @{Error:@} package @{%s@} not found or built %s\n\ + - Did you install it?" name in_json + | Json_config (pos, s) -> + Format.fprintf fmt + "File %S, line %d:\n\ + @{Error:@} %s \n\ + For more details, please check out the schema at \ + https://rescript-lang.org/docs/manual/latest/build-configuration-schema" + pos.pos_fname pos.pos_lnum s | Invalid_spec s -> - Format.fprintf fmt "@{Error: Invalid bsconfig.json %s@}" s + Format.fprintf fmt "@{Error: Invalid bsconfig.json %s@}" s | Invalid_json s -> - Format.fprintf fmt - "File %S, line 1\n@{Error: Invalid json format@}" s + Format.fprintf fmt "File %S, line 1\n@{Error: Invalid json format@}" + s let conflict_module modname dir1 dir2 = Error (Conflict_module (modname, dir1, dir2)) @@ -101,4 +103,6 @@ let invalid_json s = error (Invalid_json s) let () = Printexc.register_printer (fun x -> - match x with Error x -> Some (Format.asprintf "%a" print x) | _ -> None) + match x with + | Error x -> Some (Format.asprintf "%a" print x) + | _ -> None) diff --git a/compiler/bsb/bsb_file_groups.ml b/compiler/bsb/bsb_file_groups.ml index dac20e07c6..3b5757a06a 100644 --- a/compiler/bsb/bsb_file_groups.ml +++ b/compiler/bsb/bsb_file_groups.ml @@ -25,18 +25,18 @@ type public = Export_none | Export_all | Export_set of Set_string.t type build_generator = { - input : string list; - output : string list; - command : string; + input: string list; + output: string list; + command: string; } type file_group = { - dir : string; - sources : Bsb_db.map; - resources : string list; - public : public; - is_dev : bool; - generators : build_generator list; + dir: string; + sources: Bsb_db.map; + resources: string list; + public: public; + is_dev: bool; + generators: build_generator list; (* output of [generators] should be added to [sources], if it is [.ml,.mli,.res,.resi] *) @@ -44,9 +44,9 @@ type file_group = { type file_groups = file_group list -type t = { files : file_groups; globbed_dirs : string list } +type t = {files: file_groups; globbed_dirs: string list} -let empty : t = { files = []; globbed_dirs = [] } +let empty : t = {files = []; globbed_dirs = []} let merge (u : t) (v : t) = if u == empty then v diff --git a/compiler/bsb/bsb_file_groups.mli b/compiler/bsb/bsb_file_groups.mli index 6abc224941..521b40924d 100644 --- a/compiler/bsb/bsb_file_groups.mli +++ b/compiler/bsb/bsb_file_groups.mli @@ -25,19 +25,19 @@ type public = Export_none | Export_all | Export_set of Set_string.t type build_generator = { - input : string list; - output : string list; - command : string; + input: string list; + output: string list; + command: string; } type file_group = { - dir : string; - sources : Bsb_db.map; - resources : string list; - public : public; - is_dev : bool; + dir: string; + sources: Bsb_db.map; + resources: string list; + public: public; + is_dev: bool; (* false means not in dev mode *) - generators : build_generator list; + generators: build_generator list; (* output of [generators] should be added to [sources], if it is [.ml,.mli,.res,.resi] *) @@ -45,7 +45,7 @@ type file_group = { type file_groups = file_group list -type t = private { files : file_groups; globbed_dirs : string list } +type t = private {files: file_groups; globbed_dirs: string list} val empty : t diff --git a/compiler/bsb/bsb_jsx.ml b/compiler/bsb/bsb_jsx.ml index 9f68549863..4a13f99ca9 100644 --- a/compiler/bsb/bsb_jsx.ml +++ b/compiler/bsb/bsb_jsx.ml @@ -3,17 +3,16 @@ type module_ = React | Generic of {moduleName: string} type mode = Classic | Automatic type dependencies = string list -type t = { - version : version option; - module_ : module_ option; - mode : mode option; -} +type t = {version: version option; module_: module_ option; mode: mode option} let encode_no_nl jsx = (match jsx.version with | None -> "" | Some Jsx_v4 -> "4") - ^ (match jsx.module_ with None -> "" | Some React -> "React" | Some Generic {moduleName} -> moduleName) + ^ (match jsx.module_ with + | None -> "" + | Some React -> "React" + | Some (Generic {moduleName}) -> moduleName) ^ match jsx.mode with | None -> "" @@ -25,7 +24,9 @@ let ( |? ) m (key, cb) = m |> Ext_json.test key cb let get_list_string_acc (s : Ext_json_types.t array) acc = Ext_array.to_list_map_acc s acc (fun x -> - match x with Str x -> Some x.str | _ -> None) + match x with + | Str x -> Some x.str + | _ -> None) let get_list_string s = get_list_string_acc s [] @@ -38,43 +39,38 @@ let from_map map = `Obj (fun m -> match m.?(Bsb_build_schemas.jsx_version) with - | Some (Flo { loc; flo }) -> ( - match flo with - | "4" -> version := Some Jsx_v4 - | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo - ) + | Some (Flo {loc; flo}) -> ( + match flo with + | "4" -> version := Some Jsx_v4 + | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo) | Some x -> - Bsb_exception.config_error x - "Unexpected input (expect a version number) for jsx version" + Bsb_exception.config_error x + "Unexpected input (expect a version number) for jsx version" | None -> ()) ) |? ( Bsb_build_schemas.jsx, `Obj (fun m -> match m.?(Bsb_build_schemas.jsx_module) with - | Some (Str { str }) -> ( - match str with - | "react" -> module_ := Some React - | moduleName -> module_ := Some (Generic {moduleName})) + | Some (Str {str}) -> ( + match str with + | "react" -> module_ := Some React + | moduleName -> module_ := Some (Generic {moduleName})) | Some x -> - Bsb_exception.config_error x - "Unexpected input (jsx module name) for jsx module" + Bsb_exception.config_error x + "Unexpected input (jsx module name) for jsx module" | None -> ()) ) |? ( Bsb_build_schemas.jsx, `Obj (fun m -> match m.?(Bsb_build_schemas.jsx_mode) with - | Some (Str { loc; str }) -> ( - match str with - | "classic" -> mode := Some Classic - | "automatic" -> mode := Some Automatic - | _ -> Bsb_exception.errorf ~loc "Unsupported jsx mode %s" str) + | Some (Str {loc; str}) -> ( + match str with + | "classic" -> mode := Some Classic + | "automatic" -> mode := Some Automatic + | _ -> Bsb_exception.errorf ~loc "Unsupported jsx mode %s" str) | Some x -> - Bsb_exception.config_error x - "Unexpected input (expect classic or automatic) for jsx mode" + Bsb_exception.config_error x + "Unexpected input (expect classic or automatic) for jsx mode" | None -> ()) ) |> ignore; - { - version = !version; - module_ = !module_; - mode = !mode; - } + {version = !version; module_ = !module_; mode = !mode} diff --git a/compiler/bsb/bsb_log.ml b/compiler/bsb/bsb_log.ml index 06401aaa69..3c890deaaf 100644 --- a/compiler/bsb/bsb_log.ml +++ b/compiler/bsb/bsb_log.ml @@ -62,7 +62,11 @@ let setup () = type level = Debug | Info | Warn | Error let int_of_level (x : level) = - match x with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3 + match x with + | Debug -> 0 + | Info -> 1 + | Warn -> 2 + | Error -> 3 let log_level = ref Warn diff --git a/compiler/bsb/bsb_ninja_check.ml b/compiler/bsb/bsb_ninja_check.ml index b11bf66c12..6ae3693b99 100644 --- a/compiler/bsb/bsb_ninja_check.ml +++ b/compiler/bsb/bsb_ninja_check.ml @@ -64,26 +64,25 @@ let rec check_aux cwd (xs : string list) = | [] -> Good | "===" :: rest -> check_global_atime rest | item :: rest -> ( - match Ext_string.split item '\t' with - | [ file; stamp ] -> - let stamp = float_of_string stamp in - let cur_file = Filename.concat cwd file in - let stat = Unix.stat cur_file in - if stat.st_mtime <= stamp then check_aux cwd rest else Other cur_file - | _ -> Bsb_file_corrupted) + match Ext_string.split item '\t' with + | [file; stamp] -> + let stamp = float_of_string stamp in + let cur_file = Filename.concat cwd file in + let stat = Unix.stat cur_file in + if stat.st_mtime <= stamp then check_aux cwd rest else Other cur_file + | _ -> Bsb_file_corrupted) and check_global_atime rest = match rest with | [] -> Good | item :: rest -> ( - match Ext_string.split item '\t' with - | [ file; stamp ] -> - let stamp = float_of_string stamp in - let cur_file = file in - let stat = Unix.stat cur_file in - if stat.st_atime <= stamp then check_global_atime rest - else Other cur_file - | _ -> Bsb_file_corrupted) + match Ext_string.split item '\t' with + | [file; stamp] -> + let stamp = float_of_string stamp in + let cur_file = file in + let stat = Unix.stat cur_file in + if stat.st_atime <= stamp then check_global_atime rest else Other cur_file + | _ -> Bsb_file_corrupted) (* TODO: for such small data structure, maybe text format is better *) @@ -93,14 +92,19 @@ let record_global_atime buf name = Ext_buffer.add_string_char buf (hex_of_float stamp) '\n' let record ~(package_kind : Bsb_package_kind.t) ~per_proj_dir ~file - ~(config : Bsb_config_types.t) ~(warn_as_error: string option) (file_or_dirs : string list) : unit = + ~(config : Bsb_config_types.t) ~(warn_as_error : string option) + (file_or_dirs : string list) : unit = let buf = Ext_buffer.create 1_000 in Ext_buffer.add_string_char buf Bs_version.version '\n'; Ext_buffer.add_string_char buf per_proj_dir '\n'; Ext_buffer.add_string_char buf (Bsb_package_kind.encode_no_nl package_kind) '\n'; - Ext_buffer.add_string_char buf (match warn_as_error with | Some s -> s | None -> "0") '\n'; + Ext_buffer.add_string_char buf + (match warn_as_error with + | Some s -> s + | None -> "0") + '\n'; Ext_list.iter file_or_dirs (fun f -> Ext_buffer.add_string_char buf f '\t'; Ext_buffer.add_string_char buf @@ -108,7 +112,7 @@ let record ~(package_kind : Bsb_package_kind.t) ~per_proj_dir ~file '\n'); Ext_buffer.add_string buf "===\n"; record_global_atime buf Sys.executable_name; - Ext_list.iter config.ppx_files (fun { name; args = _ } -> + Ext_list.iter config.ppx_files (fun {name; args = _} -> try record_global_atime buf name with _ -> (* record the ppx files as a best effort *) ()); @@ -122,28 +126,31 @@ let record ~(package_kind : Bsb_package_kind.t) ~per_proj_dir ~file Even forced, we still need walk through a little bit in case we found a different version of compiler *) -let check ~(package_kind : Bsb_package_kind.t) ~(per_proj_dir : string) ~forced ~(warn_as_error: string option) ~file : check_result = +let check ~(package_kind : Bsb_package_kind.t) ~(per_proj_dir : string) ~forced + ~(warn_as_error : string option) ~file : check_result = match open_in_bin file with (* Windows binary mode*) | exception _ -> Bsb_file_not_exist | ic -> ( - match List.rev (Ext_io.rev_lines_of_chann ic) with - | exception _ -> Bsb_file_corrupted - | version :: source_directory :: package_kind_str :: previous_warn_as_error :: dir_or_files -> ( - let warn_as_error_changed = match warn_as_error with - | None -> previous_warn_as_error <> "0" - | Some current -> current <> previous_warn_as_error in + match List.rev (Ext_io.rev_lines_of_chann ic) with + | exception _ -> Bsb_file_corrupted + | version :: source_directory :: package_kind_str :: previous_warn_as_error + :: dir_or_files -> ( + let warn_as_error_changed = + match warn_as_error with + | None -> previous_warn_as_error <> "0" + | Some current -> current <> previous_warn_as_error + in - if version <> Bs_version.version then Bsb_bsc_version_mismatch - else if per_proj_dir <> source_directory then - Bsb_source_directory_changed - else if forced then Bsb_forced (* No need walk through *) - else if Bsb_package_kind.encode_no_nl package_kind <> package_kind_str - then Bsb_package_kind_inconsistent - else if warn_as_error_changed then Bsb_regenerate_required - else - try check_aux per_proj_dir dir_or_files - with e -> - Bsb_log.info "@{Stat miss %s@}@." (Printexc.to_string e); - Bsb_file_not_exist) - | _ -> Bsb_file_corrupted) + if version <> Bs_version.version then Bsb_bsc_version_mismatch + else if per_proj_dir <> source_directory then Bsb_source_directory_changed + else if forced then Bsb_forced (* No need walk through *) + else if Bsb_package_kind.encode_no_nl package_kind <> package_kind_str + then Bsb_package_kind_inconsistent + else if warn_as_error_changed then Bsb_regenerate_required + else + try check_aux per_proj_dir dir_or_files + with e -> + Bsb_log.info "@{Stat miss %s@}@." (Printexc.to_string e); + Bsb_file_not_exist) + | _ -> Bsb_file_corrupted) diff --git a/compiler/bsb/bsb_ninja_check.mli b/compiler/bsb/bsb_ninja_check.mli index adff881079..96419ec5eb 100644 --- a/compiler/bsb/bsb_ninja_check.mli +++ b/compiler/bsb/bsb_ninja_check.mli @@ -66,7 +66,7 @@ val check : package_kind:Bsb_package_kind.t -> per_proj_dir:string -> forced:bool -> - warn_as_error: string option -> + warn_as_error:string option -> file:string -> check_result (** check if [build.ninja] should be regenerated *) diff --git a/compiler/bsb/bsb_ninja_file_groups.ml b/compiler/bsb/bsb_ninja_file_groups.ml index 32c3f2f55e..8e4d157cf9 100644 --- a/compiler/bsb/bsb_ninja_file_groups.ml +++ b/compiler/bsb/bsb_ninja_file_groups.ml @@ -26,21 +26,21 @@ let ( // ) = Ext_path.combine let handle_generators oc (group : Bsb_file_groups.file_group) custom_rules = let map_to_source_dir x = Bsb_config.proj_rel (group.dir // x) in - Ext_list.iter group.generators (fun { output; input; command } -> + Ext_list.iter group.generators (fun {output; input; command} -> (*TODO: add a loc for better error message *) match Map_string.find_opt custom_rules command with | None -> - Ext_fmt.failwithf ~loc:__LOC__ "custom rule %s used but not defined" - command + Ext_fmt.failwithf ~loc:__LOC__ "custom rule %s used but not defined" + command | Some rule -> - Bsb_ninja_targets.output_build oc - ~outputs:(Ext_list.map output map_to_source_dir) - ~inputs:(Ext_list.map input map_to_source_dir) - ~rule) + Bsb_ninja_targets.output_build oc + ~outputs:(Ext_list.map output map_to_source_dir) + ~inputs:(Ext_list.map input map_to_source_dir) + ~rule) -type suffixes = { impl : string; intf : string } +type suffixes = {impl: string; intf: string} -let res_suffixes = { impl = Literals.suffix_res; intf = Literals.suffix_resi } +let res_suffixes = {impl = Literals.suffix_res; intf = Literals.suffix_resi} let emit_module_build (rules : Bsb_ninja_rule.builtin) (package_specs : Bsb_package_specs.t) (is_dev : bool) oc namespace @@ -67,22 +67,20 @@ let emit_module_build (rules : Bsb_ninja_rule.builtin) output_filename_sans_extension in - Bsb_ninja_targets.output_build oc ~outputs:[ output_ast ] - ~inputs:[ input_impl ] ~rule:ast_rule; - Bsb_ninja_targets.output_build oc ~outputs:[ output_d ] - ~inputs: - (if has_intf_file then [ output_ast; output_iast ] else [ output_ast ]) + Bsb_ninja_targets.output_build oc ~outputs:[output_ast] ~inputs:[input_impl] + ~rule:ast_rule; + Bsb_ninja_targets.output_build oc ~outputs:[output_d] + ~inputs:(if has_intf_file then [output_ast; output_iast] else [output_ast]) ~rule:(if is_dev then rules.build_bin_deps_dev else rules.build_bin_deps); if has_intf_file then ( Bsb_ninja_targets.output_build oc - ~outputs: - [ output_iast ] + ~outputs:[output_iast] (* TODO: we can get rid of absloute path if we fixed the location to be [lib/bs], better for testing? *) - ~inputs:[ input_intf ] ~rule:ast_rule; - Bsb_ninja_targets.output_build oc ~outputs:[ output_cmi ] - ~inputs:[ output_iast ] + ~inputs:[input_intf] ~rule:ast_rule; + Bsb_ninja_targets.output_build oc ~outputs:[output_cmi] + ~inputs:[output_iast] ~rule:(if is_dev then rules.mi_dev else rules.mi)); let rule = if has_intf_file then if is_dev then rules.mj_dev else rules.mj @@ -92,9 +90,8 @@ let emit_module_build (rules : Bsb_ninja_rule.builtin) Bsb_ninja_targets.output_build oc ~outputs: (if has_intf_file then output_cmj :: output_js - else output_cmj :: output_cmi :: output_js) - ~inputs: - (if has_intf_file then [ output_ast; output_cmi ] else [ output_ast ]) + else output_cmj :: output_cmi :: output_js) + ~inputs:(if has_intf_file then [output_ast; output_cmi] else [output_ast]) ~rule let handle_files_per_dir oc ~(rules : Bsb_ninja_rule.builtin) ~package_specs diff --git a/compiler/bsb/bsb_ninja_gen.ml b/compiler/bsb/bsb_ninja_gen.ml index 762329a7d1..cc3d80536d 100644 --- a/compiler/bsb/bsb_ninja_gen.ml +++ b/compiler/bsb/bsb_ninja_gen.ml @@ -51,13 +51,13 @@ let emit_bsc_lib_includes (bs_dependencies : Bsb_config_types.dependencies) Bsb_build_util.include_dirs (all_includes (if namespace = None then source_dirs - else Filename.current_dir_name :: source_dirs - (*working dir is [lib/bs] we include this path to have namespace mapping*))) + else Filename.current_dir_name :: source_dirs + (*working dir is [lib/bs] we include this path to have namespace mapping*))) let output_static_resources (static_resources : string list) copy_rule oc = Ext_list.iter static_resources (fun output -> - Bsb_ninja_targets.output_build oc ~outputs:[ output ] - ~inputs:[ Bsb_config.proj_rel output ] + Bsb_ninja_targets.output_build oc ~outputs:[output] + ~inputs:[Bsb_config.proj_rel output] ~rule:copy_rule); if static_resources <> [] then Bsb_ninja_targets.phony oc ~order_only_deps:static_resources ~inputs:[] @@ -86,15 +86,14 @@ let output_installation_file cwd_lib_bs namespace files_to_install = let sb = ".." // ".." in o (if Ext_sys.is_windows_or_cygwin then - "rule cp\n\ - \ command = cmd.exe /C copy /Y $i $out >NUL\n\ - rule touch\n\ - \ command = cmd.exe /C type nul >>$out & copy $out+,, >NUL\n" - else "rule cp\n command = cp $i $out\nrule touch\n command = touch $out\n"); + "rule cp\n\ + \ command = cmd.exe /C copy /Y $i $out >NUL\n\ + rule touch\n\ + \ command = cmd.exe /C type nul >>$out & copy $out+,, >NUL\n" + else "rule cp\n command = cp $i $out\nrule touch\n command = touch $out\n"); let essentials = Ext_buffer.create 1_000 in files_to_install - |> Queue.iter - (fun ({ name_sans_extension; info } : Bsb_db.module_info) -> + |> Queue.iter (fun ({name_sans_extension; info} : Bsb_db.module_info) -> let base = Filename.basename name_sans_extension in let dest = Ext_namespace_encode.make ?ns:namespace base in let ns_origin = @@ -116,20 +115,20 @@ let output_installation_file cwd_lib_bs namespace files_to_install = | Intf -> assert false | Impl -> () | Impl_intf -> - let suffix_intf = Literals.suffix_resi in - oo suffix_intf ~dest:base ~src:(sb // name_sans_extension); - oo Literals.suffix_cmti ~dest ~src); + let suffix_intf = Literals.suffix_resi in + oo suffix_intf ~dest:base ~src:(sb // name_sans_extension); + oo Literals.suffix_cmti ~dest ~src); (match namespace with | None -> () | Some dest -> - let src = bs // dest in - oo Literals.suffix_cmi ~dest ~src; - oo Literals.suffix_cmj ~dest ~src; - oo Literals.suffix_cmt ~dest ~src; - Ext_buffer.add_string essentials dest; - Ext_buffer.add_string_char essentials Literals.suffix_cmi ' '; - Ext_buffer.add_string essentials dest; - Ext_buffer.add_string essentials Literals.suffix_cmj); + let src = bs // dest in + oo Literals.suffix_cmi ~dest ~src; + oo Literals.suffix_cmj ~dest ~src; + oo Literals.suffix_cmt ~dest ~src; + Ext_buffer.add_string essentials dest; + Ext_buffer.add_string_char essentials Literals.suffix_cmi ' '; + Ext_buffer.add_string essentials dest; + Ext_buffer.add_string essentials Literals.suffix_cmj); Ext_buffer.add_char essentials '\n'; o "build install.stamp : touch "; Ext_buffer.output_buffer install_oc essentials; @@ -146,7 +145,7 @@ let output_ninja_and_namespace_map ~per_proj_dir ~package_kind bs_dev_dependencies; js_post_build_cmd; package_specs; - file_groups = { files = bs_file_groups }; + file_groups = {files = bs_file_groups}; files_to_install; jsx; generators; @@ -164,13 +163,11 @@ let output_ninja_and_namespace_map ~per_proj_dir ~package_kind Bsb_build_util.include_dirs_by bs_dev_dependencies (fun x -> x.package_install_path) in - let bs_groups : Bsb_db.t = - { lib = Map_string.empty; dev = Map_string.empty } - in - let source_dirs : string list Bsb_db.cat = { lib = []; dev = [] } in + let bs_groups : Bsb_db.t = {lib = Map_string.empty; dev = Map_string.empty} in + let source_dirs : string list Bsb_db.cat = {lib = []; dev = []} in let static_resources = Ext_list.fold_left bs_file_groups [] - (fun (acc_resources : string list) { sources; dir; resources; is_dev } -> + (fun (acc_resources : string list) {sources; dir; resources; is_dev} -> if is_dev then ( bs_groups.dev <- Bsb_db_util.merge bs_groups.dev sources; source_dirs.dev <- dir :: source_dirs.dev) @@ -194,9 +191,9 @@ let output_ninja_and_namespace_map ~per_proj_dir ~package_kind in let rules : Bsb_ninja_rule.builtin = Bsb_ninja_rule.make_custom_rules ~gentype_config - ~has_postbuild:js_post_build_cmd ~pp_file ~jsx - ~package_specs ~namespace ~digest ~package_name - ~warnings ~ppx_files ~bsc_flags ~dpkg_incls (* dev dependencies *) + ~has_postbuild:js_post_build_cmd ~pp_file ~jsx ~package_specs ~namespace + ~digest ~package_name ~warnings ~ppx_files ~bsc_flags + ~dpkg_incls (* dev dependencies *) ~lib_incls (* its own libs *) ~dev_incls (* its own devs *) ~bs_dependencies ~bs_dev_dependencies generators @@ -222,8 +219,8 @@ let output_ninja_and_namespace_map ~per_proj_dir ~package_kind let namespace_dir = per_proj_dir // lib_artifacts_dir in Bsb_namespace_map_gen.output ~dir:namespace_dir ns bs_file_groups; Bsb_ninja_targets.output_build oc - ~outputs:[ ns ^ Literals.suffix_cmi ] - ~inputs:[ ns ^ Literals.suffix_mlmap ] + ~outputs:[ns ^ Literals.suffix_cmi] + ~inputs:[ns ^ Literals.suffix_mlmap] ~rule:rules.build_package); close_out oc; output_installation_file cwd_lib_bs namespace files_to_install diff --git a/compiler/bsb/bsb_ninja_regen.ml b/compiler/bsb/bsb_ninja_regen.ml index cabf8d84bd..fb5fe31fcc 100644 --- a/compiler/bsb/bsb_ninja_regen.ml +++ b/compiler/bsb/bsb_ninja_regen.ml @@ -30,13 +30,14 @@ let ( // ) = Ext_path.combine return None if we dont need regenerate otherwise return Some info *) -let regenerate_ninja ~(package_kind : Bsb_package_kind.t) ~forced ~per_proj_dir ~warn_legacy_config ~warn_as_error - : Bsb_config_types.t option = +let regenerate_ninja ~(package_kind : Bsb_package_kind.t) ~forced ~per_proj_dir + ~warn_legacy_config ~warn_as_error : Bsb_config_types.t option = let lib_artifacts_dir = Bsb_config.lib_bs in let lib_bs_dir = per_proj_dir // lib_artifacts_dir in let output_deps = lib_bs_dir // bsdeps in let check_result = - Bsb_ninja_check.check ~package_kind ~per_proj_dir ~forced ~warn_as_error ~file:output_deps + Bsb_ninja_check.check ~package_kind ~per_proj_dir ~forced ~warn_as_error + ~file:output_deps in let config_filename, config_json = Bsb_config_load.load_json ~per_proj_dir ~warn_legacy_config @@ -45,57 +46,57 @@ let regenerate_ninja ~(package_kind : Bsb_package_kind.t) ~forced ~per_proj_dir | Good -> None (* Fast path, no need regenerate ninja *) | Bsb_forced | Bsb_bsc_version_mismatch | Bsb_package_kind_inconsistent | Bsb_file_corrupted | Bsb_file_not_exist | Bsb_source_directory_changed - | Bsb_regenerate_required - | Other _ -> - Bsb_log.info "@{BSB check@} build spec : %a @." - Bsb_ninja_check.pp_check_result check_result; - if check_result = Bsb_bsc_version_mismatch then ( - Bsb_log.warn - "@{Different compiler version@}: clean current repo@."; - Bsb_clean.clean_bs_deps per_proj_dir; - Bsb_clean.clean_self per_proj_dir); + | Bsb_regenerate_required | Other _ -> + Bsb_log.info "@{BSB check@} build spec : %a @." + Bsb_ninja_check.pp_check_result check_result; + if check_result = Bsb_bsc_version_mismatch then ( + Bsb_log.warn "@{Different compiler version@}: clean current repo@."; + Bsb_clean.clean_bs_deps per_proj_dir; + Bsb_clean.clean_self per_proj_dir); - let config : Bsb_config_types.t = - Bsb_config_parse.interpret_json - ~filename:config_filename ~json:config_json ~package_kind ~per_proj_dir - in + let config : Bsb_config_types.t = + Bsb_config_parse.interpret_json ~filename:config_filename + ~json:config_json ~package_kind ~per_proj_dir + in - let warning = match config.warning with + let warning = + match config.warning with | None -> ( - match warn_as_error with - | Some e -> Some {Bsb_warning.number = Some e; error = Warn_error_number e} - | None -> None) - | Some {error} as t -> - match (warn_as_error, error) with - | (Some error_str, Warn_error_false) -> - Some {number = Some error_str; error = Warn_error_number error_str} - | (Some error_str, Warn_error_number prev) -> - let new_error = prev ^ error_str in - Some {number = Some new_error; error = Warn_error_number new_error} - | _ -> t - in + match warn_as_error with + | Some e -> + Some {Bsb_warning.number = Some e; error = Warn_error_number e} + | None -> None) + | Some {error} as t -> ( + match (warn_as_error, error) with + | Some error_str, Warn_error_false -> + Some {number = Some error_str; error = Warn_error_number error_str} + | Some error_str, Warn_error_number prev -> + let new_error = prev ^ error_str in + Some {number = Some new_error; error = Warn_error_number new_error} + | _ -> t) + in - let config = {config with warning = warning} in - (* create directory, lib/bs, lib/js, lib/es6 etc *) - Bsb_build_util.mkp lib_bs_dir; - Bsb_package_specs.list_dirs_by config.package_specs (fun x -> - let dir = per_proj_dir // x in - (*Unix.EEXIST error*) - if not (Sys.file_exists dir) then Unix.mkdir dir 0o777); - (match package_kind with - | Toplevel -> - Bsb_watcher_gen.generate_sourcedirs_meta - ~name:(lib_bs_dir // Literals.sourcedirs_meta) - config.file_groups - | Pinned_dependency _ (* FIXME: seems need to be watched *) | Dependency _ - -> - ()); + let config = {config with warning} in + (* create directory, lib/bs, lib/js, lib/es6 etc *) + Bsb_build_util.mkp lib_bs_dir; + Bsb_package_specs.list_dirs_by config.package_specs (fun x -> + let dir = per_proj_dir // x in + (*Unix.EEXIST error*) + if not (Sys.file_exists dir) then Unix.mkdir dir 0o777); + (match package_kind with + | Toplevel -> + Bsb_watcher_gen.generate_sourcedirs_meta + ~name:(lib_bs_dir // Literals.sourcedirs_meta) + config.file_groups + | Pinned_dependency _ (* FIXME: seems need to be watched *) | Dependency _ + -> + ()); - Bsb_ninja_gen.output_ninja_and_namespace_map ~per_proj_dir ~package_kind - config; - (* PR2184: we still need record empty dir - since it may add files in the future *) - Bsb_ninja_check.record ~package_kind ~per_proj_dir ~config ~warn_as_error - ~file:output_deps - (config.filename :: config.file_groups.globbed_dirs); - Some config + Bsb_ninja_gen.output_ninja_and_namespace_map ~per_proj_dir ~package_kind + config; + (* PR2184: we still need record empty dir + since it may add files in the future *) + Bsb_ninja_check.record ~package_kind ~per_proj_dir ~config ~warn_as_error + ~file:output_deps + (config.filename :: config.file_groups.globbed_dirs); + Some config diff --git a/compiler/bsb/bsb_ninja_rule.ml b/compiler/bsb/bsb_ninja_rule.ml index 2c4810d4fd..a65b7d9862 100644 --- a/compiler/bsb/bsb_ninja_rule.ml +++ b/compiler/bsb/bsb_ninja_rule.ml @@ -23,9 +23,9 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = { - mutable used : bool; + mutable used: bool; (* rule_name : string; *) - name : out_channel -> string; + name: out_channel -> string; } let get_name (x : t) oc = x.name oc @@ -43,9 +43,9 @@ let print_rule (oc : out_channel) ?description ?(restat : unit option) match description with | None -> () | Some description -> - output_string oc " description = "; - output_string oc description; - output_string oc "\n" + output_string oc " description = "; + output_string oc description; + output_string oc "\n" (** allocate an unique name for such rule*) let define ~command ?dyndep ?restat rule_name : t = @@ -67,23 +67,23 @@ let define ~command ?dyndep ?restat rule_name : t = type command = string type builtin = { - build_ast_from_re : t; + build_ast_from_re: t; (* build_ast_from_rei : t ; *) (* platform dependent, on Win32, invoking cmd.exe *) - copy_resources : t; + copy_resources: t; (* Rules below all need restat *) - build_bin_deps : t; - build_bin_deps_dev : t; - mj : t; - mj_dev : t; - mij : t; - mij_dev : t; - mi : t; - mi_dev : t; - build_package : t; - customs : t Map_string.t; + build_bin_deps: t; + build_bin_deps_dev: t; + mj: t; + mj_dev: t; + mij: t; + mij_dev: t; + mi: t; + mi_dev: t; + build_package: t; + customs: t Map_string.t; } let make_custom_rules ~(gentype_config : Bsb_config_types.gentype_config) @@ -98,8 +98,12 @@ let make_custom_rules ~(gentype_config : Bsb_config_types.gentype_config) (* FIXME: We don't need set [-o ${out}] when building ast since the default is already good -- it does not*) let buf = Ext_buffer.create 100 in - let ns_flag = match namespace with None -> "" | Some n -> " -bs-ns " ^ n in - let mk_ml_cmj_cmd ~(read_cmi : [ `yes | `is_cmi | `no ]) ~is_dev ~postbuild : + let ns_flag = + match namespace with + | None -> "" + | Some n -> " -bs-ns " ^ n + in + let mk_ml_cmj_cmd ~(read_cmi : [`yes | `is_cmi | `no]) ~is_dev ~postbuild : string = Ext_buffer.clear buf; Ext_buffer.add_string buf bsc; @@ -126,15 +130,15 @@ let make_custom_rules ~(gentype_config : Bsb_config_types.gentype_config) (match (bs_dependencies, bs_dev_dependencies) with | [], [] -> () | _, _ -> - Ext_buffer.add_string buf " -bs-v"; - Ext_buffer.add_ninja_prefix_var buf Bsb_ninja_global_vars.g_finger); + Ext_buffer.add_string buf " -bs-v"; + Ext_buffer.add_ninja_prefix_var buf Bsb_ninja_global_vars.g_finger); Ext_buffer.add_string buf " $i"; (match postbuild with | None -> () | Some cmd -> - Ext_buffer.add_string buf " && "; - Ext_buffer.add_string buf cmd; - Ext_buffer.add_string buf " $out_last"); + Ext_buffer.add_string buf " && "; + Ext_buffer.add_string buf cmd; + Ext_buffer.add_string buf " $out_last"); Ext_buffer.contents buf in let mk_ast = @@ -146,22 +150,23 @@ let make_custom_rules ~(gentype_config : Bsb_config_types.gentype_config) (match ppx_files with | [] -> () | _ -> - Ext_list.iter ppx_files (fun x -> - match string_of_float (Unix.stat x.name).st_mtime with - | exception _ -> () - | st -> Ext_buffer.add_char_string buf ',' st); - Ext_buffer.add_char_string buf ' ' (Bsb_build_util.ppx_flags ppx_files)); + Ext_list.iter ppx_files (fun x -> + match string_of_float (Unix.stat x.name).st_mtime with + | exception _ -> () + | st -> Ext_buffer.add_char_string buf ',' st); + Ext_buffer.add_char_string buf ' ' (Bsb_build_util.ppx_flags ppx_files)); (match pp_file with | None -> () | Some flag -> - Ext_buffer.add_char_string buf ' ' (Bsb_build_util.pp_flag flag)); - (match (jsx.version) with + Ext_buffer.add_char_string buf ' ' (Bsb_build_util.pp_flag flag)); + (match jsx.version with | Some Jsx_v4 -> Ext_buffer.add_string buf " -bs-jsx 4" | None -> ()); (match jsx.module_ with | None -> () | Some React -> Ext_buffer.add_string buf " -bs-jsx-module react" - | Some Generic {moduleName} -> Ext_buffer.add_string buf (" -bs-jsx-module " ^ moduleName)); + | Some (Generic {moduleName}) -> + Ext_buffer.add_string buf (" -bs-jsx-module " ^ moduleName)); (match jsx.mode with | None -> () | Some Classic -> Ext_buffer.add_string buf " -bs-jsx-mode classic" @@ -177,7 +182,7 @@ let make_custom_rules ~(gentype_config : Bsb_config_types.gentype_config) define ~command: (if Ext_sys.is_windows_or_cygwin then "cmd.exe /C copy /Y $i $out >NUL" - else "cp $i $out") + else "cp $i $out") "copy_resource" in diff --git a/compiler/bsb/bsb_ninja_rule.mli b/compiler/bsb/bsb_ninja_rule.mli index b6ce806ab9..65efad6781 100644 --- a/compiler/bsb/bsb_ninja_rule.mli +++ b/compiler/bsb/bsb_ninja_rule.mli @@ -32,22 +32,22 @@ val get_name : t -> out_channel -> string (***********************************************************) type builtin = { - build_ast_from_re : t; + build_ast_from_re: t; (* platform dependent, on Win32, invoking cmd.exe *) - copy_resources : t; + copy_resources: t; (* Rules below all need restat *) - build_bin_deps : t; - build_bin_deps_dev : t; - mj : t; - mj_dev : t; - mij : t; - mij_dev : t; - mi : t; - mi_dev : t; - build_package : t; - customs : t Map_string.t; + build_bin_deps: t; + build_bin_deps_dev: t; + mj: t; + mj_dev: t; + mij: t; + mij_dev: t; + mi: t; + mi_dev: t; + build_package: t; + customs: t Map_string.t; } (** A list of existing rules *) diff --git a/compiler/bsb/bsb_package_kind.ml b/compiler/bsb/bsb_package_kind.ml index 0f4f74802e..12198ce3dc 100644 --- a/compiler/bsb/bsb_package_kind.ml +++ b/compiler/bsb/bsb_package_kind.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type dep_payload = { package_specs : Bsb_package_specs.t; jsx : Bsb_jsx.t } +type dep_payload = {package_specs: Bsb_package_specs.t; jsx: Bsb_jsx.t} type t = | Toplevel @@ -36,12 +36,12 @@ let encode_no_nl (x : t) = match x with | Toplevel -> "0" | Dependency x -> - "1" - ^ Bsb_package_specs.package_flag_of_package_specs x.package_specs - ~dirname:"." - ^ Bsb_jsx.encode_no_nl x.jsx + "1" + ^ Bsb_package_specs.package_flag_of_package_specs x.package_specs + ~dirname:"." + ^ Bsb_jsx.encode_no_nl x.jsx | Pinned_dependency x -> - "2" - ^ Bsb_package_specs.package_flag_of_package_specs x.package_specs - ~dirname:"." - ^ Bsb_jsx.encode_no_nl x.jsx + "2" + ^ Bsb_package_specs.package_flag_of_package_specs x.package_specs + ~dirname:"." + ^ Bsb_jsx.encode_no_nl x.jsx diff --git a/compiler/bsb/bsb_package_specs.ml b/compiler/bsb/bsb_package_specs.ml index 9f6085f1c8..0a5efe8664 100644 --- a/compiler/bsb/bsb_package_specs.ml +++ b/compiler/bsb/bsb_package_specs.ml @@ -28,8 +28,8 @@ let ( // ) = Ext_path.combine module Spec_set = Bsb_spec_set type t = { - modules : Spec_set.t; - runtime : string option; + modules: Spec_set.t; + runtime: string option; (* This has to be resolved as early as possible, since the path will be inherited in sub projects *) @@ -86,58 +86,59 @@ let rec from_array suffix (arr : Ext_json_types.t array) : Spec_set.t = (* TODO: FIXME: better API without mutating *) and from_json_single suffix (x : Ext_json_types.t) : Bsb_spec_set.spec = match x with - | Str { str = format; loc } -> - { format = supported_format format loc; in_source = false; suffix } - | Obj { map; loc } -> ( - match map.?("module") with - | Some (Str { str = format }) -> - let in_source = - match map.?(Bsb_build_schemas.in_source) with - | Some (True _) -> true - | Some _ | None -> false - in - let suffix = - match map.?(Bsb_build_schemas.suffix) with - | Some (Str { str = suffix; _ }) when validate_js_suffix suffix -> suffix - | Some (Str {str; loc}) -> - Bsb_exception.errorf ~loc - ("invalid suffix \"%s\". The suffix and may contain letters, digits, \"-\", \"_\" and \".\" and must end with .js, .mjs or .cjs.") str - | Some _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "expected a string extension like \".js\"" - | None -> suffix - in - { format = supported_format format loc; in_source; suffix } - | Some _ -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, `module` \ - field should be a string, not an array. If you want to pass \ - multiple module specs, try turning package-specs into an array of \ - objects (or strings) instead." - | None -> + | Str {str = format; loc} -> + {format = supported_format format loc; in_source = false; suffix} + | Obj {map; loc} -> ( + match map.?("module") with + | Some (Str {str = format}) -> + let in_source = + match map.?(Bsb_build_schemas.in_source) with + | Some (True _) -> true + | Some _ | None -> false + in + let suffix = + match map.?(Bsb_build_schemas.suffix) with + | Some (Str {str = suffix; _}) when validate_js_suffix suffix -> suffix + | Some (Str {str; loc}) -> Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, the `module` \ - field is mandatory.") + "invalid suffix \"%s\". The suffix and may contain letters, \ + digits, \"-\", \"_\" and \".\" and must end with .js, .mjs or \ + .cjs." + str + | Some _ -> + Bsb_exception.errorf ~loc:(Ext_json.loc_of x) + "expected a string extension like \".js\"" + | None -> suffix + in + {format = supported_format format loc; in_source; suffix} + | Some _ -> + Bsb_exception.errorf ~loc + "package-specs: when the configuration is an object, `module` field \ + should be a string, not an array. If you want to pass multiple module \ + specs, try turning package-specs into an array of objects (or \ + strings) instead." + | None -> + Bsb_exception.errorf ~loc + "package-specs: when the configuration is an object, the `module` \ + field is mandatory.") | _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: expected either a string or an object." + Bsb_exception.errorf ~loc:(Ext_json.loc_of x) + "package-specs: expected either a string or an object." let from_json suffix (x : Ext_json_types.t) : Spec_set.t = match x with - | Arr { content; _ } -> from_array suffix content + | Arr {content; _} -> from_array suffix content | _ -> Spec_set.singleton (from_json_single suffix x) let bs_package_output = "-bs-package-output" [@@@warning "+9"] -let package_flag ({ format; in_source; suffix } : Bsb_spec_set.spec) dir = +let package_flag ({format; in_source; suffix} : Bsb_spec_set.spec) dir = Ext_string.inter2 bs_package_output (Ext_string.concat5 (string_of_format format) Ext_string.single_colon - (if in_source then dir - else Bsb_config.top_prefix_of_format format // dir) - Ext_string.single_colon - suffix) + (if in_source then dir else Bsb_config.top_prefix_of_format format // dir) + Ext_string.single_colon suffix) (* FIXME: we should adapt it *) let package_flag_of_package_specs (package_specs : t) ~(dirname : string) : @@ -145,19 +146,18 @@ let package_flag_of_package_specs (package_specs : t) ~(dirname : string) : let res = match (package_specs.modules :> Bsb_spec_set.spec list) with | [] -> Ext_string.empty - | [ format ] -> - Ext_string.inter2 Ext_string.empty (package_flag format dirname) - | [ a; b ] -> - Ext_string.inter3 Ext_string.empty (package_flag a dirname) - (package_flag b dirname) - | [ a; b; c ] -> - Ext_string.inter4 Ext_string.empty (package_flag a dirname) - (package_flag b dirname) (package_flag c dirname) + | [format] -> + Ext_string.inter2 Ext_string.empty (package_flag format dirname) + | [a; b] -> + Ext_string.inter3 Ext_string.empty (package_flag a dirname) + (package_flag b dirname) + | [a; b; c] -> + Ext_string.inter4 Ext_string.empty (package_flag a dirname) + (package_flag b dirname) (package_flag c dirname) | _ -> - Spec_set.fold - (fun format acc -> - Ext_string.inter2 acc (package_flag format dirname)) - package_specs.modules Ext_string.empty + Spec_set.fold + (fun format acc -> Ext_string.inter2 acc (package_flag format dirname)) + package_specs.modules Ext_string.empty in match package_specs.runtime with | None -> res @@ -165,7 +165,7 @@ let package_flag_of_package_specs (package_specs : t) ~(dirname : string) : let default_package_specs suffix = (* TODO: swap default to Esmodule in v12 *) - Spec_set.singleton { format = Commonjs; in_source = false; suffix } + Spec_set.singleton {format = Commonjs; in_source = false; suffix} (** [get_list_of_output_js specs "src/hi/hello"] @@ -176,10 +176,11 @@ let get_list_of_output_js (package_specs : t) Spec_set.fold (fun (spec : Bsb_spec_set.spec) acc -> let basename = - Ext_namespace.change_ext_ns_suffix output_file_sans_extension spec.suffix + Ext_namespace.change_ext_ns_suffix output_file_sans_extension + spec.suffix in (if spec.in_source then Bsb_config.rev_lib_bs_prefix basename - else Bsb_config.lib_bs_prefix_of_format spec.format // basename) + else Bsb_config.lib_bs_prefix_of_format spec.format // basename) :: acc) package_specs.modules [] @@ -194,13 +195,14 @@ type json_map = Ext_json_types.t Map_string.t let extract_js_suffix_exn (map : json_map) : string = match map.?(Bsb_build_schemas.suffix) with | None -> Literals.suffix_js - | Some (Str { str = suffix; _ }) when validate_js_suffix suffix -> suffix - | Some ((Str {str; _}) as config) -> + | Some (Str {str = suffix; _}) when validate_js_suffix suffix -> suffix + | Some (Str {str; _} as config) -> Bsb_exception.config_error config - ("invalid suffix \"" ^ str ^ "\". The suffix and may contain letters, digits, \"-\", \"_\" and \".\" and must end with .js, .mjs or .cjs.") + ("invalid suffix \"" ^ str + ^ "\". The suffix and may contain letters, digits, \"-\", \"_\" and \".\" \ + and must end with .js, .mjs or .cjs.") | Some config -> - Bsb_exception.config_error config - "expected a string extension like \".js\"" + Bsb_exception.config_error config "expected a string extension like \".js\"" let from_map ~(cwd : string) map = let suffix = extract_js_suffix_exn map in @@ -212,10 +214,9 @@ let from_map ~(cwd : string) map = let runtime = match map.?(Bsb_build_schemas.external_stdlib) with | None -> None - | Some (Str { str; _ }) -> - Some - (Bsb_pkg.resolve_bs_package ~cwd - (Bsb_pkg_types.string_as_package str)) + | Some (Str {str; _}) -> + Some + (Bsb_pkg.resolve_bs_package ~cwd (Bsb_pkg_types.string_as_package str)) | _ -> assert false in - { runtime; modules } + {runtime; modules} diff --git a/compiler/bsb/bsb_parse_sources.ml b/compiler/bsb/bsb_parse_sources.ml index e9969e957d..fe2af4ba3b 100644 --- a/compiler/bsb/bsb_parse_sources.ml +++ b/compiler/bsb/bsb_parse_sources.ml @@ -31,21 +31,21 @@ let ( .?() ) = Map_string.find_opt type t = Bsb_file_groups.t let is_input_or_output (xs : build_generator list) (x : string) = - Ext_list.exists xs (fun { input; output } -> + Ext_list.exists xs (fun {input; output} -> let it_is y = y = x in Ext_list.exists input it_is || Ext_list.exists output it_is) let errorf x fmt = Bsb_exception.errorf ~loc:(Ext_json.loc_of x) fmt type cxt = { - package_kind : Bsb_package_kind.t; - is_dev : bool; - cwd : string; - root : string; - cut_generators : bool; - traverse : bool; + package_kind: Bsb_package_kind.t; + is_dev: bool; + cwd: string; + root: string; + cut_generators: bool; + traverse: bool; (* namespace : string option; *) - ignored_dirs : Set_string.t; + ignored_dirs: Set_string.t; } (** [public] has a list of modules, we do a sanity check to see if all the listed @@ -57,25 +57,24 @@ let collect_pub_modules (xs : Ext_json_types.t array) (cache : Bsb_db.map) : for i = 0 to Array.length xs - 1 do let v = Array.unsafe_get xs i in match v with - | Str { str; loc } -> - if Map_string.mem cache str then set := Set_string.add !set str - else - Bsb_exception.errorf ~loc "%S in public is not an existing module" str + | Str {str; loc} -> + if Map_string.mem cache str then set := Set_string.add !set str + else + Bsb_exception.errorf ~loc "%S in public is not an existing module" str | _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of v) - "public expects a list of strings" + Bsb_exception.errorf ~loc:(Ext_json.loc_of v) + "public expects a list of strings" done; !set let extract_pub (input : Ext_json_types.t Map_string.t) (cur_sources : Bsb_db.map) : Bsb_file_groups.public = match input.?(Bsb_build_schemas.public) with - | Some (Str { str = s } as x) -> - if s = Bsb_build_schemas.export_all then Export_all - else if s = Bsb_build_schemas.export_none then Export_none - else errorf x "invalid str for %s " s - | Some (Arr { content }) -> - Export_set (collect_pub_modules content cur_sources) + | Some (Str {str = s} as x) -> + if s = Bsb_build_schemas.export_all then Export_all + else if s = Bsb_build_schemas.export_none then Export_none + else errorf x "invalid str for %s " s + | Some (Arr {content}) -> Export_set (collect_pub_modules content cur_sources) | Some config -> Bsb_exception.config_error config "expect array or string" | None -> Export_all @@ -90,46 +89,48 @@ let extract_input_output (edge : Ext_json_types.t) : string list * string list = errorf edge {| invalid edge format, expect ["output" , ":", "input" ]|} in match edge with - | Arr { content } -> ( - match - Ext_array.find_and_split content - (fun x () -> match x with Str { str = ":" } -> true | _ -> false) - () - with - | No_split -> error () - | Split (output, input) -> - ( Ext_array.to_list_map output (fun x -> - match x with - | Str { str = ":" } -> error () - | Str { str } -> Some str - | _ -> None), - Ext_array.to_list_map input (fun x -> - match x with - | Str { str = ":" } -> error () - | Str { str } -> - Some str - (* More rigirous error checking: It would trigger a ninja syntax error *) - | _ -> None) )) + | Arr {content} -> ( + match + Ext_array.find_and_split content + (fun x () -> + match x with + | Str {str = ":"} -> true + | _ -> false) + () + with + | No_split -> error () + | Split (output, input) -> + ( Ext_array.to_list_map output (fun x -> + match x with + | Str {str = ":"} -> error () + | Str {str} -> Some str + | _ -> None), + Ext_array.to_list_map input (fun x -> + match x with + | Str {str = ":"} -> error () + | Str {str} -> + Some str + (* More rigirous error checking: It would trigger a ninja syntax error *) + | _ -> None) )) | _ -> error () type json_map = Ext_json_types.t Map_string.t let extract_generators (input : json_map) : build_generator list = match input.?(Bsb_build_schemas.generators) with - | Some (Arr { content; loc_start = _ }) -> - (* Need check is dev build or not *) - Ext_array.fold_left content [] (fun acc x -> - match x with - | Obj { map } -> ( - match - (map.?(Bsb_build_schemas.name), map.?(Bsb_build_schemas.edge)) - with - | Some (Str command), Some edge -> - let output, input = extract_input_output edge in - { Bsb_file_groups.input; output; command = command.str } - :: acc - | _ -> errorf x "Invalid generator format") + | Some (Arr {content; loc_start = _}) -> + (* Need check is dev build or not *) + Ext_array.fold_left content [] (fun acc x -> + match x with + | Obj {map} -> ( + match + (map.?(Bsb_build_schemas.name), map.?(Bsb_build_schemas.edge)) + with + | Some (Str command), Some edge -> + let output, input = extract_input_output edge in + {Bsb_file_groups.input; output; command = command.str} :: acc | _ -> errorf x "Invalid generator format") + | _ -> errorf x "Invalid generator format") | Some x -> errorf x "Invalid generator format" | None -> [] @@ -137,21 +138,21 @@ let extract_predicate (m : json_map) : string -> bool = let excludes = match m.?(Bsb_build_schemas.excludes) with | None -> [] - | Some (Arr { content = arr }) -> Bsb_build_util.get_list_string arr + | Some (Arr {content = arr}) -> Bsb_build_util.get_list_string arr | Some x -> Bsb_exception.config_error x "excludes expect array " in let slow_re = m.?(Bsb_build_schemas.slow_re) in match (slow_re, excludes) with - | Some (Str { str = s }), [] -> - let re = Str.regexp s in - fun name -> Str.string_match re name 0 - | Some (Str { str = s }), _ :: _ -> - let re = Str.regexp s in - fun name -> - Str.string_match re name 0 && not (Ext_list.mem_string excludes name) + | Some (Str {str = s}), [] -> + let re = Str.regexp s in + fun name -> Str.string_match re name 0 + | Some (Str {str = s}), _ :: _ -> + let re = Str.regexp s in + fun name -> + Str.string_match re name 0 && not (Ext_list.mem_string excludes name) | Some config, _ -> - Bsb_exception.config_error config - (Bsb_build_schemas.slow_re ^ " expect a string literal") + Bsb_exception.config_error config + (Bsb_build_schemas.slow_re ^ " expect a string literal") | None, _ -> fun name -> not (Ext_list.mem_string excludes name) (** [parsing_source_dir_map cxt input] @@ -166,21 +167,19 @@ let extract_predicate (m : json_map) : string -> bool = (********************************************************************) (* starts parsing *) -let rec parsing_source_dir_map ({ cwd = dir } as cxt) +let rec parsing_source_dir_map ({cwd = dir} as cxt) (input : Ext_json_types.t Map_string.t) : Bsb_file_groups.t = if Set_string.mem cxt.ignored_dirs dir then Bsb_file_groups.empty else let cur_globbed_dirs = ref false in let has_generators = match cxt with - | { - cut_generators = false; - package_kind = Toplevel | Pinned_dependency _; - } -> - true - | { cut_generators = false; package_kind = Dependency _ } - | { cut_generators = true; _ } -> - false + | {cut_generators = false; package_kind = Toplevel | Pinned_dependency _} + -> + true + | {cut_generators = false; package_kind = Dependency _} + | {cut_generators = true; _} -> + false in let scanned_generators = extract_generators input in let sub_dirs_field = input.?(Bsb_build_schemas.subdirs) in @@ -198,31 +197,31 @@ let rec parsing_source_dir_map ({ cwd = dir } as cxt) let sources = match input.?(Bsb_build_schemas.files) with | None -> - (* We should avoid temporary files *) - Ext_array.fold_left (Lazy.force base_name_array) output_sources - (fun acc basename -> - if is_input_or_output scanned_generators basename then acc - else Bsb_db_util.add_basename ~dir acc basename) + (* We should avoid temporary files *) + Ext_array.fold_left (Lazy.force base_name_array) output_sources + (fun acc basename -> + if is_input_or_output scanned_generators basename then acc + else Bsb_db_util.add_basename ~dir acc basename) | Some (Arr basenames) -> - Ext_array.fold_left basenames.content output_sources - (fun acc basename -> - match basename with - | Str { str = basename; loc } -> - Bsb_db_util.add_basename ~dir acc basename - ~error_on_invalid_suffix:loc - | _ -> acc) - | Some (Obj { map; loc = _ }) -> - (* { excludes : [], slow_re : "" }*) - let predicate = extract_predicate map in - Ext_array.fold_left (Lazy.force base_name_array) output_sources - (fun acc basename -> - if - is_input_or_output scanned_generators basename - || not (predicate basename) - then acc - else Bsb_db_util.add_basename ~dir acc basename) + Ext_array.fold_left basenames.content output_sources + (fun acc basename -> + match basename with + | Str {str = basename; loc} -> + Bsb_db_util.add_basename ~dir acc basename + ~error_on_invalid_suffix:loc + | _ -> acc) + | Some (Obj {map; loc = _}) -> + (* { excludes : [], slow_re : "" }*) + let predicate = extract_predicate map in + Ext_array.fold_left (Lazy.force base_name_array) output_sources + (fun acc basename -> + if + is_input_or_output scanned_generators basename + || not (predicate basename) + then acc + else Bsb_db_util.add_basename ~dir acc basename) | Some x -> - Bsb_exception.config_error x "files field expect array or object " + Bsb_exception.config_error x "files field expect array or object " in let resources = extract_resources input in let public = extract_pub input sources in @@ -230,26 +229,26 @@ let rec parsing_source_dir_map ({ cwd = dir } as cxt) let children = match (sub_dirs_field, cxt.traverse) with | None, true | Some (True _), _ -> - let root = cxt.root in - let parent = Filename.concat root dir in - Ext_array.fold_left (Lazy.force base_name_array) Bsb_file_groups.empty - (fun origin x -> - if - (not (Set_string.mem cxt.ignored_dirs x)) - && Ext_sys.is_directory_no_exn (Filename.concat parent x) - then - Bsb_file_groups.merge - (parsing_source_dir_map - { - cxt with - cwd = - Ext_path.concat cxt.cwd - (Ext_path.simple_convert_node_path_to_os_path x); - traverse = true; - } - Map_string.empty) - origin - else origin) + let root = cxt.root in + let parent = Filename.concat root dir in + Ext_array.fold_left (Lazy.force base_name_array) Bsb_file_groups.empty + (fun origin x -> + if + (not (Set_string.mem cxt.ignored_dirs x)) + && Ext_sys.is_directory_no_exn (Filename.concat parent x) + then + Bsb_file_groups.merge + (parsing_source_dir_map + { + cxt with + cwd = + Ext_path.concat cxt.cwd + (Ext_path.simple_convert_node_path_to_os_path x); + traverse = true; + } + Map_string.empty) + origin + else origin) (* readdir parent avoiding scanning twice *) | None, false | Some (False _), _ -> Bsb_file_groups.empty | Some s, _ -> parse_sources cxt s @@ -269,53 +268,49 @@ let rec parsing_source_dir_map ({ cwd = dir } as cxt) ?globbed_dir:(if !cur_globbed_dirs then Some dir else None) children -and parsing_single_source ({ package_kind; is_dev; cwd } as cxt) +and parsing_single_source ({package_kind; is_dev; cwd} as cxt) (x : Ext_json_types.t) : t = match x with - | Str { str = dir } -> ( - match (package_kind, is_dev) with - | Dependency _, true -> Bsb_file_groups.empty - | Dependency _, false | (Toplevel | Pinned_dependency _), _ -> - parsing_source_dir_map - { - cxt with - cwd = - Ext_path.concat cwd - (Ext_path.simple_convert_node_path_to_os_path dir); - } - Map_string.empty) - | Obj { map } -> ( - let current_dir_index = - match map.?(Bsb_build_schemas.type_) with - | Some (Str { str = "dev" }) -> true - | Some _ -> - Bsb_exception.config_error x {|type field expect "dev" literal |} - | None -> is_dev + | Str {str = dir} -> ( + match (package_kind, is_dev) with + | Dependency _, true -> Bsb_file_groups.empty + | Dependency _, false | (Toplevel | Pinned_dependency _), _ -> + parsing_source_dir_map + { + cxt with + cwd = + Ext_path.concat cwd + (Ext_path.simple_convert_node_path_to_os_path dir); + } + Map_string.empty) + | Obj {map} -> ( + let current_dir_index = + match map.?(Bsb_build_schemas.type_) with + | Some (Str {str = "dev"}) -> true + | Some _ -> + Bsb_exception.config_error x {|type field expect "dev" literal |} + | None -> is_dev + in + match (package_kind, current_dir_index) with + | Dependency _, true -> Bsb_file_groups.empty + | Dependency _, false | (Toplevel | Pinned_dependency _), _ -> + let dir = + match map.?(Bsb_build_schemas.dir) with + | Some (Str {str}) -> + if str = Literals.library_file then + Bsb_exception.config_error x + (Printf.sprintf "dir field should be different from `%s`" + Literals.library_file) + else Ext_path.simple_convert_node_path_to_os_path str + | Some x -> Bsb_exception.config_error x "dir expected to be a string" + | None -> + Bsb_exception.config_error x + ("required field :" ^ Bsb_build_schemas.dir ^ " missing") in - match (package_kind, current_dir_index) with - | Dependency _, true -> Bsb_file_groups.empty - | Dependency _, false | (Toplevel | Pinned_dependency _), _ -> - let dir = - match map.?(Bsb_build_schemas.dir) with - | Some (Str { str }) -> - if str = Literals.library_file then - Bsb_exception.config_error x (Printf.sprintf "dir field should be different from `%s`" Literals.library_file) - else - Ext_path.simple_convert_node_path_to_os_path str - | Some x -> - Bsb_exception.config_error x "dir expected to be a string" - | None -> - Bsb_exception.config_error x - ("required field :" ^ Bsb_build_schemas.dir ^ " missing") - in - parsing_source_dir_map - { - cxt with - is_dev = current_dir_index; - cwd = Ext_path.concat cwd dir; - } - map) + parsing_source_dir_map + {cxt with is_dev = current_dir_index; cwd = Ext_path.concat cwd dir} + map) | _ -> Bsb_file_groups.empty and parsing_arr_sources cxt (file_groups : Ext_json_types.t array) = @@ -328,7 +323,7 @@ and parse_sources (cxt : cxt) (sources : Ext_json_types.t) = | _ -> parsing_single_source cxt sources let scan ~package_kind ~root ~cut_generators ~(* ~namespace *) - ignored_dirs x : t = + ignored_dirs x : t = parse_sources { ignored_dirs; @@ -344,32 +339,31 @@ let scan ~package_kind ~root ~cut_generators ~(* ~namespace *) (* Walk through to do some work *) type walk_cxt = { - cwd : string; - root : string; - traverse : bool; - ignored_dirs : Set_string.t; - gentype_language : string; + cwd: string; + root: string; + traverse: bool; + ignored_dirs: Set_string.t; + gentype_language: string; } let rec walk_sources (cxt : walk_cxt) (sources : Ext_json_types.t) = match sources with - | Arr { content } -> - Ext_array.iter content (fun x -> walk_single_source cxt x) + | Arr {content} -> Ext_array.iter content (fun x -> walk_single_source cxt x) | x -> walk_single_source cxt x and walk_single_source cxt (x : Ext_json_types.t) = match x with - | Str { str = dir } -> - let dir = Ext_path.simple_convert_node_path_to_os_path dir in - walk_source_dir_map { cxt with cwd = Ext_path.concat cxt.cwd dir } None - | Obj { map } -> ( - match map.?(Bsb_build_schemas.dir) with - | Some (Str { str }) -> - let dir = Ext_path.simple_convert_node_path_to_os_path str in - walk_source_dir_map - { cxt with cwd = Ext_path.concat cxt.cwd dir } - map.?(Bsb_build_schemas.subdirs) - | _ -> ()) + | Str {str = dir} -> + let dir = Ext_path.simple_convert_node_path_to_os_path dir in + walk_source_dir_map {cxt with cwd = Ext_path.concat cxt.cwd dir} None + | Obj {map} -> ( + match map.?(Bsb_build_schemas.dir) with + | Some (Str {str}) -> + let dir = Ext_path.simple_convert_node_path_to_os_path str in + walk_source_dir_map + {cxt with cwd = Ext_path.concat cxt.cwd dir} + map.?(Bsb_build_schemas.subdirs) + | _ -> ()) | _ -> () and walk_source_dir_map (cxt : walk_cxt) sub_dirs_field = @@ -387,20 +381,20 @@ and walk_source_dir_map (cxt : walk_cxt) sub_dirs_field = let cxt_traverse = cxt.traverse in match (sub_dirs_field, cxt_traverse) with | None, true | Some (True _), _ -> - Ext_array.iter file_array (fun f -> - if - (not (Set_string.mem cxt.ignored_dirs f)) - && Ext_sys.is_directory_no_exn (Filename.concat working_dir f) - then - walk_source_dir_map - { - cxt with - cwd = - Ext_path.concat cxt.cwd - (Ext_path.simple_convert_node_path_to_os_path f); - traverse = true; - } - None) + Ext_array.iter file_array (fun f -> + if + (not (Set_string.mem cxt.ignored_dirs f)) + && Ext_sys.is_directory_no_exn (Filename.concat working_dir f) + then + walk_source_dir_map + { + cxt with + cwd = + Ext_path.concat cxt.cwd + (Ext_path.simple_convert_node_path_to_os_path f); + traverse = true; + } + None) | None, _ | Some (False _), _ -> () | Some s, _ -> walk_sources cxt s) @@ -412,34 +406,34 @@ let clean_re_js root = Ext_json_parse.parse_json_from_file (Filename.concat root Literals.bsconfig_json) with - | Obj { map } -> - let ignored_dirs = - match map.?(Bsb_build_schemas.ignored_dirs) with - | Some (Arr { content = x }) -> - Set_string.of_list (Bsb_build_util.get_list_string x) - | Some _ | None -> Set_string.empty - in - let gentype_language = - match map.?(Bsb_build_schemas.gentypeconfig) with + | Obj {map} -> + let ignored_dirs = + match map.?(Bsb_build_schemas.ignored_dirs) with + | Some (Arr {content = x}) -> + Set_string.of_list (Bsb_build_util.get_list_string x) + | Some _ | None -> Set_string.empty + in + let gentype_language = + match map.?(Bsb_build_schemas.gentypeconfig) with + | None -> "" + | Some (Obj {map}) -> ( + match map.?(Bsb_build_schemas.language) with | None -> "" - | Some (Obj { map }) -> ( - match map.?(Bsb_build_schemas.language) with - | None -> "" - | Some (Str { str }) -> str - | Some _ -> "") - | Some _ -> "" - in - Ext_option.iter map.?(Bsb_build_schemas.sources) (fun config -> - try - walk_sources - { - root; - traverse = true; - cwd = Filename.current_dir_name; - ignored_dirs; - gentype_language; - } - config - with _ -> ()) + | Some (Str {str}) -> str + | Some _ -> "") + | Some _ -> "" + in + Ext_option.iter map.?(Bsb_build_schemas.sources) (fun config -> + try + walk_sources + { + root; + traverse = true; + cwd = Filename.current_dir_name; + ignored_dirs; + gentype_language; + } + config + with _ -> ()) | _ -> () | exception _ -> () diff --git a/compiler/bsb/bsb_pkg.ml b/compiler/bsb/bsb_pkg.ml index f2c1d27730..87ac5cef4a 100644 --- a/compiler/bsb/bsb_pkg.ml +++ b/compiler/bsb/bsb_pkg.ml @@ -44,7 +44,9 @@ let node_paths : string list Lazy.t = a failure *) let check_dir dir = - match Sys.file_exists dir with true -> Some dir | false -> None + match Sys.file_exists dir with + | true -> Some dir + | false -> None let resolve_bs_package_aux ~cwd (pkg : t) = (* First try to resolve recursively from the current working directory *) @@ -83,18 +85,18 @@ let to_list cb = Coll.to_list cache cb let resolve_bs_package ~cwd (package : t) = match Coll.find_opt cache package with | None -> - let result = resolve_bs_package_aux ~cwd package in - Bsb_log.info "@{Package@} %a -> %s@." Bsb_pkg_types.print package - result; - Coll.add cache package result; - result + let result = resolve_bs_package_aux ~cwd package in + Bsb_log.info "@{Package@} %a -> %s@." Bsb_pkg_types.print package + result; + Coll.add cache package result; + result | Some x -> - let result = resolve_bs_package_aux ~cwd package in - if not (Bsb_real_path.is_same_paths_via_io result x) then - Bsb_log.warn - "@{Duplicated package:@} %a %s (chosen) vs %s in %s @." - Bsb_pkg_types.print package x result cwd; - x + let result = resolve_bs_package_aux ~cwd package in + if not (Bsb_real_path.is_same_paths_via_io result x) then + Bsb_log.warn + "@{Duplicated package:@} %a %s (chosen) vs %s in %s @." + Bsb_pkg_types.print package x result cwd; + x (** The package does not need to be a bspackage example: diff --git a/compiler/bsb/bsb_pkg_types.ml b/compiler/bsb/bsb_pkg_types.ml index 8a7aa44e75..c4c5c37082 100644 --- a/compiler/bsb/bsb_pkg_types.ml +++ b/compiler/bsb/bsb_pkg_types.ml @@ -29,7 +29,9 @@ type t = Global of string | Scope of string * scope and scope = string let to_string (x : t) = - match x with Global s -> s | Scope (s, scope) -> scope // s + match x with + | Global s -> s + | Scope (s, scope) -> scope // s let print fmt (x : t) = match x with diff --git a/compiler/bsb/bsb_real_path.ml b/compiler/bsb/bsb_real_path.ml index d4c33d5eb0..47a6f91a49 100644 --- a/compiler/bsb/bsb_real_path.ml +++ b/compiler/bsb/bsb_real_path.ml @@ -34,17 +34,19 @@ let normalize_exn (s : string) : string = let real_path p = match Sys.is_directory p with | exception _ -> - let rec resolve dir = - if Sys.file_exists dir then normalize_exn dir - else - let parent = Filename.dirname dir in - if dir = parent then dir else resolve parent // Filename.basename dir - in - let p = if Filename.is_relative p then Sys.getcwd () // p else p in - resolve p + let rec resolve dir = + if Sys.file_exists dir then normalize_exn dir + else + let parent = Filename.dirname dir in + if dir = parent then dir else resolve parent // Filename.basename dir + in + let p = if Filename.is_relative p then Sys.getcwd () // p else p in + resolve p | true -> normalize_exn p | false -> ( - let dir = normalize_exn (Filename.dirname p) in - match Filename.basename p with "." -> dir | base -> dir // base) + let dir = normalize_exn (Filename.dirname p) in + match Filename.basename p with + | "." -> dir + | base -> dir // base) let is_same_paths_via_io a b = if a = b then true else real_path a = real_path b diff --git a/compiler/bsb/bsb_regex.ml b/compiler/bsb/bsb_regex.ml index 98437c319d..603004e0b3 100644 --- a/compiler/bsb/bsb_regex.ml +++ b/compiler/bsb/bsb_regex.ml @@ -41,19 +41,19 @@ let global_substitute text ~reg:expr repl_fun = match Str.search_forward expr text startpos with | exception Not_found -> string_after text start :: accu | pos -> - let end_pos = Str.match_end () in - let matched = Str.matched_string text in - let groups = - let rec aux n acc = - match Str.matched_group n text with - | exception (Not_found | Invalid_argument _) -> acc - | v -> aux (succ n) (v :: acc) - in - aux 1 [] + let end_pos = Str.match_end () in + let matched = Str.matched_string text in + let groups = + let rec aux n acc = + match Str.matched_group n text with + | exception (Not_found | Invalid_argument _) -> acc + | v -> aux (succ n) (v :: acc) in - let repl_text = repl_fun matched groups in - replace - (repl_text :: String.sub text start (pos - start) :: accu) - end_pos (end_pos = pos) + aux 1 [] + in + let repl_text = repl_fun matched groups in + replace + (repl_text :: String.sub text start (pos - start) :: accu) + end_pos (end_pos = pos) in String.concat "" (List.rev (replace [] 0 false)) diff --git a/compiler/bsb/bsb_spec_set.ml b/compiler/bsb/bsb_spec_set.ml index a53862fbc8..d60bc4374a 100644 --- a/compiler/bsb/bsb_spec_set.ml +++ b/compiler/bsb/bsb_spec_set.ml @@ -27,11 +27,11 @@ (* TODO: sync up with {!Js_packages_info.module_system} *) type format = Ext_module_system.t -type spec = { format : format; in_source : bool; suffix : string } +type spec = {format: format; in_source: bool; suffix: string} type t = spec list -let cmp (s1 : spec) ({ format; in_source; suffix } : spec) = +let cmp (s1 : spec) ({format; in_source; suffix} : spec) = let v = compare s1.format format in if v <> 0 then v else @@ -42,39 +42,40 @@ let empty = [] let rec insert lst piviot = match lst with - | [] -> [ piviot ] + | [] -> [piviot] | x :: xs -> - let v = cmp piviot x in - if v = 0 then lst - else if v < 0 then piviot :: lst - else x :: insert xs piviot + let v = cmp piviot x in + if v = 0 then lst + else if v < 0 then piviot :: lst + else x :: insert xs piviot let add spec specs = match specs with - | [] -> [ spec ] - | [ a ] -> - let v = cmp spec a in - if v < 0 then spec :: specs else if v = 0 then specs else [ a; spec ] - | [ a; b ] -> - let v = cmp spec a in - if v < 0 then spec :: specs - else if v = 0 then specs - else - let v1 = cmp spec b in - if v < 0 then [ a; spec; b ] - else if v1 = 0 then specs - else [ a; b; spec ] + | [] -> [spec] + | [a] -> + let v = cmp spec a in + if v < 0 then spec :: specs else if v = 0 then specs else [a; spec] + | [a; b] -> + let v = cmp spec a in + if v < 0 then spec :: specs + else if v = 0 then specs + else + let v1 = cmp spec b in + if v < 0 then [a; spec; b] else if v1 = 0 then specs else [a; b; spec] | _ :: _ :: _ :: _ -> - (* unlikely to happen *) - insert specs spec + (* unlikely to happen *) + insert specs spec -let singleton x = [ x ] +let singleton x = [x] -let rec fold f t acc = match t with [] -> acc | x :: xs -> fold f xs (f x acc) +let rec fold f t acc = + match t with + | [] -> acc + | x :: xs -> fold f xs (f x acc) let rec iter f t = match t with | [] -> () | x :: xs -> - f x; - iter f xs + f x; + iter f xs diff --git a/compiler/bsb/bsb_spec_set.mli b/compiler/bsb/bsb_spec_set.mli index 996475c207..96312be026 100644 --- a/compiler/bsb/bsb_spec_set.mli +++ b/compiler/bsb/bsb_spec_set.mli @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type format = Ext_module_system.t -type spec = { format : format; in_source : bool; suffix : string } +type spec = {format: format; in_source: bool; suffix: string} type t = private spec list diff --git a/compiler/bsb/bsb_unix.ml b/compiler/bsb/bsb_unix.ml index e1c43c20af..47979ed750 100644 --- a/compiler/bsb/bsb_unix.ml +++ b/compiler/bsb/bsb_unix.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type command = { cmd : string; cwd : string; args : string array } +type command = {cmd: string; cwd: string; args: string array} let log cmd = Bsb_log.info "@{Entering@} %s @." cmd.cwd; @@ -36,17 +36,17 @@ let command_fatal_error cmd eid = let run_command_execv_unix cmd : int = match Unix.fork () with | 0 -> - log cmd; - Unix.chdir cmd.cwd; - Unix.execv cmd.cmd cmd.args + log cmd; + Unix.chdir cmd.cwd; + Unix.execv cmd.cmd cmd.args | pid -> ( - match Unix.waitpid [] pid with - | _, process_status -> ( - match process_status with - | Unix.WEXITED eid -> eid - | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> - Bsb_log.error "@{Interrupted:@} %s@." cmd.cmd; - 2)) + match Unix.waitpid [] pid with + | _, process_status -> ( + match process_status with + | Unix.WEXITED eid -> eid + | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> + Bsb_log.error "@{Interrupted:@} %s@." cmd.cmd; + 2)) (** TODO: the args are not quoted, here we are calling a very limited set of `bsb` commands, so that @@ -75,10 +75,10 @@ let run_command_execv = let rec remove_dir_recursive dir = match Sys.is_directory dir with | true -> - let files = Sys.readdir dir in - for i = 0 to Array.length files - 1 do - remove_dir_recursive (Filename.concat dir (Array.unsafe_get files i)) - done; - Unix.rmdir dir + let files = Sys.readdir dir in + for i = 0 to Array.length files - 1 do + remove_dir_recursive (Filename.concat dir (Array.unsafe_get files i)) + done; + Unix.rmdir dir | false -> Sys.remove dir | exception _ -> () diff --git a/compiler/bsb/bsb_unix.mli b/compiler/bsb/bsb_unix.mli index 1df6758352..e5c6720adc 100644 --- a/compiler/bsb/bsb_unix.mli +++ b/compiler/bsb/bsb_unix.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type command = { cmd : string; cwd : string; args : string array } +type command = {cmd: string; cwd: string; args: string array} val command_fatal_error : command -> int -> unit diff --git a/compiler/bsb/bsb_warning.ml b/compiler/bsb/bsb_warning.ml index 179b77a9b6..9e6958fd67 100644 --- a/compiler/bsb/bsb_warning.ml +++ b/compiler/bsb/bsb_warning.ml @@ -28,7 +28,7 @@ type warning_error = | Warn_error_true | Warn_error_number of string -type t0 = { number : string option; error : warning_error } +type t0 = {number: string option; error: warning_error} type nonrec t = t0 option @@ -49,8 +49,8 @@ let to_merlin_string x = ^ let customize = match x with - | Some { number = None } | None -> Ext_string.empty - | Some { number = Some x } -> prepare_warning_concat ~beg:false x + | Some {number = None} | None -> Ext_string.empty + | Some {number = Some x} -> prepare_warning_concat ~beg:false x in if customize = "" then customize else customize ^ "-40-42-61" (* see #4406 to avoid user pass A @@ -63,36 +63,36 @@ let from_map (m : Ext_json_types.t Map_string.t) = match (number_opt, error_opt) with | None, None -> None | _, _ -> - let error = - match error_opt with - | Some (True _) -> Warn_error_true - | Some (False _) -> Warn_error_false - | Some (Str { str }) -> Warn_error_number str - | Some x -> Bsb_exception.config_error x "expect true/false or string" - | None -> Warn_error_false - (* To make it less intrusive : warning error has to be enabled*) - in - let number = - match number_opt with - | Some (Str { str = number }) -> Some number - | None -> None - | Some x -> Bsb_exception.config_error x "expect a string" - in - Some { number; error } + let error = + match error_opt with + | Some (True _) -> Warn_error_true + | Some (False _) -> Warn_error_false + | Some (Str {str}) -> Warn_error_number str + | Some x -> Bsb_exception.config_error x "expect true/false or string" + | None -> Warn_error_false + (* To make it less intrusive : warning error has to be enabled*) + in + let number = + match number_opt with + | Some (Str {str = number}) -> Some number + | None -> None + | Some x -> Bsb_exception.config_error x "expect a string" + in + Some {number; error} let to_bsb_string ~(package_kind : Bsb_package_kind.t) warning = match package_kind with | Toplevel | Pinned_dependency _ -> ( - match warning with + match warning with + | None -> Ext_string.empty + | Some warning -> ( + (match warning.number with | None -> Ext_string.empty - | Some warning -> ( - (match warning.number with - | None -> Ext_string.empty - | Some x -> prepare_warning_concat ~beg:true x) - ^ - match warning.error with - | Warn_error_true -> " -warn-error A" - | Warn_error_number y -> " -warn-error " ^ y - | Warn_error_false -> Ext_string.empty)) + | Some x -> prepare_warning_concat ~beg:true x) + ^ + match warning.error with + | Warn_error_true -> " -warn-error A" + | Warn_error_number y -> " -warn-error " ^ y + | Warn_error_false -> Ext_string.empty)) | Dependency _ -> " -w a" (* TODO: this is the current default behavior *) diff --git a/compiler/bsb/bsb_warning.mli b/compiler/bsb/bsb_warning.mli index b04fb6f038..d83ec88907 100644 --- a/compiler/bsb/bsb_warning.mli +++ b/compiler/bsb/bsb_warning.mli @@ -28,11 +28,10 @@ type warning_error = | Warn_error_true | Warn_error_number of string -type t0 = { number : string option; error : warning_error } +type t0 = {number: string option; error: warning_error} type nonrec t = t0 option - val to_merlin_string : t -> string (** Extra work is need to make merlin happy *) diff --git a/compiler/bsb/bsb_watcher_gen.ml b/compiler/bsb/bsb_watcher_gen.ml index f72c1830f5..341b2b0d8b 100644 --- a/compiler/bsb/bsb_watcher_gen.ml +++ b/compiler/bsb/bsb_watcher_gen.ml @@ -43,7 +43,7 @@ let generate_sourcedirs_meta ~name (res : Bsb_file_groups.t) = arr (Array.of_list (Bsb_pkg.to_list (fun pkg path -> - arr [| str (Bsb_pkg_types.to_string pkg); str path |]))) ); + arr [|str (Bsb_pkg_types.to_string pkg); str path|]))) ); ] in Ext_json_noloc.to_file name v diff --git a/compiler/bsb/bsb_world.ml b/compiler/bsb/bsb_world.ml index 631523a1e3..63c69f6d9d 100644 --- a/compiler/bsb/bsb_world.ml +++ b/compiler/bsb/bsb_world.ml @@ -30,17 +30,17 @@ let make_world_deps cwd (config : Bsb_config_types.t option) let package_specs, jsx, pinned_dependencies = match config with | None -> - (* When this running bsb does not read rescript.json, - we will read such json file to know which [package-specs] - it wants - *) - Bsb_config_parse.deps_from_bsconfig () + (* When this running bsb does not read rescript.json, + we will read such json file to know which [package-specs] + it wants + *) + Bsb_config_parse.deps_from_bsconfig () | Some config -> - (config.package_specs, config.jsx, config.pinned_dependencies) + (config.package_specs, config.jsx, config.pinned_dependencies) in let args = - if Ext_array.is_empty ninja_args then [| vendor_ninja |] - else Array.append [| vendor_ninja |] ninja_args + if Ext_array.is_empty ninja_args then [|vendor_ninja|] + else Array.append [|vendor_ninja|] ninja_args in let lib_artifacts_dir = Bsb_config.lib_bs in let queue = Bsb_build_util.walk_all_deps cwd ~pinned_dependencies in @@ -56,45 +56,44 @@ let make_world_deps cwd (config : Bsb_config_types.t option) ); close_out oc ; *) queue - |> Queue.iter (fun ({ top; proj_dir; is_pinned } : Bsb_build_util.package_context) -> + |> Queue.iter + (fun ({top; proj_dir; is_pinned} : Bsb_build_util.package_context) -> match top with | Expect_none -> () | Expect_name s -> - if is_pinned then print_endline ("Dependency pinned on " ^ s) - else print_endline ("Dependency on " ^ s); - let lib_bs_dir = proj_dir // lib_artifacts_dir in - Bsb_build_util.mkp lib_bs_dir; - let _config : _ option = - Bsb_ninja_regen.regenerate_ninja - ~package_kind: - (if is_pinned then Pinned_dependency { package_specs; jsx } - else Dependency { package_specs; jsx }) - ~per_proj_dir:proj_dir ~forced:false - ~warn_legacy_config:false - ~warn_as_error:(if is_pinned then warn_as_error else None) - in - let command = - { Bsb_unix.cmd = vendor_ninja; cwd = lib_bs_dir; args } - in - let eid = Bsb_unix.run_command_execv command in - if eid <> 0 then Bsb_unix.command_fatal_error command eid; - (* When ninja is not regenerated, ninja will still do the build, - still need reinstall check - Note that we can check if ninja print "no work to do", - then don't need reinstall more - *) - Bsb_log.info "@{Installation started@}@."; - let install_dir = proj_dir // "lib" // "ocaml" in - Bsb_build_util.mkp install_dir; - let install_command = - { - Bsb_unix.cmd = vendor_ninja; - cwd = install_dir; - args = - [| vendor_ninja; "-f"; ".." // "bs" // "install.ninja" |]; - } - in - let eid = Bsb_unix.run_command_execv install_command in - if eid <> 0 then Bsb_unix.command_fatal_error install_command eid; - Bsb_log.info "@{Installation finished@}@."); + if is_pinned then print_endline ("Dependency pinned on " ^ s) + else print_endline ("Dependency on " ^ s); + let lib_bs_dir = proj_dir // lib_artifacts_dir in + Bsb_build_util.mkp lib_bs_dir; + let _config : _ option = + Bsb_ninja_regen.regenerate_ninja + ~package_kind: + (if is_pinned then Pinned_dependency {package_specs; jsx} + else Dependency {package_specs; jsx}) + ~per_proj_dir:proj_dir ~forced:false ~warn_legacy_config:false + ~warn_as_error:(if is_pinned then warn_as_error else None) + in + let command = + {Bsb_unix.cmd = vendor_ninja; cwd = lib_bs_dir; args} + in + let eid = Bsb_unix.run_command_execv command in + if eid <> 0 then Bsb_unix.command_fatal_error command eid; + (* When ninja is not regenerated, ninja will still do the build, + still need reinstall check + Note that we can check if ninja print "no work to do", + then don't need reinstall more + *) + Bsb_log.info "@{Installation started@}@."; + let install_dir = proj_dir // "lib" // "ocaml" in + Bsb_build_util.mkp install_dir; + let install_command = + { + Bsb_unix.cmd = vendor_ninja; + cwd = install_dir; + args = [|vendor_ninja; "-f"; ".." // "bs" // "install.ninja"|]; + } + in + let eid = Bsb_unix.run_command_execv install_command in + if eid <> 0 then Bsb_unix.command_fatal_error install_command eid; + Bsb_log.info "@{Installation finished@}@."); print_endline "Dependency Finished" diff --git a/compiler/bsb_exe/.ocamlformat b/compiler/bsb_exe/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/bsb_exe/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/bsb_exe/rescript_main.ml b/compiler/bsb_exe/rescript_main.ml index 7498116934..d066de72b9 100644 --- a/compiler/bsb_exe/rescript_main.ml +++ b/compiler/bsb_exe/rescript_main.ml @@ -42,7 +42,7 @@ let unit_set_spec b : spec = Unit (Unit_set b) let string_set_spec s : spec = String (String_set s) -let string_call f: spec = String (String_call f) +let string_call f : spec = String (String_call f) let failed_annon ~rev_args = match rev_args with @@ -64,14 +64,14 @@ let ninja_command_exit (type t) (ninja_args : string array) : t = let path_ninja = Filename.quote Bsb_global_paths.vendor_ninja in exec_command_then_exit (if ninja_args_len = 0 then - Ext_string.inter3 path_ninja "-C" lib_artifacts_dir - else - let args = - Array.append [| path_ninja; "-C"; lib_artifacts_dir |] ninja_args - in - Ext_string.concat_array Ext_string.single_space args) + Ext_string.inter3 path_ninja "-C" lib_artifacts_dir + else + let args = + Array.append [|path_ninja; "-C"; lib_artifacts_dir|] ninja_args + in + Ext_string.concat_array Ext_string.single_space args) else - let ninja_common_args = [| "ninja.exe"; "-C"; lib_artifacts_dir |] in + let ninja_common_args = [|"ninja.exe"; "-C"; lib_artifacts_dir|] in let args = if ninja_args_len = 0 then ninja_common_args else Array.append ninja_common_args ninja_args @@ -88,8 +88,7 @@ let ninja_command_exit (type t) (ninja_args : string array) : t = ninja -C _build *) let clean_usage = - "Usage: rescript clean \n\n\ - `rescript clean` cleans build artifacts\n" + "Usage: rescript clean \n\n`rescript clean` cleans build artifacts\n" let build_usage = "Usage: rescript build -- \n\n\ @@ -105,7 +104,7 @@ let install_target () = { Bsb_unix.cmd = vendor_ninja; cwd = install_dir; - args = [| vendor_ninja; "-f"; ".." // "bs" // "install.ninja" |]; + args = [|vendor_ninja; "-f"; ".." // "bs" // "install.ninja"|]; } in let eid = Bsb_unix.run_command_execv install_command in @@ -123,7 +122,10 @@ let build_subcommand ~start argv argv_len = string_set_spec (ref ""), "[host]:port set up host & port for WebSocket build notifications" ); ("-verbose", call_spec Bsb_log.verbose, "Set the output to be verbose"); - ("-with-deps", unit_set_spec (ref true), "*deprecated* This is the default behavior now. This option will be removed in a future release"); + ( "-with-deps", + unit_set_spec (ref true), + "*deprecated* This is the default behavior now. This option will be \ + removed in a future release" ); ( "-install", unit_set_spec do_install, "*internal* Install public interface files for dependencies" ); @@ -135,8 +137,14 @@ let build_subcommand ~start argv argv_len = "*internal* \n\ Always regenerate build.ninja no matter bsconfig.json is changed or \ not" ); - ("-no-deps", unit_set_spec no_deps_mode, "*internal* Needed for watcher to build without dependencies on file change"); - ("-warn-error", string_call (fun s -> warning_as_error := Some s), "Warning numbers and whether to turn them into errors, e.g., \"+8+32-102\"") + ( "-no-deps", + unit_set_spec no_deps_mode, + "*internal* Needed for watcher to build without dependencies on file \ + change" ); + ( "-warn-error", + string_call (fun s -> warning_as_error := Some s), + "Warning numbers and whether to turn them into errors, e.g., \ + \"+8+32-102\"" ); |] failed_annon; @@ -144,24 +152,28 @@ let build_subcommand ~start argv argv_len = if i < 0 then [||] else Array.sub argv (i + 1) (argv_len - i - 1) in match ninja_args with - | [| "-h" |] -> ninja_command_exit ninja_args + | [|"-h"|] -> ninja_command_exit ninja_args | _ -> - let warn_as_error = match !warning_as_error with + let warn_as_error = + match !warning_as_error with | Some s -> - let () = try Warnings.parse_options true s with Arg.Bad msg -> Bsb_arg.bad_arg (msg ^ "\n") in - Some s - | None -> None in - let config_opt = - Bsb_ninja_regen.regenerate_ninja - ~package_kind:Toplevel - ~per_proj_dir:Bsb_global_paths.cwd - ~forced:!force_regenerate - ~warn_legacy_config:true - ~warn_as_error + let () = + try Warnings.parse_options true s + with Arg.Bad msg -> Bsb_arg.bad_arg (msg ^ "\n") in - if not !no_deps_mode then Bsb_world.make_world_deps Bsb_global_paths.cwd config_opt ninja_args warn_as_error; - if !do_install then install_target (); - ninja_command_exit ninja_args + Some s + | None -> None + in + let config_opt = + Bsb_ninja_regen.regenerate_ninja ~package_kind:Toplevel + ~per_proj_dir:Bsb_global_paths.cwd ~forced:!force_regenerate + ~warn_legacy_config:true ~warn_as_error + in + if not !no_deps_mode then + Bsb_world.make_world_deps Bsb_global_paths.cwd config_opt ninja_args + warn_as_error; + if !do_install then install_target (); + ninja_command_exit ninja_args let clean_subcommand ~start argv = Bsb_arg.parse_exn ~usage:clean_usage ~start ~argv @@ -169,7 +181,8 @@ let clean_subcommand ~start argv = ("-verbose", call_spec Bsb_log.verbose, "Set the output to be verbose"); ( "-with-deps", unit_set_spec (ref true), - "*deprecated* This is the default behavior now. This option will be removed in a future release" ); + "*deprecated* This is the default behavior now. This option will be \ + removed in a future release" ); |] failed_annon; Bsb_clean.clean_bs_deps Bsb_global_paths.cwd; @@ -179,33 +192,29 @@ let list_files = ref false let info_subcommand ~start argv = Bsb_arg.parse_exn ~usage:"query the project" ~start ~argv - [| ("-list-files", unit_set_spec list_files, "list source files") |] + [|("-list-files", unit_set_spec list_files, "list source files")|] (fun ~rev_args -> (match rev_args with | x :: _ -> raise (Bsb_arg.Bad ("Don't know what to do with " ^ x)) | [] -> ()); if !list_files then match - Bsb_ninja_regen.regenerate_ninja - ~package_kind:Toplevel - ~per_proj_dir:Bsb_global_paths.cwd - ~forced:true - ~warn_legacy_config:true - ~warn_as_error:None + Bsb_ninja_regen.regenerate_ninja ~package_kind:Toplevel + ~per_proj_dir:Bsb_global_paths.cwd ~forced:true + ~warn_legacy_config:true ~warn_as_error:None with | None -> assert false - | Some { file_groups = { files } } -> - Ext_list.iter files (fun { sources } -> - Map_string.iter sources - (fun _ { info; name_sans_extension } -> - let extensions = - match info with - | Intf -> assert false - | Impl -> [ ".res" ] - | Impl_intf -> [ ".res"; ".resi" ] - in - Ext_list.iter extensions (fun x -> - print_endline (name_sans_extension ^ x))))) + | Some {file_groups = {files}} -> + Ext_list.iter files (fun {sources} -> + Map_string.iter sources (fun _ {info; name_sans_extension} -> + let extensions = + match info with + | Intf -> assert false + | Impl -> [".res"] + | Impl_intf -> [".res"; ".resi"] + in + Ext_list.iter extensions (fun x -> + print_endline (name_sans_extension ^ x))))) (* see discussion #929, if we catch the exception, we don't have stacktrace... *) let () = @@ -215,12 +224,9 @@ let () = if argv_len = 1 then ( (* specialize this path which is used in watcher *) let config_opt = - Bsb_ninja_regen.regenerate_ninja - ~package_kind:Toplevel - ~per_proj_dir:Bsb_global_paths.cwd - ~forced:false - ~warn_legacy_config:true - ~warn_as_error:None + Bsb_ninja_regen.regenerate_ninja ~package_kind:Toplevel + ~per_proj_dir:Bsb_global_paths.cwd ~forced:false + ~warn_legacy_config:true ~warn_as_error:None in Bsb_world.make_world_deps Bsb_global_paths.cwd config_opt [||] None; ninja_command_exit [||]) @@ -229,22 +235,22 @@ let () = | "build" -> build_subcommand ~start:2 argv argv_len | "clean" -> clean_subcommand ~start:2 argv | "info" -> - (* internal *) - info_subcommand ~start:2 argv + (* internal *) + info_subcommand ~start:2 argv | first_arg -> - prerr_endline @@ "Unknown subcommand or flags: " ^ first_arg; - exit 1 + prerr_endline @@ "Unknown subcommand or flags: " ^ first_arg; + exit 1 with | Bsb_exception.Error e -> - Bsb_exception.print Format.err_formatter e; - Format.pp_print_newline Format.err_formatter (); - exit 2 + Bsb_exception.print Format.err_formatter e; + Format.pp_print_newline Format.err_formatter (); + exit 2 | Ext_json_parse.Error (start, _, e) -> - Format.fprintf Format.err_formatter - "File %S, line %d\n@{Error:@} %a@." start.pos_fname - start.pos_lnum Ext_json_parse.report_error e; - exit 2 + Format.fprintf Format.err_formatter + "File %S, line %d\n@{Error:@} %a@." start.pos_fname start.pos_lnum + Ext_json_parse.report_error e; + exit 2 | Bsb_arg.Bad s | Sys_error s -> - Format.fprintf Format.err_formatter "@{Error:@} %s" s; - exit 2 + Format.fprintf Format.err_formatter "@{Error:@} %s" s; + exit 2 | e -> Ext_pervasives.reraise e diff --git a/compiler/bsb_helper/.ocamlformat b/compiler/bsb_helper/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/bsb_helper/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/bsb_helper/bsb_db_decode.ml b/compiler/bsb_helper/bsb_db_decode.ml index f3f1d6ccd9..2ba5da0a25 100644 --- a/compiler/bsb_helper/bsb_db_decode.ml +++ b/compiler/bsb_helper/bsb_db_decode.ml @@ -27,17 +27,13 @@ let bsbuild_cache = Literals.bsbuild_cache type group = | Dummy | Group of { - modules : string array; - dir_length : int; - dir_info_offset : int; - module_info_offset : int; + modules: string array; + dir_length: int; + dir_info_offset: int; + module_info_offset: int; } -type t = { - lib : group; - dev : group; - content : string; (* string is whole content*) -} +type t = {lib: group; dev: group; content: string (* string is whole content*)} type cursor = int ref @@ -46,7 +42,7 @@ let rec decode (x : string) : t = let (offset : cursor) = ref 0 in let lib = decode_single x offset in let dev = decode_single x offset in - { lib; dev; content = x } + {lib; dev; content = x} and decode_single (x : string) (offset : cursor) : group = let module_number = Ext_pervasives.parse_nat_of_string x offset in @@ -57,7 +53,7 @@ and decode_single (x : string) (offset : cursor) : group = let module_info_offset = String.index_from x dir_info_offset '\n' + 1 in let dir_length = Char.code x.[module_info_offset] - 48 (* Char.code '0'*) in offset := module_info_offset + 1 + (dir_length * module_number) + 1; - Group { modules; dir_info_offset; module_info_offset; dir_length }) + Group {modules; dir_info_offset; module_info_offset; dir_length}) else Dummy and decode_modules (x : string) (offset : cursor) module_number : string array = @@ -82,37 +78,36 @@ let read_build_cache ~dir : t = let all_content = Ext_io.load_file (Filename.concat dir bsbuild_cache) in decode all_content -type module_info = { case : bool; (* which is Bsb_db.case*) dir_name : string } +type module_info = {case: bool; (* which is Bsb_db.case*) dir_name: string} -let find_opt ({ content = whole } as db : t) lib (key : string) : +let find_opt ({content = whole} as db : t) lib (key : string) : module_info option = match if lib then db.lib else db.dev with | Dummy -> None - | Group ({ modules } as group) -> ( - let i = Ext_string_array.find_sorted modules key in - match i with - | None -> None - | Some count -> - let encode_len = group.dir_length in - let index = - Ext_string.get_1_2_3_4 whole - ~off:(group.module_info_offset + 1 + (count * encode_len)) - encode_len - in - let case = not (index mod 2 = 0) in - let ith = index lsr 1 in - let dir_name_start = - if ith = 0 then group.dir_info_offset - else Ext_string.index_count whole group.dir_info_offset '\t' ith + 1 - in - let dir_name_finish = String.index_from whole dir_name_start '\t' in - Some - { - case; - dir_name = - String.sub whole dir_name_start - (dir_name_finish - dir_name_start); - }) + | Group ({modules} as group) -> ( + let i = Ext_string_array.find_sorted modules key in + match i with + | None -> None + | Some count -> + let encode_len = group.dir_length in + let index = + Ext_string.get_1_2_3_4 whole + ~off:(group.module_info_offset + 1 + (count * encode_len)) + encode_len + in + let case = not (index mod 2 = 0) in + let ith = index lsr 1 in + let dir_name_start = + if ith = 0 then group.dir_info_offset + else Ext_string.index_count whole group.dir_info_offset '\t' ith + 1 + in + let dir_name_finish = String.index_from whole dir_name_start '\t' in + Some + { + case; + dir_name = + String.sub whole dir_name_start (dir_name_finish - dir_name_start); + }) let find db dependent_module is_not_lib_dir = let opt = find_opt db true dependent_module in diff --git a/compiler/bsb_helper/bsb_db_decode.mli b/compiler/bsb_helper/bsb_db_decode.mli index b6e2ccf2aa..2aa097bb7d 100644 --- a/compiler/bsb_helper/bsb_db_decode.mli +++ b/compiler/bsb_helper/bsb_db_decode.mli @@ -25,21 +25,17 @@ type group = private | Dummy | Group of { - modules : string array; - dir_length : int; - dir_info_offset : int; - module_info_offset : int; + modules: string array; + dir_length: int; + dir_info_offset: int; + module_info_offset: int; } -type t = { - lib : group; - dev : group; - content : string; (* string is whole content*) -} +type t = {lib: group; dev: group; content: string (* string is whole content*)} val read_build_cache : dir:string -> t -type module_info = { case : bool; (* Bsb_db.case*) dir_name : string } +type module_info = {case: bool; (* Bsb_db.case*) dir_name: string} val find : t -> diff --git a/compiler/bsb_helper/bsb_helper_depfile_gen.ml b/compiler/bsb_helper/bsb_helper_depfile_gen.ml index 1b29491d5e..e4f9edb750 100644 --- a/compiler/bsb_helper/bsb_helper_depfile_gen.ml +++ b/compiler/bsb_helper/bsb_helper_depfile_gen.ml @@ -112,8 +112,8 @@ let oc_cmi buf namespace source = So we will just ignore the self-cycles. Even if there is indeed a self-cycle, it should fail to compile anyway. *) let oc_deps (ast_file : string) (is_dev : bool) (db : Bsb_db_decode.t) - (namespace : string option) (buf : Ext_buffer.t) (kind : [ `impl | `intf ]) - : unit = + (namespace : string option) (buf : Ext_buffer.t) (kind : [`impl | `intf]) : + unit = (* TODO: move namespace upper, it is better to resolve ealier *) let cur_module_name = Ext_filename.module_name ast_file in let at_most_once : unit lazy_t = @@ -127,10 +127,10 @@ let oc_deps (ast_file : string) (is_dev : bool) (db : Bsb_db_decode.t) (match namespace with | None -> () | Some ns -> - Lazy.force at_most_once; - Ext_buffer.add_char buf ' '; - Ext_buffer.add_string buf ns; - Ext_buffer.add_string buf Literals.suffix_cmi (* always cmi *)); + Lazy.force at_most_once; + Ext_buffer.add_char buf ' '; + Ext_buffer.add_string buf ns; + Ext_buffer.add_string buf Literals.suffix_cmi (* always cmi *)); (* TODO: moved into static files*) let s = extract_dep_raw_string ast_file in let offset = ref 1 in @@ -139,25 +139,25 @@ let oc_deps (ast_file : string) (is_dev : bool) (db : Bsb_db_decode.t) let next_tab = String.index_from s !offset magic_sep_char in let dependent_module = String.sub s !offset (next_tab - !offset) in (if dependent_module = cur_module_name then - (*prerr_endline ("FAILED: " ^ cur_module_name ^ " has a self cycle"); - exit 2*) - (* #5368 ignore self dependencies *) () - else - match Bsb_db_decode.find db dependent_module is_dev with - | None -> () - | Some { dir_name; case } -> - Lazy.force at_most_once; - let source = - Filename.concat dir_name - (if case then dependent_module + (*prerr_endline ("FAILED: " ^ cur_module_name ^ " has a self cycle"); + exit 2*) + (* #5368 ignore self dependencies *) () + else + match Bsb_db_decode.find db dependent_module is_dev with + | None -> () + | Some {dir_name; case} -> + Lazy.force at_most_once; + let source = + Filename.concat dir_name + (if case then dependent_module else Ext_string.uncapitalize_ascii dependent_module) - in - Ext_buffer.add_char buf ' '; - if kind = `impl then ( - output_file buf source namespace; - Ext_buffer.add_string buf Literals.suffix_cmj); - (* #3260 cmj changes does not imply cmi change anymore *) - oc_cmi buf namespace source); + in + Ext_buffer.add_char buf ' '; + if kind = `impl then ( + output_file buf source namespace; + Ext_buffer.add_string buf Literals.suffix_cmj); + (* #3260 cmj changes does not imply cmi change anymore *) + oc_cmi buf namespace source); offset := next_tab + 1 done; if Lazy.is_val at_most_once then Ext_buffer.add_char buf '\n' diff --git a/compiler/bsb_helper_exe/.ocamlformat b/compiler/bsb_helper_exe/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/bsb_helper_exe/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/bsb_helper_exe/bsb_helper_main.ml b/compiler/bsb_helper_exe/bsb_helper_main.ml index adbbba6dde..1564ea7215 100644 --- a/compiler/bsb_helper_exe/bsb_helper_main.ml +++ b/compiler/bsb_helper_exe/bsb_helper_main.ml @@ -36,18 +36,18 @@ let () = match s with | "-hash" -> incr current | "-bs-ns" -> - let ns = argv.(!current) in - namespace := Some ns; - incr current + let ns = argv.(!current) in + namespace := Some ns; + incr current | "-g" -> dev_group := true | s -> - prerr_endline ("unknown options: " ^ s); - prerr_endline "available options: -hash [hash]; -bs-ns [ns]; -g"; - exit 2) + prerr_endline ("unknown options: " ^ s); + prerr_endline "available options: -hash [hash]; -bs-ns [ns]; -g"; + exit 2) else rev_list := s :: !rev_list done; match !rev_list with - | [ x ] -> Bsb_helper_depfile_gen.emit_d !dev_group !namespace x "" - | [ y; x ] (* reverse order *) -> - Bsb_helper_depfile_gen.emit_d !dev_group !namespace x y + | [x] -> Bsb_helper_depfile_gen.emit_d !dev_group !namespace x "" + | [y; x] (* reverse order *) -> + Bsb_helper_depfile_gen.emit_d !dev_group !namespace x y | _ -> () diff --git a/compiler/bsc/.ocamlformat b/compiler/bsc/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/bsc/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 542c248da9..fa84fe09c0 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -10,111 +10,120 @@ (* *) (***********************************************************************) - -let set_abs_input_name sourcefile = - let sourcefile = - if !Location.absname && Filename.is_relative sourcefile then +let set_abs_input_name sourcefile = + let sourcefile = + if !Location.absname && Filename.is_relative sourcefile then Ext_path.absolute_cwd_path sourcefile - else sourcefile in + else sourcefile + in Location.set_input_name sourcefile; - sourcefile -let setup_outcome_printer () = - Lazy.force Res_outcome_printer.setup - -let setup_runtime_path path = - let u0 = Filename.dirname path in - let std = Filename.basename path in - let _path = Filename.dirname u0 in - let rescript = Filename.basename u0 in - (match rescript.[0] with - | '@' -> (* scoped package *) - Bs_version.package_name := rescript ^ "/" ^ std; - | _ -> Bs_version.package_name := std - | exception _ -> - Bs_version.package_name := std); + sourcefile +let setup_outcome_printer () = Lazy.force Res_outcome_printer.setup + +let setup_runtime_path path = + let u0 = Filename.dirname path in + let std = Filename.basename path in + let _path = Filename.dirname u0 in + let rescript = Filename.basename u0 in + (match rescript.[0] with + | '@' -> + (* scoped package *) + Bs_version.package_name := rescript ^ "/" ^ std + | _ -> Bs_version.package_name := std + | exception _ -> Bs_version.package_name := std); Js_config.customize_runtime := Some path - -let process_file sourcefile ?(kind ) ppf = - (* This is a better default then "", it will be changed later - The {!Location.input_name} relies on that we write the binary ast +let process_file sourcefile ?kind ppf = + (* This is a better default then "", it will be changed later + The {!Location.input_name} relies on that we write the binary ast properly *) setup_outcome_printer (); let kind = - match kind with - | None -> Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe sourcefile) - | Some kind -> kind in - let res = match kind with - | Res -> - let sourcefile = set_abs_input_name sourcefile in - Js_implementation.implementation - ~parser:(Res_driver.parse_implementation ~ignore_parse_errors:!Clflags.ignore_parse_errors) - ppf sourcefile - | Resi -> - let sourcefile = set_abs_input_name sourcefile in - Js_implementation.interface - ~parser:(Res_driver.parse_interface ~ignore_parse_errors:!Clflags.ignore_parse_errors) - ppf sourcefile - | Intf_ast - -> - Js_implementation.interface_mliast ppf sourcefile - (* The printer setup is done in the runtime depends on - the content of ast - *) - | Impl_ast - -> - Js_implementation.implementation_mlast ppf sourcefile - | Mlmap - -> - Location.set_input_name sourcefile; - Js_implementation.implementation_map ppf sourcefile - | Cmi - -> - let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in - Printtyp.signature Format.std_formatter cmi_sign ; - Format.pp_print_newline Format.std_formatter () - | Unknown -> - Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile) + match kind with + | None -> + Ext_file_extensions.classify_input + (Ext_filename.get_extension_maybe sourcefile) + | Some kind -> kind + in + let res = + match kind with + | Res -> + let sourcefile = set_abs_input_name sourcefile in + Js_implementation.implementation + ~parser: + (Res_driver.parse_implementation + ~ignore_parse_errors:!Clflags.ignore_parse_errors) + ppf sourcefile + | Resi -> + let sourcefile = set_abs_input_name sourcefile in + Js_implementation.interface + ~parser: + (Res_driver.parse_interface + ~ignore_parse_errors:!Clflags.ignore_parse_errors) + ppf sourcefile + | Intf_ast -> Js_implementation.interface_mliast ppf sourcefile + (* The printer setup is done in the runtime depends on + the content of ast + *) + | Impl_ast -> Js_implementation.implementation_mlast ppf sourcefile + | Mlmap -> + Location.set_input_name sourcefile; + Js_implementation.implementation_map ppf sourcefile + | Cmi -> + let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in + Printtyp.signature Format.std_formatter cmi_sign; + Format.pp_print_newline Format.std_formatter () + | Unknown -> Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile) in res -let reprint_source_file sourcefile = - let kind = Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe sourcefile) in +let reprint_source_file sourcefile = + let kind = + Ext_file_extensions.classify_input + (Ext_filename.get_extension_maybe sourcefile) + in let sourcefile = set_abs_input_name sourcefile in - let res = match kind with - | Res -> - let parse_result = - Res_driver.parsing_engine.parse_implementation ~for_printer:true ~filename:sourcefile - in - if parse_result.invalid then ( - Res_diagnostics.print_report parse_result.diagnostics parse_result.source; - exit 1 - ); - Res_compmisc.init_path (); - parse_result.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Ml - |> Ppx_entry.rewrite_implementation - |> Res_printer.print_implementation ~width:100 ~comments:parse_result.comments - |> print_endline - | Resi -> - let parse_result = - Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename:sourcefile - in - if parse_result.invalid then ( - Res_diagnostics.print_report parse_result.diagnostics parse_result.source; - exit 1 - ); - Res_compmisc.init_path (); - parse_result.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Mli - |> Ppx_entry.rewrite_signature - |> Res_printer.print_interface ~width:100 ~comments:parse_result.comments - |> print_endline - | _ - -> - print_endline ("Invalid input for reprinting ReScript source. Must be a ReScript file: " ^ sourcefile); - exit 2 + let res = + match kind with + | Res -> + let parse_result = + Res_driver.parsing_engine.parse_implementation ~for_printer:true + ~filename:sourcefile + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics + parse_result.source; + exit 1); + Res_compmisc.init_path (); + parse_result.parsetree + |> Cmd_ppx_apply.apply_rewriters ~restore:false + ~tool_name:Js_config.tool_name Ml + |> Ppx_entry.rewrite_implementation + |> Res_printer.print_implementation ~width:100 + ~comments:parse_result.comments + |> print_endline + | Resi -> + let parse_result = + Res_driver.parsing_engine.parse_interface ~for_printer:true + ~filename:sourcefile + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics + parse_result.source; + exit 1); + Res_compmisc.init_path (); + parse_result.parsetree + |> Cmd_ppx_apply.apply_rewriters ~restore:false + ~tool_name:Js_config.tool_name Mli + |> Ppx_entry.rewrite_signature + |> Res_printer.print_interface ~width:100 ~comments:parse_result.comments + |> print_endline + | _ -> + print_endline + ("Invalid input for reprinting ReScript source. Must be a ReScript \ + file: " ^ sourcefile); + exit 2 in res @@ -125,363 +134,340 @@ let ppf = Format.err_formatter (* Error messages to standard error formatter *) let anonymous ~(rev_args : string list) = - if !Js_config.as_ppx then - match rev_args with + if !Js_config.as_ppx then + match rev_args with | [output; input] -> - Ppx_apply.apply_lazy - ~source:input - ~target:output - Ppx_entry.rewrite_implementation - Ppx_entry.rewrite_signature + Ppx_apply.apply_lazy ~source:input ~target:output + Ppx_entry.rewrite_implementation Ppx_entry.rewrite_signature | _ -> Bsc_args.bad_arg "Wrong format when use -as-ppx" - else - begin - match rev_args with - | [filename] -> - process_file filename ppf - | [] -> () - | _ -> - if !Js_config.syntax_only then - Ext_list.rev_iter rev_args (fun filename -> - begin - Clflags.reset_dump_state (); - Warnings.reset (); - process_file filename ppf - end ) - else - Bsc_args.bad_arg "can not handle multiple files" - end - -let format_file input = - let ext = Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) in - ( match ext with - | Res | Resi -> () - | _ -> Bsc_args.bad_arg ("don't know what to do with " ^ input) ); - let formatted = Res_multi_printer.print ~ignore_parse_errors:!Clflags.ignore_parse_errors input in - match !Clflags.output_name with - | None -> - output_string stdout formatted - | Some fname -> - Ext_io.write_file fname formatted + else + match rev_args with + | [filename] -> process_file filename ppf + | [] -> () + | _ -> + if !Js_config.syntax_only then + Ext_list.rev_iter rev_args (fun filename -> + Clflags.reset_dump_state (); + Warnings.reset (); + process_file filename ppf) + else Bsc_args.bad_arg "can not handle multiple files" + +let format_file input = + let ext = + Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) + in + (match ext with + | Res | Resi -> () + | _ -> Bsc_args.bad_arg ("don't know what to do with " ^ input)); + let formatted = + Res_multi_printer.print + ~ignore_parse_errors:!Clflags.ignore_parse_errors + input + in + match !Clflags.output_name with + | None -> output_string stdout formatted + | Some fname -> Ext_io.write_file fname formatted -let set_color_option option = +let set_color_option option = match Clflags.parse_color_setting option with | None -> () | Some setting -> Clflags.color := Some setting let eval (s : string) ~suffix = - let tmpfile = Filename.temp_file "eval" suffix in - Ext_io.write_file tmpfile s; - anonymous ~rev_args:[tmpfile]; + let tmpfile = Filename.temp_file "eval" suffix in + Ext_io.write_file tmpfile s; + anonymous ~rev_args:[tmpfile]; if not !Clflags.verbose then try Sys.remove tmpfile with _ -> () - (* let (//) = Filename.concat *) - - - module Pp = Rescript_cpp let define_variable s = match Ext_string.split ~keep_empty:true s '=' with - | [key; v] -> - if not (Pp.define_key_value key v) then + | [key; v] -> + if not (Pp.define_key_value key v) then Bsc_args.bad_arg ("illegal definition: " ^ s) | _ -> Bsc_args.bad_arg ("illegal definition: " ^ s) -let print_standard_library () = - let (//) = Filename.concat in - let standard_library = +let print_standard_library () = + let ( // ) = Filename.concat in + let standard_library = Filename.dirname Sys.executable_name - // Filename.parent_dir_name // "lib"// "ocaml" in - print_string standard_library; print_newline(); - exit 0 + // Filename.parent_dir_name // "lib" // "ocaml" + in + print_string standard_library; + print_newline (); + exit 0 -let bs_version_string = - "ReScript " ^ Bs_version.version +let bs_version_string = "ReScript " ^ Bs_version.version -let print_version_string () = +let print_version_string () = print_endline bs_version_string; - exit 0 + exit 0 -let [@inline] set s : Bsc_args.spec = Unit (Unit_set s) -let [@inline] clear s : Bsc_args.spec = Unit (Unit_clear s) -let [@inline] string_call s : Bsc_args.spec = - String (String_call s) -let [@inline] string_optional_set s : Bsc_args.spec = +let[@inline] set s : Bsc_args.spec = Unit (Unit_set s) +let[@inline] clear s : Bsc_args.spec = Unit (Unit_clear s) +let[@inline] string_call s : Bsc_args.spec = String (String_call s) +let[@inline] string_optional_set s : Bsc_args.spec = String (String_optional_set s) -let [@inline] unit_call s : Bsc_args.spec = - Unit (Unit_call s) -let [@inline] string_list_add s : Bsc_args.spec = - String (String_list_add s) +let[@inline] unit_call s : Bsc_args.spec = Unit (Unit_call s) +let[@inline] string_list_add s : Bsc_args.spec = String (String_list_add s) (* mostly common used to list in the beginning to make search fast *) let buckle_script_flags : (string * Bsc_args.spec * string) array = [| - "-I", string_list_add Clflags.include_dirs , - "*internal* Add to the list of include directories" ; - - "-w", string_call (Warnings.parse_options false), - " Enable or disable warnings according to :\n\ - + enable warnings in \n\ - - disable warnings in \n\ - @ enable warnings in and treat them as errors\n\ - can be:\n\ - a single warning number\n\ - .. a range of consecutive warning numbers\n\ - default setting is " ^ Bsc_warnings.defaults_w; - - - "-o", string_optional_set Clflags.output_name, - "*internal* set output file name to "; - - "-bs-read-cmi", unit_call (fun _ -> Clflags.assume_no_mli := Mli_exists), - "*internal* Assume mli always exist "; - - "-ppx", string_list_add Clflags.all_ppx, - "*internal* Pipe abstract syntax trees through preprocessor "; - - "-open", string_list_add Clflags.open_modules, - "*internal* Opens the module before typing"; - - "-bs-jsx", string_call (fun i -> - (if i <> "3" && i <> "4" then Bsc_args.bad_arg (" Not supported jsx version : " ^ i)); - Js_config.jsx_version := Js_config.jsx_version_of_int @@ int_of_string i), - "*internal* Set jsx version"; - - "-bs-jsx-module", string_call (fun i -> - let is_generic = match i |> String.lowercase_ascii with - | "react" -> false - | _ -> true in - Js_config.jsx_module := Js_config.jsx_module_of_string i; - if is_generic then ( - Js_config.jsx_mode := Automatic; - Js_config.jsx_version := Some Jsx_v4 - )), - "*internal* Set jsx module"; - - "-bs-jsx-mode", string_call (fun i -> - (if i <> "classic" && i <> "automatic" then Bsc_args.bad_arg (" Not supported jsx-mode : " ^ i)); - Js_config.jsx_mode := Js_config.jsx_mode_of_string i), - "*internal* Set jsx mode"; - - "-bs-package-output", string_call Js_packages_state.update_npm_package_path, - "*internal* Set npm-output-path: [opt_module]:path, for example: 'lib/cjs', 'amdjs:lib/amdjs', 'es6:lib/es6' "; - - "-bs-ast", unit_call(fun _ -> Js_config.binary_ast := true; Js_config.syntax_only := true), - "*internal* Generate binary .mli_ast and ml_ast and stop"; - - "-bs-syntax-only", set Js_config.syntax_only, - "*internal* Only check syntax"; - - "-bs-g", unit_call (fun _ -> Js_config.debug := true; Pp.replace_directive_bool "DEBUG" true), - "Debug mode"; - - "-bs-v", string_call ignore, - "*internal* version check to force a rebuild"; - "-bs-package-name", string_call Js_packages_state.set_package_name, - "*internal* Set package name, useful when you want to produce npm packages"; - - "-bs-ns", string_call Js_packages_state.set_package_map, - "*internal* Set package map, not only set package name but also use it as a namespace" ; - - "-as-ppx", set Js_config.as_ppx, - "*internal*As ppx for editor integration"; - "-as-pp", unit_call(fun _ -> Js_config.as_pp := true ; Js_config.syntax_only := true), - "*internal*As pp to interact with native tools"; - "-no-alias-deps", set Clflags.transparent_modules, - "*internal*Do not record dependencies for module aliases"; - - "-bs-gentype", set Clflags.bs_gentype, - "*internal* Pass gentype command"; - + ( "-I", + string_list_add Clflags.include_dirs, + "*internal* Add to the list of include directories" ); + ( "-w", + string_call (Warnings.parse_options false), + " Enable or disable warnings according to :\n\ + + enable warnings in \n\ + - disable warnings in \n\ + @ enable warnings in and treat them as errors\n\ + can be:\n\ + a single warning number\n\ + .. a range of consecutive warning numbers\n\ + default setting is " ^ Bsc_warnings.defaults_w ); + ( "-o", + string_optional_set Clflags.output_name, + "*internal* set output file name to " ); + ( "-bs-read-cmi", + unit_call (fun _ -> Clflags.assume_no_mli := Mli_exists), + "*internal* Assume mli always exist " ); + ( "-ppx", + string_list_add Clflags.all_ppx, + "*internal* Pipe abstract syntax trees through preprocessor \ + " ); + ( "-open", + string_list_add Clflags.open_modules, + "*internal* Opens the module before typing" ); + ( "-bs-jsx", + string_call (fun i -> + if i <> "3" && i <> "4" then + Bsc_args.bad_arg (" Not supported jsx version : " ^ i); + Js_config.jsx_version := + Js_config.jsx_version_of_int @@ int_of_string i), + "*internal* Set jsx version" ); + ( "-bs-jsx-module", + string_call (fun i -> + let is_generic = + match i |> String.lowercase_ascii with + | "react" -> false + | _ -> true + in + Js_config.jsx_module := Js_config.jsx_module_of_string i; + if is_generic then ( + Js_config.jsx_mode := Automatic; + Js_config.jsx_version := Some Jsx_v4)), + "*internal* Set jsx module" ); + ( "-bs-jsx-mode", + string_call (fun i -> + if i <> "classic" && i <> "automatic" then + Bsc_args.bad_arg (" Not supported jsx-mode : " ^ i); + Js_config.jsx_mode := Js_config.jsx_mode_of_string i), + "*internal* Set jsx mode" ); + ( "-bs-package-output", + string_call Js_packages_state.update_npm_package_path, + "*internal* Set npm-output-path: [opt_module]:path, for example: \ + 'lib/cjs', 'amdjs:lib/amdjs', 'es6:lib/es6' " ); + ( "-bs-ast", + unit_call (fun _ -> + Js_config.binary_ast := true; + Js_config.syntax_only := true), + "*internal* Generate binary .mli_ast and ml_ast and stop" ); + ( "-bs-syntax-only", + set Js_config.syntax_only, + "*internal* Only check syntax" ); + ( "-bs-g", + unit_call (fun _ -> + Js_config.debug := true; + Pp.replace_directive_bool "DEBUG" true), + "Debug mode" ); + ("-bs-v", string_call ignore, "*internal* version check to force a rebuild"); + ( "-bs-package-name", + string_call Js_packages_state.set_package_name, + "*internal* Set package name, useful when you want to produce npm \ + packages" ); + ( "-bs-ns", + string_call Js_packages_state.set_package_map, + "*internal* Set package map, not only set package name but also use it \ + as a namespace" ); + ("-as-ppx", set Js_config.as_ppx, "*internal*As ppx for editor integration"); + ( "-as-pp", + unit_call (fun _ -> + Js_config.as_pp := true; + Js_config.syntax_only := true), + "*internal*As pp to interact with native tools" ); + ( "-no-alias-deps", + set Clflags.transparent_modules, + "*internal*Do not record dependencies for module aliases" ); + ("-bs-gentype", set Clflags.bs_gentype, "*internal* Pass gentype command"); (******************************************************************************) - - "-unboxed-types", set Clflags.unboxed_types, - "*internal* Unannotated unboxable types will be unboxed"; - - "-bs-D", string_call define_variable, - "Define conditional variable e.g, -D DEBUG=true"; - - "-bs-unsafe-empty-array", set Config.unsafe_empty_array, - "*internal* Allow [||] to be polymorphic"; - - "-nostdlib", set Js_config.no_stdlib, - "*internal* Don't use stdlib"; - - "-color", string_call set_color_option, - "*internal* Enable or disable colors in compiler messages\n\ - The following settings are supported:\n\ - auto use heuristics to enable colors only if supported\n\ - always enable colors\n\ - never disable colors\n\ - The default setting is 'always'\n\ - The current heuristic for 'auto'\n\ - checks that the TERM environment variable exists and is\n\ - not empty or \"dumb\", and that isatty(stderr) holds."; - - "-bs-list-conditionals", unit_call (fun () -> Pp.list_variables Format.err_formatter), - "*internal* List existing conditional variables"; - - "-e", string_call (fun s -> eval s ~suffix:Literals.suffix_res), - "(experimental) set the string to be evaluated in ReScript syntax"; - - "-bs-cmi-only", set Js_config.cmi_only, - "*internal* Stop after generating cmi file"; - - "-bs-cmi", set Js_config.force_cmi, - "*internal* Not using cached cmi, always generate cmi"; - - "-bs-cmj", set Js_config.force_cmj, - "*internal* Not using cached cmj, always generate cmj"; - - "-bs-no-version-header", set Js_config.no_version_header, - "*internal*Don't print version header"; - - "-bs-no-builtin-ppx", set Js_config.no_builtin_ppx, - "*internal* Disable built-in ppx"; - - "-bs-cross-module-opt", set Js_config.cross_module_inline, - "*internal* Enable cross module inlining(experimental), default(false)"; - - "-bs-no-cross-module-opt", clear Js_config.cross_module_inline, - "*internal* Disable cross module inlining(experimental)"; - - "-bs-diagnose", set Js_config.diagnose, - "*internal* More verbose output"; - - "-bs-no-check-div-by-zero", clear Js_config.check_div_by_zero, - "*internal* unsafe mode, don't check div by zero and mod by zero"; - - "-bs-noassertfalse", set Clflags.no_assert_false, - "*internal* no code for assert false"; - - "-noassert", set Clflags.noassert, - "*internal* Do not compile assertion checks"; - - "-bs-loc", set Clflags.dump_location, - "*internal* dont display location with -dtypedtree, -dparsetree"; - - "-dtypedtree", set Clflags.dump_typedtree, - "*internal* debug typedtree"; - - "-dparsetree", set Clflags.dump_parsetree, - "*internal* debug parsetree"; - - "-drawlambda", set Clflags.dump_rawlambda, - "*internal* debug raw lambda"; - - "-dsource", set Clflags.dump_source, - "*internal* print source"; - - "-reprint-source", string_call reprint_source_file, - "*internal* transform the target ReScript file using PPXes provided, and print the transformed ReScript code to stdout"; - - "-format", string_call format_file, - "*internal* Format as Res syntax"; - - "-only-parse", set Clflags.only_parse, - "*internal* stop after parsing"; - - "-ignore-parse-errors", set Clflags.ignore_parse_errors, - "*internal* continue after parse errors"; - - "-where", unit_call print_standard_library, - "*internal* Print location of standard library and exit"; - - "-verbose", set Clflags.verbose, - "*internal* Print calls to external commands"; - - "-keep-locs", set Clflags.keep_locs, - "*internal* Keep locations in .cmi files"; - - "-no-keep-locs", clear Clflags.keep_locs, - "*internal* Do not keep locations in .cmi files"; - - "-nopervasives", set Clflags.nopervasives, - "*internal*"; - "-uncurried", unit_call (fun () -> ()), - "*internal* deprecated"; - "-v", unit_call print_version_string, - "Print compiler version and location of standard library and exit"; - - "-version", unit_call print_version_string, - "Print version and exit"; - - "-pp", string_optional_set Clflags.preprocessor, - "*internal* Pipe sources through preprocessor "; - - "-absname", set Location.absname, - "*internal* Show absolute filenames in error messages"; + ( "-unboxed-types", + set Clflags.unboxed_types, + "*internal* Unannotated unboxable types will be unboxed" ); + ( "-bs-D", + string_call define_variable, + "Define conditional variable e.g, -D DEBUG=true" ); + ( "-bs-unsafe-empty-array", + set Config.unsafe_empty_array, + "*internal* Allow [||] to be polymorphic" ); + ("-nostdlib", set Js_config.no_stdlib, "*internal* Don't use stdlib"); + ( "-color", + string_call set_color_option, + "*internal* Enable or disable colors in compiler messages\n\ + The following settings are supported:\n\ + auto use heuristics to enable colors only if supported\n\ + always enable colors\n\ + never disable colors\n\ + The default setting is 'always'\n\ + The current heuristic for 'auto'\n\ + checks that the TERM environment variable exists and is\n\ + not empty or \"dumb\", and that isatty(stderr) holds." ); + ( "-bs-list-conditionals", + unit_call (fun () -> Pp.list_variables Format.err_formatter), + "*internal* List existing conditional variables" ); + ( "-e", + string_call (fun s -> eval s ~suffix:Literals.suffix_res), + "(experimental) set the string to be evaluated in ReScript syntax" ); + ( "-bs-cmi-only", + set Js_config.cmi_only, + "*internal* Stop after generating cmi file" ); + ( "-bs-cmi", + set Js_config.force_cmi, + "*internal* Not using cached cmi, always generate cmi" ); + ( "-bs-cmj", + set Js_config.force_cmj, + "*internal* Not using cached cmj, always generate cmj" ); + ( "-bs-no-version-header", + set Js_config.no_version_header, + "*internal*Don't print version header" ); + ( "-bs-no-builtin-ppx", + set Js_config.no_builtin_ppx, + "*internal* Disable built-in ppx" ); + ( "-bs-cross-module-opt", + set Js_config.cross_module_inline, + "*internal* Enable cross module inlining(experimental), default(false)" ); + ( "-bs-no-cross-module-opt", + clear Js_config.cross_module_inline, + "*internal* Disable cross module inlining(experimental)" ); + ("-bs-diagnose", set Js_config.diagnose, "*internal* More verbose output"); + ( "-bs-no-check-div-by-zero", + clear Js_config.check_div_by_zero, + "*internal* unsafe mode, don't check div by zero and mod by zero" ); + ( "-bs-noassertfalse", + set Clflags.no_assert_false, + "*internal* no code for assert false" ); + ( "-noassert", + set Clflags.noassert, + "*internal* Do not compile assertion checks" ); + ( "-bs-loc", + set Clflags.dump_location, + "*internal* dont display location with -dtypedtree, -dparsetree" ); + ("-dtypedtree", set Clflags.dump_typedtree, "*internal* debug typedtree"); + ("-dparsetree", set Clflags.dump_parsetree, "*internal* debug parsetree"); + ("-drawlambda", set Clflags.dump_rawlambda, "*internal* debug raw lambda"); + ("-dsource", set Clflags.dump_source, "*internal* print source"); + ( "-reprint-source", + string_call reprint_source_file, + "*internal* transform the target ReScript file using PPXes provided, and \ + print the transformed ReScript code to stdout" ); + ("-format", string_call format_file, "*internal* Format as Res syntax"); + ("-only-parse", set Clflags.only_parse, "*internal* stop after parsing"); + ( "-ignore-parse-errors", + set Clflags.ignore_parse_errors, + "*internal* continue after parse errors" ); + ( "-where", + unit_call print_standard_library, + "*internal* Print location of standard library and exit" ); + ( "-verbose", + set Clflags.verbose, + "*internal* Print calls to external commands" ); + ( "-keep-locs", + set Clflags.keep_locs, + "*internal* Keep locations in .cmi files" ); + ( "-no-keep-locs", + clear Clflags.keep_locs, + "*internal* Do not keep locations in .cmi files" ); + ("-nopervasives", set Clflags.nopervasives, "*internal*"); + ("-uncurried", unit_call (fun () -> ()), "*internal* deprecated"); + ( "-v", + unit_call print_version_string, + "Print compiler version and location of standard library and exit" ); + ("-version", unit_call print_version_string, "Print version and exit"); + ( "-pp", + string_optional_set Clflags.preprocessor, + "*internal* Pipe sources through preprocessor " ); + ( "-absname", + set Location.absname, + "*internal* Show absolute filenames in error messages" ); (* Not used, the build system did the expansion *) - - "-bs-no-bin-annot", clear Clflags.binary_annotations, - "*internal* Disable binary annotations (by default on)"; - - "-modules", set Js_config.modules, - "*internal* serve similar to ocamldep"; - - "-short-paths", clear Clflags.real_paths, - "*internal* Shorten paths in types"; - - "-unsafe", set Clflags.fast, - "*internal* Do not compile bounds checking on array and string access"; - - "-warn-help", unit_call Warnings.help_warnings, - "Show description of warning numbers"; - "-warn-error", string_call (Warnings.parse_options true), - " Enable or disable error status for warnings according\n\ - to . See option -w for the syntax of .\n\ - Default setting is " ^ Bsc_warnings.defaults_warn_error; - "-runtime",string_call setup_runtime_path, - "*internal* Set the runtime directory"; - "-make-runtime", unit_call Js_packages_state.make_runtime, - "*internal* make runtime library"; - + ( "-bs-no-bin-annot", + clear Clflags.binary_annotations, + "*internal* Disable binary annotations (by default on)" ); + ("-modules", set Js_config.modules, "*internal* serve similar to ocamldep"); + ( "-short-paths", + clear Clflags.real_paths, + "*internal* Shorten paths in types" ); + ( "-unsafe", + set Clflags.fast, + "*internal* Do not compile bounds checking on array and string access" ); + ( "-warn-help", + unit_call Warnings.help_warnings, + "Show description of warning numbers" ); + ( "-warn-error", + string_call (Warnings.parse_options true), + " Enable or disable error status for warnings according\n\ + to . See option -w for the syntax of .\n\ + Default setting is " ^ Bsc_warnings.defaults_warn_error ); + ( "-runtime", + string_call setup_runtime_path, + "*internal* Set the runtime directory" ); + ( "-make-runtime", + unit_call Js_packages_state.make_runtime, + "*internal* make runtime library" ); |] - - (** parse flags in config *) -let file_level_flags_handler (e : Parsetree.expression option) = - match e with +let file_level_flags_handler (e : Parsetree.expression option) = + match e with | None -> () - | Some {pexp_desc = Pexp_array args ; pexp_loc} -> - let args = Array.of_list - ( Ext_list.map args (fun e -> - match e.pexp_desc with - | Pexp_constant (Pconst_string(name,_)) -> name - | _ -> Location.raise_errorf ~loc:e.pexp_loc "string literal expected" )) in - (try Bsc_args.parse_exn ~start:0 - ~argv:args buckle_script_flags (fun ~rev_args:_ -> ()) ~usage - with _ -> Location.prerr_warning pexp_loc (Preprocessor "invalid flags for bsc")) - | Some e -> - Location.raise_errorf ~loc:e.pexp_loc "string array expected" - -let _ : unit = + | Some {pexp_desc = Pexp_array args; pexp_loc} -> ( + let args = + Array.of_list + (Ext_list.map args (fun e -> + match e.pexp_desc with + | Pexp_constant (Pconst_string (name, _)) -> name + | _ -> + Location.raise_errorf ~loc:e.pexp_loc "string literal expected")) + in + try + Bsc_args.parse_exn ~start:0 ~argv:args buckle_script_flags + (fun ~rev_args:_ -> ()) + ~usage + with _ -> + Location.prerr_warning pexp_loc (Preprocessor "invalid flags for bsc")) + | Some e -> Location.raise_errorf ~loc:e.pexp_loc "string array expected" + +let _ : unit = Bs_conditional_initial.setup_env (); Clflags.color := Some Always; - - let flags = "flags" in - Ast_config.add_structure - flags file_level_flags_handler; - Ast_config.add_signature - flags file_level_flags_handler; + + let flags = "flags" in + Ast_config.add_structure flags file_level_flags_handler; + Ast_config.add_signature flags file_level_flags_handler; try - Bsc_args.parse_exn - ~argv:Sys.argv - buckle_script_flags anonymous ~usage; - with - | Bsc_args.Bad msg -> - Format.eprintf "%s@." msg ; + Bsc_args.parse_exn ~argv:Sys.argv buckle_script_flags anonymous ~usage + with + | Bsc_args.Bad msg -> + Format.eprintf "%s@." msg; exit 2 - | x -> - begin -(* + | x -> + (* Ext_obj.bt (); *) - Location.report_exception ppf x; - exit 2 - end + Location.report_exception ppf x; + exit 2 diff --git a/compiler/cmij/.ocamlformat b/compiler/cmij/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/cmij/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/cmij/cmjdump_main.ml b/compiler/cmij/cmjdump_main.ml index 49d73164cd..9e7995e760 100644 --- a/compiler/cmij/cmjdump_main.ml +++ b/compiler/cmij/cmjdump_main.ml @@ -27,45 +27,49 @@ let f fmt = Printf.fprintf stdout fmt let pp_cmj_case (case : Ext_js_file_kind.case) : unit = - f "%s\n" ("case : " ^ match case with Little -> "little" | Upper -> "upper") + f "%s\n" + ("case : " + ^ + match case with + | Little -> "little" + | Upper -> "upper") let pp_cmj - ({ values; pure; package_spec = npm_package_path; case } : Js_cmj_format.t) - = + ({values; pure; package_spec = npm_package_path; case} : Js_cmj_format.t) = f "package info: %s\n" (Format.asprintf "%a" Js_packages_info.dump_packages_info npm_package_path); pp_cmj_case case; f "effect: %s\n" (if pure then "pure" else "not pure"); - Ext_array.iter values (fun { name; arity; persistent_closed_lambda } -> + Ext_array.iter values (fun {name; arity; persistent_closed_lambda} -> (match arity with | Single arity -> ( - f "%s: %s\n" name (Format.asprintf "%a" Lam_arity.print arity); - match persistent_closed_lambda with - | None -> f "%s: not saved\n" name - | Some lam -> - f "%s: ======[start]\n" name; - f "%s\n" (Lam_print.lambda_to_string lam); - f "%s: ======[finish]\n" name) + f "%s: %s\n" name (Format.asprintf "%a" Lam_arity.print arity); + match persistent_closed_lambda with + | None -> f "%s: not saved\n" name + | Some lam -> + f "%s: ======[start]\n" name; + f "%s\n" (Lam_print.lambda_to_string lam); + f "%s: ======[finish]\n" name) | Submodule xs -> - (match persistent_closed_lambda with - | None -> f "%s: not saved\n" name - | Some lam -> - f "%s: ======[start]\n" name; - f "%s" (Lam_print.lambda_to_string lam); - f "%s: ======[finish]\n" name); - Array.iteri - (fun i arity -> - f "%s[%i] : %s \n" name i - (Format.asprintf "%a" Lam_arity.print arity)) - xs); + (match persistent_closed_lambda with + | None -> f "%s: not saved\n" name + | Some lam -> + f "%s: ======[start]\n" name; + f "%s" (Lam_print.lambda_to_string lam); + f "%s: ======[finish]\n" name); + Array.iteri + (fun i arity -> + f "%s[%i] : %s \n" name i + (Format.asprintf "%a" Lam_arity.print arity)) + xs); f "\n") let () = match Sys.argv with - | [| _; file |] -> - let cmj, digest = Js_cmj_format.from_file_with_digest file in - Format.fprintf Format.std_formatter "@[Digest: %s@]@." - (Digest.to_hex digest); - pp_cmj cmj + | [|_; file|] -> + let cmj, digest = Js_cmj_format.from_file_with_digest file in + Format.fprintf Format.std_formatter "@[Digest: %s@]@." + (Digest.to_hex digest); + pp_cmj cmj | _ -> failwith "expect one argument" diff --git a/compiler/core/.ocamlformat b/compiler/core/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/core/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/core/bs_cmi_load.ml b/compiler/core/bs_cmi_load.ml index 72a5f28558..0af28ea667 100644 --- a/compiler/core/bs_cmi_load.ml +++ b/compiler/core/bs_cmi_load.ml @@ -23,6 +23,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let load_cmi ~unit_name : Env.Persistent_signature.t option = - match Config_util.find_opt (unit_name ^".cmi") with + match Config_util.find_opt (unit_name ^ ".cmi") with | Some filename -> Some {filename; cmi = Cmi_format.read_cmi filename} - | None -> None \ No newline at end of file + | None -> None diff --git a/compiler/core/bs_conditional_initial.ml b/compiler/core/bs_conditional_initial.ml index 3e99275919..56c981532d 100644 --- a/compiler/core/bs_conditional_initial.ml +++ b/compiler/core/bs_conditional_initial.ml @@ -23,12 +23,15 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let setup_env () = - Env.Persistent_signature.load := Bs_cmi_load.load_cmi; - Matching.make_test_sequence_variant_constant := Polyvar_pattern_match.make_test_sequence_variant_constant; - Matching.call_switcher_variant_constant := Polyvar_pattern_match.call_switcher_variant_constant; - Matching.call_switcher_variant_constr := Polyvar_pattern_match.call_switcher_variant_constr; + Env.Persistent_signature.load := Bs_cmi_load.load_cmi; + Matching.make_test_sequence_variant_constant := + Polyvar_pattern_match.make_test_sequence_variant_constant; + Matching.call_switcher_variant_constant := + Polyvar_pattern_match.call_switcher_variant_constant; + Matching.call_switcher_variant_constr := + Polyvar_pattern_match.call_switcher_variant_constr; Ctype.variant_is_subtype := Matching_polyfill.variant_is_subtype; - Clflags.dump_location := false; + Clflags.dump_location := false; Parmatch.print_res_pat := Pattern_printer.print_pattern; (* default true otherwise [bsc -I sc src/hello.ml ] will include current directory to search path @@ -37,18 +40,18 @@ let setup_env () = Clflags.binary_annotations := true; (* Turn on [-no-alias-deps] by default -- double check *) Oprint.out_ident := Outcome_printer_ns.out_ident; - Builtin_attributes.check_bs_attributes_inclusion := Record_attributes_check.check_bs_attributes_inclusion; + Builtin_attributes.check_bs_attributes_inclusion := + Record_attributes_check.check_bs_attributes_inclusion; Builtin_attributes.check_duplicated_labels := Record_attributes_check.check_duplicated_labels; - Matching.names_from_construct_pattern := + Matching.names_from_construct_pattern := Matching_polyfill.names_from_construct_pattern; - - Rescript_cpp.replace_directive_bool "BS" true; + + Rescript_cpp.replace_directive_bool "BS" true; Rescript_cpp.replace_directive_bool "JS" true; Printtyp.print_res_poly_identifier := Res_printer.polyvar_ident_to_string; - Rescript_cpp.replace_directive_string "BS_VERSION" Bs_version.version - (*; Switch.cut := 100*) (* tweakable but not very useful *) - + Rescript_cpp.replace_directive_string "BS_VERSION" Bs_version.version +(*; Switch.cut := 100*) +(* tweakable but not very useful *) -let () = - at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ()) +let () = at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ()) diff --git a/compiler/core/bs_conditional_initial.mli b/compiler/core/bs_conditional_initial.mli index c0f84004fb..9e8358be51 100644 --- a/compiler/core/bs_conditional_initial.mli +++ b/compiler/core/bs_conditional_initial.mli @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +val setup_env : unit -> unit (** This function set up built in compile time variables used in conditional compilation so that {[ @@ -31,5 +32,3 @@ ]} Is understood, also make sure the playground do the same initialization. *) -val setup_env : unit -> unit - diff --git a/compiler/core/cmd_ast_exception.ml b/compiler/core/cmd_ast_exception.ml index 28b63d0e6a..a65aad18af 100644 --- a/compiler/core/cmd_ast_exception.ml +++ b/compiler/core/cmd_ast_exception.ml @@ -27,13 +27,12 @@ exception Error of error let report_error ppf = function | CannotRun cmd -> - Format.fprintf ppf - "Error while running external preprocessor@.Command line: %s@." cmd + Format.fprintf ppf + "Error while running external preprocessor@.Command line: %s@." cmd | WrongMagic cmd -> - Format.fprintf ppf - "External preprocessor does not produce a valid file@.Command line: \ - %s@." - cmd + Format.fprintf ppf + "External preprocessor does not produce a valid file@.Command line: %s@." + cmd let () = Location.register_error_of_exn (function diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index 3729a4dabf..3f1a64feaa 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -78,32 +78,32 @@ let rewrite kind ppxs ast = match fns with | [] -> assert false | fn_in :: _ -> apply_rewriter kind fn_in ppx :: fns) - ppxs [ fn_in ] + ppxs [fn_in] in match temp_files with | last_fn :: _ -> - let out = read_ast kind last_fn in - Ext_list.iter temp_files Misc.remove_file; - out + let out = read_ast kind last_fn in + Ext_list.iter temp_files Misc.remove_file; + out | _ -> assert false let apply_rewriters_str ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - ast - |> Ast_mapper.add_ppx_context_str ~tool_name - |> rewrite Ml ppxs - |> Ast_mapper.drop_ppx_context_str ~restore + ast + |> Ast_mapper.add_ppx_context_str ~tool_name + |> rewrite Ml ppxs + |> Ast_mapper.drop_ppx_context_str ~restore let apply_rewriters_sig ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - ast - |> Ast_mapper.add_ppx_context_sig ~tool_name - |> rewrite Mli ppxs - |> Ast_mapper.drop_ppx_context_sig ~restore + ast + |> Ast_mapper.add_ppx_context_sig ~tool_name + |> rewrite Mli ppxs + |> Ast_mapper.drop_ppx_context_sig ~restore let apply_rewriters ?restore ~tool_name (type a) (kind : a Ml_binary.kind) (ast : a) : a = diff --git a/compiler/core/config_util.ml b/compiler/core/config_util.ml index f65dee5363..e957cf9d18 100644 --- a/compiler/core/config_util.ml +++ b/compiler/core/config_util.ml @@ -27,11 +27,11 @@ let find_in_path_uncap path name = let rec try_dir = function | [] -> None | dir :: rem -> - let ufullname = Filename.concat dir uname in - if Sys.file_exists ufullname then Some ufullname - else - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then Some fullname else try_dir rem + let ufullname = Filename.concat dir uname in + if Sys.file_exists ufullname then Some ufullname + else + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then Some fullname else try_dir rem in try_dir path @@ -41,7 +41,7 @@ let find_opt file = find_in_path_uncap !Config.load_path file let output_prefix name = match !Clflags.output_name with | None -> - Ext_namespace_encode.make - (Filename.remove_extension name) - ?ns:!Clflags.dont_record_crc_unit + Ext_namespace_encode.make + (Filename.remove_extension name) + ?ns:!Clflags.dont_record_crc_unit | Some oname -> Filename.remove_extension oname diff --git a/compiler/core/j.ml b/compiler/core/j.ml index c9b4961c37..c578f54703 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -50,7 +50,7 @@ and ident = Ident.t currently we always use quote *) -and module_id = { id : ident; kind : Js_op.kind ; dynamic_import : bool } +and module_id = {id: ident; kind: Js_op.kind; dynamic_import: bool} and required_modules = module_id list and vident = Id of ident | Qualified of module_id * string option @@ -75,7 +75,7 @@ and for_ident = ident and for_direction = Js_op.direction_flag and property_map = (property_name * expression) list and length_object = Js_op.length_object -and delim = External_arg_spec.delim = | DNone | DStarJ | DNoQuotes +and delim = External_arg_spec.delim = DNone | DStarJ | DNoQuotes and expression_desc = | Length of expression * length_object @@ -129,15 +129,15 @@ and expression_desc = | New of expression * expression list option (* TODO: option remove *) | Var of vident | Fun of { - is_method : bool; - params : ident list; - body : block; - env : Js_fun_env.t; - return_unit : bool; - async : bool; - directive : string option; + is_method: bool; + params: ident list; + body: block; + env: Js_fun_env.t; + return_unit: bool; + async: bool; + directive: string option; } - | Str of { delim : delim; txt : string } + | Str of {delim: delim; txt: string} (* A string is UTF-8 encoded, and may contain escape sequences. *) @@ -151,7 +151,6 @@ and expression_desc = (* The third argument is [tag] , forth is [tag_info] *) (* | Caml_uninitialized_obj of expression * expression *) (* [tag] and [size] tailed for [Obj.new_block] *) - | Caml_block_tag of expression * string (* e.tag *) (* | Caml_block_set_length of expression * expression *) (* It will just fetch tag, to make it safe, when creating it, @@ -240,10 +239,10 @@ and finish_ident_expression = expression ]} *) and case_clause = { - switch_body : block; - should_break : bool; + switch_body: block; + should_break: bool; (* true means break *) - comment : string option; + comment: string option; } and string_clause = Ast_untagged_variants.tag_type * case_clause @@ -284,26 +283,26 @@ and statement_desc = | Try of block * (exception_ident * block) option * block option | Debugger -and expression = { expression_desc : expression_desc; comment : string option } -and statement = { statement_desc : statement_desc; comment : string option } +and expression = {expression_desc: expression_desc; comment: string option} +and statement = {statement_desc: statement_desc; comment: string option} and variable_declaration = { - ident : ident; - value : expression option; - property : property; - ident_info : ident_info; + ident: ident; + value: expression option; + property: property; + ident_info: ident_info; } (* TODO: For efficency: block should not be a list, it should be able to be concatenated in both ways *) and block = statement list -and program = { block : block; exports : exports; export_set : Set_ident.t } +and program = {block: block; exports: exports; export_set: Set_ident.t} and deps_program = { - program : program; - modules : required_modules; - side_effect : string option; (* None: no, Some reason *) + program: program; + modules: required_modules; + side_effect: string option; (* None: no, Some reason *) } [@@deriving { diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index b88c77e6ca..2b660a025a 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -23,8 +23,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type idents_stats = { - mutable used_idents : Set_ident.t; - mutable defined_idents : Set_ident.t; + mutable used_idents: Set_ident.t; + mutable defined_idents: Set_ident.t; } let add_defined_idents (x : idents_stats) ident = @@ -45,7 +45,9 @@ let free_variables (stats : idents_stats) = variable_declaration = (fun self st -> add_defined_idents stats st.ident; - match st.value with None -> () | Some v -> self.expression self v); + match st.value with + | None -> () + | Some v -> self.expression self v); ident = (fun _ id -> if not (Set_ident.mem stats.defined_idents id) then @@ -57,12 +59,12 @@ let free_variables (stats : idents_stats) = (* a optimization to avoid walking into function again if it's already comuted *) -> - stats.used_idents <- - Set_ident.union (Js_fun_env.get_unbounded env) stats.used_idents + stats.used_idents <- + Set_ident.union (Js_fun_env.get_unbounded env) stats.used_idents | _ -> super.expression self exp); } -let init = { used_idents = Set_ident.empty; defined_idents = Set_ident.empty } +let init = {used_idents = Set_ident.empty; defined_idents = Set_ident.empty} let obj = free_variables init @@ -86,28 +88,30 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = | Fun _ -> true | Number _ -> true (* Can be refined later *) | Static_index (obj, (_name : string), (_pos : int32 option)) -> - no_side_effect obj + no_side_effect obj | String_index (a, b) | Array_index (a, b) -> - no_side_effect a && no_side_effect b + no_side_effect a && no_side_effect b | Is_null_or_undefined b -> no_side_effect b | Str _ -> true | Array (xs, _mutable_flag) | Caml_block (xs, _mutable_flag, _, _) -> - (* create [immutable] block, - does not really mean that this opreation itself is [pure]. + (* create [immutable] block, + does not really mean that this opreation itself is [pure]. - the block is mutable does not mean this operation is non-pure - *) - Ext_list.for_all xs no_side_effect + the block is mutable does not mean this operation is non-pure + *) + Ext_list.for_all xs no_side_effect | Optional_block (x, _) -> no_side_effect x | Object (_, kvs) -> Ext_list.for_all_snd kvs no_side_effect | String_append (a, b) | Seq (a, b) -> no_side_effect a && no_side_effect b | Length (e, _) | Caml_block_tag (e, _) | Typeof e -> no_side_effect e | Bin (op, a, b) -> op <> Eq && no_side_effect a && no_side_effect b - | Tagged_template (call_expr, strings, values) -> no_side_effect call_expr && - Ext_list.for_all strings no_side_effect && Ext_list.for_all values no_side_effect + | Tagged_template (call_expr, strings, values) -> + no_side_effect call_expr + && Ext_list.for_all strings no_side_effect + && Ext_list.for_all values no_side_effect | Js_not _ | Cond _ | FlatCall _ | Call _ | New _ | Raw_js_code _ (* actually true? *) -> - false + false | Await _ -> false | Spread _ -> false @@ -125,11 +129,11 @@ let no_side_effect_obj = (fun self s -> match s.statement_desc with | Throw _ | Debugger | Break | Variable _ | Continue -> - raise_notrace Not_found + raise_notrace Not_found | Exp e -> self.expression self e | Int_switch _ | String_switch _ | ForRange _ | If _ | While _ | Block _ | Return _ | Try _ -> - super.statement self s); + super.statement self s); expression = (fun _ s -> if not (no_side_effect_expression s) then raise_notrace Not_found); @@ -152,15 +156,19 @@ let no_side_effect_statement st = ]} *) -let rec eq_expression ({ expression_desc = x0 } : J.expression) - ({ expression_desc = y0 } : J.expression) = +let rec eq_expression ({expression_desc = x0} : J.expression) + ({expression_desc = y0} : J.expression) = match x0 with | Null -> y0 = Null | Undefined x -> y0 = Undefined x - | Number (Int { i }) -> ( - match y0 with Number (Int { i = j }) -> i = j | _ -> false) + | Number (Int {i}) -> ( + match y0 with + | Number (Int {i = j}) -> i = j + | _ -> false) | Number (BigInt {positive = p0; value = v0}) -> ( - match y0 with Number (BigInt {positive = p1; value = v1}) -> p0 = p1 && v0 = v1 | _ -> false) + match y0 with + | Number (BigInt {positive = p1; value = v1}) -> p0 = p1 && v0 = v1 + | _ -> false) | Number (Float _) -> false (* begin match y0 with | Number (Float j) -> @@ -168,49 +176,57 @@ let rec eq_expression ({ expression_desc = x0 } : J.expression) | _ -> false end *) | String_index (a0, a1) -> ( - match y0 with - | String_index (b0, b1) -> eq_expression a0 b0 && eq_expression a1 b1 - | _ -> false) + match y0 with + | String_index (b0, b1) -> eq_expression a0 b0 && eq_expression a1 b1 + | _ -> false) | Array_index (a0, a1) -> ( - match y0 with - | Array_index (b0, b1) -> eq_expression a0 b0 && eq_expression a1 b1 - | _ -> false) + match y0 with + | Array_index (b0, b1) -> eq_expression a0 b0 && eq_expression a1 b1 + | _ -> false) | Call (a0, args00, _) -> ( - match y0 with - | Call (b0, args10, _) -> - eq_expression a0 b0 && eq_expression_list args00 args10 - | _ -> false) - | Var x -> ( match y0 with Var y -> Js_op_util.same_vident x y | _ -> false) + match y0 with + | Call (b0, args10, _) -> + eq_expression a0 b0 && eq_expression_list args00 args10 + | _ -> false) + | Var x -> ( + match y0 with + | Var y -> Js_op_util.same_vident x y + | _ -> false) | Bin (op0, a0, b0) -> ( - match y0 with - | Bin (op1, a1, b1) -> - op0 = op1 && eq_expression a0 a1 && eq_expression b0 b1 - | _ -> false) - | Str {delim=a0; txt=b0} -> ( - match y0 with Str {delim=a1; txt=b1} -> a0 = a1 && b0 = b1 | _ -> false) + match y0 with + | Bin (op1, a1, b1) -> + op0 = op1 && eq_expression a0 a1 && eq_expression b0 b1 + | _ -> false) + | Str {delim = a0; txt = b0} -> ( + match y0 with + | Str {delim = a1; txt = b1} -> a0 = a1 && b0 = b1 + | _ -> false) | Static_index (e0, p0, off0) -> ( - match y0 with - | Static_index (e1, p1, off1) -> - p0 = p1 && eq_expression e0 e1 && off0 = off1 (* could be relaxed *) - | _ -> false) + match y0 with + | Static_index (e1, p1, off1) -> + p0 = p1 && eq_expression e0 e1 && off0 = off1 (* could be relaxed *) + | _ -> false) | Seq (a0, b0) -> ( - match y0 with - | Seq (a1, b1) -> eq_expression a0 a1 && eq_expression b0 b1 - | _ -> false) - | Bool a0 -> ( match y0 with Bool b0 -> a0 = b0 | _ -> false) + match y0 with + | Seq (a1, b1) -> eq_expression a0 a1 && eq_expression b0 b1 + | _ -> false) + | Bool a0 -> ( + match y0 with + | Bool b0 -> a0 = b0 + | _ -> false) | Optional_block (a0, b0) -> ( - match y0 with - | Optional_block (a1, b1) -> b0 = b1 && eq_expression a0 a1 - | _ -> false) + match y0 with + | Optional_block (a1, b1) -> b0 = b1 && eq_expression a0 a1 + | _ -> false) | Caml_block (ls0, flag0, tag0, _) -> ( - match y0 with - | Caml_block (ls1, flag1, tag1, _) -> - eq_expression_list ls0 ls1 && flag0 = flag1 && eq_expression tag0 tag1 - | _ -> false) + match y0 with + | Caml_block (ls1, flag1, tag1, _) -> + eq_expression_list ls0 ls1 && flag0 = flag1 && eq_expression tag0 tag1 + | _ -> false) | Length _ | Is_null_or_undefined _ | String_append _ | Typeof _ | Js_not _ | Cond _ | FlatCall _ | New _ | Fun _ | Raw_js_code _ | Array _ - | Caml_block_tag _ | Object _ | Tagged_template _ - | Await _ -> false + | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ -> + false | Spread _ -> false and eq_expression_list xs ys = Ext_list.for_all2_no_exn xs ys eq_expression @@ -218,23 +234,32 @@ and eq_expression_list xs ys = Ext_list.for_all2_no_exn xs ys eq_expression and eq_block (xs : J.block) (ys : J.block) = Ext_list.for_all2_no_exn xs ys eq_statement -and eq_statement ({ statement_desc = x0 } : J.statement) - ({ statement_desc = y0 } : J.statement) = +and eq_statement ({statement_desc = x0} : J.statement) + ({statement_desc = y0} : J.statement) = match x0 with - | Exp a -> ( match y0 with Exp b -> eq_expression a b | _ -> false) - | Return a -> ( match y0 with Return b -> eq_expression a b | _ -> false) + | Exp a -> ( + match y0 with + | Exp b -> eq_expression a b + | _ -> false) + | Return a -> ( + match y0 with + | Return b -> eq_expression a b + | _ -> false) | Debugger -> y0 = Debugger | Break -> y0 = Break - | Block xs0 -> ( match y0 with Block ys0 -> eq_block xs0 ys0 | _ -> false) + | Block xs0 -> ( + match y0 with + | Block ys0 -> eq_block xs0 ys0 + | _ -> false) | Variable _ | If _ | While _ | ForRange _ | Continue | Int_switch _ | String_switch _ | Throw _ | Try _ -> - false + false let rev_flatten_seq (x : J.expression) = let rec aux acc (x : J.expression) : J.block = match x.expression_desc with | Seq (a, b) -> aux (aux acc a) b - | _ -> { statement_desc = Exp x; comment = None } :: acc + | _ -> {statement_desc = Exp x; comment = None} :: acc in aux [] x @@ -249,12 +274,12 @@ let rev_toplevel_flatten block = | { statement_desc = Variable - ( { ident_info = { used_stats = Dead_pure }; _ } - | { ident_info = { used_stats = Dead_non_pure }; value = None } ); + ( {ident_info = {used_stats = Dead_pure}; _} + | {ident_info = {used_stats = Dead_non_pure}; value = None} ); } :: xs -> - aux acc xs - | { statement_desc = Block b; _ } :: xs -> aux (aux acc b) xs + aux acc xs + | {statement_desc = Block b; _} :: xs -> aux (aux acc b) xs | x :: xs -> aux (x :: acc) xs in aux [] block diff --git a/compiler/core/js_block_runtime.ml b/compiler/core/js_block_runtime.ml index 3f529b5476..b328237ec9 100644 --- a/compiler/core/js_block_runtime.ml +++ b/compiler/core/js_block_runtime.ml @@ -29,5 +29,5 @@ let curry_id = Ident.create_persistent Primitive_modules.curry let check_additional_id (x : J.expression) : Ident.t option = match x.expression_desc with | Optional_block (_, false) -> Some option_id - | Call (_, _, { arity = NA }) -> Some curry_id + | Call (_, _, {arity = NA}) -> Some curry_id | _ -> None diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index e3f8cfa763..547f03c7f8 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -33,10 +33,10 @@ type call_info = {[ fun x y -> (f x y) === f ]} when [f] is an atom *) -type t = { call_info : call_info; arity : arity } +type t = {call_info: call_info; arity: arity} -let dummy = { arity = NA; call_info = Call_na } +let dummy = {arity = NA; call_info = Call_na} -let builtin_runtime_call = { arity = Full; call_info = Call_builtin_runtime } +let builtin_runtime_call = {arity = Full; call_info = Call_builtin_runtime} -let ml_full_call = { arity = Full; call_info = Call_ml } +let ml_full_call = {arity = Full; call_info = Call_ml} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index 9e8a5f3b20..0381c0cd2b 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -35,7 +35,7 @@ type call_info = {[ fun x y -> f x y === f ]} when [f] is an atom *) -type t = { call_info : call_info; arity : arity } +type t = {call_info: call_info; arity: arity} val dummy : t diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 20d3a52262..7c1fac4498 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -28,8 +28,8 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array (* TODO: add a magic number *) type cmj_value = { - arity : arity; - persistent_closed_lambda : Lam.t option; + arity: arity; + persistent_closed_lambda: Lam.t option; (** Either constant or closed functor *) } @@ -38,18 +38,18 @@ type effect = string option let single_na = Single Lam_arity.na type keyed_cmj_value = { - name : string; - arity : arity; - persistent_closed_lambda : Lam.t option; + name: string; + arity: arity; + persistent_closed_lambda: Lam.t option; } type keyed_cmj_values = keyed_cmj_value array type t = { - values : keyed_cmj_values; - pure : bool; - package_spec : Js_packages_info.t; - case : Ext_js_file_kind.case; + values: keyed_cmj_values; + pure: bool; + package_spec: Js_packages_info.t; + case: Ext_js_file_kind.case; } let make ~(values : cmj_value Map_string.t) ~effect ~package_spec ~case : t = @@ -107,7 +107,7 @@ let to_file name ~check_exists (v : t) = let key_comp (a : string) b = Map_string.compare_key a b.name let not_found key = - { name = key; arity = single_na; persistent_closed_lambda = None } + {name = key; arity = single_na; persistent_closed_lambda = None} let get_result mid_val = match mid_val.persistent_closed_lambda with @@ -115,10 +115,10 @@ let get_result mid_val = (Lconst (Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false)) | None -> - mid_val + mid_val | Some _ -> - if !Js_config.cross_module_inline then mid_val - else { mid_val with persistent_closed_lambda = None } + if !Js_config.cross_module_inline then mid_val + else {mid_val with persistent_closed_lambda = None} let rec binary_search_aux arr lo hi (key : string) = let mid = (lo + hi) / 2 in @@ -159,8 +159,8 @@ let query_by_name (cmj_table : t) name : keyed_cmj_value = type path = string type cmj_load_info = { - cmj_table : t; - package_path : path; + cmj_table: t; + package_path: path; (* Note it is the package path we want for ES6_global module spec diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index 902ca04b81..1792e9d573 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -48,24 +48,23 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array type cmj_value = { - arity : arity; - persistent_closed_lambda : Lam.t option; - (* Either constant or closed functor *) + arity: arity; + persistent_closed_lambda: Lam.t option; (* Either constant or closed functor *) } type effect = string option type keyed_cmj_value = { - name : string; - arity : arity; - persistent_closed_lambda : Lam.t option; + name: string; + arity: arity; + persistent_closed_lambda: Lam.t option; } type t = { - values : keyed_cmj_value array; - pure : bool; - package_spec : Js_packages_info.t; - case : Ext_js_file_kind.case; + values: keyed_cmj_value array; + pure: bool; + package_spec: Js_packages_info.t; + case: Ext_js_file_kind.case; } val make : @@ -92,4 +91,4 @@ val to_file : string -> check_exists:bool -> t -> unit type path = string -type cmj_load_info = { cmj_table : t; package_path : path } +type cmj_load_info = {cmj_table: t; package_path: path} diff --git a/compiler/core/js_cmj_load.ml b/compiler/core/js_cmj_load.ml index ac94a1aff7..e00f9cfe02 100644 --- a/compiler/core/js_cmj_load.ml +++ b/compiler/core/js_cmj_load.ml @@ -23,39 +23,37 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (* strategy: - If not installed, use the distributed [cmj] files, + If not installed, use the distributed [cmj] files, make sure that the distributed files are platform independent *) +(* + let load_unit_no_file unit_name : Js_cmj_format.cmj_load_info = + let file = unit_name ^ Literals.suffix_cmj in + match Config_util.find_opt file with + | Some f + -> + {package_path = + (** hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) + Filename.dirname (Filename.dirname (Filename.dirname f)); + cmj_table = Js_cmj_format.from_file f} + | None -> + Bs_exception.error (Cmj_not_found unit_name) *) - - -(* -let load_unit_no_file unit_name : Js_cmj_format.cmj_load_info = - let file = unit_name ^ Literals.suffix_cmj in - match Config_util.find_opt file with - | Some f - -> - {package_path = - (** hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) - Filename.dirname (Filename.dirname (Filename.dirname f)); - cmj_table = Js_cmj_format.from_file f} - | None -> - Bs_exception.error (Cmj_not_found unit_name) *) - -let load_unit_with_file unit_name : Js_cmj_format.cmj_load_info = - let file = unit_name ^ Literals.suffix_cmj in +let load_unit_with_file unit_name : Js_cmj_format.cmj_load_info = + let file = unit_name ^ Literals.suffix_cmj in match Config_util.find_opt file with - | Some f - -> - {package_path = - (* hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) - Filename.dirname (Filename.dirname (Filename.dirname f)); - cmj_table = Js_cmj_format.from_file f} + | Some f -> + { + package_path = + (* hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) + Filename.dirname (Filename.dirname (Filename.dirname f)); + cmj_table = Js_cmj_format.from_file f; + } | None -> Bs_exception.error (Cmj_not_found unit_name) (* we can disable loading from file for troubleshooting - Note in dev mode we still allow loading from file is to - make the dev build still function correct + Note in dev mode we still allow loading from file is to + make the dev build still function correct *) -let load_unit = ref load_unit_with_file \ No newline at end of file +let load_unit = ref load_unit_with_file diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 6d83b5243a..5bad4c9602 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -102,31 +102,39 @@ let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info) let field_name = match ext with | Blk_extension -> ( - fun i -> - match i with 0 -> Literals.exception_id | i -> "_" ^ string_of_int i) - | Blk_record_ext { fields = ss } -> ( - fun i -> match i with 0 -> Literals.exception_id | i -> ss.(i - 1)) + fun i -> + match i with + | 0 -> Literals.exception_id + | i -> "_" ^ string_of_int i) + | Blk_record_ext {fields = ss} -> ( + fun i -> + match i with + | 0 -> Literals.exception_id + | i -> ss.(i - 1)) | _ -> assert false in Object - (None, if stack then - Ext_list.mapi_append el - (fun i e -> (Js_op.Lit (field_name i), e)) - [ (Js_op.Lit "Error", E.new_ (E.js_global "Error") []) ] - else Ext_list.mapi el (fun i e -> (Js_op.Lit (field_name i), e))) + ( None, + if stack then + Ext_list.mapi_append el + (fun i e -> (Js_op.Lit (field_name i), e)) + [(Js_op.Lit "Error", E.new_ (E.js_global "Error") [])] + else Ext_list.mapi el (fun i e -> (Js_op.Lit (field_name i), e)) ) let rec iter_lst cxt (f : P.t) ls element inter = match ls with | [] -> cxt - | [ e ] -> element cxt f e + | [e] -> element cxt f e | e :: r -> - let acxt = element cxt f e in - inter f; - iter_lst acxt f r element inter + let acxt = element cxt f e in + inter f; + iter_lst acxt f r element inter let raw_snippet_exp_simple_enough (s : string) = Ext_string.for_all s (fun c -> - match c with 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> true | _ -> false) + match c with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> true + | _ -> false) (* Parentheses are required when the expression starts syntactically with "{" or "function" TODO: be more conservative, since Google Closure will handle @@ -140,11 +148,11 @@ let raw_snippet_exp_simple_enough (s : string) = (* e = function(x){...}(x); is good *) -let rec exp_need_paren ?(arrow=false) (e : J.expression) = +let rec exp_need_paren ?(arrow = false) (e : J.expression) = match e.expression_desc with (* | Caml_uninitialized_obj _ *) - | Call ({ expression_desc = Raw_js_code _ }, _, _) -> true - | Raw_js_code { code_info = Exp _ } + | Call ({expression_desc = Raw_js_code _}, _, _) -> true + | Raw_js_code {code_info = Exp _} | Fun _ | Caml_block ( _, @@ -153,14 +161,14 @@ let rec exp_need_paren ?(arrow=false) (e : J.expression) = ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ) ) | Object _ -> - true - | Raw_js_code { code_info = Stmt _ } + true + | Raw_js_code {code_info = Stmt _} | Length _ | Call _ | Caml_block_tag _ | Seq _ | Static_index _ | Cond _ | Bin _ | Is_null_or_undefined _ | String_index _ | Array_index _ | String_append _ | Var _ | Undefined _ | Null | Str _ | Array _ - | Caml_block _ | FlatCall _ | Typeof _ | Number _ - | Js_not _ | Bool _ | New _ -> - false + | Caml_block _ | FlatCall _ | Typeof _ | Number _ | Js_not _ | Bool _ | New _ + -> + false | Await _ -> false | Spread _ -> false | Tagged_template _ -> false @@ -266,16 +274,18 @@ f/122 --> *) let is_var (b : J.expression) a = - match b.expression_desc with Var (Id i) -> Ident.same i a | _ -> false + match b.expression_desc with + | Var (Id i) -> Ident.same i a + | _ -> false type fn_exp_state = | Is_return (* for sure no name *) | Name_top of Ident.t | Name_non_top of Ident.t - | No_name of { single_arg : bool } + | No_name of {single_arg: bool} (* true means for sure, false -- not sure *) -let default_fn_exp_state = No_name { single_arg = false } +let default_fn_exp_state = No_name {single_arg = false} (* TODO: refactoring Note that {!pp_function} could print both statement and expression when [No_name] is given @@ -284,8 +294,8 @@ let rec try_optimize_curry cxt f len function_id = Curry_gen.pp_optimize_curry f len; P.paren_group f 1 (fun _ -> expression ~level:1 cxt f function_id) -and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) ~fn_state - (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = +and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) + ~fn_state (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = match b with | [ { @@ -294,7 +304,7 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) ~fn_stat { expression_desc = Call - ( ({ expression_desc = Var v; _ } as function_id), + ( ({expression_desc = Var v; _} as function_id), ls, { arity = (Full | NA) as arity (* see #234*); @@ -318,113 +328,109 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) ~fn_stat *) | Id id -> not (Ext_list.exists l (fun x -> Ident.same x id)) | Qualified _ -> true -> ( - let optimize len ~p cxt f v = - if p then try_optimize_curry cxt f len function_id else vident cxt f v - in - let len = List.length l in - (* length *) - match fn_state with - | Name_top i | Name_non_top i -> - let cxt = pp_var_assign cxt f i in - let cxt = optimize len ~p:(arity = NA && len <= 8) cxt f v in - semi f; - cxt - | Is_return | No_name _ -> - if fn_state = Is_return then return_sp f; - optimize len ~p:(arity = NA && len <= 8) cxt f v) + let optimize len ~p cxt f v = + if p then try_optimize_curry cxt f len function_id else vident cxt f v + in + let len = List.length l in + (* length *) + match fn_state with + | Name_top i | Name_non_top i -> + let cxt = pp_var_assign cxt f i in + let cxt = optimize len ~p:(arity = NA && len <= 8) cxt f v in + semi f; + cxt + | Is_return | No_name _ -> + if fn_state = Is_return then return_sp f; + optimize len ~p:(arity = NA && len <= 8) cxt f v) | _ -> - let set_env : Set_ident.t = - (* identifiers will be printed following*) - match fn_state with - | Is_return | No_name _ -> Js_fun_env.get_unbounded env - | Name_top id | Name_non_top id -> - Set_ident.add (Js_fun_env.get_unbounded env) id - in - (* the context will be continued after this function *) - let outer_cxt = Ext_pp_scope.merge cxt set_env in + let set_env : Set_ident.t = + (* identifiers will be printed following*) + match fn_state with + | Is_return | No_name _ -> Js_fun_env.get_unbounded env + | Name_top id | Name_non_top id -> + Set_ident.add (Js_fun_env.get_unbounded env) id + in + (* the context will be continued after this function *) + let outer_cxt = Ext_pp_scope.merge cxt set_env in - (* whether the function output can use arrow syntax *) - let arrow = match fn_state with - | Name_top _ -> false - | _ -> not is_method - in + (* whether the function output can use arrow syntax *) + let arrow = + match fn_state with + | Name_top _ -> false + | _ -> not is_method + in - (* the context used to be printed inside this function + (* the context used to be printed inside this function - when printing a function, - only the enclosed variables and function name matters, - if the function does not capture any variable, then the context is empty - *) - let inner_cxt = Ext_pp_scope.sub_scope outer_cxt set_env in - let param_body () : unit = - if is_method then ( - match l with - | [] -> assert false - | this :: arguments -> - let cxt = - P.paren_group f 1 (fun _ -> - formal_parameter_list inner_cxt f arguments) - in - P.space f; - P.brace_vgroup f 1 (fun _ -> - let cxt = - if Js_fun_env.get_unused env 0 then cxt - else pp_var_assign_this cxt f this - in - function_body ?directive ~return_unit cxt f b)) - else + when printing a function, + only the enclosed variables and function name matters, + if the function does not capture any variable, then the context is empty + *) + let inner_cxt = Ext_pp_scope.sub_scope outer_cxt set_env in + let param_body () : unit = + if is_method then ( + match l with + | [] -> assert false + | this :: arguments -> let cxt = - match l with - | [ single ] when arrow -> - Ext_pp_scope.ident inner_cxt f single - | l -> - P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f l) + P.paren_group f 1 (fun _ -> + formal_parameter_list inner_cxt f arguments) in P.space f; - if arrow then ( - P.string f (L.arrow); - P.space f; - ); - match b with - | [ { statement_desc = Return { expression_desc = Undefined _ } } ] - when arrow - -> - P.string f "{"; - P.string f "}"; - - | [ { statement_desc = Return e } ] | [ { statement_desc = Exp e } ] - when arrow && directive == None - -> (if exp_need_paren ~arrow e then P.paren_group f 0 else P.group f 0) - (fun _ -> ignore (expression ~level:0 cxt f e)) - - | _ -> - P.brace_vgroup f 1 (fun _ -> function_body ?directive ~return_unit cxt f b) - in - let enclose () = - let handle () = - ( - match fn_state with - | Is_return -> - return_sp f; - P.string f (L.function_ ~async ~arrow); - param_body () - | No_name _ -> - P.string f (L.function_ ~async ~arrow); - param_body () - | Name_non_top x -> - ignore (pp_var_assign inner_cxt f x : cxt); - P.string f (L.function_ ~async ~arrow); - param_body (); - semi f - | Name_top x -> - P.string f (L.function_ ~async ~arrow); - ignore (Ext_pp_scope.ident inner_cxt f x : cxt); - param_body ()) + P.brace_vgroup f 1 (fun _ -> + let cxt = + if Js_fun_env.get_unused env 0 then cxt + else pp_var_assign_this cxt f this + in + function_body ?directive ~return_unit cxt f b)) + else + let cxt = + match l with + | [single] when arrow -> Ext_pp_scope.ident inner_cxt f single + | l -> + P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f l) in - handle () + P.space f; + if arrow then ( + P.string f L.arrow; + P.space f); + match b with + | [{statement_desc = Return {expression_desc = Undefined _}}] when arrow + -> + P.string f "{"; + P.string f "}" + | ([{statement_desc = Return e}] | [{statement_desc = Exp e}]) + when arrow && directive == None -> + (if exp_need_paren ~arrow e then P.paren_group f 0 else P.group f 0) + (fun _ -> ignore (expression ~level:0 cxt f e)) + | _ -> + P.brace_vgroup f 1 (fun _ -> + function_body ?directive ~return_unit cxt f b) + in + let enclose () = + let handle () = + match fn_state with + | Is_return -> + return_sp f; + P.string f (L.function_ ~async ~arrow); + param_body () + | No_name _ -> + P.string f (L.function_ ~async ~arrow); + param_body () + | Name_non_top x -> + ignore (pp_var_assign inner_cxt f x : cxt); + P.string f (L.function_ ~async ~arrow); + param_body (); + semi f + | Name_top x -> + P.string f (L.function_ ~async ~arrow); + ignore (Ext_pp_scope.ident inner_cxt f x : cxt); + param_body () in - enclose (); - outer_cxt + handle () + in + enclose (); + outer_cxt (* Assume the cond would not change the context, since it can be either [int] or [string] @@ -432,7 +438,7 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) ~fn_stat and pp_one_case_clause : 'a. _ -> P.t -> (P.t -> 'a -> unit) -> 'a * J.case_clause -> _ = fun cxt f pp_cond - (switch_case, ({ switch_body; should_break; comment } : J.case_clause)) -> + (switch_case, ({switch_body; should_break; comment} : J.case_clause)) -> P.newline f; let cxt = P.group f 1 (fun _ -> @@ -449,8 +455,8 @@ and pp_one_case_clause : match switch_body with | [] -> cxt | _ -> - P.newline f; - statements false cxt f switch_body + P.newline f; + statements false cxt f switch_body in if should_break then ( P.newline f; @@ -469,20 +475,20 @@ and loop_case_clauses : and vident cxt f (v : J.vident) = match v with | Id v - | Qualified ({ id = v }, None) - | Qualified ({ id = v; kind = External { default = true } }, _) -> - Ext_pp_scope.ident cxt f v - | Qualified ({ id; kind = Ml | Runtime }, Some name) -> - let cxt = Ext_pp_scope.ident cxt f id in - P.string f L.dot; - P.string f - (if name = Js_dump_import_export.default_export then name - else Ext_ident.convert name); - cxt - | Qualified ({ id; kind = External _ }, Some name) -> - let cxt = Ext_pp_scope.ident cxt f id in - Js_dump_property.property_access f name; - cxt + | Qualified ({id = v}, None) + | Qualified ({id = v; kind = External {default = true}}, _) -> + Ext_pp_scope.ident cxt f v + | Qualified ({id; kind = Ml | Runtime}, Some name) -> + let cxt = Ext_pp_scope.ident cxt f id in + P.string f L.dot; + P.string f + (if name = Js_dump_import_export.default_export then name + else Ext_ident.convert name); + cxt + | Qualified ({id; kind = External _}, Some name) -> + let cxt = Ext_pp_scope.ident cxt f id in + Js_dump_property.property_access f name; + cxt (* The higher the level, the more likely that inner has to add parens *) and expression ~level:l cxt f (exp : J.expression) : cxt = @@ -492,190 +498,194 @@ and expression ~level:l cxt f (exp : J.expression) : cxt = and expression_desc cxt ~(level : int) f x : cxt = match x with | Null -> - P.string f L.null; - cxt + P.string f L.null; + cxt | Undefined _ -> - P.string f L.undefined; - cxt + P.string f L.undefined; + cxt | Var v -> vident cxt f v | Bool b -> - bool f b; - cxt + bool f b; + cxt | Seq (e1, e2) -> - P.cond_paren_group f (level > 0) (fun () -> - let cxt = expression ~level:0 cxt f e1 in - comma_sp f; - expression ~level:0 cxt f e2) - | Fun { is_method; params; body; env; return_unit; async; directive } -> - (* TODO: dump for comments *) - pp_function ?directive ~is_method ~return_unit ~async - ~fn_state:default_fn_exp_state - cxt f params body env - (* TODO: - when [e] is [Js_raw_code] with arity - print it in a more precise way - It seems the optimizer already did work to make sure - {[ - Call (Raw_js_code (s, Exp i), el, {Full}) - when Ext_list.length_equal el i - ]} - *) + P.cond_paren_group f (level > 0) (fun () -> + let cxt = expression ~level:0 cxt f e1 in + comma_sp f; + expression ~level:0 cxt f e2) + | Fun {is_method; params; body; env; return_unit; async; directive} -> + (* TODO: dump for comments *) + pp_function ?directive ~is_method ~return_unit ~async + ~fn_state:default_fn_exp_state cxt f params body env + (* TODO: + when [e] is [Js_raw_code] with arity + print it in a more precise way + It seems the optimizer already did work to make sure + {[ + Call (Raw_js_code (s, Exp i), el, {Full}) + when Ext_list.length_equal el i + ]} + *) | Call (e, el, info) -> - P.cond_paren_group f (level > 15) (fun _ -> - P.group f 0 (fun _ -> - match (info, el) with - | { arity = Full }, _ | _, [] -> - let cxt = - P.cond_paren_group f - (match e.expression_desc with Fun _ -> true | _ -> false) - (fun () -> expression ~level:15 cxt f e ) - in - P.paren_group f 0 (fun _ -> + P.cond_paren_group f (level > 15) (fun _ -> + P.group f 0 (fun _ -> + match (info, el) with + | {arity = Full}, _ | _, [] -> + let cxt = + P.cond_paren_group f + (match e.expression_desc with + | Fun _ -> true + | _ -> false) + (fun () -> expression ~level:15 cxt f e) + in + P.paren_group f 0 (fun _ -> + match el with + | [ + { + expression_desc = + Fun + { + is_method; + params; + body; + env; + return_unit; + async; + directive; + }; + }; + ] -> + pp_function ?directive ~is_method ~return_unit ~async + ~fn_state:(No_name {single_arg = true}) + cxt f params body env + | _ -> + let el = match el with - | [ - { - expression_desc = - Fun - { - is_method; - params; - body; - env; - return_unit; - async; - directive; - }; - }; - ] -> - pp_function ?directive ~is_method ~return_unit ~async - ~fn_state:(No_name { single_arg = true }) - cxt f params body env - | _ -> - let el = match el with - | [e] when e.expression_desc = Undefined {is_unit = true} -> - (* omit passing undefined when the call is f() *) - [] - | _ -> - el in - arguments cxt f el) - | _, _ -> - let len = List.length el in - if 1 <= len && len <= 8 then ( - Curry_gen.pp_app f len; - P.paren_group f 0 (fun _ -> arguments cxt f (e :: el))) - else ( - Curry_gen.pp_app_any f; - P.paren_group f 0 (fun _ -> - arguments cxt f [ e; E.array Mutable el ])))) + | [e] when e.expression_desc = Undefined {is_unit = true} + -> + (* omit passing undefined when the call is f() *) + [] + | _ -> el + in + arguments cxt f el) + | _, _ -> + let len = List.length el in + if 1 <= len && len <= 8 then ( + Curry_gen.pp_app f len; + P.paren_group f 0 (fun _ -> arguments cxt f (e :: el))) + else ( + Curry_gen.pp_app_any f; + P.paren_group f 0 (fun _ -> + arguments cxt f [e; E.array Mutable el])))) | FlatCall (e, el) -> - P.group f 0 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f L.apply; - P.paren_group f 1 (fun _ -> - P.string f L.null; - comma_sp f; - expression ~level:1 cxt f el)) + P.group f 0 (fun _ -> + let cxt = expression ~level:15 cxt f e in + P.string f L.dot; + P.string f L.apply; + P.paren_group f 1 (fun _ -> + P.string f L.null; + comma_sp f; + expression ~level:1 cxt f el)) | Tagged_template (call_expr, string_args, value_args) -> let cxt = expression cxt ~level f call_expr in P.string f "`"; - let rec aux cxt xs ys = match xs, ys with - | [], [] -> () - | [{J.expression_desc = Str { txt; _ }}], [] -> - P.string f txt - | {J.expression_desc = Str { txt; _ }} :: x_rest, y :: y_rest -> + let rec aux cxt xs ys = + match (xs, ys) with + | [], [] -> () + | [{J.expression_desc = Str {txt; _}}], [] -> P.string f txt + | {J.expression_desc = Str {txt; _}} :: x_rest, y :: y_rest -> P.string f txt; P.string f "${"; let cxt = expression cxt ~level f y in P.string f "}"; aux cxt x_rest y_rest - | _ -> assert false + | _ -> assert false in aux cxt string_args value_args; P.string f "`"; cxt | String_index (a, b) -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f a in - P.string f L.dot; - P.string f L.code_point_at; - (* FIXME: use code_point_at *) - P.paren_group f 1 (fun _ -> expression ~level:0 cxt f b)) - | Str { delim; txt } -> - (*TODO -- - when utf8-> it will not escape '\\' which is definitely not we want - *) - let () = - match delim with - | DStarJ -> P.string f ("\"" ^ txt ^ "\"") - | DNoQuotes -> P.string f txt - | DNone -> Js_dump_string.pp_string f txt + P.group f 1 (fun _ -> + let cxt = expression ~level:15 cxt f a in + P.string f L.dot; + P.string f L.code_point_at; + (* FIXME: use code_point_at *) + P.paren_group f 1 (fun _ -> expression ~level:0 cxt f b)) + | Str {delim; txt} -> + (*TODO -- + when utf8-> it will not escape '\\' which is definitely not we want + *) + let () = + match delim with + | DStarJ -> P.string f ("\"" ^ txt ^ "\"") + | DNoQuotes -> P.string f txt + | DNone -> Js_dump_string.pp_string f txt + in + cxt + | Raw_js_code {code = s; code_info = info} -> ( + match info with + | Exp exp_info -> + let raw_paren = + not + (match exp_info with + | Js_literal _ -> true + | Js_function _ | Js_exp_unknown -> + false || raw_snippet_exp_simple_enough s) in + if raw_paren then P.string f L.lparen; + P.string f s; + if raw_paren then P.string f L.rparen; cxt - | Raw_js_code { code = s; code_info = info } -> ( - match info with - | Exp exp_info -> - let raw_paren = - not - (match exp_info with - | Js_literal _ -> true - | Js_function _ | Js_exp_unknown -> - false || raw_snippet_exp_simple_enough s) - in - if raw_paren then P.string f L.lparen; - P.string f s; - if raw_paren then P.string f L.rparen; - cxt - | Stmt stmt_info -> - if stmt_info = Js_stmt_comment then P.string f s - else ( - P.newline f; - P.string f s; - P.newline f); - cxt) + | Stmt stmt_info -> + if stmt_info = Js_stmt_comment then P.string f s + else ( + P.newline f; + P.string f s; + P.newline f); + cxt) | Number v -> - let s = - match v with - | Float { f } -> Js_number.caml_float_literal_to_js_string f - (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i - | Int { i; c = None } -> - Int32.to_string i - (* check , js convention with ocaml lexical convention *) - | BigInt {positive; value} -> Format.asprintf "%sn" (Bigint_utils.to_string positive value) - in - let need_paren = - if s.[0] = '-' then level > 13 - (* Negative numbers may need to be parenthesized. *) - else - level = 15 (* Parenthesize as well when followed by a dot. *) - && s.[0] <> 'I' (* Infinity *) - && s.[0] <> 'N' (* NaN *) - in - let action _ = P.string f s in - if need_paren then P.paren f action else action (); - cxt + let s = + match v with + | Float {f} -> Js_number.caml_float_literal_to_js_string f + (* attach string here for float constant folding?*) + | Int {i; c = Some c} -> + Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i + | Int {i; c = None} -> + Int32.to_string i + (* check , js convention with ocaml lexical convention *) + | BigInt {positive; value} -> + Format.asprintf "%sn" (Bigint_utils.to_string positive value) + in + let need_paren = + if s.[0] = '-' then level > 13 + (* Negative numbers may need to be parenthesized. *) + else + level = 15 (* Parenthesize as well when followed by a dot. *) + && s.[0] <> 'I' (* Infinity *) + && s.[0] <> 'N' (* NaN *) + in + let action _ = P.string f s in + if need_paren then P.paren f action else action (); + cxt | Is_null_or_undefined e -> - P.cond_paren_group f (level > 0) (fun _ -> - let cxt = expression ~level:1 cxt f e in - P.space f; - P.string f "=="; - P.space f; - P.string f L.null; - cxt) + P.cond_paren_group f (level > 0) (fun _ -> + let cxt = expression ~level:1 cxt f e in + P.space f; + P.string f "=="; + P.space f; + P.string f L.null; + cxt) | Js_not e -> - P.cond_paren_group f (level > 13) (fun _ -> - P.string f "!"; - expression ~level:13 cxt f e) + P.cond_paren_group f (level > 13) (fun _ -> + P.string f "!"; + expression ~level:13 cxt f e) | Typeof e -> - P.string f "typeof"; - P.space f; - expression ~level:13 cxt f e + P.string f "typeof"; + P.space f; + expression ~level:13 cxt f e | Bin ( Minus, { - expression_desc = - Number ((Int { i = 0l; _ } | Float { f = "0." }) as desc); + expression_desc = Number ((Int {i = 0l; _} | Float {f = "0."}) as desc); }, e ) (* TODO: @@ -684,226 +694,250 @@ and expression_desc cxt ~(level : int) f x : cxt = {[ 0.00 - x ]} {[ 0.000 - x ]} *) -> - P.cond_paren_group f (level > 13) (fun _ -> - P.string f (match desc with Float _ -> "- " | _ -> "-"); - expression ~level:13 cxt f e) + P.cond_paren_group f (level > 13) (fun _ -> + P.string f + (match desc with + | Float _ -> "- " + | _ -> "-"); + expression ~level:13 cxt f e) | Bin (op, e1, e2) -> - let out, lft, rght = Js_op_util.op_prec op in - let need_paren = - level > out || match op with Lsl | Lsr | Asr -> true | _ -> false - in - (* We are more conservative here, to make the generated code more readable - to the user *) - P.cond_paren_group f need_paren (fun _ -> - let cxt = expression ~level:lft cxt f e1 in - P.space f; - P.string f (Js_op_util.op_str op); - P.space f; - expression ~level:rght cxt f e2) + let out, lft, rght = Js_op_util.op_prec op in + let need_paren = + level > out + || + match op with + | Lsl | Lsr | Asr -> true + | _ -> false + in + (* We are more conservative here, to make the generated code more readable + to the user *) + P.cond_paren_group f need_paren (fun _ -> + let cxt = expression ~level:lft cxt f e1 in + P.space f; + P.string f (Js_op_util.op_str op); + P.space f; + expression ~level:rght cxt f e2) | String_append (e1, e2) -> - let op : Js_op.binop = Plus in - let out, lft, rght = Js_op_util.op_prec op in - let need_paren = - level > out || match op with Lsl | Lsr | Asr -> true | _ -> false - in - P.cond_paren_group f need_paren (fun _ -> - let cxt = expression ~level:lft cxt f e1 in - P.space f; - P.string f "+"; - P.space f; - expression ~level:rght cxt f e2) + let op : Js_op.binop = Plus in + let out, lft, rght = Js_op_util.op_prec op in + let need_paren = + level > out + || + match op with + | Lsl | Lsr | Asr -> true + | _ -> false + in + P.cond_paren_group f need_paren (fun _ -> + let cxt = expression ~level:lft cxt f e1 in + P.space f; + P.string f "+"; + P.space f; + expression ~level:rght cxt f e2) | Array (el, _) -> ( - (* TODO: simplify for singleton list *) - match el with - | [] | [ _ ] -> P.bracket_group f 1 (fun _ -> array_element_list cxt f el) - | _ -> P.bracket_vgroup f 1 (fun _ -> array_element_list cxt f el)) + (* TODO: simplify for singleton list *) + match el with + | [] | [_] -> P.bracket_group f 1 (fun _ -> array_element_list cxt f el) + | _ -> P.bracket_vgroup f 1 (fun _ -> array_element_list cxt f el)) | Optional_block (e, identity) -> - expression ~level cxt f - (if identity then e - else E.runtime_call Primitive_modules.option "some" [ e ]) + expression ~level cxt f + (if identity then e + else E.runtime_call Primitive_modules.option "some" [e]) | Caml_block (el, _, _, Blk_module fields) -> - expression_desc cxt ~level f - (Object (None, - (Ext_list.map_combine fields el (fun x -> - Js_op.Lit (Ext_ident.convert x))))) + expression_desc cxt ~level f + (Object + ( None, + Ext_list.map_combine fields el (fun x -> + Js_op.Lit (Ext_ident.convert x)) )) (*name convention of Record is slight different from modules*) - | Caml_block (el, mutable_flag, _, Blk_record { fields; record_repr }) -> ( - if - Array.length fields <> 0 - && Ext_array.for_alli fields (fun i v -> string_of_int i = v) - then expression_desc cxt ~level f (Array (el, mutable_flag)) - else - match record_repr with - | Record_regular -> - expression_desc cxt ~level f - (Object (None, Ext_list.combine_array fields el (fun i -> Js_op.Lit i))) - | Record_optional -> - let fields = - Ext_list.array_list_filter_map fields el (fun f x -> - match x.expression_desc with - | Undefined _ -> None - | _ -> Some (Js_op.Lit f, x)) - in - expression_desc cxt ~level f (Object (None, fields))) + | Caml_block (el, mutable_flag, _, Blk_record {fields; record_repr}) -> ( + if + Array.length fields <> 0 + && Ext_array.for_alli fields (fun i v -> string_of_int i = v) + then expression_desc cxt ~level f (Array (el, mutable_flag)) + else + match record_repr with + | Record_regular -> + expression_desc cxt ~level f + (Object (None, Ext_list.combine_array fields el (fun i -> Js_op.Lit i))) + | Record_optional -> + let fields = + Ext_list.array_list_filter_map fields el (fun f x -> + match x.expression_desc with + | Undefined _ -> None + | _ -> Some (Js_op.Lit f, x)) + in + expression_desc cxt ~level f (Object (None, fields))) | Caml_block (el, _, _, Blk_poly_var _) -> ( - match el with - | [ tag; value ] -> - expression_desc cxt ~level f - (Object (None, - [ - (Js_op.Lit Literals.polyvar_hash, tag); - (Lit Literals.polyvar_value, value); - ])) - | _ -> assert false) + match el with + | [tag; value] -> + expression_desc cxt ~level f + (Object + ( None, + [ + (Js_op.Lit Literals.polyvar_hash, tag); + (Lit Literals.polyvar_value, value); + ] )) + | _ -> assert false) | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> - expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext) + expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext) | Caml_block (el, _, tag, Blk_record_inlined p) -> - let untagged = Ast_untagged_variants.process_untagged p.attrs in - let objs = - let tails = - Ext_list.combine_array_append p.fields el - (if !Js_config.debug then [ (name_symbol, E.str p.name) ] else []) - (fun i -> Js_op.Lit i) - in - let is_optional (pname: Js_op.property_name) = - match pname with - | Lit n -> Ext_list.mem_string p.optional_labels n - | Symbol_name -> false - in - let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with + let untagged = Ast_untagged_variants.process_untagged p.attrs in + let objs = + let tails = + Ext_list.combine_array_append p.fields el + (if !Js_config.debug then [(name_symbol, E.str p.name)] else []) + (fun i -> Js_op.Lit i) + in + let is_optional (pname : Js_op.property_name) = + match pname with + | Lit n -> Ext_list.mem_string p.optional_labels n + | Symbol_name -> false + in + let tag_name = + match Ast_untagged_variants.process_tag_name p.attrs with | None -> L.tag - | Some s -> s in - let tails = - match p.optional_labels with - | [] -> tails - | _ -> - Ext_list.filter_map tails (fun (f, x) -> + | Some s -> s + in + let tails = + match p.optional_labels with + | [] -> tails + | _ -> + Ext_list.filter_map tails (fun (f, x) -> match x.expression_desc with | Undefined _ when is_optional f -> None | _ -> Some (f, x)) - in - if untagged then - tails - else - (Js_op.Lit tag_name, (* TAG:xx for inline records *) - match Ast_untagged_variants.process_tag_type p.attrs with - | None -> E.str p.name - | Some t -> E.tag_type t ) - :: tails in - expression_desc cxt ~level f (Object (None, objs)) + if untagged then tails + else + ( Js_op.Lit tag_name, + (* TAG:xx for inline records *) + match Ast_untagged_variants.process_tag_type p.attrs with + | None -> E.str p.name + | Some t -> E.tag_type t ) + :: tails + in + expression_desc cxt ~level f (Object (None, objs)) | Caml_block (el, _, tag, Blk_constructor p) -> - let not_is_cons = p.name <> Literals.cons in - let tag_type = Ast_untagged_variants.process_tag_type p.attrs in - let untagged = Ast_untagged_variants.process_untagged p.attrs in - let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with - | None -> L.tag - | Some s -> s in - let objs = - let tails = - Ext_list.mapi_append el - (fun i e -> - ( (match (not_is_cons, i) with - | false, 0 -> Js_op.Lit Literals.hd - | false, 1 -> Js_op.Lit Literals.tl - | _ -> Js_op.Lit ("_" ^ string_of_int i)), - e )) - (if !Js_config.debug && not_is_cons then - [ (name_symbol, E.str p.name) ] - else []) - in - if untagged || (not_is_cons = false) && p.num_nonconst = 1 then tails - else - ( Js_op.Lit tag_name, (* TAG:xx *) - match tag_type with - | None -> E.str p.name - | Some t -> E.tag_type t ) - :: tails + let not_is_cons = p.name <> Literals.cons in + let tag_type = Ast_untagged_variants.process_tag_type p.attrs in + let untagged = Ast_untagged_variants.process_untagged p.attrs in + let tag_name = + match Ast_untagged_variants.process_tag_name p.attrs with + | None -> L.tag + | Some s -> s + in + let objs = + let tails = + Ext_list.mapi_append el + (fun i e -> + ( (match (not_is_cons, i) with + | false, 0 -> Js_op.Lit Literals.hd + | false, 1 -> Js_op.Lit Literals.tl + | _ -> Js_op.Lit ("_" ^ string_of_int i)), + e )) + (if !Js_config.debug && not_is_cons then [(name_symbol, E.str p.name)] + else []) in - let exp = match objs with - | [(_, e)] when untagged -> e.expression_desc - | _ when untagged -> assert false (* should not happen *) - (* TODO: put restriction on the variant definitions allowed, to make sure this never happens. *) - | _ -> J.Object (None, objs) in - expression_desc cxt ~level f exp + if untagged || (not_is_cons = false && p.num_nonconst = 1) then tails + else + ( Js_op.Lit tag_name, + (* TAG:xx *) + match tag_type with + | None -> E.str p.name + | Some t -> E.tag_type t ) + :: tails + in + let exp = + match objs with + | [(_, e)] when untagged -> e.expression_desc + | _ when untagged -> assert false (* should not happen *) + (* TODO: put restriction on the variant definitions allowed, to make sure this never happens. *) + | _ -> J.Object (None, objs) + in + expression_desc cxt ~level f exp | Caml_block ( _, _, _, (Blk_module_export _ | Blk_some | Blk_some_not_nested | Blk_lazy_general) ) -> - assert false + assert false | Caml_block (el, mutable_flag, _tag, Blk_tuple) -> - expression_desc cxt ~level f (Array (el, mutable_flag)) + expression_desc cxt ~level f (Array (el, mutable_flag)) | Caml_block_tag (e, tag) -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f tag; - cxt) + P.group f 1 (fun _ -> + let cxt = expression ~level:15 cxt f e in + P.string f L.dot; + P.string f tag; + cxt) | Array_index (e, p) -> - P.cond_paren_group f (level > 15) (fun _ -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.bracket_group f 1 (fun _ -> expression ~level:0 cxt f p))) + P.cond_paren_group f (level > 15) (fun _ -> + P.group f 1 (fun _ -> + let cxt = expression ~level:15 cxt f e in + P.bracket_group f 1 (fun _ -> expression ~level:0 cxt f p))) | Static_index (e, s, _) -> - P.cond_paren_group f (level > 15) (fun _ -> - let cxt = expression ~level:15 cxt f e in - Js_dump_property.property_access f s; - (* See [ .obj_of_exports] - maybe in the ast level we should have - refer and export - *) - cxt) + P.cond_paren_group f (level > 15) (fun _ -> + let cxt = expression ~level:15 cxt f e in + Js_dump_property.property_access f s; + (* See [ .obj_of_exports] + maybe in the ast level we should have + refer and export + *) + cxt) | Length (e, _) -> - (*Todo: check parens *) - P.cond_paren_group f (level > 15) (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f L.length; - cxt) + (*Todo: check parens *) + P.cond_paren_group f (level > 15) (fun _ -> + let cxt = expression ~level:15 cxt f e in + P.string f L.dot; + P.string f L.length; + cxt) | New (e, el) -> - P.cond_paren_group f (level > 15) (fun _ -> - P.group f 0 (fun _ -> - P.string f L.new_; - P.space f; - let cxt = expression ~level:16 cxt f e in - P.paren_group f 0 (fun _ -> - match el with Some el -> arguments cxt f el | None -> cxt))) + P.cond_paren_group f (level > 15) (fun _ -> + P.group f 0 (fun _ -> + P.string f L.new_; + P.space f; + let cxt = expression ~level:16 cxt f e in + P.paren_group f 0 (fun _ -> + match el with + | Some el -> arguments cxt f el + | None -> cxt))) | Cond (e, e1, e2) -> - let action () = - let cxt = expression ~level:3 cxt f e in - P.space f; - P.string f L.question; - P.space f; - (* + let action () = + let cxt = expression ~level:3 cxt f e in + P.space f; + P.string f L.question; + P.space f; + (* [level 1] is correct, however to make nice indentation , force nested conditional to be parenthesized *) - let cxt = P.group f 1 (fun _ -> expression ~level:3 cxt f e1) in + let cxt = P.group f 1 (fun _ -> expression ~level:3 cxt f e1) in - P.space f; - P.string f L.colon_space; - (* idem *) - P.group f 1 (fun _ -> expression ~level:3 cxt f e2) - in - if level > 2 then P.paren_vgroup f 1 action else action () + P.space f; + P.string f L.colon_space; + (* idem *) + P.group f 1 (fun _ -> expression ~level:3 cxt f e2) + in + if level > 2 then P.paren_vgroup f 1 action else action () | Object (dup, lst) -> - (* #1946 object literal is easy to be - interpreted as block statement - here we avoid parens in such case - {[ - var f = { x : 2 , y : 2} - ]} - *) - P.cond_paren_group f (level > 1) (fun _ -> - let dup_expression e = - expression ~level:1 cxt f { e with expression_desc = J.Spread e } - in - if lst = [] then - P.brace f (fun _ -> match dup with Some e -> dup_expression e | _ -> cxt) - else - P.brace_vgroup f 1 (fun _ -> + (* #1946 object literal is easy to be + interpreted as block statement + here we avoid parens in such case + {[ + var f = { x : 2 , y : 2} + ]} + *) + P.cond_paren_group f (level > 1) (fun _ -> + let dup_expression e = + expression ~level:1 cxt f {e with expression_desc = J.Spread e} + in + if lst = [] then + P.brace f (fun _ -> + match dup with + | Some e -> dup_expression e + | _ -> cxt) + else + P.brace_vgroup f 1 (fun _ -> let cxt = match dup with | Some e -> @@ -914,33 +948,33 @@ and expression_desc cxt ~(level : int) f x : cxt = in property_name_and_value_list cxt f lst)) | Await e -> - P.cond_paren_group f (level > 13) (fun _ -> - P.string f "await "; - expression ~level:13 cxt f e) + P.cond_paren_group f (level > 13) (fun _ -> + P.string f "await "; + expression ~level:13 cxt f e) | Spread e -> - P.cond_paren_group f (level > 13) (fun _ -> - P.string f "..."; - expression ~level:13 cxt f e) + P.cond_paren_group f (level > 13) (fun _ -> + P.string f "..."; + expression ~level:13 cxt f e) and property_name_and_value_list cxt f (l : J.property_map) = iter_lst cxt f l (fun cxt f (pn, e) -> match e.expression_desc with - | Var (Id v | Qualified ({ id = v; _ }, None)) -> - let key = Js_dump_property.property_key pn in - let str, cxt = Ext_pp_scope.str_of_ident cxt v in - let content = - (* if key = str then key - else *) - key ^ L.colon_space ^ str - in - P.string f content; - cxt + | Var (Id v | Qualified ({id = v; _}, None)) -> + let key = Js_dump_property.property_key pn in + let str, cxt = Ext_pp_scope.str_of_ident cxt v in + let content = + (* if key = str then key + else *) + key ^ L.colon_space ^ str + in + P.string f content; + cxt | _ -> - let key = Js_dump_property.property_key pn in - P.string f key; - P.string f L.colon_space; - expression ~level:1 cxt f e) + let key = Js_dump_property.property_key pn in + P.string f key; + P.string f L.colon_space; + expression ~level:1 cxt f e) comma_nl and array_element_list cxt f (el : E.t list) : cxt = @@ -952,25 +986,25 @@ and arguments cxt f (l : E.t list) : cxt = and variable_declaration top cxt f (variable : J.variable_declaration) : cxt = (* TODO: print [const/var] for different backends *) match variable with - | { ident = i; value = None; ident_info; _ } -> - if ident_info.used_stats = Dead_pure then cxt else pp_var_declare cxt f i - | { ident = name; value = Some e; ident_info = { used_stats; _ } } -> ( - match used_stats with - | Dead_pure -> cxt - | Dead_non_pure -> - (* Make sure parens are added correctly *) - statement_desc top cxt f (J.Exp e) - | _ -> ( - match e.expression_desc with - | Fun { is_method; params; body; env; return_unit; async; directive } -> - pp_function ?directive ~is_method ~return_unit ~async - ~fn_state:(if top then Name_top name else Name_non_top name) - cxt f params body env - | _ -> - let cxt = pp_var_assign cxt f name in - let cxt = expression ~level:1 cxt f e in - semi f; - cxt)) + | {ident = i; value = None; ident_info; _} -> + if ident_info.used_stats = Dead_pure then cxt else pp_var_declare cxt f i + | {ident = name; value = Some e; ident_info = {used_stats; _}} -> ( + match used_stats with + | Dead_pure -> cxt + | Dead_non_pure -> + (* Make sure parens are added correctly *) + statement_desc top cxt f (J.Exp e) + | _ -> ( + match e.expression_desc with + | Fun {is_method; params; body; env; return_unit; async; directive} -> + pp_function ?directive ~is_method ~return_unit ~async + ~fn_state:(if top then Name_top name else Name_non_top name) + cxt f params body env + | _ -> + let cxt = pp_var_assign cxt f name in + let cxt = expression ~level:1 cxt f e in + semi f; + cxt)) and ipp_comment : 'a. P.t -> 'a -> unit = fun _f _comment -> () @@ -989,139 +1023,133 @@ and pp_comment f comment = P.string f " */") and pp_comment_option f comment = - match comment with None -> () | Some x -> pp_comment f x + match comment with + | None -> () + | Some x -> pp_comment f x -and statement top cxt f ({ statement_desc = s; comment; _ } : J.statement) : cxt - = +and statement top cxt f ({statement_desc = s; comment; _} : J.statement) : cxt = pp_comment_option f comment; statement_desc top cxt f s and statement_desc top cxt f (s : J.statement_desc) : cxt = match s with | Block [] -> - ipp_comment f L.empty_block; - (* debugging*) + ipp_comment f L.empty_block; + (* debugging*) + cxt + | Exp {expression_desc = Var _} -> + (* Does it make sense to optimize here? *) + (* semi f; *) + cxt + | Exp e -> ( + match e.expression_desc with + | Raw_js_code {code; code_info = Stmt Js_stmt_comment} -> + P.string f code; cxt - | Exp { expression_desc = Var _ } -> - (* Does it make sense to optimize here? *) - (* semi f; *) + | Raw_js_code {code_info = Exp (Js_literal {comment})} -> + (match comment with + (* The %raw is just a comment *) + | Some s -> P.string f s + | None -> ()); cxt - | Exp e -> ( - match e.expression_desc with - | Raw_js_code { code; code_info = Stmt Js_stmt_comment } -> - P.string f code; - cxt - | Raw_js_code { code_info = Exp (Js_literal { comment }) } -> - (match comment with - (* The %raw is just a comment *) - | Some s -> P.string f s - | None -> ()); - cxt - | Str _ -> cxt - | _ -> - let cxt = - (if exp_need_paren e then P.paren_group f 1 else P.group f 0) - (fun _ -> expression ~level:0 cxt f e) - in - semi f; - cxt) + | Str _ -> cxt + | _ -> + let cxt = + (if exp_need_paren e then P.paren_group f 1 else P.group f 0) (fun _ -> + expression ~level:0 cxt f e) + in + semi f; + cxt) | Block b -> - (* No braces needed here *) - ipp_comment f L.start_block; - let cxt = statements top cxt f b in - ipp_comment f L.end_block; - cxt + (* No braces needed here *) + ipp_comment f L.start_block; + let cxt = statements top cxt f b in + ipp_comment f L.end_block; + cxt | Variable l -> variable_declaration top cxt f l | If (e, s1, s2) -> ( - (* TODO: always brace those statements *) - P.string f L.if_; + (* TODO: always brace those statements *) + P.string f L.if_; + P.space f; + let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in + P.space f; + let cxt = brace_block cxt f s1 in + match s2 with + | [] | [{statement_desc = Block [] | Exp {expression_desc = Var _}}] -> + P.newline f; + cxt + | [({statement_desc = If _} as nest)] + | [{statement_desc = Block [({statement_desc = If _; _} as nest)]; _}] -> P.space f; - let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in + P.string f L.else_; P.space f; - let cxt = brace_block cxt f s1 in - match s2 with - | [] | [ { statement_desc = Block [] | Exp { expression_desc = Var _ } } ] - -> - P.newline f; - cxt - | [ ({ statement_desc = If _ } as nest) ] - | [ - { - statement_desc = Block [ ({ statement_desc = If _; _ } as nest) ]; - _; - }; - ] -> - P.space f; - P.string f L.else_; - P.space f; - statement false cxt f nest - | _ :: _ as s2 -> - P.space f; - P.string f L.else_; - P.space f; - brace_block cxt f s2) + statement false cxt f nest + | _ :: _ as s2 -> + P.space f; + P.string f L.else_; + P.space f; + brace_block cxt f s2) | While (e, s) -> - (* FIXME: print scope as well *) - let cxt = - match e.expression_desc with - | Number (Int { i = 1l }) -> - P.string f L.while_; - P.space f; - P.string f L.lparen; - P.string f L.true_; - P.string f L.rparen; - P.space f; - cxt - | _ -> - P.string f L.while_; - P.space f; - let cxt = - P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) - in - P.space f; - cxt - in - let cxt = brace_block cxt f s in - semi f; - cxt + (* FIXME: print scope as well *) + let cxt = + match e.expression_desc with + | Number (Int {i = 1l}) -> + P.string f L.while_; + P.space f; + P.string f L.lparen; + P.string f L.true_; + P.string f L.rparen; + P.space f; + cxt + | _ -> + P.string f L.while_; + P.space f; + let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in + P.space f; + cxt + in + let cxt = brace_block cxt f s in + semi f; + cxt | ForRange (for_ident_expression, finish, id, direction, s) -> - let action cxt = - P.vgroup f 0 (fun _ -> - let cxt = - P.group f 0 (fun _ -> - (* The only place that [semi] may have semantics here *) - P.string f L.for_; - P.space f; - let ctx = P.paren_group f 1 (fun _ -> + let action cxt = + P.vgroup f 0 (fun _ -> + let cxt = + P.group f 0 (fun _ -> + (* The only place that [semi] may have semantics here *) + P.string f L.for_; + P.space f; + let ctx = + P.paren_group f 1 (fun _ -> let cxt, new_id = match (for_ident_expression, finish.expression_desc) with | Some ident_expression, (Number _ | Var _) -> - let cxt = pp_var_assign cxt f id in - (expression ~level:0 cxt f ident_expression, None) + let cxt = pp_var_assign cxt f id in + (expression ~level:0 cxt f ident_expression, None) | Some ident_expression, _ -> - let cxt = pp_var_assign cxt f id in - let cxt = - expression ~level:1 cxt f ident_expression - in - comma f; - P.space f; - let id = - Ext_ident.create (Ident.name id ^ "_finish") - in - let cxt = Ext_pp_scope.ident cxt f id in - P.space f; - P.string f L.eq; - P.space f; - (expression ~level:1 cxt f finish, Some id) + let cxt = pp_var_assign cxt f id in + let cxt = + expression ~level:1 cxt f ident_expression + in + comma f; + P.space f; + let id = + Ext_ident.create (Ident.name id ^ "_finish") + in + let cxt = Ext_pp_scope.ident cxt f id in + P.space f; + P.string f L.eq; + P.space f; + (expression ~level:1 cxt f finish, Some id) | None, (Number _ | Var _) -> (cxt, None) | None, _ -> - let id = - Ext_ident.create (Ident.name id ^ "_finish") - in - let cxt = pp_var_assign cxt f id in - (expression ~level:15 cxt f finish, Some id) + let id = + Ext_ident.create (Ident.name id ^ "_finish") + in + let cxt = pp_var_assign cxt f id in + (expression ~level:15 cxt f finish, Some id) in semi f; P.space f; @@ -1130,17 +1158,17 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt = let right_prec = match direction with | Upto -> - let _, _, right = Js_op_util.op_prec Le in - P.string f L.le; - right + let _, _, right = Js_op_util.op_prec Le in + P.string f L.le; + right | Up -> - let _, _, right = Js_op_util.op_prec Lt in - P.string f L.lt; - right + let _, _, right = Js_op_util.op_prec Lt in + P.string f L.lt; + right | Downto -> - let _, _, right = Js_op_util.op_prec Ge in - P.string f L.ge; - right + let _, _, right = Js_op_util.op_prec Ge in + P.string f L.ge; + right in P.space f; let cxt = @@ -1152,150 +1180,150 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt = semi f; P.space f; pp_direction f direction; - Ext_pp_scope.ident cxt f id) in - P.space f; - ctx) - in - brace_block cxt f s) - in - action cxt + Ext_pp_scope.ident cxt f id) + in + P.space f; + ctx) + in + brace_block cxt f s) + in + action cxt | Continue -> - continue f; - cxt + continue f; + cxt (* P.newline f; #2642 *) | Debugger -> - debugger_nl f; - cxt + debugger_nl f; + cxt | Break -> - break_nl f; - cxt + break_nl f; + cxt | Return e -> ( - match e.expression_desc with - | Fun { is_method; params; body; env; return_unit; async; directive } -> - let cxt = - pp_function ?directive ~return_unit ~is_method ~async - ~fn_state:Is_return - cxt f params body env - in - semi f; - cxt - | Undefined _ -> - P.string f L.return; + match e.expression_desc with + | Fun {is_method; params; body; env; return_unit; async; directive} -> + let cxt = + pp_function ?directive ~return_unit ~is_method ~async + ~fn_state:Is_return cxt f params body env + in + semi f; + cxt + | Undefined _ -> + P.string f L.return; + semi f; + cxt + | _ -> + return_sp f; + (* P.string f "return ";(\* ASI -- when there is a comment*\) *) + P.group f 0 (fun _ -> + let cxt = expression ~level:0 cxt f e in semi f; - cxt - | _ -> - return_sp f; - (* P.string f "return ";(\* ASI -- when there is a comment*\) *) - P.group f 0 (fun _ -> - let cxt = expression ~level:0 cxt f e in - semi f; - cxt) - (* There MUST be a space between the return and its - argument. A line return will not work *)) + cxt) + (* There MUST be a space between the return and its + argument. A line return will not work *)) | Int_switch (e, cc, def) -> - P.string f L.switch; - P.space f; - let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in - P.space f; - P.brace_vgroup f 1 (fun _ -> - let cxt = - loop_case_clauses cxt f (fun f i -> P.string f (string_of_int i)) cc - in - match def with - | None -> cxt - | Some def -> + P.string f L.switch; + P.space f; + let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in + P.space f; + P.brace_vgroup f 1 (fun _ -> + let cxt = + loop_case_clauses cxt f (fun f i -> P.string f (string_of_int i)) cc + in + match def with + | None -> cxt + | Some def -> + P.newline f; + P.group f 1 (fun _ -> + P.string f L.default; + P.string f L.colon; P.newline f; - P.group f 1 (fun _ -> - P.string f L.default; - P.string f L.colon; - P.newline f; - statements false cxt f def)) + statements false cxt f def)) | String_switch (e, cc, def) -> - P.string f L.switch; - P.space f; - let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in - P.space f; - P.brace_vgroup f 1 (fun _ -> - let pp_as_value f (tag_type: Ast_untagged_variants.tag_type) = - let e = E.tag_type tag_type in - ignore @@ expression_desc cxt ~level:0 f e.expression_desc in - let cxt = loop_case_clauses cxt f pp_as_value cc in - match def with - | None -> cxt - | Some def -> + P.string f L.switch; + P.space f; + let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in + P.space f; + P.brace_vgroup f 1 (fun _ -> + let pp_as_value f (tag_type : Ast_untagged_variants.tag_type) = + let e = E.tag_type tag_type in + ignore @@ expression_desc cxt ~level:0 f e.expression_desc + in + let cxt = loop_case_clauses cxt f pp_as_value cc in + match def with + | None -> cxt + | Some def -> + P.newline f; + P.group f 1 (fun _ -> + P.string f L.default; + P.string f L.colon; P.newline f; - P.group f 1 (fun _ -> - P.string f L.default; - P.string f L.colon; - P.newline f; - statements false cxt f def)) + statements false cxt f def)) | Throw e -> - let e = - match e.expression_desc with - | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> - { e with expression_desc = exn_block_as_obj ~stack:true el ext } - | _ -> e - in - P.string f L.throw; - P.space f; - P.group f 0 (fun _ -> - let cxt = expression ~level:0 cxt f e in - semi f; - cxt) + let e = + match e.expression_desc with + | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> + {e with expression_desc = exn_block_as_obj ~stack:true el ext} + | _ -> e + in + P.string f L.throw; + P.space f; + P.group f 0 (fun _ -> + let cxt = expression ~level:0 cxt f e in + semi f; + cxt) (* There must be a space between the return and its argument. A line return would not work *) | Try (b, ctch, fin) -> - P.vgroup f 0 (fun _ -> - P.string f L.try_; - P.space f; - let cxt = brace_block cxt f b in - let cxt = - match ctch with - | None -> cxt - | Some (i, b) -> - P.string f " catch ("; - let cxt = Ext_pp_scope.ident cxt f i in - P.string f ") "; - brace_block cxt f b - in - match fin with + P.vgroup f 0 (fun _ -> + P.string f L.try_; + P.space f; + let cxt = brace_block cxt f b in + let cxt = + match ctch with | None -> cxt - | Some b -> - P.group f 1 (fun _ -> - P.string f L.finally; - P.space f; - brace_block cxt f b)) - + | Some (i, b) -> + P.string f " catch ("; + let cxt = Ext_pp_scope.ident cxt f i in + P.string f ") "; + brace_block cxt f b + in + match fin with + | None -> cxt + | Some b -> + P.group f 1 (fun _ -> + P.string f L.finally; + P.space f; + brace_block cxt f b)) and function_body ?directive (cxt : cxt) f ~return_unit (b : J.block) : unit = - (match directive with - | None -> () - | Some directive -> + (match directive with + | None -> () + | Some directive -> P.newline f; - P.string f directive; P.string f ";"; + P.string f directive; + P.string f ";"; P.newline f); match b with | [] -> () - | [ s ] -> ( - match s.statement_desc with - | If - ( bool, - then_, - [ { statement_desc = Return { expression_desc = Undefined _ } } ] ) -> - ignore - (statement false cxt f - { s with statement_desc = If (bool, then_, []) } - : cxt) - | Return { expression_desc = Undefined _ } -> () - | Return exp when return_unit -> - ignore (statement false cxt f (S.exp exp) : cxt) - | _ -> ignore (statement false cxt f s : cxt)) - | [ s; { statement_desc = Return { expression_desc = Undefined _ } } ] -> - ignore (statement false cxt f s : cxt) + | [s] -> ( + match s.statement_desc with + | If + ( bool, + then_, + [{statement_desc = Return {expression_desc = Undefined _}}] ) -> + ignore + (statement false cxt f {s with statement_desc = If (bool, then_, [])} + : cxt) + | Return {expression_desc = Undefined _} -> () + | Return exp when return_unit -> + ignore (statement false cxt f (S.exp exp) : cxt) + | _ -> ignore (statement false cxt f s : cxt)) + | [s; {statement_desc = Return {expression_desc = Undefined _}}] -> + ignore (statement false cxt f s : cxt) | s :: r -> - let cxt = statement false cxt f s in - P.newline f; - function_body cxt f r ~return_unit + let cxt = statement false cxt f s in + P.newline f; + function_body cxt f r ~return_unit and brace_block cxt f b = (* This one is for '{' *) diff --git a/compiler/core/js_dump_import_export.ml b/compiler/core/js_dump_import_export.ml index 18b23a58ea..c9a017802b 100644 --- a/compiler/core/js_dump_import_export.ml +++ b/compiler/core/js_dump_import_export.ml @@ -33,12 +33,12 @@ let es_module = ("__esModule", "true") let rev_iter_inter lst f inter = match lst with | [] -> () - | [ a ] -> f a + | [a] -> f a | a :: rest -> - Ext_list.rev_iter rest (fun x -> - f x; - inter ()); - f a + Ext_list.rev_iter rest (fun x -> + f x; + inter ()); + f a (* Print exports in Google module format, CommonJS format *) let exports cxt f (idents : Ident.t list) = @@ -73,16 +73,15 @@ let es6_export cxt f (idents : Ident.t list) = P.at_least_two_lines f; match idents with | [] -> cxt - | _ -> + | _ -> let outer_cxt, reversed_list = - Ext_list.fold_left idents (cxt, []) (fun (cxt, acc) id -> - let id_name = id.name in - let s = Ext_ident.convert id_name in - let str, cxt = Ext_pp_scope.str_of_ident cxt id in - ( cxt, - if id_name = default_export then - (default_export, str) :: acc - else (s, str) :: acc )) + Ext_list.fold_left idents (cxt, []) (fun (cxt, acc) id -> + let id_name = id.name in + let s = Ext_ident.convert id_name in + let str, cxt = Ext_pp_scope.str_of_ident cxt id in + ( cxt, + if id_name = default_export then (default_export, str) :: acc + else (s, str) :: acc )) in P.string f L.export; P.space f; @@ -99,7 +98,6 @@ let es6_export cxt f (idents : Ident.t list) = P.string f L.comma)) (fun _ -> P.newline f)); outer_cxt - (** Node or Google module style imports *) let requires require_lit cxt f (modules : (Ident.t * string * bool) list) = @@ -124,32 +122,33 @@ let requires require_lit cxt f (modules : (Ident.t * string * bool) list) = P.newline f); outer_cxt -let dump_import_attributes f (import_attributes : External_ffi_types.import_attributes option) = - match import_attributes with - | None -> () - | Some import_attributes -> +let dump_import_attributes f + (import_attributes : External_ffi_types.import_attributes option) = + match import_attributes with + | None -> () + | Some import_attributes -> P.space f; P.string f "with"; P.space f; let total = Hashtbl.length import_attributes in let idx = ref 1 in - P.brace_group f 0 ( - fun _ -> - import_attributes |> Hashtbl.iter(fun key value -> - Js_dump_string.pp_string f key; - P.string f L.colon_space; - Js_dump_string.pp_string f value; - let should_add_comma = !idx < total in - if should_add_comma then ( - P.string f L.comma; - P.space f - ); - idx := !idx + 1; - ) - ) + P.brace_group f 0 (fun _ -> + import_attributes + |> Hashtbl.iter (fun key value -> + Js_dump_string.pp_string f key; + P.string f L.colon_space; + Js_dump_string.pp_string f value; + let should_add_comma = !idx < total in + if should_add_comma then ( + P.string f L.comma; + P.space f); + idx := !idx + 1)) (** ES6 module style imports *) -let imports cxt f (modules : (Ident.t * string * bool * External_ffi_types.import_attributes option) list) = +let imports cxt f + (modules : + (Ident.t * string * bool * External_ffi_types.import_attributes option) + list) = (* the context used to print the following program *) let outer_cxt, reversed_list = Ext_list.fold_left modules (cxt, []) (fun (cxt, acc) (id, s, b, i) -> diff --git a/compiler/core/js_dump_import_export.mli b/compiler/core/js_dump_import_export.mli index 4d03a46b51..db700a82ae 100644 --- a/compiler/core/js_dump_import_export.mli +++ b/compiler/core/js_dump_import_export.mli @@ -36,4 +36,7 @@ val requires : Ext_pp_scope.t val imports : - Ext_pp_scope.t -> Ext_pp.t -> (Ident.t * string * bool * External_ffi_types.import_attributes option) list -> Ext_pp_scope.t + Ext_pp_scope.t -> + Ext_pp.t -> + (Ident.t * string * bool * External_ffi_types.import_attributes option) list -> + Ext_pp_scope.t diff --git a/compiler/core/js_dump_lit.ml b/compiler/core/js_dump_lit.ml index fd53d77449..fc982710ae 100644 --- a/compiler/core/js_dump_lit.ml +++ b/compiler/core/js_dump_lit.ml @@ -26,10 +26,10 @@ let await = "await" let function_ ~async ~arrow = match (async, arrow) with - | (true, true) -> "async " - | (false, true) -> "" - | (true, false) -> "async function " - | (false, false) -> "function " + | true, true -> "async " + | false, true -> "" + | true, false -> "async function " + | false, false -> "function " let arrow = "=>" diff --git a/compiler/core/js_dump_program.ml b/compiler/core/js_dump_program.ml index 1d9ab3e092..0a35bdc26a 100644 --- a/compiler/core/js_dump_program.ml +++ b/compiler/core/js_dump_program.ml @@ -31,12 +31,12 @@ let empty_explanation = let program_is_empty (x : J.program) = match x with - | { block = []; exports = []; export_set = _ } -> true + | {block = []; exports = []; export_set = _} -> true | _ -> false let deps_program_is_empty (x : J.deps_program) = match x with - | { modules = []; program; side_effect = None } -> program_is_empty program + | {modules = []; program; side_effect = None} -> program_is_empty program | _ -> false let rec extract_block_comments acc (x : J.block) = @@ -46,16 +46,16 @@ let rec extract_block_comments acc (x : J.block) = Exp { expression_desc = - Raw_js_code { code; code_info = Stmt Js_stmt_comment }; + Raw_js_code {code; code_info = Stmt Js_stmt_comment}; }; } :: rest -> - extract_block_comments (code :: acc) rest + extract_block_comments (code :: acc) rest | _ -> (acc, x) let extract_file_comments (x : J.deps_program) = let comments, new_block = extract_block_comments [] x.program.block in - (comments, { x with program = { x.program with block = new_block } }) + (comments, {x with program = {x.program with block = new_block}}) let program f cxt (x : J.program) = P.at_least_two_lines f; @@ -66,7 +66,9 @@ let dump_program (x : J.program) oc = ignore (program (P.from_channel oc) Ext_pp_scope.empty x) let[@inline] is_default (x : Js_op.kind) = - match x with External { default } -> default | _ -> false + match x with + | External {default} -> default + | _ -> false let node_program ~output_dir f (x : J.deps_program) = P.string f L.strict_directive; @@ -75,12 +77,13 @@ let node_program ~output_dir f (x : J.deps_program) = Js_dump_import_export.requires L.require Ext_pp_scope.empty f (* Not be emitted in require statements *) (Ext_list.filter_map x.modules (fun x -> - match x.dynamic_import with - | true -> None - | false -> - Some ( x.id, - Js_name_of_module_id.string_of_module_id x ~output_dir Commonjs, - is_default x.kind ))) + match x.dynamic_import with + | true -> None + | false -> + Some + ( x.id, + Js_name_of_module_id.string_of_module_id x ~output_dir Commonjs, + is_default x.kind ))) in program f cxt x.program @@ -89,13 +92,16 @@ let es6_program ~output_dir fmt f (x : J.deps_program) = Js_dump_import_export.imports Ext_pp_scope.empty f (* Not be emitted in import statements *) (Ext_list.filter_map x.modules (fun x -> - match x.dynamic_import with - | true -> None - | false -> - Some ( x.id, - Js_name_of_module_id.string_of_module_id x ~output_dir fmt, - is_default x.kind, - (match x.kind with | External {import_attributes} -> import_attributes | _ -> None) ))) + match x.dynamic_import with + | true -> None + | false -> + Some + ( x.id, + Js_name_of_module_id.string_of_module_id x ~output_dir fmt, + is_default x.kind, + match x.kind with + | External {import_attributes} -> import_attributes + | _ -> None ))) in let () = P.at_least_two_lines f in let cxt = Js_dump.statements true cxt f x.program.block in @@ -104,10 +110,10 @@ let es6_program ~output_dir fmt f (x : J.deps_program) = let pp_deps_program ~(output_prefix : string) (kind : Js_packages_info.module_system) (program : J.deps_program) (f : Ext_pp.t) = - - !Js_config.directives |> List.iter (fun prim -> - P.string f prim; - P.newline f); + !Js_config.directives + |> List.iter (fun prim -> + P.string f prim; + P.newline f); if not !Js_config.no_version_header then ( P.string f Bs_version.header; P.newline f); diff --git a/compiler/core/js_dump_property.ml b/compiler/core/js_dump_property.ml index 6633cc98d2..6df115808b 100644 --- a/compiler/core/js_dump_property.ml +++ b/compiler/core/js_dump_property.ml @@ -55,9 +55,9 @@ let obj_property_no_need_quot s = if len > 0 then match String.unsafe_get s 0 with | '$' | '_' | 'a' .. 'z' | 'A' .. 'Z' -> - Ext_string.for_all_from s 1 (function - | 'a' .. 'z' | 'A' .. 'Z' | '$' | '_' | '0' .. '9' -> true - | _ -> false) + Ext_string.for_all_from s 1 (function + | 'a' .. 'z' | 'A' .. 'Z' | '$' | '_' | '0' .. '9' -> true + | _ -> false) | _ -> false else false @@ -84,7 +84,6 @@ let property_access f s = let property_key (s : J.property_name) : string = match s with | Lit s -> - let s = Ext_ident.unwrap_uppercase_exotic s in - if obj_property_no_need_quot s then s - else Js_dump_string.escape_to_string s + let s = Ext_ident.unwrap_uppercase_exotic s in + if obj_property_no_need_quot s then s else Js_dump_string.escape_to_string s | Symbol_name -> {|[Symbol.for("name")]|} diff --git a/compiler/core/js_dump_string.ml b/compiler/core/js_dump_string.ml index 11b8d253e2..25899961a0 100644 --- a/compiler/core/js_dump_string.ml +++ b/compiler/core/js_dump_string.ml @@ -76,18 +76,18 @@ let escape_to_buffer f (* ?(utf=false)*) s = || let next = String.unsafe_get s (i + 1) in next < '0' || next > '9' -> - f +> "\\0" + f +> "\\0" | '\\' (* when not utf*) -> f +> "\\\\" | '\000' .. '\031' | '\127' -> - let c = Char.code c in - f +> "\\x"; - f +> Array.unsafe_get array_conv (c lsr 4); - f +> Array.unsafe_get array_conv (c land 0xf) + let c = Char.code c in + f +> "\\x"; + f +> Array.unsafe_get array_conv (c lsr 4); + f +> Array.unsafe_get array_conv (c land 0xf) | '\128' .. '\255' (* when not utf*) -> - let c = Char.code c in - f +> "\\x"; - f +> Array.unsafe_get array_conv (c lsr 4); - f +> Array.unsafe_get array_conv (c land 0xf) + let c = Char.code c in + f +> "\\x"; + f +> Array.unsafe_get array_conv (c lsr 4); + f +> Array.unsafe_get array_conv (c land 0xf) | '\"' -> f +> "\\\"" (* quote*) | _ -> f +> Array.unsafe_get array_str1 (Char.code c) done diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index fd37ab75dc..5d9c197ddd 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -37,16 +37,16 @@ let rec remove_pure_sub_exp (x : t) : t option = match x.expression_desc with | Var _ | Str _ | Number _ -> None (* Can be refined later *) | Array_index (a, b) -> - if is_pure_sub_exp a && is_pure_sub_exp b then None else Some x + if is_pure_sub_exp a && is_pure_sub_exp b then None else Some x | Array (xs, _mutable_flag) -> - if Ext_list.for_all xs is_pure_sub_exp then None else Some x + if Ext_list.for_all xs is_pure_sub_exp then None else Some x | Seq (a, b) -> ( - match (remove_pure_sub_exp a, remove_pure_sub_exp b) with - | None, None -> None - | Some u, Some v -> Some { x with expression_desc = Seq (u, v) } - (* may still have some simplification*) - | None, (Some _ as v) -> v - | (Some _ as u), None -> u) + match (remove_pure_sub_exp a, remove_pure_sub_exp b) with + | None, None -> None + | Some u, Some v -> Some {x with expression_desc = Seq (u, v)} + (* may still have some simplification*) + | None, (Some _ as v) -> v + | (Some _ as u), None -> u) | _ -> Some x and is_pure_sub_exp (x : t) = remove_pure_sub_exp x = None @@ -54,37 +54,51 @@ and is_pure_sub_exp (x : t) = remove_pure_sub_exp x = None (* let mk ?comment exp : t = {expression_desc = exp ; comment } *) -let var ?comment id : t = { expression_desc = Var (Id id); comment } +let var ?comment id : t = {expression_desc = Var (Id id); comment} (* only used in property access, Invariant: it should not call an external module .. *) let js_global ?comment (v : string) = var ?comment (Ext_ident.create_js v) -let undefined : t = { expression_desc = Undefined {is_unit = false}; comment = None } -let nil : t = { expression_desc = Null; comment = None } +let undefined : t = + {expression_desc = Undefined {is_unit = false}; comment = None} +let nil : t = {expression_desc = Null; comment = None} let call ?comment ~info e0 args : t = - { expression_desc = Call (e0, args, info); comment } + {expression_desc = Call (e0, args, info); comment} (* TODO: optimization when es is known at compile time to be an array *) let flat_call ?comment e0 es : t = - { expression_desc = FlatCall (e0, es); comment } + {expression_desc = FlatCall (e0, es); comment} let tagged_template ?comment call_expr string_args value_args : t = - { expression_desc = Tagged_template (call_expr, string_args, value_args); comment } + { + expression_desc = Tagged_template (call_expr, string_args, value_args); + comment; + } let runtime_var_dot ?comment (x : string) (e1 : string) : J.expression = { expression_desc = Var - (Qualified ({ id = Ident.create_persistent x; kind = Runtime; dynamic_import = false }, Some e1)); + (Qualified + ( { + id = Ident.create_persistent x; + kind = Runtime; + dynamic_import = false; + }, + Some e1 )); comment; } -let ml_var_dot ?comment ?(dynamic_import = false) (id : Ident.t) e : J.expression = - { expression_desc = Var (Qualified ({ id; kind = Ml; dynamic_import }, Some e)); comment } +let ml_var_dot ?comment ?(dynamic_import = false) (id : Ident.t) e : + J.expression = + { + expression_desc = Var (Qualified ({id; kind = Ml; dynamic_import}, Some e)); + comment; + } (** module as a value @@ -92,11 +106,18 @@ let ml_var_dot ?comment ?(dynamic_import = false) (id : Ident.t) e : J.expressio var http = require("http") ]} *) -let external_var_field ?import_attributes ?comment ~external_name:name (id : Ident.t) ~field - ~default : t = +let external_var_field ?import_attributes ?comment ~external_name:name + (id : Ident.t) ~field ~default : t = { expression_desc = - Var (Qualified ({ id; kind = External { name; default; import_attributes }; dynamic_import = false }, Some field)); + Var + (Qualified + ( { + id; + kind = External {name; default; import_attributes}; + dynamic_import = false; + }, + Some field )); comment; } @@ -105,13 +126,22 @@ let external_var ?import_attributes ?comment ~external_name (id : Ident.t) : t = expression_desc = Var (Qualified - ( { id; kind = External { name = external_name; default = false; import_attributes }; dynamic_import = false }, + ( { + id; + kind = + External + {name = external_name; default = false; import_attributes}; + dynamic_import = false; + }, None )); comment; } let ml_module_as_var ?comment ?(dynamic_import = false) (id : Ident.t) : t = - { expression_desc = Var (Qualified ({ id; kind = Ml; dynamic_import }, None)); comment } + { + expression_desc = Var (Qualified ({id; kind = Ml; dynamic_import}, None)); + comment; + } (* Static_index .....................**) let runtime_call module_name fn_name args = @@ -127,43 +157,42 @@ let pure_runtime_call module_name fn_name args = let runtime_ref module_name fn_name = runtime_var_dot module_name fn_name let str ?(delim = J.DNone) ?comment txt : t = - { expression_desc = Str { txt; delim }; comment } + {expression_desc = Str {txt; delim}; comment} let raw_js_code ?comment info s : t = { - expression_desc = Raw_js_code { code = String.trim s; code_info = info }; + expression_desc = Raw_js_code {code = String.trim s; code_info = info}; comment; } -let array ?comment mt es : t = { expression_desc = Array (es, mt); comment } +let array ?comment mt es : t = {expression_desc = Array (es, mt); comment} let some_comment = None let optional_block e : J.expression = - { expression_desc = Optional_block (e, false); comment = some_comment } + {expression_desc = Optional_block (e, false); comment = some_comment} let optional_not_nest_block e : J.expression = - { expression_desc = Optional_block (e, true); comment = None } + {expression_desc = Optional_block (e, true); comment = None} (** used in normal property like [e.length], no dependency introduced *) let dot ?comment (e0 : t) (e1 : string) : t = - { expression_desc = Static_index (e0, e1, None); comment } + {expression_desc = Static_index (e0, e1, None); comment} let module_access (e : t) (name : string) (pos : int32) = let name = Ext_ident.convert name in match e.expression_desc with | Caml_block (l, _, _, _) when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - { expression_desc = Static_index (e, name, Some pos); comment = None } - ) - | _ -> { expression_desc = Static_index (e, name, Some pos); comment = None } + match Ext_list.nth_opt l (Int32.to_int pos) with + | Some x -> x + | None -> + {expression_desc = Static_index (e, name, Some pos); comment = None}) + | _ -> {expression_desc = Static_index (e, name, Some pos); comment = None} let make_block ?comment (tag : t) (tag_info : J.tag_info) (es : t list) (mutable_flag : J.mutable_flag) : t = - { expression_desc = Caml_block (es, mutable_flag, tag, tag_info); comment } + {expression_desc = Caml_block (es, mutable_flag, tag, tag_info); comment} module L = Literals @@ -174,19 +203,18 @@ let typeof ?comment (e : t) : t = | Str _ -> str ?comment L.js_type_string | Array _ -> str ?comment L.js_type_object | Bool _ -> str ?comment L.js_type_boolean - | _ -> { expression_desc = Typeof e; comment } + | _ -> {expression_desc = Typeof e; comment} -let instanceof ?comment (e0 : t) (e1: t) : t = - { expression_desc = Bin (InstanceOf, e0, e1); comment } +let instanceof ?comment (e0 : t) (e1 : t) : t = + {expression_desc = Bin (InstanceOf, e0, e1); comment} -let is_array (e0 : t) : t = +let is_array (e0 : t) : t = let f = str "Array.isArray" ~delim:DNoQuotes in - { expression_desc = Call (f, [e0], Js_call_info.ml_full_call); comment=None } + {expression_desc = Call (f, [e0], Js_call_info.ml_full_call); comment = None} -let new_ ?comment e0 args : t = - { expression_desc = New (e0, Some args); comment } +let new_ ?comment e0 args : t = {expression_desc = New (e0, Some args); comment} -let unit : t = { expression_desc = Undefined {is_unit = true}; comment = None } +let unit : t = {expression_desc = Undefined {is_unit = true}; comment = None} (* let math ?comment v args : t = {comment ; expression_desc = Math(v,args)} *) @@ -207,7 +235,8 @@ let unit : t = { expression_desc = Undefined {is_unit = true}; comment = None } [Js_fun_env.empty] is a mutable state .. *) -let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async ~one_unit_arg params body : t = +let ocaml_fun ?comment ?immutable_mask ?directive ~return_unit ~async + ~one_unit_arg params body : t = let params = if one_unit_arg then [] else params in let len = List.length params in { @@ -251,9 +280,9 @@ let dummy_obj ?comment (info : Lam_tag_info.t) : t = match info with | Blk_record _ | Blk_module _ | Blk_constructor _ | Blk_record_inlined _ | Blk_poly_var _ | Blk_extension | Blk_record_ext _ -> - { comment; expression_desc = Object (None, []) } + {comment; expression_desc = Object (None, [])} | Blk_tuple | Blk_module_export _ -> - { comment; expression_desc = Array ([], Mutable) } + {comment; expression_desc = Array ([], Mutable)} | Blk_some | Blk_some_not_nested | Blk_lazy_general -> assert false (* TODO: complete @@ -261,18 +290,18 @@ let dummy_obj ?comment (info : Lam_tag_info.t) : t = *) let rec seq ?comment (e0 : t) (e1 : t) : t = match (e0.expression_desc, e1.expression_desc) with - | ( ( Seq (a, { expression_desc = Number _ | Undefined _ }) - | Seq ({ expression_desc = Number _ | Undefined _ }, a) ), + | ( ( Seq (a, {expression_desc = Number _ | Undefined _}) + | Seq ({expression_desc = Number _ | Undefined _}, a) ), _ ) -> - seq ?comment a e1 - | _, Seq ({ expression_desc = Number _ | Undefined _ }, a) -> - (* Return value could not be changed*) - seq ?comment e0 a - | _, Seq (a, ({ expression_desc = Number _ | Undefined _ } as v)) -> - (* Return value could not be changed*) - seq ?comment (seq e0 a) v + seq ?comment a e1 + | _, Seq ({expression_desc = Number _ | Undefined _}, a) -> + (* Return value could not be changed*) + seq ?comment e0 a + | _, Seq (a, ({expression_desc = Number _ | Undefined _} as v)) -> + (* Return value could not be changed*) + seq ?comment (seq e0 a) v | (Number _ | Var _ | Undefined _), _ -> e1 - | _ -> { expression_desc = Seq (e0, e1); comment } + | _ -> {expression_desc = Seq (e0, e1); comment} let fuse_to_seq x xs = if xs = [] then x else Ext_list.fold_left xs x seq @@ -280,43 +309,48 @@ let fuse_to_seq x xs = if xs = [] then x else Ext_list.fold_left xs x seq {expression_desc = Str (true,""); comment = None} *) let zero_int_literal : t = - { expression_desc = Number (Int { i = 0l; c = None }); comment = None } + {expression_desc = Number (Int {i = 0l; c = None}); comment = None} let one_int_literal : t = - { expression_desc = Number (Int { i = 1l; c = None }); comment = None } + {expression_desc = Number (Int {i = 1l; c = None}); comment = None} let two_int_literal : t = - { expression_desc = Number (Int { i = 2l; c = None }); comment = None } + {expression_desc = Number (Int {i = 2l; c = None}); comment = None} let three_int_literal : t = - { expression_desc = Number (Int { i = 3l; c = None }); comment = None } + {expression_desc = Number (Int {i = 3l; c = None}); comment = None} let four_int_literal : t = - { expression_desc = Number (Int { i = 4l; c = None }); comment = None } + {expression_desc = Number (Int {i = 4l; c = None}); comment = None} let five_int_literal : t = - { expression_desc = Number (Int { i = 5l; c = None }); comment = None } + {expression_desc = Number (Int {i = 5l; c = None}); comment = None} let six_int_literal : t = - { expression_desc = Number (Int { i = 6l; c = None }); comment = None } + {expression_desc = Number (Int {i = 6l; c = None}); comment = None} let seven_int_literal : t = - { expression_desc = Number (Int { i = 7l; c = None }); comment = None } + {expression_desc = Number (Int {i = 7l; c = None}); comment = None} let eight_int_literal : t = - { expression_desc = Number (Int { i = 8l; c = None }); comment = None } + {expression_desc = Number (Int {i = 8l; c = None}); comment = None} let nine_int_literal : t = - { expression_desc = Number (Int { i = 9l; c = None }); comment = None } + {expression_desc = Number (Int {i = 9l; c = None}); comment = None} let obj_int_tag_literal : t = - { expression_desc = Number (Int { i = 248l; c = None }); comment = None } + {expression_desc = Number (Int {i = 248l; c = None}); comment = None} -let int ?comment ?c i : t = { expression_desc = Number (Int { i; c }); comment } +let int ?comment ?c i : t = {expression_desc = Number (Int {i; c}); comment} -let bigint ?comment sign i : t = { expression_desc = Number (BigInt {positive=sign; value=i}); comment} +let bigint ?comment sign i : t = + {expression_desc = Number (BigInt {positive = sign; value = i}); comment} -let zero_bigint_literal : t = {expression_desc = Number (BigInt {positive=true; value="0"}); comment = None} +let zero_bigint_literal : t = + { + expression_desc = Number (BigInt {positive = true; value = "0"}); + comment = None; + } let small_int i : t = match i with @@ -333,41 +367,38 @@ let small_int i : t = | 248 -> obj_int_tag_literal | i -> int (Int32.of_int i) -let true_ : t = { comment = None; expression_desc = Bool true } -let false_ : t = { comment = None; expression_desc = Bool false } +let true_ : t = {comment = None; expression_desc = Bool true} +let false_ : t = {comment = None; expression_desc = Bool false} let bool v = if v then true_ else false_ -let float ?comment f : t = { expression_desc = Number (Float { f }); comment } +let float ?comment f : t = {expression_desc = Number (Float {f}); comment} let zero_float_lit : t = - { expression_desc = Number (Float { f = "0." }); comment = None } + {expression_desc = Number (Float {f = "0."}); comment = None} let float_mod ?comment e1 e2 : J.expression = - { comment; expression_desc = Bin (Mod, e1, e2) } + {comment; expression_desc = Bin (Mod, e1, e2)} let array_index ?comment (e0 : t) (e1 : t) : t = match (e0.expression_desc, e1.expression_desc) with - | Array (l, _), Number (Int { i; _ }) + | Array (l, _), Number (Int {i; _}) (* Float i -- should not appear here *) when no_side_effect e0 -> ( - match Ext_list.nth_opt l (Int32.to_int i) with - | None -> { expression_desc = Array_index (e0, e1); comment } - | Some x -> x (* FIX #3084*)) - | _ -> { expression_desc = Array_index (e0, e1); comment } + match Ext_list.nth_opt l (Int32.to_int i) with + | None -> {expression_desc = Array_index (e0, e1); comment} + | Some x -> x (* FIX #3084*)) + | _ -> {expression_desc = Array_index (e0, e1); comment} let array_index_by_int ?comment (e : t) (pos : int32) : t = match e.expression_desc with | Array (l, _) (* Float i -- should not appear here *) | Caml_block (l, _, _, _) when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - { - expression_desc = Array_index (e, int ?comment pos); - comment = None; - }) - | _ -> { expression_desc = Array_index (e, int ?comment pos); comment = None } + match Ext_list.nth_opt l (Int32.to_int pos) with + | Some x -> x + | None -> + {expression_desc = Array_index (e, int ?comment pos); comment = None}) + | _ -> {expression_desc = Array_index (e, int ?comment pos); comment = None} let record_access (e : t) (name : string) (pos : int32) = (* let name = Ext_ident.convert name in *) @@ -375,12 +406,11 @@ let record_access (e : t) (name : string) (pos : int32) = | Array (l, _) (* Float i -- should not appear here *) | Caml_block (l, _, _, _) when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - { expression_desc = Static_index (e, name, Some pos); comment = None } - ) - | _ -> { expression_desc = Static_index (e, name, Some pos); comment = None } + match Ext_list.nth_opt l (Int32.to_int pos) with + | Some x -> x + | None -> + {expression_desc = Static_index (e, name, Some pos); comment = None}) + | _ -> {expression_desc = Static_index (e, name, Some pos); comment = None} (* The same as {!record_access} except tag*) let inline_record_access = record_access @@ -399,56 +429,63 @@ let cons_access (e : t) (pos : int32) = let poly_var_tag_access (e : t) = match e.expression_desc with | Caml_block (l, _, _, _) when no_side_effect e -> ( - match l with x :: _ -> x | [] -> assert false) + match l with + | x :: _ -> x + | [] -> assert false) | _ -> - { - expression_desc = Static_index (e, Literals.polyvar_hash, Some 0l); - comment = None; - } + { + expression_desc = Static_index (e, Literals.polyvar_hash, Some 0l); + comment = None; + } let poly_var_value_access (e : t) = match e.expression_desc with | Caml_block (l, _, _, _) when no_side_effect e -> ( - match l with _ :: v :: _ -> v | _ -> assert false) + match l with + | _ :: v :: _ -> v + | _ -> assert false) | _ -> - { - expression_desc = Static_index (e, Literals.polyvar_value, Some 1l); - comment = None; - } + { + expression_desc = Static_index (e, Literals.polyvar_value, Some 1l); + comment = None; + } let extension_access (e : t) name (pos : int32) : t = match e.expression_desc with | Array (l, _) (* Float i -- should not appear here *) | Caml_block (l, _, _, _) when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - let name = - match name with Some n -> n | None -> "_" ^ Int32.to_string pos - in - { expression_desc = Static_index (e, name, Some pos); comment = None } - ) - | _ -> + match Ext_list.nth_opt l (Int32.to_int pos) with + | Some x -> x + | None -> let name = - match name with Some n -> n | None -> "_" ^ Int32.to_string pos + match name with + | Some n -> n + | None -> "_" ^ Int32.to_string pos in - { expression_desc = Static_index (e, name, Some pos); comment = None } + {expression_desc = Static_index (e, name, Some pos); comment = None}) + | _ -> + let name = + match name with + | Some n -> n + | None -> "_" ^ Int32.to_string pos + in + {expression_desc = Static_index (e, name, Some pos); comment = None} let string_index ?comment (e0 : t) (e1 : t) : t = match (e0.expression_desc, e1.expression_desc) with - | Str { txt }, Number (Int { i; _ }) -> - (* Don't optimize {j||j} *) - let i = Int32.to_int i in - if i >= 0 && i < String.length txt then - (* TODO: check exception when i is out of range.. - RangeError? - *) - str (String.make 1 txt.[i]) - else { expression_desc = String_index (e0, e1); comment } - | _ -> { expression_desc = String_index (e0, e1); comment } - -let assign ?comment e0 e1 : t = { expression_desc = Bin (Eq, e0, e1); comment } + | Str {txt}, Number (Int {i; _}) -> + (* Don't optimize {j||j} *) + let i = Int32.to_int i in + if i >= 0 && i < String.length txt then + (* TODO: check exception when i is out of range.. + RangeError? + *) + str (String.make 1 txt.[i]) + else {expression_desc = String_index (e0, e1); comment} + | _ -> {expression_desc = String_index (e0, e1); comment} + +let assign ?comment e0 e1 : t = {expression_desc = Bin (Eq, e0, e1); comment} let assign_by_exp (e : t) index value : t = match e.expression_desc with @@ -462,9 +499,8 @@ let assign_by_exp (e : t) index value : t = *) | Caml_block _ when no_side_effect e && no_side_effect index -> - value - | _ -> - assign { expression_desc = Array_index (e, index); comment = None } value + value + | _ -> assign {expression_desc = Array_index (e, index); comment = None} value let assign_by_int ?comment e0 (index : int32) value = assign_by_exp e0 (int ?comment index) value @@ -481,11 +517,11 @@ let record_assign (e : t) (pos : int32) (name : string) (value : t) = *) | Caml_block _ when no_side_effect e -> - value + value | _ -> - assign - { expression_desc = Static_index (e, name, Some pos); comment = None } - value + assign + {expression_desc = Static_index (e, name, Some pos); comment = None} + value let extension_assign (e : t) (pos : int32) name (value : t) = match e.expression_desc with @@ -499,11 +535,11 @@ let extension_assign (e : t) (pos : int32) name (value : t) = *) | Caml_block _ when no_side_effect e -> - value + value | _ -> - assign - { expression_desc = Static_index (e, name, Some pos); comment = None } - value + assign + {expression_desc = Static_index (e, name, Some pos); comment = None} + value (* This is a property access not external module *) @@ -511,28 +547,28 @@ let array_length ?comment (e : t) : t = match e.expression_desc with (* TODO: use array instead? *) | (Array (l, _) | Caml_block (l, _, _, _)) when no_side_effect e -> - int ?comment (Int32.of_int (List.length l)) - | _ -> { expression_desc = Length (e, Array); comment } + int ?comment (Int32.of_int (List.length l)) + | _ -> {expression_desc = Length (e, Array); comment} let string_length ?comment (e : t) : t = match e.expression_desc with - | Str { txt; delim = DNone } -> int ?comment (Int32.of_int (String.length txt)) + | Str {txt; delim = DNone} -> int ?comment (Int32.of_int (String.length txt)) (* No optimization for {j||j}*) - | _ -> { expression_desc = Length (e, String); comment } + | _ -> {expression_desc = Length (e, String); comment} (* TODO: use [Buffer] instead? *) let bytes_length ?comment (e : t) : t = match e.expression_desc with | Array (l, _) -> int ?comment (Int32.of_int (List.length l)) - | _ -> { expression_desc = Length (e, Bytes); comment } + | _ -> {expression_desc = Length (e, Bytes); comment} let function_length ?comment (e : t) : t = match e.expression_desc with - | Fun { is_method; params } -> - let params_length = List.length params in - int ?comment - (Int32.of_int (if is_method then params_length - 1 else params_length)) - | _ -> { expression_desc = Length (e, Function); comment } + | Fun {is_method; params} -> + let params_length = List.length params in + int ?comment + (Int32.of_int (if is_method then params_length - 1 else params_length)) + | _ -> {expression_desc = Length (e, Function); comment} (** no dependency introduced *) (* let js_global_dot ?comment (x : string) (e1 : string) : t = @@ -540,36 +576,35 @@ let function_length ?comment (e : t) : t = *) let rec string_append ?comment (e : t) (el : t) : t = - let concat a b ~delim = - { e with expression_desc = Str { txt = a ^ b; delim } } - in + let concat a b ~delim = {e with expression_desc = Str {txt = a ^ b; delim}} in match (e.expression_desc, el.expression_desc) with - | Str { txt = ""}, _ -> el - | _, Str { txt = ""} -> e - | ( Str { txt = a; delim }, - String_append ({ expression_desc = Str { txt = b; delim = delim_ } }, c) ) + | Str {txt = ""}, _ -> el + | _, Str {txt = ""} -> e + | ( Str {txt = a; delim}, + String_append ({expression_desc = Str {txt = b; delim = delim_}}, c) ) when delim = delim_ -> - string_append ?comment (concat a b ~delim) c - | ( String_append (c, { expression_desc = Str { txt = b; delim } }), - Str { txt = a; delim = delim_ } ) + string_append ?comment (concat a b ~delim) c + | ( String_append (c, {expression_desc = Str {txt = b; delim}}), + Str {txt = a; delim = delim_} ) when delim = delim_ -> - string_append ?comment c (concat b a ~delim) - | ( String_append (a, { expression_desc = Str { txt = b; delim } }), - String_append ({ expression_desc = Str { txt = c; delim = delim_ } }, d) ) + string_append ?comment c (concat b a ~delim) + | ( String_append (a, {expression_desc = Str {txt = b; delim}}), + String_append ({expression_desc = Str {txt = c; delim = delim_}}, d) ) when delim = delim_ -> - string_append ?comment (string_append a (concat b c ~delim)) d - | Str { txt = a; delim }, Str { txt = b; delim = delim_ } when delim = delim_ - -> - { (concat a b ~delim) with comment } - | _, _ -> { comment; expression_desc = String_append (e, el) } + string_append ?comment (string_append a (concat b c ~delim)) d + | Str {txt = a; delim}, Str {txt = b; delim = delim_} when delim = delim_ -> + {(concat a b ~delim) with comment} + | _, _ -> {comment; expression_desc = String_append (e, el)} let obj ?comment ?dup properties : t = - { expression_desc = Object (dup, properties); comment } + {expression_desc = Object (dup, properties); comment} -let str_equal (txt0:string) (delim0:External_arg_spec.delim) txt1 delim1 = +let str_equal (txt0 : string) (delim0 : External_arg_spec.delim) txt1 delim1 = if delim0 = delim1 then if Ext_string.equal txt0 txt1 then Some true - else if Ast_utf8_string.simple_comparison txt0 && Ast_utf8_string.simple_comparison txt1 + else if + Ast_utf8_string.simple_comparison txt0 + && Ast_utf8_string.simple_comparison txt1 then Some false else None else None @@ -579,30 +614,30 @@ let rec triple_equal ?comment (e0 : t) (e1 : t) : t = | ( (Null | Undefined _), (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _) ) when no_side_effect e1 -> - false_ + false_ | ( (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _), (Null | Undefined _) ) when no_side_effect e0 -> - false_ - | Number (Int { i = i0; _ }), Number (Int { i = i1; _ }) -> bool (i0 = i1) + false_ + | Number (Int {i = i0; _}), Number (Int {i = i1; _}) -> bool (i0 = i1) | Optional_block (a, _), Optional_block (b, _) -> triple_equal ?comment a b | Undefined _, Optional_block _ | Optional_block _, Undefined _ | Null, Undefined _ | Undefined _, Null -> - false_ + false_ | Null, Null | Undefined _, Undefined _ -> true_ - | _ -> { expression_desc = Bin (EqEqEq, e0, e1); comment } + | _ -> {expression_desc = Bin (EqEqEq, e0, e1); comment} let bin ?comment (op : J.binop) (e0 : t) (e1 : t) : t = match (op, e0.expression_desc, e1.expression_desc) with | EqEqEq, _, _ -> triple_equal ?comment e0 e1 - | Ge, Length (e, _), Number (Int { i = 0l }) when no_side_effect e -> - true_ (* x.length >=0 | [x] is pure -> true*) - | Gt, Length (_, _), Number (Int { i = 0l }) -> - (* [e] is kept so no side effect check needed *) - { expression_desc = Bin (NotEqEq, e0, e1); comment } - | _ -> { expression_desc = Bin (op, e0, e1); comment } + | Ge, Length (e, _), Number (Int {i = 0l}) when no_side_effect e -> + true_ (* x.length >=0 | [x] is pure -> true*) + | Gt, Length (_, _), Number (Int {i = 0l}) -> + (* [e] is kept so no side effect check needed *) + {expression_desc = Bin (NotEqEq, e0, e1); comment} + | _ -> {expression_desc = Bin (op, e0, e1); comment} (* TODO: Constant folding, Google Closure will do that?, Even if Google Clsoure can do that, we will see how it interact with other @@ -627,70 +662,66 @@ let bin ?comment (op : J.binop) (e0 : t) (e1 : t) : t = be careful for side effect *) -let rec filter_bool (e: t) ~j ~b = match e.expression_desc with - | Bin (And, e1, e2) -> - (match (filter_bool e1 ~j ~b, filter_bool e2 ~j ~b) with +let rec filter_bool (e : t) ~j ~b = + match e.expression_desc with + | Bin (And, e1, e2) -> ( + match (filter_bool e1 ~j ~b, filter_bool e2 ~j ~b) with | None, None -> None - | Some e, None - | None, Some e -> Some e - | Some e1, Some e2 -> - Some {e with expression_desc = Bin (And, e1, e2)} ) - | Bin (Or, e1, e2) -> - (match (filter_bool e1 ~j ~b, filter_bool e2 ~j ~b) with - | None, _ | _, None -> - None - | Some e1, Some e2 -> - Some {e with expression_desc = Bin (Or, e1, e2)} ) + | Some e, None | None, Some e -> Some e + | Some e1, Some e2 -> Some {e with expression_desc = Bin (And, e1, e2)}) + | Bin (Or, e1, e2) -> ( + match (filter_bool e1 ~j ~b, filter_bool e2 ~j ~b) with + | None, _ | _, None -> None + | Some e1, Some e2 -> Some {e with expression_desc = Bin (Or, e1, e2)}) | Bin - ( NotEqEq, - {expression_desc = Typeof {expression_desc = Var i}}, - {expression_desc = Str {txt}}) when Js_op_util.same_vident i j -> - if txt <> "bool" - then None - else assert false - | Js_not {expression_desc = - Call ({expression_desc = Str {txt = "Array.isArray"}}, - [{expression_desc = Var i}], _)} when Js_op_util.same_vident i j -> + ( NotEqEq, + {expression_desc = Typeof {expression_desc = Var i}}, + {expression_desc = Str {txt}} ) + when Js_op_util.same_vident i j -> + if txt <> "bool" then None else assert false + | Js_not + { + expression_desc = + Call + ( {expression_desc = Str {txt = "Array.isArray"}}, + [{expression_desc = Var i}], + _ ); + } + when Js_op_util.same_vident i j -> None | _ -> Some e let and_ ?comment (e1 : t) (e2 : t) : t = match (e1.expression_desc, e2.expression_desc) with | Var i, Var j when Js_op_util.same_vident i j -> e1 - | Var i, Bin (And, { expression_desc = Var j; _ }, _) + | Var i, Bin (And, {expression_desc = Var j; _}, _) when Js_op_util.same_vident i j -> - e2 - | Var i, Bin (And, l, ({ expression_desc = Var j; _ } as r)) + e2 + | Var i, Bin (And, l, ({expression_desc = Var j; _} as r)) when Js_op_util.same_vident i j -> - { e2 with expression_desc = Bin (And, r, l) } - | ( Bin (NotEqEq, { expression_desc = Var i }, { expression_desc = Undefined _ }), + {e2 with expression_desc = Bin (And, r, l)} + | ( Bin (NotEqEq, {expression_desc = Var i}, {expression_desc = Undefined _}), Bin - ( EqEqEq, - { expression_desc = Var j }, - { expression_desc = Str _ | Number _ } ) ) + (EqEqEq, {expression_desc = Var j}, {expression_desc = Str _ | Number _}) + ) when Js_op_util.same_vident i j -> - e2 - | ( _, - Bin - ( EqEqEq, - { expression_desc = Var j }, - { expression_desc = Bool b } ) - ) -> - (match filter_bool e1 ~j ~b with - | None -> e2 - | Some e1 -> { expression_desc = Bin (And, e1, e2); comment }) - | _, _ -> { expression_desc = Bin (And, e1, e2); comment } + e2 + | _, Bin (EqEqEq, {expression_desc = Var j}, {expression_desc = Bool b}) -> ( + match filter_bool e1 ~j ~b with + | None -> e2 + | Some e1 -> {expression_desc = Bin (And, e1, e2); comment}) + | _, _ -> {expression_desc = Bin (And, e1, e2); comment} let or_ ?comment (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with | Var i, Var j when Js_op_util.same_vident i j -> e1 - | Var i, Bin (Or, { expression_desc = Var j; _ }, _) + | Var i, Bin (Or, {expression_desc = Var j; _}, _) when Js_op_util.same_vident i j -> - e2 - | Var i, Bin (Or, l, ({ expression_desc = Var j; _ } as r)) + e2 + | Var i, Bin (Or, l, ({expression_desc = Var j; _} as r)) when Js_op_util.same_vident i j -> - { e2 with expression_desc = Bin (Or, r, l) } - | _, _ -> { expression_desc = Bin (Or, e1, e2); comment } + {e2 with expression_desc = Bin (Or, r, l)} + | _, _ -> {expression_desc = Bin (Or, e1, e2); comment} (* return a value of type boolean *) (* TODO: @@ -698,63 +729,63 @@ let or_ ?comment (e1 : t) (e2 : t) = it is right that !(x > 3 ) -> x <= 3 *) let not (e : t) : t = match e.expression_desc with - | Number (Int { i; _ }) -> bool (i = 0l) + | Number (Int {i; _}) -> bool (i = 0l) | Js_not e -> e | Bool b -> if b then false_ else true_ - | Bin (EqEqEq, e0, e1) -> { e with expression_desc = Bin (NotEqEq, e0, e1) } - | Bin (NotEqEq, e0, e1) -> { e with expression_desc = Bin (EqEqEq, e0, e1) } - | Bin (Lt, a, b) -> { e with expression_desc = Bin (Ge, a, b) } - | Bin (Ge, a, b) -> { e with expression_desc = Bin (Lt, a, b) } - | Bin (Le, a, b) -> { e with expression_desc = Bin (Gt, a, b) } - | Bin (Gt, a, b) -> { e with expression_desc = Bin (Le, a, b) } - | _ -> { expression_desc = Js_not e; comment = None } + | Bin (EqEqEq, e0, e1) -> {e with expression_desc = Bin (NotEqEq, e0, e1)} + | Bin (NotEqEq, e0, e1) -> {e with expression_desc = Bin (EqEqEq, e0, e1)} + | Bin (Lt, a, b) -> {e with expression_desc = Bin (Ge, a, b)} + | Bin (Ge, a, b) -> {e with expression_desc = Bin (Lt, a, b)} + | Bin (Le, a, b) -> {e with expression_desc = Bin (Gt, a, b)} + | Bin (Gt, a, b) -> {e with expression_desc = Bin (Le, a, b)} + | _ -> {expression_desc = Js_not e; comment = None} let not_empty_branch (x : t) = match x.expression_desc with - | Number (Int { i = 0l }) | Undefined _ -> false + | Number (Int {i = 0l}) | Undefined _ -> false | _ -> true let rec econd ?comment (pred : t) (ifso : t) (ifnot : t) : t = match (pred.expression_desc, ifso.expression_desc, ifnot.expression_desc) with | Bool false, _, _ -> ifnot - | Number (Int { i = 0l; _ }), _, _ -> ifnot + | Number (Int {i = 0l; _}), _, _ -> ifnot | (Number _ | Array _ | Caml_block _), _, _ when no_side_effect pred -> - ifso (* a block can not be false in OCAML, CF - relies on flow inference*) + ifso (* a block can not be false in OCAML, CF - relies on flow inference*) | Bool true, _, _ -> ifso | _, Cond (pred1, ifso1, ifnot1), _ when Js_analyzer.eq_expression ifnot1 ifnot -> - (* {[ - if b then (if p1 then branch_code0 else branch_code1) - else branch_code1 - ]} - is equivalent to - {[ - if b && p1 then branch_code0 else branch_code1 - ]} - *) - econd (and_ pred pred1) ifso1 ifnot + (* {[ + if b then (if p1 then branch_code0 else branch_code1) + else branch_code1 + ]} + is equivalent to + {[ + if b && p1 then branch_code0 else branch_code1 + ]} + *) + econd (and_ pred pred1) ifso1 ifnot | _, Cond (pred1, ifso1, ifnot1), _ when Js_analyzer.eq_expression ifso1 ifnot -> - econd (and_ pred (not pred1)) ifnot1 ifnot + econd (and_ pred (not pred1)) ifnot1 ifnot | _, _, Cond (pred1, ifso1, ifnot1) when Js_analyzer.eq_expression ifso ifso1 -> - econd (or_ pred pred1) ifso ifnot1 + econd (or_ pred pred1) ifso ifnot1 | _, _, Cond (pred1, ifso1, ifnot1) when Js_analyzer.eq_expression ifso ifnot1 -> - econd (or_ pred (not pred1)) ifso ifso1 + econd (or_ pred (not pred1)) ifso ifso1 | Js_not e, _, _ when not_empty_branch ifnot -> econd ?comment e ifnot ifso | ( _, - Seq (a, { expression_desc = Undefined _ }), - Seq (b, { expression_desc = Undefined _ }) ) -> - seq (econd ?comment pred a b) undefined + Seq (a, {expression_desc = Undefined _}), + Seq (b, {expression_desc = Undefined _}) ) -> + seq (econd ?comment pred a b) undefined | _ -> - if Js_analyzer.eq_expression ifso ifnot then - if no_side_effect pred then ifso else seq ?comment pred ifso - else { expression_desc = Cond (pred, ifso, ifnot); comment } + if Js_analyzer.eq_expression ifso ifnot then + if no_side_effect pred then ifso else seq ?comment pred ifso + else {expression_desc = Cond (pred, ifso, ifnot); comment} let rec float_equal ?comment (e0 : t) (e1 : t) : t = match (e0.expression_desc, e1.expression_desc) with - | Number (Int { i = i0; _ }), Number (Int { i = i1 }) -> bool (i0 = i1) + | Number (Int {i = i0; _}), Number (Int {i = i1}) -> bool (i0 = i1) | Undefined _, Undefined _ -> true_ (* | (Bin(Bor, {expression_desc = Number(Int {i = 0l; _})}, @@ -768,28 +799,27 @@ let rec float_equal ?comment (e0 : t) (e1 : t) : t = not a *) | ( ( Bin ( Bor, - { expression_desc = Number (Int { i = 0l; _ }) }, - ({ expression_desc = Caml_block_tag _; _ } as a) ) + {expression_desc = Number (Int {i = 0l; _})}, + ({expression_desc = Caml_block_tag _; _} as a) ) | Bin ( Bor, - ({ expression_desc = Caml_block_tag _; _ } as a), - { expression_desc = Number (Int { i = 0l; _ }) } ) ), + ({expression_desc = Caml_block_tag _; _} as a), + {expression_desc = Number (Int {i = 0l; _})} ) ), Number _ ) -> - (* for sure [i <> 0 ]*) - (* since a is integer, if we guarantee there is no overflow - of a - then [a | 0] is a nop unless a is undefined - (which is applicable when applied to tag), - obviously tag can not be overflowed. - if a is undefined, then [ a|0===0 ] is true - while [a === 0 ] is not true - [a|0 === non_zero] is false and [a===non_zero] is false - so we can not eliminate when the tag is zero - *) - float_equal ?comment a e1 - | Number (Float { f = f0; _ }), Number (Float { f = f1 }) when f0 = f1 -> - true_ - | _ -> { expression_desc = Bin (EqEqEq, e0, e1); comment } + (* for sure [i <> 0 ]*) + (* since a is integer, if we guarantee there is no overflow + of a + then [a | 0] is a nop unless a is undefined + (which is applicable when applied to tag), + obviously tag can not be overflowed. + if a is undefined, then [ a|0===0 ] is true + while [a === 0 ] is not true + [a|0 === non_zero] is false and [a===non_zero] is false + so we can not eliminate when the tag is zero + *) + float_equal ?comment a e1 + | Number (Float {f = f0; _}), Number (Float {f = f1}) when f0 = f1 -> true_ + | _ -> {expression_desc = Bin (EqEqEq, e0, e1); comment} let int_equal = float_equal @@ -809,16 +839,19 @@ let tag_type = function | Untagged BooleanType -> str "boolean" | Untagged FunctionType -> str "function" | Untagged StringType -> str "string" - | Untagged (InstanceType i) -> str (Ast_untagged_variants.Instance.to_string i) ~delim:DNoQuotes + | Untagged (InstanceType i) -> + str (Ast_untagged_variants.Instance.to_string i) ~delim:DNoQuotes | Untagged ObjectType -> str "object" | Untagged UnknownType -> (* TODO: this should not happen *) assert false -let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = match check with +let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = + match check with | TagType t -> tag_type t - | BinOp(op, x, y) -> - let op = match op with + | BinOp (op, x, y) -> + let op = + match op with | EqEqEq -> Js_op.EqEqEq | NotEqEq -> NotEqEq | And -> And @@ -833,21 +866,27 @@ let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = match che | Not x -> not (emit_check x) | Expr x -> x -let is_a_literal_case ~literal_cases ~block_cases (e:t) = - let check = Ast_untagged_variants.DynamicChecks.is_a_literal_case ~literal_cases ~block_cases (Expr e) in +let is_a_literal_case ~literal_cases ~block_cases (e : t) = + let check = + Ast_untagged_variants.DynamicChecks.is_a_literal_case ~literal_cases + ~block_cases (Expr e) + in emit_check check let is_int_tag ?has_null_undefined_other e = - let check = Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other (Expr e) in - emit_check check + let check = + Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other + (Expr e) + in + emit_check check (* we are calling [Caml_primitive.primitive_name], since it's under our control, we should make it follow the javascript name convention, and call plain [dot] *) -let tag ?comment ?(name=Js_dump_lit.tag) e : t = - { expression_desc = Caml_block_tag (e, name); comment } +let tag ?comment ?(name = Js_dump_lit.tag) e : t = + {expression_desc = Caml_block_tag (e, name); comment} (* according to the compiler, [Btype.hash_variant], it's reduced to 31 bits for hash @@ -865,23 +904,20 @@ let tag ?comment ?(name=Js_dump_lit.tag) e : t = let rec int32_bor ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i = i1 }), Number (Int { i = i2 }) -> - int ?comment (Int32.logor i1 i2) - | _, Bin (Lsr, e2, { expression_desc = Number (Int { i = 0l }); _ }) - -> - int32_bor e1 e2 - | Bin (Lsr, e1, { expression_desc = Number (Int { i = 0l }); _ }), _ - -> - int32_bor e1 e2 - | ( Bin (Lsr, _, { expression_desc = Number (Int { i }); _ }), - Number (Int { i = 0l }) ) + | Number (Int {i = i1}), Number (Int {i = i2}) -> + int ?comment (Int32.logor i1 i2) + | _, Bin (Lsr, e2, {expression_desc = Number (Int {i = 0l}); _}) -> + int32_bor e1 e2 + | Bin (Lsr, e1, {expression_desc = Number (Int {i = 0l}); _}), _ -> + int32_bor e1 e2 + | Bin (Lsr, _, {expression_desc = Number (Int {i}); _}), Number (Int {i = 0l}) when i > 0l -> - (* a >>> 3 | 0 -> a >>> 3 *) - e1 - | ( Bin (Bor, e1, { expression_desc = Number (Int { i = 0l }); _ }), - Number (Int { i = 0l }) ) -> - int32_bor e1 e2 - | _ -> { comment; expression_desc = Bin (Bor, e1, e2) } + (* a >>> 3 | 0 -> a >>> 3 *) + e1 + | ( Bin (Bor, e1, {expression_desc = Number (Int {i = 0l}); _}), + Number (Int {i = 0l}) ) -> + int32_bor e1 e2 + | _ -> {comment; expression_desc = Bin (Bor, e1, e2)} let to_int32 ?comment (e : J.expression) : J.expression = int32_bor ?comment e zero_int_literal @@ -889,16 +925,14 @@ let to_int32 ?comment (e : J.expression) : J.expression = let string_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = match (e0.expression_desc, e1.expression_desc) with - | Str { txt = a0; delim = d0 }, Str { txt = a1; delim = d1 } -> ( - match cmp, str_equal a0 d0 a1 d1 with - | Ceq, Some b -> bool b - | Cneq, Some b -> bool (b = false) - | _ -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) + | Str {txt = a0; delim = d0}, Str {txt = a1; delim = d1} -> ( + match (cmp, str_equal a0 d0 a1 d1) with + | Ceq, Some b -> bool b + | Cneq, Some b -> bool (b = false) + | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let string_equal ?comment (e0 : t) (e1 : t) : t = - string_comp Ceq ?comment e0 e1 +let string_equal ?comment (e0 : t) (e1 : t) : t = string_comp Ceq ?comment e0 e1 let is_type_number ?comment (e : t) : t = string_equal ?comment (typeof e) (str "number") @@ -909,7 +943,7 @@ let is_type_string ?comment (e : t) : t = let is_type_object (e : t) : t = string_equal (typeof e) (str "object") let obj_length ?comment e : t = - to_int32 { expression_desc = Length (e, Caml_block); comment } + to_int32 {expression_desc = Length (e, Caml_block); comment} let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = match cmp with @@ -922,56 +956,55 @@ let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = match (cmp, e0.expression_desc, e1.expression_desc) with - | _, Number ((Int { i = l })), Number ((Int { i = r })) -> - let l = Ext_int.int32_unsigned_to_int l in - let r = Int32.to_int r in - bool (compare_int_aux cmp l r) + | _, Number (Int {i = l}), Number (Int {i = r}) -> + let l = Ext_int.int32_unsigned_to_int l in + let r = Int32.to_int r in + bool (compare_int_aux cmp l r) | ( _, Call ( { - expression_desc = - Var (Qualified ({ kind = Runtime }, Some "compare")); + expression_desc = Var (Qualified ({kind = Runtime}, Some "compare")); _; }, - [ l; r ], + [l; r], _ ), - Number (Int { i = 0l }) ) -> - int_comp cmp l r (* = 0 > 0 < 0 *) + Number (Int {i = 0l}) ) -> + int_comp cmp l r (* = 0 > 0 < 0 *) | Ceq, Optional_block _, Undefined _ | Ceq, Undefined _, Optional_block _ -> - false_ + false_ | Ceq, _, _ -> int_equal e0 e1 | Cneq, Optional_block _, Undefined _ | Cneq, Undefined _, Optional_block _ | Cneq, Caml_block _, Number _ | Cneq, Number _, Caml_block _ -> - true_ + true_ | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = match (e0, e1) with - | { expression_desc = Bool l }, { expression_desc = Bool r } -> - bool - (match cmp with - | Ceq -> l = r - | Cneq -> l <> r - | Clt -> l < r - | Cgt -> l > r - | Cle -> l <= r - | Cge -> l >= r) - | { expression_desc = Bool true }, rest - | rest, { expression_desc = Bool false } -> ( - match cmp with - | Clt -> seq rest false_ - | Cge -> seq rest true_ - | Cle | Cgt | Ceq | Cneq -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) - | rest, { expression_desc = Bool true } - | { expression_desc = Bool false }, rest -> ( - match cmp with - | Cle -> seq rest true_ - | Cgt -> seq rest false_ - | Clt | Cge | Ceq | Cneq -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) + | {expression_desc = Bool l}, {expression_desc = Bool r} -> + bool + (match cmp with + | Ceq -> l = r + | Cneq -> l <> r + | Clt -> l < r + | Cgt -> l > r + | Cle -> l <= r + | Cge -> l >= r) + | {expression_desc = Bool true}, rest | rest, {expression_desc = Bool false} + -> ( + match cmp with + | Clt -> seq rest false_ + | Cge -> seq rest true_ + | Cle | Cgt | Ceq | Cneq -> + bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) + | rest, {expression_desc = Bool true} | {expression_desc = Bool false}, rest + -> ( + match cmp with + | Cle -> seq rest true_ + | Cgt -> seq rest false_ + | Clt | Cge | Ceq | Cneq -> + bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) | _, _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 let float_comp cmp ?comment e0 e1 = @@ -984,15 +1017,13 @@ let rec int32_lsr ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = let aux i1 i = int (Int32.shift_right_logical i1 i) in match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i = i1 }), Number (Int { i = i2 }) -> - aux i1 (Int32.to_int i2) - | Bin (Lsr, _, _), Number (Int { i = 0l }) -> - e1 (* TODO: more opportunities here *) - | ( Bin - (Bor, e1, { expression_desc = Number (Int { i = 0l; _ }); _ }), - Number (Int { i = 0l }) ) -> - int32_lsr ?comment e1 e2 - | _, _ -> { comment; expression_desc = Bin (Lsr, e1, e2) } + | Number (Int {i = i1}), Number (Int {i = i2}) -> aux i1 (Int32.to_int i2) + | Bin (Lsr, _, _), Number (Int {i = 0l}) -> + e1 (* TODO: more opportunities here *) + | ( Bin (Bor, e1, {expression_desc = Number (Int {i = 0l; _}); _}), + Number (Int {i = 0l}) ) -> + int32_lsr ?comment e1 e2 + | _, _ -> {comment; expression_desc = Bin (Lsr, e1, e2)} (* TODO: we can apply a more general optimization here, @@ -1000,40 +1031,39 @@ let rec int32_lsr ?comment (e1 : J.expression) (e2 : J.expression) : *) let rec is_out ?comment (e : t) (range : t) : t = match (range.expression_desc, e.expression_desc) with - | Number (Int { i = 1l }), Var _ -> - not - (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal)) - | ( Number (Int { i = 1l }), + | Number (Int {i = 1l}), Var _ -> + not (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal)) + | ( Number (Int {i = 1l}), ( Bin ( Plus, - { expression_desc = Number (Int { i; _ }) }, - ({ expression_desc = Var _; _ } as x) ) + {expression_desc = Number (Int {i; _})}, + ({expression_desc = Var _; _} as x) ) | Bin ( Plus, - ({ expression_desc = Var _; _ } as x), - { expression_desc = Number (Int { i; _ }) } ) ) ) -> - not - (or_ - (triple_equal x (int (Int32.neg i))) - (triple_equal x (int (Int32.sub Int32.one i)))) - | ( Number (Int { i = 1l }), + ({expression_desc = Var _; _} as x), + {expression_desc = Number (Int {i; _})} ) ) ) -> + not + (or_ + (triple_equal x (int (Int32.neg i))) + (triple_equal x (int (Int32.sub Int32.one i)))) + | ( Number (Int {i = 1l}), Bin ( Minus, - ({ expression_desc = Var _; _ } as x), - { expression_desc = Number (Int { i; _ }) } ) ) -> - not (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) + ({expression_desc = Var _; _} as x), + {expression_desc = Number (Int {i; _})} ) ) -> + not (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) (* (x - i >>> 0 ) > k *) - | ( Number (Int { i = k }), + | ( Number (Int {i = k}), Bin ( Minus, - ({ expression_desc = Var _; _ } as x), - { expression_desc = Number (Int { i; _ }) } ) ) -> - or_ (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) - | Number (Int { i = k }), Var _ -> - (* Note that js support [ 1 < x < 3], - we can optimize it into [ not ( 0<= x <= k)] - *) - or_ (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) + ({expression_desc = Var _; _} as x), + {expression_desc = Number (Int {i; _})} ) ) -> + or_ (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) + | Number (Int {i = k}), Var _ -> + (* Note that js support [ 1 < x < 3], + we can optimize it into [ not ( 0<= x <= k)] + *) + or_ (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) | ( _, Bin ( Bor, @@ -1041,29 +1071,27 @@ let rec is_out ?comment (e : t) (range : t) : t = expression_desc = ( Bin ( (Plus | Minus), - { expression_desc = Number (Int { i = _; _ }) }, - { expression_desc = Var _; _ } ) + {expression_desc = Number (Int {i = _; _})}, + {expression_desc = Var _; _} ) | Bin ( (Plus | Minus), - { expression_desc = Var _; _ }, - { expression_desc = Number (Int { i = _; _ }) } ) ); + {expression_desc = Var _; _}, + {expression_desc = Number (Int {i = _; _})} ) ); } as e), - { expression_desc = Number (Int { i = 0l }); _ } ) ) -> - (* TODO: check correctness *) - is_out ?comment e range - | _, _ -> - int_comp ?comment Cgt e range + {expression_desc = Number (Int {i = 0l}); _} ) ) -> + (* TODO: check correctness *) + is_out ?comment e range + | _, _ -> int_comp ?comment Cgt e range let rec float_add ?comment (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i; _ }), Number (Int { i = j; _ }) -> - int ?comment (Int32.add i j) - | _, Number (Int { i = j; c }) when j < 0l -> - float_minus ?comment e1 - { e2 with expression_desc = Number (Int { i = Int32.neg j; c }) } - | ( Bin (Plus, a1, { expression_desc = Number (Int { i = k; _ }) }), - Number (Int { i = j; _ }) ) -> - { comment; expression_desc = Bin (Plus, a1, int (Int32.add k j)) } + | Number (Int {i; _}), Number (Int {i = j; _}) -> int ?comment (Int32.add i j) + | _, Number (Int {i = j; c}) when j < 0l -> + float_minus ?comment e1 + {e2 with expression_desc = Number (Int {i = Int32.neg j; c})} + | ( Bin (Plus, a1, {expression_desc = Number (Int {i = k; _})}), + Number (Int {i = j; _}) ) -> + {comment; expression_desc = Bin (Plus, a1, int (Int32.add k j))} (* bin ?comment Plus a1 (int (k + j)) *) (* TODO remove commented code ?? *) (* | Bin(Plus, a0 , ({expression_desc = Number (Int a1)} )), *) @@ -1081,15 +1109,14 @@ let rec float_add ?comment (e1 : t) (e2 : t) = (* | Number _, _ *) (* -> *) (* bin ?comment Plus e2 e1 *) - | _ -> { comment; expression_desc = Bin (Plus, e1, e2) } + | _ -> {comment; expression_desc = Bin (Plus, e1, e2)} (* bin ?comment Plus e1 e2 *) (* associative is error prone due to overflow *) and float_minus ?comment (e1 : t) (e2 : t) : t = match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i; _ }), Number (Int { i = j; _ }) -> - int ?comment (Int32.sub i j) - | _ -> { comment; expression_desc = Bin (Minus, e1, e2) } + | Number (Int {i; _}), Number (Int {i = j; _}) -> int ?comment (Int32.sub i j) + | _ -> {comment; expression_desc = Bin (Minus, e1, e2)} (* bin ?comment Minus e1 e2 *) let unchecked_int32_add ?comment e1 e2 = float_add ?comment e1 e2 @@ -1108,36 +1135,36 @@ let float_div ?comment e1 e2 = bin ?comment Div e1 e2 let float_notequal ?comment e1 e2 = bin ?comment NotEqEq e1 e2 let int32_asr ?comment e1 e2 : J.expression = - { comment; expression_desc = Bin (Asr, e1, e2) } + {comment; expression_desc = Bin (Asr, e1, e2)} (** Division by zero is undefined behavior*) let int32_div ~checked ?comment (e1 : t) (e2 : t) : t = match (e1.expression_desc, e2.expression_desc) with - | Length _, Number (Int { i = 2l }) -> int32_asr e1 one_int_literal - | e1_desc, Number (Int { i = i1 }) when i1 <> 0l -> ( - match e1_desc with - | Number (Int { i = i0 }) -> int (Int32.div i0 i1) - | _ -> to_int32 (float_div ?comment e1 e2)) + | Length _, Number (Int {i = 2l}) -> int32_asr e1 one_int_literal + | e1_desc, Number (Int {i = i1}) when i1 <> 0l -> ( + match e1_desc with + | Number (Int {i = i0}) -> int (Int32.div i0 i1) + | _ -> to_int32 (float_div ?comment e1 e2)) | _, _ -> - if checked then runtime_call Primitive_modules.int "div" [ e1; e2 ] - else to_int32 (float_div ?comment e1 e2) + if checked then runtime_call Primitive_modules.int "div" [e1; e2] + else to_int32 (float_div ?comment e1 e2) let int32_mod ~checked ?comment e1 (e2 : t) : J.expression = match e2.expression_desc with - | Number (Int { i }) when i <> 0l -> - { comment; expression_desc = Bin (Mod, e1, e2) } + | Number (Int {i}) when i <> 0l -> + {comment; expression_desc = Bin (Mod, e1, e2)} | _ -> - if checked then runtime_call Primitive_modules.int "mod_" [ e1; e2 ] - else { comment; expression_desc = Bin (Mod, e1, e2) } + if checked then runtime_call Primitive_modules.int "mod_" [e1; e2] + else {comment; expression_desc = Bin (Mod, e1, e2)} let float_mul ?comment e1 e2 = bin ?comment Mul e1 e2 let int32_lsl ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = match (e1, e2) with - | ( { expression_desc = Number (Int { i = i0 }) }, - { expression_desc = Number (Int { i = i1 }) } ) -> - int ?comment (Int32.shift_left i0 (Int32.to_int i1)) - | _ -> { comment; expression_desc = Bin (Lsl, e1, e2) } + | ( {expression_desc = Number (Int {i = i0})}, + {expression_desc = Number (Int {i = i1})} ) -> + int ?comment (Int32.shift_left i0 (Int32.to_int i1)) + | _ -> {comment; expression_desc = Bin (Lsl, e1, e2)} let is_pos_pow n = let exception E in @@ -1151,95 +1178,91 @@ let is_pos_pow n = let int32_mul ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = match (e1, e2) with - | { expression_desc = Number (Int { i = 0l }); _ }, x + | {expression_desc = Number (Int {i = 0l}); _}, x when Js_analyzer.no_side_effect_expression x -> - zero_int_literal - | x, { expression_desc = Number (Int { i = 0l }); _ } + zero_int_literal + | x, {expression_desc = Number (Int {i = 0l}); _} when Js_analyzer.no_side_effect_expression x -> - zero_int_literal - | ( { expression_desc = Number (Int { i = i0 }); _ }, - { expression_desc = Number (Int { i = i1 }); _ } ) -> - int (Int32.mul i0 i1) - | e, { expression_desc = Number (Int { i = i0 }); _ } - | { expression_desc = Number (Int { i = i0 }); _ }, e -> - let i = is_pos_pow i0 in - if i >= 0 then int32_lsl e (small_int i) - else - call ?comment ~info:Js_call_info.builtin_runtime_call - (dot (js_global "Math") Literals.imul) - [ e1; e2 ] - | _ -> + zero_int_literal + | ( {expression_desc = Number (Int {i = i0}); _}, + {expression_desc = Number (Int {i = i1}); _} ) -> + int (Int32.mul i0 i1) + | e, {expression_desc = Number (Int {i = i0}); _} + | {expression_desc = Number (Int {i = i0}); _}, e -> + let i = is_pos_pow i0 in + if i >= 0 then int32_lsl e (small_int i) + else call ?comment ~info:Js_call_info.builtin_runtime_call (dot (js_global "Math") Literals.imul) - [ e1; e2 ] + [e1; e2] + | _ -> + call ?comment ~info:Js_call_info.builtin_runtime_call + (dot (js_global "Math") Literals.imul) + [e1; e2] let unchecked_int32_mul ?comment e1 e2 : J.expression = - { comment; expression_desc = Bin (Mul, e1, e2) } + {comment; expression_desc = Bin (Mul, e1, e2)} let rec int32_bxor ?comment (e1 : t) (e2 : t) : J.expression = match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i = i1 }), Number (Int { i = i2 }) -> - int ?comment (Int32.logxor i1 i2) - | _, Bin (Lsr, e2, { expression_desc = Number (Int { i = 0l }); _ }) - -> - int32_bxor e1 e2 - | Bin (Lsr, e1, { expression_desc = Number (Int { i = 0l }); _ }), _ - -> - int32_bxor e1 e2 - | _ -> { comment; expression_desc = Bin (Bxor, e1, e2) } + | Number (Int {i = i1}), Number (Int {i = i2}) -> + int ?comment (Int32.logxor i1 i2) + | _, Bin (Lsr, e2, {expression_desc = Number (Int {i = 0l}); _}) -> + int32_bxor e1 e2 + | Bin (Lsr, e1, {expression_desc = Number (Int {i = 0l}); _}), _ -> + int32_bxor e1 e2 + | _ -> {comment; expression_desc = Bin (Bxor, e1, e2)} let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = match e1.expression_desc with - | Bin (Bor, a, { expression_desc = Number (Int { i = 0l }) }) -> - (* Note that in JS - {[ -1 >>> 0 & 0xffffffff = -1]} is the same as - {[ (-1 >>> 0 | 0 ) & 0xffffff ]} - *) - int32_band a e2 - | _ -> { comment; expression_desc = Bin (Band, e1, e2) } + | Bin (Bor, a, {expression_desc = Number (Int {i = 0l})}) -> + (* Note that in JS + {[ -1 >>> 0 & 0xffffffff = -1]} is the same as + {[ (-1 >>> 0 | 0 ) & 0xffffff ]} + *) + int32_band a e2 + | _ -> {comment; expression_desc = Bin (Band, e1, e2)} (* let int32_bin ?comment op e1 e2 : J.expression = *) (* {expression_desc = Int32_bin(op,e1, e2); comment} *) -let bigint_op ?comment op (e1: t) (e2: t) = bin ?comment op e1 e2 +let bigint_op ?comment op (e1 : t) (e2 : t) = bin ?comment op e1 e2 -let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0: t) (e1: t) = +let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = let normalize s = let len = String.length s in let buf = Buffer.create len in let trim = ref false in - s |> String.iteri (fun i c -> ( - match (c, i, !trim) with - | ('0', 0, _) -> trim := true - | ('0', _, true) -> () - | ('_', _, _) -> () - | _ -> ( - trim := false; - Buffer.add_char buf c - ) - )); + s + |> String.iteri (fun i c -> + match (c, i, !trim) with + | '0', 0, _ -> trim := true + | '0', _, true -> () + | '_', _, _ -> () + | _ -> + trim := false; + Buffer.add_char buf c); buf |> Buffer.to_bytes |> Bytes.to_string in match (cmp, e0.expression_desc, e1.expression_desc) with - | Ceq, Number (BigInt { positive = p1; value = v1 }), Number (BigInt { positive = p2; value = v2 }) -> + | ( Ceq, + Number (BigInt {positive = p1; value = v1}), + Number (BigInt {positive = p2; value = v2}) ) -> bool (p1 = p2 && String.equal (normalize v1) (normalize v2)) - | Cneq, Number (BigInt { positive = p1; value = v1 }), Number (BigInt { positive = p2; value = v2 }) -> + | ( Cneq, + Number (BigInt {positive = p1; value = v1}), + Number (BigInt {positive = p2; value = v2}) ) -> not (bool (p1 = p2 && String.equal (normalize v1) (normalize v2))) - | _ -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 + | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let bigint_div ~checked ?comment (e0: t) (e1: t) = - if checked then - runtime_call Primitive_modules.bigint "div" [e0; e1] - else - bigint_op ?comment Div e0 e1 +let bigint_div ~checked ?comment (e0 : t) (e1 : t) = + if checked then runtime_call Primitive_modules.bigint "div" [e0; e1] + else bigint_op ?comment Div e0 e1 -let bigint_mod ~checked ?comment (e0: t) (e1: t) = - if checked then - runtime_call Primitive_modules.bigint "mod_" [e0; e1] - else - bigint_op ?comment Mod e0 e1 +let bigint_mod ~checked ?comment (e0 : t) (e1 : t) = + if checked then runtime_call Primitive_modules.bigint "mod_" [e0; e1] + else bigint_op ?comment Mod e0 e1 (* TODO -- alpha conversion remember to add parens.. @@ -1259,8 +1282,7 @@ let of_block ?comment ?e block : t = (match e with | None -> block | Some e -> - Ext_list.append block - [ { J.statement_desc = Return e; comment } ]); + Ext_list.append block [{J.statement_desc = Return e; comment}]); env = Js_fun_env.make 0; return_unit; async = false; @@ -1273,43 +1295,45 @@ let is_null ?comment (x : t) = triple_equal ?comment x nil let is_undef ?comment x = triple_equal ?comment x undefined let for_sure_js_null_undefined (x : t) = - match x.expression_desc with Null | Undefined _ -> true | _ -> false + match x.expression_desc with + | Null | Undefined _ -> true + | _ -> false let is_null_undefined ?comment (x : t) : t = match x.expression_desc with | Null | Undefined _ -> true_ | Number _ | Array _ | Caml_block _ -> false_ - | _ -> { comment; expression_desc = Is_null_or_undefined x } + | _ -> {comment; expression_desc = Is_null_or_undefined x} let eq_null_undefined_boolean ?comment (a : t) (b : t) = match (a.expression_desc, b.expression_desc) with | ( (Null | Undefined _), (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _) ) -> - false_ + false_ | ( (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _), (Null | Undefined _) ) -> - false_ + false_ | Null, Undefined _ | Undefined _, Null -> false_ | Null, Null | Undefined _, Undefined _ -> true_ - | _ -> { expression_desc = Bin (EqEqEq, a, b); comment } + | _ -> {expression_desc = Bin (EqEqEq, a, b); comment} let neq_null_undefined_boolean ?comment (a : t) (b : t) = match (a.expression_desc, b.expression_desc) with | ( (Null | Undefined _), (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _) ) -> - true_ + true_ | ( (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _), (Null | Undefined _) ) -> - true_ + true_ | Null, Null | Undefined _, Undefined _ -> false_ | Null, Undefined _ | Undefined _, Null -> true_ - | _ -> { expression_desc = Bin (NotEqEq, a, b); comment } + | _ -> {expression_desc = Bin (NotEqEq, a, b); comment} let make_exception (s : string) = - pure_runtime_call Primitive_modules.exceptions Literals.create [ str s ] + pure_runtime_call Primitive_modules.exceptions Literals.create [str s] let rec variadic_args (args : t list) = match args with | [] -> [] - | [last] -> [{ last with expression_desc = Spread last }] + | [last] -> [{last with expression_desc = Spread last}] | arg :: args -> arg :: variadic_args args diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 99bbca10d5..0c6d9fe5f3 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -49,7 +49,8 @@ val runtime_var_dot : ?comment:string -> string -> string -> t (* val runtime_var_vid : string -> string -> J.vident *) -val ml_var_dot : ?comment:string -> ?dynamic_import:bool -> Ident.t -> string -> t +val ml_var_dot : + ?comment:string -> ?dynamic_import:bool -> Ident.t -> string -> t (** [ml_var_dot ocaml_module name] *) @@ -65,7 +66,12 @@ val external_var_field : Used in FFI *) -val external_var : ?import_attributes:External_ffi_types.import_attributes -> ?comment:string -> external_name:string -> Ident.t -> t +val external_var : + ?import_attributes:External_ffi_types.import_attributes -> + ?comment:string -> + external_name:string -> + Ident.t -> + t val ml_module_as_var : ?comment:string -> ?dynamic_import:bool -> Ident.t -> t @@ -83,7 +89,7 @@ val pure_runtime_call : val runtime_ref : string -> string -> t -val str : ?delim: J.delim -> ?comment: string -> string -> t +val str : ?delim:J.delim -> ?comment:string -> string -> t val ocaml_fun : ?comment:string -> @@ -209,9 +215,13 @@ val neq_null_undefined_boolean : ?comment:string -> t -> t -> t val is_type_number : ?comment:string -> t -> t -val is_int_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t +val is_int_tag : ?has_null_undefined_other:bool * bool * bool -> t -> t -val is_a_literal_case : literal_cases:Ast_untagged_variants.tag_type list -> block_cases:Ast_untagged_variants.block_type list -> t -> t +val is_a_literal_case : + literal_cases:Ast_untagged_variants.tag_type list -> + block_cases:Ast_untagged_variants.block_type list -> + t -> + t val is_type_string : ?comment:string -> t -> t @@ -273,7 +283,7 @@ val string_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t val float_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t -val bigint_op : ?comment: string -> Js_op.binop -> t -> t -> t +val bigint_op : ?comment:string -> Js_op.binop -> t -> t -> t val bigint_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t diff --git a/compiler/core/js_fold.ml b/compiler/core/js_fold.ml index 93f4b77139..c8d50669f2 100644 --- a/compiler/core/js_fold.ml +++ b/compiler/core/js_fold.ml @@ -27,14 +27,16 @@ open J let[@inline] unknown _self _ = _self let[@inline] option sub self v = - match v with None -> self | Some x -> sub self x + match v with + | None -> self + | Some x -> sub self x let rec list (sub : 'self_type -> 'a -> 'self_type) self v = match v with | [] -> self | x :: xs -> - let self = sub self x in - list sub self xs + let self = sub self x in + list sub self xs class fold = object (_self : 'self_type) @@ -43,14 +45,14 @@ class fold = fun _f_a -> function | [] -> _self | _x :: _x_i1 -> - let _self = _f_a _self _x in - let _self = _self#list _f_a _x_i1 in - _self + let _self = _f_a _self _x in + let _self = _self#list _f_a _x_i1 in + _self method ident : ident -> 'self_type = unknown _self method module_id : module_id -> 'self_type = - fun { id = _x0; kind = _x1 } -> + fun {id = _x0; kind = _x1} -> let _self = _self#ident _x0 in _self @@ -60,11 +62,11 @@ class fold = method vident : vident -> 'self_type = function | Id _x0 -> - let _self = _self#ident _x0 in - _self + let _self = _self#ident _x0 in + _self | Qualified (_x0, _x1) -> - let _self = _self#module_id _x0 in - _self + let _self = _self#module_id _x0 in + _self method exception_ident : exception_ident -> 'self_type = _self#ident @@ -84,95 +86,95 @@ class fold = method expression_desc : expression_desc -> 'self_type = function | Length (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#length_object _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#length_object _x1 in + _self | Is_null_or_undefined _x0 -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | String_append (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#expression _x1 in + _self | Bool _ -> _self | Typeof _x0 -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | Js_not _x0 -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | Seq (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#expression _x1 in + _self | Cond (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - let _self = _self#expression _x2 in - _self + let _self = _self#expression _x0 in + let _self = _self#expression _x1 in + let _self = _self#expression _x2 in + _self | Bin (_x0, _x1, _x2) -> - let _self = _self#expression _x1 in - let _self = _self#expression _x2 in - _self + let _self = _self#expression _x1 in + let _self = _self#expression _x2 in + _self | FlatCall (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#expression _x1 in + _self | Call (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#expression) _self _x1 in - _self + let _self = _self#expression _x0 in + let _self = list (fun _self -> _self#expression) _self _x1 in + _self | Tagged_template (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#expression) _self _x1 in - let _self = list (fun _self -> _self#expression) _self _x2 in - _self + let _self = _self#expression _x0 in + let _self = list (fun _self -> _self#expression) _self _x1 in + let _self = list (fun _self -> _self#expression) _self _x2 in + _self | String_index (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#expression _x1 in + _self | Array_index (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#expression _x1 in + _self | Static_index (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | New (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = - option - (fun _self -> list (fun _self -> _self#expression) _self) - _self _x1 - in - _self + let _self = _self#expression _x0 in + let _self = + option + (fun _self -> list (fun _self -> _self#expression) _self) + _self _x1 + in + _self | Var _x0 -> - let _self = _self#vident _x0 in - _self - | Fun {params=x1; body=x2} -> - let _self = list (fun _self -> _self#ident) _self x1 in - let _self = _self#block x2 in - _self + let _self = _self#vident _x0 in + _self + | Fun {params = x1; body = x2} -> + let _self = list (fun _self -> _self#ident) _self x1 in + let _self = _self#block x2 in + _self | Str _ -> _self | Raw_js_code _ -> _self | Array (_x0, _x1) -> - let _self = list (fun _self -> _self#expression) _self _x0 in - _self + let _self = list (fun _self -> _self#expression) _self _x0 in + _self | Optional_block (_x0, _x1) -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | Caml_block (_x0, _x1, _x2, _x3) -> - let _self = list (fun _self -> _self#expression) _self _x0 in - let _self = _self#expression _x2 in - _self + let _self = list (fun _self -> _self#expression) _self _x0 in + let _self = _self#expression _x2 in + _self | Caml_block_tag (_x0, _tag) -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | Number _ -> _self | Object (_x0, _x1) -> - let _self = option (fun _self -> _self#expression) _self _x0 in - let _self = _self#property_map _x1 in - _self + let _self = option (fun _self -> _self#expression) _self _x0 in + let _self = _self#property_map _x1 in + _self | Undefined _ -> _self | Null -> _self | Await _x0 -> @@ -189,7 +191,7 @@ class fold = _self#expression method case_clause : case_clause -> 'self_type = - fun { switch_body = _x0; should_break = _x1; comment = _x2 } -> + fun {switch_body = _x0; should_break = _x1; comment = _x2} -> let _self = _self#block _x0 in _self @@ -206,76 +208,76 @@ class fold = method statement_desc : statement_desc -> 'self_type = function | Block _x0 -> - let _self = _self#block _x0 in - _self + let _self = _self#block _x0 in + _self | Variable _x0 -> - let _self = _self#variable_declaration _x0 in - _self + let _self = _self#variable_declaration _x0 in + _self | Exp _x0 -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | If (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = _self#block _x1 in - let _self = _self#block _x2 in - _self + let _self = _self#expression _x0 in + let _self = _self#block _x1 in + let _self = _self#block _x2 in + _self | While (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#block _x1 in - _self + let _self = _self#expression _x0 in + let _self = _self#block _x1 in + _self | ForRange (_x0, _x1, _x2, _x3, _x4) -> - let _self = - option (fun _self -> _self#for_ident_expression) _self _x0 - in - let _self = _self#finish_ident_expression _x1 in - let _self = _self#for_ident _x2 in - let _self = _self#for_direction _x3 in - let _self = _self#block _x4 in - _self + let _self = + option (fun _self -> _self#for_ident_expression) _self _x0 + in + let _self = _self#finish_ident_expression _x1 in + let _self = _self#for_ident _x2 in + let _self = _self#for_direction _x3 in + let _self = _self#block _x4 in + _self | Continue -> _self | Break -> _self | Return _x0 -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | Int_switch (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#int_clause) _self _x1 in - let _self = option (fun _self -> _self#block) _self _x2 in - _self + let _self = _self#expression _x0 in + let _self = list (fun _self -> _self#int_clause) _self _x1 in + let _self = option (fun _self -> _self#block) _self _x2 in + _self | String_switch (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#string_clause) _self _x1 in - let _self = option (fun _self -> _self#block) _self _x2 in - _self + let _self = _self#expression _x0 in + let _self = list (fun _self -> _self#string_clause) _self _x1 in + let _self = option (fun _self -> _self#block) _self _x2 in + _self | Throw _x0 -> - let _self = _self#expression _x0 in - _self + let _self = _self#expression _x0 in + _self | Try (_x0, _x1, _x2) -> - let _self = _self#block _x0 in - let _self = - option - (fun _self (_x0, _x1) -> - let _self = _self#exception_ident _x0 in - let _self = _self#block _x1 in - _self) - _self _x1 - in - let _self = option (fun _self -> _self#block) _self _x2 in - _self + let _self = _self#block _x0 in + let _self = + option + (fun _self (_x0, _x1) -> + let _self = _self#exception_ident _x0 in + let _self = _self#block _x1 in + _self) + _self _x1 + in + let _self = option (fun _self -> _self#block) _self _x2 in + _self | Debugger -> _self method expression : expression -> 'self_type = - fun { expression_desc = _x0; comment = _x1 } -> + fun {expression_desc = _x0; comment = _x1} -> let _self = _self#expression_desc _x0 in _self method statement : statement -> 'self_type = - fun { statement_desc = _x0; comment = _x1 } -> + fun {statement_desc = _x0; comment = _x1} -> let _self = _self#statement_desc _x0 in _self method variable_declaration : variable_declaration -> 'self_type = - fun { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> + fun {ident = _x0; value = _x1; property = _x2; ident_info = _x3} -> let _self = _self#ident _x0 in let _self = option (fun _self -> _self#expression) _self _x1 in _self @@ -284,14 +286,13 @@ class fold = list (fun _self -> _self#statement) _self method program : program -> 'self_type = - fun { block = _x0; exports = _x1; export_set = _x2 } -> + fun {block = _x0; exports = _x1; export_set = _x2} -> let _self = _self#block _x0 in _self method deps_program : deps_program -> 'self_type = - fun { program = _x0; modules = _x1; side_effect = _x2 } -> + fun {program = _x0; modules = _x1; side_effect = _x2} -> let _self = _self#program _x0 in let _self = _self#required_modules _x1 in _self end - \ No newline at end of file diff --git a/compiler/core/js_fold_basic.ml b/compiler/core/js_fold_basic.ml index e86029b4f2..b4974cec93 100644 --- a/compiler/core/js_fold_basic.ml +++ b/compiler/core/js_fold_basic.ml @@ -36,8 +36,8 @@ let count_hard_dependencies hard_dependencies = (fun self x -> (match Js_block_runtime.check_additional_id x with | Some id -> - add_lam_module_ident hard_dependencies - (Lam_module_ident.of_runtime id) + add_lam_module_ident hard_dependencies + (Lam_module_ident.of_runtime id) | _ -> ()); super.expression self x); } diff --git a/compiler/core/js_fun_env.ml b/compiler/core/js_fun_env.ml index e90ba5ee00..58197517a0 100644 --- a/compiler/core/js_fun_env.ml +++ b/compiler/core/js_fun_env.ml @@ -43,9 +43,9 @@ type immutable_mask = | Immutable_mask of bool array type t = { - mutable unbounded : Set_ident.t; - used_mask : bool array; - immutable_mask : immutable_mask; + mutable unbounded: Set_ident.t; + used_mask: bool array; + immutable_mask: immutable_mask; } (** Invariant: unused param has to be immutable *) @@ -80,8 +80,7 @@ let get_mutable_params (params : Ident.t list) (x : t) = match x.immutable_mask with | All_immutable_and_no_tail_call -> [] | Immutable_mask xs -> - Ext_list.filter_mapi params (fun p i -> - if not xs.(i) then Some p else None) + Ext_list.filter_mapi params (fun p i -> if not xs.(i) then Some p else None) let get_unbounded t = t.unbounded diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 9bf84c8264..e097d6141a 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -51,11 +51,11 @@ let after_parsing_sig ppf outputprefix ast = output_deps_set !Location.input_name (Ast_extract.read_parse_and_extract Mli ast); (if !Js_config.binary_ast then - let sourcefile = !Location.input_name in - Binary_ast.write_ast Mli ~sourcefile - ~output:(outputprefix ^ Literals.suffix_iast) - (* to support relocate to another directory *) - ast); + let sourcefile = !Location.input_name in + Binary_ast.write_ast Mli ~sourcefile + ~output:(outputprefix ^ Literals.suffix_iast) + (* to support relocate to another directory *) + ast); if !Js_config.as_pp then ( output_string stdout Config.ast_intf_magic_number; output_value stdout (!Location.input_name : string); @@ -104,27 +104,27 @@ let interface_mliast ppf fname = |> after_parsing_sig ppf (Config_util.output_prefix fname) let all_module_alias (ast : Parsetree.structure) = - Ext_list.for_all ast (fun { pstr_desc } -> + Ext_list.for_all ast (fun {pstr_desc} -> match pstr_desc with - | Pstr_module { pmb_expr = { pmod_desc = Pmod_ident _ } } -> true + | Pstr_module {pmb_expr = {pmod_desc = Pmod_ident _}} -> true | Pstr_attribute _ -> true | Pstr_eval _ | Pstr_value _ | Pstr_primitive _ | Pstr_type _ | Pstr_typext _ | Pstr_exception _ | Pstr_module _ | Pstr_recmodule _ | Pstr_modtype _ | Pstr_open _ | Pstr_class _ | Pstr_class_type _ | Pstr_include _ | Pstr_extension _ -> - false) + false) let no_export (rest : Parsetree.structure) : Parsetree.structure = match rest with | head :: _ -> - let loc = head.pstr_loc in - Ast_helper. - [ - Str.include_ ~loc - (Incl.mk ~loc - (Mod.constraint_ ~loc (Mod.structure ~loc rest) - (Mty.signature ~loc []))); - ] + let loc = head.pstr_loc in + Ast_helper. + [ + Str.include_ ~loc + (Incl.mk ~loc + (Mod.constraint_ ~loc (Mod.structure ~loc rest) + (Mty.signature ~loc []))); + ] | _ -> rest let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = @@ -137,10 +137,10 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = output_deps_set !Location.input_name (Ast_extract.read_parse_and_extract Ml ast); (if !Js_config.binary_ast then - let sourcefile = !Location.input_name in - Binary_ast.write_ast ~sourcefile Ml - ~output:(outputprefix ^ Literals.suffix_ast) - ast); + let sourcefile = !Location.input_name in + Binary_ast.write_ast ~sourcefile Ml + ~output:(outputprefix ^ Literals.suffix_ast) + ast); if !Js_config.as_pp then ( output_string stdout Config.ast_impl_magic_number; output_value stdout (!Location.input_name : string); @@ -160,16 +160,16 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = print_if ppf Clflags.dump_typedtree Printtyped.implementation_with_coercion typedtree_coercion; (if !Js_config.cmi_only then Warnings.check_fatal () - else - let lambda, exports = - Translmod.transl_implementation modulename typedtree_coercion - in - let js_program = - print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda - |> Lam_compile_main.compile outputprefix exports - in - if not !Js_config.cmj_only then - Lam_compile_main.lambda_as_module js_program outputprefix); + else + let lambda, exports = + Translmod.transl_implementation modulename typedtree_coercion + in + let js_program = + print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda + |> Lam_compile_main.compile outputprefix exports + in + if not !Js_config.cmj_only then + Lam_compile_main.lambda_as_module js_program outputprefix); process_with_gentype (outputprefix ^ ".cmt")) let implementation ~parser ppf ?outputprefix fname = @@ -198,8 +198,8 @@ let make_structure_item ~ns cunit : Parsetree.structure_item = let open Ast_helper in let loc = Location.none in Str.module_ - (Mb.mk { txt = cunit; loc } - (Mod.ident { txt = Lident (Ext_namespace_encode.make ~ns cunit); loc })) + (Mb.mk {txt = cunit; loc} + (Mod.ident {txt = Lident (Ext_namespace_encode.make ~ns cunit); loc})) (** decoding [.mlmap] keep in sync {!Bsb_namespace_map_gen.output} diff --git a/compiler/core/js_implementation.mli b/compiler/core/js_implementation.mli index c86fe4c688..3b97cf23db 100644 --- a/compiler/core/js_implementation.mli +++ b/compiler/core/js_implementation.mli @@ -35,8 +35,7 @@ val interface : it will be useful if we don't care about bytecode output(generating js only). *) -val interface_mliast : - Format.formatter -> string -> unit +val interface_mliast : Format.formatter -> string -> unit (* val after_parsing_impl : Format.formatter -> @@ -56,7 +55,6 @@ val implementation : unit (** [implementation ppf sourcefile outprefix] compiles to JS directly *) -val implementation_mlast : - Format.formatter -> string -> unit +val implementation_mlast : Format.formatter -> string -> unit val implementation_map : Format.formatter -> string -> unit diff --git a/compiler/core/js_of_lam_block.ml b/compiler/core/js_of_lam_block.ml index b665462d80..9bb1a0b2c3 100644 --- a/compiler/core/js_of_lam_block.ml +++ b/compiler/core/js_of_lam_block.ml @@ -28,23 +28,22 @@ module E = Js_exp_make about immutablility *) let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args = - match tag_info with _ -> E.make_block tag tag_info args mutable_flag + match tag_info with + | _ -> E.make_block tag tag_info args mutable_flag let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = match field_info with | Fld_tuple | Fld_array -> - E.array_index_by_int - ?comment:(Lam_compat.str_of_field_info field_info) - e i + E.array_index_by_int ?comment:(Lam_compat.str_of_field_info field_info) e i | Fld_poly_var_content -> E.poly_var_value_access e | Fld_poly_var_tag -> E.poly_var_tag_access e - | Fld_record_extension { name } -> E.extension_access e (Some name) i + | Fld_record_extension {name} -> E.extension_access e (Some name) i | Fld_extension -> E.extension_access e None i | Fld_variant -> E.variant_access e i | Fld_cons -> E.cons_access e i - | Fld_record_inline { name } -> E.inline_record_access e name i - | Fld_record { name } -> E.record_access e name i - | Fld_module { name } -> E.module_access e name i + | Fld_record_inline {name} -> E.inline_record_access e name i + | Fld_record {name} -> E.record_access e name i + | Fld_module {name} -> E.module_access e name i let field_by_exp e i = E.array_index e i @@ -52,7 +51,7 @@ let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 = match field_info with | Fld_record_extension_set name -> E.extension_assign e i name e0 | Fld_record_inline_set name | Fld_record_set name -> - E.record_assign e i name e0 + E.record_assign e i name e0 (* This dynamism commes from oo compilaton, it should not happen in record *) let set_field_by_exp self index value = E.assign_by_exp self index value diff --git a/compiler/core/js_of_lam_option.ml b/compiler/core/js_of_lam_option.ml index 7660846caf..76feff95ec 100644 --- a/compiler/core/js_of_lam_option.ml +++ b/compiler/core/js_of_lam_option.ml @@ -36,7 +36,8 @@ type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped *) let none : J.expression = E.undefined -let is_none_static (arg : J.expression_desc) = match arg with +let is_none_static (arg : J.expression_desc) = + match arg with | Undefined _ -> true | _ -> false @@ -66,7 +67,7 @@ let is_not_none (e : J.expression) : J.expression = let val_from_option (arg : J.expression) = match arg.expression_desc with | Optional_block (x, _) -> x - | _ -> E.runtime_call Primitive_modules.option "valFromOption" [ arg ] + | _ -> E.runtime_call Primitive_modules.option "valFromOption" [arg] let get_default_undefined_from_optional (arg : J.expression) : J.expression = let desc = arg.expression_desc in @@ -75,10 +76,10 @@ let get_default_undefined_from_optional (arg : J.expression) : J.expression = match desc with | Optional_block (x, _) -> x (* invariant: option encoding *) | _ -> - if Js_analyzer.is_okay_to_duplicate arg then - (* FIXME: no need do such inlining*) - E.econd (is_not_none arg) (val_from_option arg) E.undefined - else E.runtime_call Primitive_modules.option "toUndefined" [ arg ] + if Js_analyzer.is_okay_to_duplicate arg then + (* FIXME: no need do such inlining*) + E.econd (is_not_none arg) (val_from_option arg) E.undefined + else E.runtime_call Primitive_modules.option "toUndefined" [arg] let option_unwrap (arg : J.expression) : J.expression = let desc = arg.expression_desc in @@ -87,7 +88,7 @@ let option_unwrap (arg : J.expression) : J.expression = match desc with | Optional_block (x, _) -> E.poly_var_value_access x (* invariant: option encoding *) - | _ -> E.runtime_call Primitive_modules.option "unwrapPolyVar" [ arg ] + | _ -> E.runtime_call Primitive_modules.option "unwrapPolyVar" [arg] let destruct_optional ~for_sure_none ~for_sure_some ~not_sure (arg : J.expression) = diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index 89922b9bea..e8135e8633 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -33,22 +33,22 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = else match arg.expression_desc with | Str {txt} -> - let s = Ext_list.assoc_by_string dispatches txt None in - E.str s + let s = Ext_list.assoc_by_string dispatches txt None in + E.str s | _ -> - E.of_block - [ - S.string_switch arg - (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, - J. - { - switch_body = [ S.return_stmt (E.str r) ]; - should_break = false; - (* FIXME: if true, still print break*) - comment = None; - } ))); - ] + E.of_block + [ + S.string_switch arg + (Ext_list.map dispatches (fun (s, r) -> + ( Ast_untagged_variants.String s, + J. + { + switch_body = [S.return_stmt (E.str r)]; + should_break = false; + (* FIXME: if true, still print break*) + comment = None; + } ))); + ] (* invariant: optional is not allowed in this case *) (* arg is a polyvar *) @@ -63,38 +63,38 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = let eval_as_event (arg : J.expression) (dispatches : (string * string) list option) = match arg.expression_desc with - | Caml_block ([ { expression_desc = Str {txt} }; cb ], _, _, Blk_poly_var _) + | Caml_block ([{expression_desc = Str {txt}}; cb], _, _, Blk_poly_var _) when Js_analyzer.no_side_effect_expression cb -> - let v = - match dispatches with - | Some dispatches -> Ext_list.assoc_by_string dispatches txt None - | None -> txt - in - Splice2 (E.str v, cb) + let v = + match dispatches with + | Some dispatches -> Ext_list.assoc_by_string dispatches txt None + | None -> txt + in + Splice2 (E.str v, cb) | _ -> - Splice2 - ( (match dispatches with - | Some dispatches -> - E.of_block - [ - S.string_switch - (E.poly_var_tag_access arg) - (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, - J. - { - switch_body = [ S.return_stmt (E.str r) ]; - should_break = false; - (* FIXME: if true, still print break*) - comment = None; - } ))); - ] - | None -> E.poly_var_tag_access arg), - (* TODO: improve, one dispatch later, - the problem is that we can not create bindings - due to the - *) - E.poly_var_value_access arg ) + Splice2 + ( (match dispatches with + | Some dispatches -> + E.of_block + [ + S.string_switch + (E.poly_var_tag_access arg) + (Ext_list.map dispatches (fun (s, r) -> + ( Ast_untagged_variants.String s, + J. + { + switch_body = [S.return_stmt (E.str r)]; + should_break = false; + (* FIXME: if true, still print break*) + comment = None; + } ))); + ] + | None -> E.poly_var_tag_access arg), + (* TODO: improve, one dispatch later, + the problem is that we can not create bindings + due to the + *) + E.poly_var_value_access arg ) (* we need destruct [undefined] when input is optional *) let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t = @@ -102,24 +102,23 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t = else match arg.expression_desc with | Str {txt} -> - E.int (Int32.of_int (Ext_list.assoc_by_string dispatches txt None)) + E.int (Int32.of_int (Ext_list.assoc_by_string dispatches txt None)) | _ -> - E.of_block - [ - S.string_switch arg - (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, - J. - { - switch_body = - [ S.return_stmt (E.int (Int32.of_int r)) ]; - should_break = false; - (* FIXME: if true, still print break*) - comment = None; - } ))); - ] + E.of_block + [ + S.string_switch arg + (Ext_list.map dispatches (fun (s, r) -> + ( Ast_untagged_variants.String s, + J. + { + switch_body = [S.return_stmt (E.int (Int32.of_int r))]; + should_break = false; + (* FIXME: if true, still print break*) + comment = None; + } ))); + ] let eval_as_unwrap (arg : J.expression) : E.t = match arg.expression_desc with - | Caml_block ([ { expression_desc = Number _ }; cb ], _, _, _) -> cb + | Caml_block ([{expression_desc = Number _}; cb], _, _, _) -> cb | _ -> E.poly_var_value_access arg diff --git a/compiler/core/js_op.ml b/compiler/core/js_op.ml index 2d626ad08e..15f9944b27 100644 --- a/compiler/core/js_op.ml +++ b/compiler/core/js_op.ml @@ -25,10 +25,11 @@ (** Define some basic types used in JS IR *) type binop = - | Eq (* acutally assignment .. - TODO: move it into statement, so that all expressions - are side efffect free (except function calls) - *) + | Eq + (* acutally assignment .. + TODO: move it into statement, so that all expressions + are side efffect free (except function calls) + *) | Or | And | EqEqEq @@ -115,7 +116,14 @@ type int_op = *) type level = Log | Info | Warn | Error -type kind = Ml | Runtime | External of { name : string; default : bool; import_attributes : External_ffi_types.import_attributes option } +type kind = + | Ml + | Runtime + | External of { + name: string; + default: bool; + import_attributes: External_ffi_types.import_attributes option; + } type property = Lam_compat.let_kind = Strict | Alias | StrictOpt | Variable @@ -124,13 +132,13 @@ type property_name = Lit of string | Symbol_name type 'a access = Getter | Setter (* literal char *) -type float_lit = { f : string } [@@unboxed] +type float_lit = {f: string} [@@unboxed] -type bigint_lit = { positive: bool; value: string } +type bigint_lit = {positive: bool; value: string} type number = | Float of float_lit - | Int of { i : int32; c : int option } + | Int of {i: int32; c: int option} | BigInt of bigint_lit (* becareful when constant folding +/-, @@ -168,7 +176,8 @@ type used_stats = pass, you can not do it in a single pass, however, some simple dead code can be detected in a single pass *) - | Once_pure (* used only once so that, if we do the inlining, it will be [Dead] *) + | Once_pure + (* used only once so that, if we do the inlining, it will be [Dead] *) | Used (**) | Scanning_pure | Scanning_non_pure @@ -176,7 +185,7 @@ type used_stats = type ident_info = { (* mutable recursive_info : recursive_info; *) - mutable used_stats : used_stats; + mutable used_stats: used_stats; } type exports = Ident.t list diff --git a/compiler/core/js_op_util.ml b/compiler/core/js_op_util.ml index 87997f6792..af6f3c5dcb 100644 --- a/compiler/core/js_op_util.ml +++ b/compiler/core/js_op_util.ml @@ -105,7 +105,7 @@ let update_used_stats (ident_info : J.ident_info) used_stats = match ident_info.used_stats with | Dead_pure | Dead_non_pure | Exported -> () | Scanning_pure | Scanning_non_pure | Used | Once_pure | NA -> - ident_info.used_stats <- used_stats + ident_info.used_stats <- used_stats let same_str_opt (x : string option) (y : string option) = match (x, y) with @@ -117,16 +117,18 @@ let same_vident (x : J.vident) (y : J.vident) = match (x, y) with | Id x0, Id y0 -> Ident.same x0 y0 | Qualified (x, str_opt0), Qualified (y, str_opt1) -> - let same_kind (x : Js_op.kind) (y : Js_op.kind) = - match (x, y) with - | Ml, Ml | Runtime, Runtime -> true - | External { name = u; _ }, External { name = v; _ } -> - u = v (* not comparing Default since we will do it later *) - | _, _ -> false - in - Ident.same x.id y.id && same_kind x.kind y.kind - && same_str_opt str_opt0 str_opt1 + let same_kind (x : Js_op.kind) (y : Js_op.kind) = + match (x, y) with + | Ml, Ml | Runtime, Runtime -> true + | External {name = u; _}, External {name = v; _} -> + u = v (* not comparing Default since we will do it later *) + | _, _ -> false + in + Ident.same x.id y.id && same_kind x.kind y.kind + && same_str_opt str_opt0 str_opt1 | Id _, Qualified _ | Qualified _, Id _ -> false let of_lam_mutable_flag (x : Asttypes.mutable_flag) : Js_op.mutable_flag = - match x with Immutable -> Immutable | Mutable -> Mutable + match x with + | Immutable -> Immutable + | Mutable -> Mutable diff --git a/compiler/core/js_output.ml b/compiler/core/js_output.ml index b69f426daa..0269ff1c17 100644 --- a/compiler/core/js_output.ml +++ b/compiler/core/js_output.ml @@ -28,18 +28,14 @@ module S = Js_stmt_make type finished = True | False | Dummy (* Have no idea, so that when [++] is applied, always use the other *) -type t = { - block : J.block; - value : J.expression option; - output_finished : finished; -} +type t = {block: J.block; value: J.expression option; output_finished: finished} type continuation = Lam_compile_context.continuation let make ?value ?(output_finished = False) block = - { block; value; output_finished } + {block; value; output_finished} -let dummy = { value = None; block = []; output_finished = Dummy } +let dummy = {value = None; block = []; output_finished = Dummy} (** This can be merged with {!output_of_block_and_expression} *) @@ -47,22 +43,22 @@ let output_of_expression (continuation : continuation) (exp : J.expression) ~(no_effects : bool Lazy.t) = match continuation with | EffectCall Not_tail -> - if Lazy.force no_effects then dummy - else { block = []; value = Some exp; output_finished = False } - | Declare (kind, n) -> make [ S.define_variable ~kind n exp ] - | Assign n -> make [ S.assign n exp ] + if Lazy.force no_effects then dummy + else {block = []; value = Some exp; output_finished = False} + | Declare (kind, n) -> make [S.define_variable ~kind n exp] + | Assign n -> make [S.assign n exp] | EffectCall (Maybe_tail_is_return _) -> - make [ S.return_stmt exp ] ~output_finished:True - | NeedValue _ -> { block = []; value = Some exp; output_finished = False } + make [S.return_stmt exp] ~output_finished:True + | NeedValue _ -> {block = []; value = Some exp; output_finished = False} let output_of_block_and_expression (continuation : continuation) (block : J.block) exp : t = match continuation with | EffectCall Not_tail -> make block ~value:exp | EffectCall (Maybe_tail_is_return _) -> - make (Ext_list.append_one block (S.return_stmt exp)) ~output_finished:True + make (Ext_list.append_one block (S.return_stmt exp)) ~output_finished:True | Declare (kind, n) -> - make (Ext_list.append_one block (S.define_variable ~kind n exp)) + make (Ext_list.append_one block (S.define_variable ~kind n exp)) | Assign n -> make (Ext_list.append_one block (S.assign n exp)) | NeedValue _ -> make block ~value:exp @@ -70,7 +66,7 @@ let block_with_opt_expr block (x : J.expression option) : J.block = match x with | None -> block | Some x when Js_analyzer.no_side_effect_expression x -> block - | Some x -> block @ [ S.exp x ] + | Some x -> block @ [S.exp x] let opt_expr_with_block (x : J.expression option) block : J.block = match x with @@ -80,25 +76,28 @@ let opt_expr_with_block (x : J.expression option) block : J.block = let rec unnest_block (block : J.block) : J.block = match block with - | [ { statement_desc = Block block } ] -> unnest_block block + | [{statement_desc = Block block}] -> unnest_block block | _ -> block let output_as_block (x : t) : J.block = match x with - | { block; value = opt; output_finished } -> - let block = unnest_block block in - if output_finished = True then block else block_with_opt_expr block opt + | {block; value = opt; output_finished} -> + let block = unnest_block block in + if output_finished = True then block else block_with_opt_expr block opt let to_break_block (x : t) : J.block * bool = let block = unnest_block x.block in match x with - | { output_finished = True; _ } -> (block, false) + | {output_finished = True; _} -> (block, false) (* value does not matter when [finished] is true TODO: check if it has side efects *) - | { value = None; output_finished } -> ( - (block, match output_finished with True -> false | False | Dummy -> true)) - | { value = Some _ as opt; _ } -> (block_with_opt_expr block opt, true) + | {value = None; output_finished} -> + ( block, + match output_finished with + | True -> false + | False | Dummy -> true ) + | {value = Some _ as opt; _} -> (block_with_opt_expr block opt, true) (** TODO: make everything expression make inlining hard, and code not readable? 1. readability dpends on how we print the expression @@ -118,25 +117,25 @@ let to_break_block (x : t) : J.block * bool = let append_output (x : t) (y : t) : t = match (x, y) with (* ATTTENTION: should not optimize [opt_e2], it has to conform to [NeedValue]*) - | { output_finished = True; _ }, _ -> x - | _, { block = []; value = None; output_finished = Dummy } -> x + | {output_finished = True; _}, _ -> x + | _, {block = []; value = None; output_finished = Dummy} -> x (* finished = true --> value = E.undefined otherwise would throw*) - | { block = []; value = None; _ }, y -> y - | { block = []; value = Some _; _ }, { block = []; value = None; _ } -> x - | ( { block = []; value = Some e1; _ }, - ({ block = []; value = Some e2; output_finished } as z) ) -> - if Js_analyzer.no_side_effect_expression e1 then z - (* It would optimize cases like [module aliases] - Bigarray, List - *) - else { block = []; value = Some (E.seq e1 e2); output_finished } - (* {block = [S.exp e1]; value = Some e2(\* (E.seq e1 e2) *\); finished} *) - | ( { block = block1; value = opt_e1; _ }, - { block = block2; value = opt_e2; output_finished } ) -> - let block1 = unnest_block block1 in - make - (block1 @ opt_expr_with_block opt_e1 @@ unnest_block block2) - ?value:opt_e2 ~output_finished + | {block = []; value = None; _}, y -> y + | {block = []; value = Some _; _}, {block = []; value = None; _} -> x + | ( {block = []; value = Some e1; _}, + ({block = []; value = Some e2; output_finished} as z) ) -> + if Js_analyzer.no_side_effect_expression e1 then z + (* It would optimize cases like [module aliases] + Bigarray, List + *) + else {block = []; value = Some (E.seq e1 e2); output_finished} + (* {block = [S.exp e1]; value = Some e2(\* (E.seq e1 e2) *\); finished} *) + | ( {block = block1; value = opt_e1; _}, + {block = block2; value = opt_e2; output_finished} ) -> + let block1 = unnest_block block1 in + make + (block1 @ opt_expr_with_block opt_e1 @@ unnest_block block2) + ?value:opt_e2 ~output_finished (* Fold right is more efficient *) let concat (xs : t list) : t = diff --git a/compiler/core/js_output.mli b/compiler/core/js_output.mli index 28e764191b..19204e1877 100644 --- a/compiler/core/js_output.mli +++ b/compiler/core/js_output.mli @@ -31,11 +31,7 @@ type finished = True | False | Dummy (* Have no idea, so that when [++] is applied, always use the other *) -type t = { - block : J.block; - value : J.expression option; - output_finished : finished; -} +type t = {block: J.block; value: J.expression option; output_finished: finished} (** When [finished] is true the block is already terminated, value does not make sense diff --git a/compiler/core/js_packages_info.ml b/compiler/core/js_packages_info.ml index b3fe0190d6..fd00099828 100644 --- a/compiler/core/js_packages_info.ml +++ b/compiler/core/js_packages_info.ml @@ -35,11 +35,7 @@ let compatible (dep : module_system) (query : module_system) = | Es6_global -> dep = Es6_global || dep = Esmodule (* As a dependency Leaf Node, it is the same either [global] or [not] *) -type package_info = { - module_system : module_system; - path : string; - suffix : string; -} +type package_info = {module_system: module_system; path: string; suffix: string} type package_name = Pkg_empty | Pkg_runtime | Pkg_normal of string @@ -47,22 +43,24 @@ let ( // ) = Filename.concat (* in runtime lib, [es6] and [es6] are treated the same wway *) let runtime_dir_of_module_system (ms : module_system) = - match ms with Commonjs -> "js" | Esmodule | Es6_global -> "es6" + match ms with + | Commonjs -> "js" + | Esmodule | Es6_global -> "es6" let runtime_package_path (ms : module_system) js_file = !Bs_version.package_name // "lib" // runtime_dir_of_module_system ms // js_file -type t = { name : package_name; module_systems : package_info list } +type t = {name: package_name; module_systems: package_info list} let runtime_package_specs : t = { name = Pkg_runtime; module_systems = [ - { module_system = Esmodule; path = "lib/es6"; suffix = Literals.suffix_js }; - { module_system = Commonjs; path = "lib/js"; suffix = Literals.suffix_js }; + {module_system = Esmodule; path = "lib/es6"; suffix = Literals.suffix_js}; + {module_system = Commonjs; path = "lib/js"; suffix = Literals.suffix_js}; ]; } @@ -71,9 +69,9 @@ let same_package_by_name (x : t) (y : t) = | Pkg_empty -> y.name = Pkg_empty | Pkg_runtime -> y.name = Pkg_runtime | Pkg_normal s -> ( - match y.name with - | Pkg_normal y -> s = y - | Pkg_empty | Pkg_runtime -> false) + match y.name with + | Pkg_normal y -> s = y + | Pkg_empty | Pkg_runtime -> false) let is_runtime_package (x : t) = x.name = Pkg_runtime @@ -94,15 +92,18 @@ let map (x : t) cb = Ext_list.map x.module_systems cb For empty package, [-bs-package-output] does not make sense it is only allowed to generate commonjs file in the same directory *) -let empty : t = { name = Pkg_empty; module_systems = [] } +let empty : t = {name = Pkg_empty; module_systems = []} let from_name (name : string) : t = - { name = Pkg_normal name; module_systems = [] } + {name = Pkg_normal name; module_systems = []} let is_empty (x : t) = x.name = Pkg_empty let string_of_module_system (ms : module_system) = - match ms with Commonjs -> "CommonJS" | Esmodule -> "ESModule" | Es6_global -> "Es6_global" + match ms with + | Commonjs -> "CommonJS" + | Esmodule -> "ESModule" + | Es6_global -> "Es6_global" let module_system_of_string package_name : module_system option = match package_name with @@ -112,11 +113,8 @@ let module_system_of_string package_name : module_system option = | _ -> None let dump_package_info (fmt : Format.formatter) - ({ module_system = ms; path = name; suffix } : package_info) = - Format.fprintf fmt "@[%s@ %s@ %s@]" - (string_of_module_system ms) - name - suffix + ({module_system = ms; path = name; suffix} : package_info) = + Format.fprintf fmt "@[%s@ %s@ %s@]" (string_of_module_system ms) name suffix let dump_package_name fmt (x : package_name) = match x with @@ -125,7 +123,7 @@ let dump_package_name fmt (x : package_name) = | Pkg_runtime -> Format.pp_print_string fmt "@runtime" let dump_packages_info (fmt : Format.formatter) - ({ name; module_systems = ls } : t) = + ({name; module_systems = ls} : t) = Format.fprintf fmt "@[%a;@ @[%a@]@]" dump_package_name name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_space fmt ()) @@ -133,9 +131,9 @@ let dump_packages_info (fmt : Format.formatter) ls type package_found_info = { - rel_path : string; - pkg_rel_path : string; - suffix : string; + rel_path: string; + pkg_rel_path: string; + suffix: string; } type info_query = @@ -145,31 +143,31 @@ type info_query = (* Note that package-name has to be exactly the same as npm package name, otherwise the path resolution will be wrong *) -let query_package_infos ({ name; module_systems } : t) +let query_package_infos ({name; module_systems} : t) (module_system : module_system) : info_query = match name with | Pkg_empty -> Package_script | Pkg_normal name -> ( - match - Ext_list.find_first module_systems (fun k -> - compatible k.module_system module_system) - with - | Some k -> - let rel_path = k.path in - let pkg_rel_path = name // rel_path in - Package_found { rel_path; pkg_rel_path; suffix = k.suffix } - | None -> Package_not_found) + match + Ext_list.find_first module_systems (fun k -> + compatible k.module_system module_system) + with + | Some k -> + let rel_path = k.path in + let pkg_rel_path = name // rel_path in + Package_found {rel_path; pkg_rel_path; suffix = k.suffix} + | None -> Package_not_found) | Pkg_runtime -> ( - (*FIXME: [compatible] seems not correct *) - match - Ext_list.find_first module_systems (fun k -> - compatible k.module_system module_system) - with - | Some k -> - let rel_path = k.path in - let pkg_rel_path = !Bs_version.package_name // rel_path in - Package_found { rel_path; pkg_rel_path; suffix = k.suffix } - | None -> Package_not_found) + (*FIXME: [compatible] seems not correct *) + match + Ext_list.find_first module_systems (fun k -> + compatible k.module_system module_system) + with + | Some k -> + let rel_path = k.path in + let pkg_rel_path = !Bs_version.package_name // rel_path in + Package_found {rel_path; pkg_rel_path; suffix = k.suffix} + | None -> Package_not_found) let get_js_path (x : t) (module_system : module_system) : string = match @@ -196,22 +194,18 @@ let add_npm_package_path (packages_info : t) (s : string) : t = in let m = match Ext_string.split ~keep_empty:true s ':' with - | [ path ] -> { module_system = Esmodule; path; suffix = Literals.suffix_js } - | [ module_system; path ] -> - { - module_system = handle_module_system module_system; - path; - suffix = Literals.suffix_js; - } - | [ module_system; path; suffix ] -> - { - module_system = handle_module_system module_system; - path; - suffix; - } + | [path] -> {module_system = Esmodule; path; suffix = Literals.suffix_js} + | [module_system; path] -> + { + module_system = handle_module_system module_system; + path; + suffix = Literals.suffix_js; + } + | [module_system; path; suffix] -> + {module_system = handle_module_system module_system; path; suffix} | _ -> Bsc_args.bad_arg ("invalid npm package path: " ^ s) in - { packages_info with module_systems = m :: packages_info.module_systems } + {packages_info with module_systems = m :: packages_info.module_systems} (* support es6 modules instead TODO: enrich ast to support import export diff --git a/compiler/core/js_packages_info.mli b/compiler/core/js_packages_info.mli index 2a9e8f78fa..6e5c551df8 100644 --- a/compiler/core/js_packages_info.mli +++ b/compiler/core/js_packages_info.mli @@ -28,11 +28,7 @@ val runtime_dir_of_module_system : module_system -> string val runtime_package_path : module_system -> string -> string -type package_info = { - module_system : module_system; - path : string; - suffix : string; -} +type package_info = {module_system: module_system; path: string; suffix: string} type t @@ -60,9 +56,9 @@ val add_npm_package_path : t -> string -> t *) type package_found_info = { - rel_path : string; - pkg_rel_path : string; - suffix : string; + rel_path: string; + pkg_rel_path: string; + suffix: string; } type info_query = diff --git a/compiler/core/js_packages_state.ml b/compiler/core/js_packages_state.ml index e511af8478..468b058c89 100644 --- a/compiler/core/js_packages_state.ml +++ b/compiler/core/js_packages_state.ml @@ -28,7 +28,8 @@ let make_runtime = ref false let set_package_name name = if Js_packages_info.is_empty !packages_info then packages_info := Js_packages_info.from_name name - else if not !make_runtime then Bsc_args.bad_arg "duplicated flag for -bs-package-name" + else if not !make_runtime then + Bsc_args.bad_arg "duplicated flag for -bs-package-name" let make_runtime () : unit = make_runtime := true; diff --git a/compiler/core/js_pass_flatten.ml b/compiler/core/js_pass_flatten.ml index 397d2dc281..1e40c4827f 100644 --- a/compiler/core/js_pass_flatten.ml +++ b/compiler/core/js_pass_flatten.ml @@ -40,74 +40,73 @@ let flatten_map = statement = (fun self x -> match x.statement_desc with - | Exp ({ expression_desc = Seq _; _ } as v) -> - S.block - (List.rev_map - (fun x -> self.statement self x) - (Js_analyzer.rev_flatten_seq v)) + | Exp ({expression_desc = Seq _; _} as v) -> + S.block + (List.rev_map + (fun x -> self.statement self x) + (Js_analyzer.rev_flatten_seq v)) | Exp { expression_desc = Caml_block (args, _mutable_flag, _tag, _tag_info); } -> - S.block - (Ext_list.map args (fun arg -> self.statement self (S.exp arg))) - | Exp { expression_desc = Cond (a, b, c); comment } -> - { - statement_desc = - If - ( a, - [ self.statement self (S.exp b) ], - [ self.statement self (S.exp c) ] ); - comment; - } + S.block + (Ext_list.map args (fun arg -> self.statement self (S.exp arg))) + | Exp {expression_desc = Cond (a, b, c); comment} -> + { + statement_desc = + If + ( a, + [self.statement self (S.exp b)], + [self.statement self (S.exp c)] ); + comment; + } | Exp { - expression_desc = - Bin (Eq, a, ({ expression_desc = Seq _; _ } as v)); + expression_desc = Bin (Eq, a, ({expression_desc = Seq _; _} as v)); _; } -> ( - let block = Js_analyzer.rev_flatten_seq v in - match block with - | { statement_desc = Exp last_one; _ } :: rest_rev -> - S.block - (Ext_list.rev_map_append rest_rev - [ self.statement self (S.exp (E.assign a last_one)) ] - (fun x -> self.statement self x)) - (* TODO: here we introduce a block, should avoid it *) - (* super#statement *) - (* (S.block (List.rev_append rest_rev [S.exp (E.assign a last_one)])) *) - | _ -> assert false) - | Return { expression_desc = Cond (a, b, c); comment } -> - { - statement_desc = - If - ( a, - [ self.statement self (S.return_stmt b) ], - [ self.statement self (S.return_stmt c) ] ); - comment; - } - | Return ({ expression_desc = Seq _; _ } as v) -> ( - let block = Js_analyzer.rev_flatten_seq v in - match block with - | { statement_desc = Exp last_one; _ } :: rest_rev -> - super.statement self - (S.block - (Ext_list.rev_map_append rest_rev - [ S.return_stmt last_one ] (fun x -> - self.statement self x))) - | _ -> assert false) - | Block [ x ] -> self.statement self x + let block = Js_analyzer.rev_flatten_seq v in + match block with + | {statement_desc = Exp last_one; _} :: rest_rev -> + S.block + (Ext_list.rev_map_append rest_rev + [self.statement self (S.exp (E.assign a last_one))] + (fun x -> self.statement self x)) + (* TODO: here we introduce a block, should avoid it *) + (* super#statement *) + (* (S.block (List.rev_append rest_rev [S.exp (E.assign a last_one)])) *) + | _ -> assert false) + | Return {expression_desc = Cond (a, b, c); comment} -> + { + statement_desc = + If + ( a, + [self.statement self (S.return_stmt b)], + [self.statement self (S.return_stmt c)] ); + comment; + } + | Return ({expression_desc = Seq _; _} as v) -> ( + let block = Js_analyzer.rev_flatten_seq v in + match block with + | {statement_desc = Exp last_one; _} :: rest_rev -> + super.statement self + (S.block + (Ext_list.rev_map_append rest_rev + [S.return_stmt last_one] + (fun x -> self.statement self x))) + | _ -> assert false) + | Block [x] -> self.statement self x | _ -> super.statement self x); block = (fun self b -> match b with - | { statement_desc = Block bs } :: rest -> self.block self (bs @ rest) + | {statement_desc = Block bs} :: rest -> self.block self (bs @ rest) | x :: rest -> ( - let st = self.statement self x in - let block = self.block self rest in - match st.statement_desc with - | Block bs -> bs @ block - | _ -> st :: block) + let st = self.statement self x in + let block = self.block self rest in + match st.statement_desc with + | Block bs -> bs @ block + | _ -> st :: block) | [] -> []); } diff --git a/compiler/core/js_pass_flatten_and_mark_dead.ml b/compiler/core/js_pass_flatten_and_mark_dead.ml index 6ff6066283..23c34f23eb 100644 --- a/compiler/core/js_pass_flatten_and_mark_dead.ml +++ b/compiler/core/js_pass_flatten_and_mark_dead.ml @@ -38,8 +38,8 @@ let mark_dead_code (js : J.program) : J.program = (fun _ ident -> match Hash_ident.find_opt ident_use_stats ident with | None -> - (* First time *) - Hash_ident.add ident_use_stats ident Recursive + (* First time *) + Hash_ident.add ident_use_stats ident Recursive (* recursive identifiers *) | Some Recursive -> () | Some (Info x) -> Js_op_util.update_used_stats x Used); @@ -48,48 +48,46 @@ let mark_dead_code (js : J.program) : J.program = match vd.ident_info.used_stats with | Dead_pure -> () | Dead_non_pure -> ( - match vd.value with - | None -> () - | Some x -> self.expression self x) + match vd.value with + | None -> () + | Some x -> self.expression self x) | _ -> ( - let ({ ident; ident_info; value; _ } : J.variable_declaration) = - vd - in - let pure = - match value with - | None -> true - | Some x -> - self.expression self x; - Js_analyzer.no_side_effect_expression x - in - let () = - if Set_ident.mem js.export_set ident then - Js_op_util.update_used_stats ident_info Exported - in - match Hash_ident.find_opt ident_use_stats ident with - | Some Recursive -> - Js_op_util.update_used_stats ident_info Used; - Hash_ident.replace ident_use_stats ident (Info ident_info) - | Some (Info _) -> - (* check [camlinternlFormat,box_type] inlined twice - FIXME: seems we have redeclared identifiers - *) - () - (* assert false *) - | None -> - (* First time *) - Hash_ident.add ident_use_stats ident (Info ident_info); - Js_op_util.update_used_stats ident_info - (if pure then Scanning_pure else Scanning_non_pure))); + let ({ident; ident_info; value; _} : J.variable_declaration) = vd in + let pure = + match value with + | None -> true + | Some x -> + self.expression self x; + Js_analyzer.no_side_effect_expression x + in + let () = + if Set_ident.mem js.export_set ident then + Js_op_util.update_used_stats ident_info Exported + in + match Hash_ident.find_opt ident_use_stats ident with + | Some Recursive -> + Js_op_util.update_used_stats ident_info Used; + Hash_ident.replace ident_use_stats ident (Info ident_info) + | Some (Info _) -> + (* check [camlinternlFormat,box_type] inlined twice + FIXME: seems we have redeclared identifiers + *) + () + (* assert false *) + | None -> + (* First time *) + Hash_ident.add ident_use_stats ident (Info ident_info); + Js_op_util.update_used_stats ident_info + (if pure then Scanning_pure else Scanning_non_pure))); } in mark_dead.program mark_dead js; Hash_ident.iter ident_use_stats (fun _id (info : meta_info) -> match info with - | Info ({ used_stats = Scanning_pure } as info) -> - Js_op_util.update_used_stats info Dead_pure - | Info ({ used_stats = Scanning_non_pure } as info) -> - Js_op_util.update_used_stats info Dead_non_pure + | Info ({used_stats = Scanning_pure} as info) -> + Js_op_util.update_used_stats info Dead_pure + | Info ({used_stats = Scanning_non_pure} as info) -> + Js_op_util.update_used_stats info Dead_non_pure | _ -> ()); js @@ -158,22 +156,19 @@ let subst_map (substitution : J.expression Hash_ident.t) = statement = (fun self v -> match v.statement_desc with - | Variable { ident = _; ident_info = { used_stats = Dead_pure }; _ } -> - { v with statement_desc = Block [] } + | Variable {ident = _; ident_info = {used_stats = Dead_pure}; _} -> + {v with statement_desc = Block []} | Variable - { - ident = _; - ident_info = { used_stats = Dead_non_pure }; - value = None; - } -> - { v with statement_desc = Block [] } + {ident = _; ident_info = {used_stats = Dead_non_pure}; value = None} + -> + {v with statement_desc = Block []} | Variable { ident = _; - ident_info = { used_stats = Dead_non_pure }; + ident_info = {used_stats = Dead_non_pure}; value = Some x; } -> - { v with statement_desc = Exp x } + {v with statement_desc = Exp x} | Variable ({ ident; @@ -186,82 +181,77 @@ let subst_map (substitution : J.expression Hash_ident.t) = ((_ :: _ :: _ as ls), Immutable, tag, tag_info); } as block); } as variable) -> ( - (* If we do this, we should prevent incorrect inlning to inline it into an array :) - do it only when block size is larger than one - *) - let _, e, bindings = - Ext_list.fold_left ls (0, [], []) (fun (i, e, acc) x -> - match x.expression_desc with - | Var _ | Number _ | Str _ | J.Bool _ | Undefined _ -> - (* TODO: check the optimization *) - (i + 1, x :: e, acc) - | _ -> - (* tradeoff, - when the block is small, it does not make - sense too much -- - bottomline, when the block size is one, no need to do - this - *) - let v' = self.expression self x in - let match_id = - Ext_ident.create - (ident.name ^ "_" - ^ - match tag_info with - | Blk_module fields -> ( - match Ext_list.nth_opt fields i with - | None -> Printf.sprintf "%d" i - | Some x -> x) - | Blk_record { fields } -> - Ext_array.get_or fields i (fun _ -> - Printf.sprintf "%d" i) - | _ -> Printf.sprintf "%d" i) - in - (i + 1, E.var match_id :: e, (match_id, v') :: acc)) - in - let e = - { - block with - expression_desc = - Caml_block (List.rev e, Immutable, tag, tag_info); - } - in - let () = add_substitue substitution ident e in - (* let bindings = !bindings in *) - let original_statement = - { - v with - statement_desc = Variable { variable with value = Some e }; - } - in - match bindings with - | [] -> original_statement - | _ -> - (* self#add_substitue ident e ; *) - S.block - @@ Ext_list.rev_map_append bindings [ original_statement ] - (fun (id, v) -> S.define_variable ~kind:Strict id v)) + (* If we do this, we should prevent incorrect inlning to inline it into an array :) + do it only when block size is larger than one + *) + let _, e, bindings = + Ext_list.fold_left ls (0, [], []) (fun (i, e, acc) x -> + match x.expression_desc with + | Var _ | Number _ | Str _ | J.Bool _ | Undefined _ -> + (* TODO: check the optimization *) + (i + 1, x :: e, acc) + | _ -> + (* tradeoff, + when the block is small, it does not make + sense too much -- + bottomline, when the block size is one, no need to do + this + *) + let v' = self.expression self x in + let match_id = + Ext_ident.create + (ident.name ^ "_" + ^ + match tag_info with + | Blk_module fields -> ( + match Ext_list.nth_opt fields i with + | None -> Printf.sprintf "%d" i + | Some x -> x) + | Blk_record {fields} -> + Ext_array.get_or fields i (fun _ -> + Printf.sprintf "%d" i) + | _ -> Printf.sprintf "%d" i) + in + (i + 1, E.var match_id :: e, (match_id, v') :: acc)) + in + let e = + { + block with + expression_desc = Caml_block (List.rev e, Immutable, tag, tag_info); + } + in + let () = add_substitue substitution ident e in + (* let bindings = !bindings in *) + let original_statement = + {v with statement_desc = Variable {variable with value = Some e}} + in + match bindings with + | [] -> original_statement + | _ -> + (* self#add_substitue ident e ; *) + S.block + @@ Ext_list.rev_map_append bindings [original_statement] + (fun (id, v) -> S.define_variable ~kind:Strict id v)) | _ -> super.statement self v); expression = (fun self x -> match x.expression_desc with | Array_index - ( { expression_desc = Var (Id id) }, - { expression_desc = Number (Int { i; _ }) } ) - | Static_index ({ expression_desc = Var (Id id) }, _, Some i) -> ( - match Hash_ident.find_opt substitution id with - | Some { expression_desc = Caml_block (ls, Immutable, _, _) } -> ( - (* user program can be wrong, we should not - turn a runtime crash into compile time crash : ) - *) - match Ext_list.nth_opt ls (Int32.to_int i) with - | Some - ({ - expression_desc = J.Var _ | Number _ | Str _ | Undefined _; - } as x) -> - x - | None | Some _ -> super.expression self x) - | Some _ | None -> super.expression self x) + ( {expression_desc = Var (Id id)}, + {expression_desc = Number (Int {i; _})} ) + | Static_index ({expression_desc = Var (Id id)}, _, Some i) -> ( + match Hash_ident.find_opt substitution id with + | Some {expression_desc = Caml_block (ls, Immutable, _, _)} -> ( + (* user program can be wrong, we should not + turn a runtime crash into compile time crash : ) + *) + match Ext_list.nth_opt ls (Int32.to_int i) with + | Some + ({expression_desc = J.Var _ | Number _ | Str _ | Undefined _} as + x) -> + x + | None | Some _ -> super.expression self x) + | Some _ | None -> super.expression self x) | _ -> super.expression self x); } diff --git a/compiler/core/js_pass_get_used.ml b/compiler/core/js_pass_get_used.ml index adb21dca1e..57c5b8bb07 100644 --- a/compiler/core/js_pass_get_used.ml +++ b/compiler/core/js_pass_get_used.ml @@ -37,12 +37,12 @@ let post_process_stats my_export_set in match Hash_ident.find_opt stats ident with | None -> - Js_op_util.update_used_stats v.ident_info - (if pure then Dead_pure else Dead_non_pure) + Js_op_util.update_used_stats v.ident_info + (if pure then Dead_pure else Dead_non_pure) | Some num -> - if num = 1 then - Js_op_util.update_used_stats v.ident_info - (if pure then Once_pure else Used)); + if num = 1 then + Js_op_util.update_used_stats v.ident_info + (if pure then Once_pure else Used)); defined_idents (* Update ident info use cases, it is a non pure function, @@ -58,9 +58,11 @@ let count_collects (* collect used status*) (stats : int Hash_ident.t) { super with variable_declaration = - (fun self ({ ident; value; property = _; ident_info = _ } as v) -> + (fun self ({ident; value; property = _; ident_info = _} as v) -> Hash_ident.add defined_idents ident v; - match value with None -> () | Some x -> self.expression self x); + match value with + | None -> () + | Some x -> self.expression self x); ident = (fun _ id -> add_use stats id); } diff --git a/compiler/core/js_pass_scope.ml b/compiler/core/js_pass_scope.ml index df74ace257..6011bd554d 100644 --- a/compiler/core/js_pass_scope.ml +++ b/compiler/core/js_pass_scope.ml @@ -92,12 +92,12 @@ ]} *) type state = { - defined_idents : Set_ident.t; - used_idents : Set_ident.t; - loop_mutable_values : Set_ident.t; - mutable_values : Set_ident.t; - closured_idents : Set_ident.t; - in_loop : bool; + defined_idents: Set_ident.t; + used_idents: Set_ident.t; + loop_mutable_values: Set_ident.t; + mutable_values: Set_ident.t; + closured_idents: Set_ident.t; + in_loop: bool; } let init_state = @@ -111,7 +111,7 @@ let init_state = } let with_in_loop (st : state) b = - if b = st.in_loop then st else { st with in_loop = b } + if b = st.in_loop then st else {st with in_loop = b} let add_loop_mutable_variable (st : state) id = { @@ -121,13 +121,13 @@ let add_loop_mutable_variable (st : state) id = } let add_mutable_variable (st : state) id = - { st with mutable_values = Set_ident.add st.mutable_values id } + {st with mutable_values = Set_ident.add st.mutable_values id} let add_defined_ident (st : state) id = - { st with defined_idents = Set_ident.add st.defined_idents id } + {st with defined_idents = Set_ident.add st.defined_idents id} let add_used_ident (st : state) id = - { st with used_idents = Set_ident.add st.used_idents id } + {st with used_idents = Set_ident.add st.used_idents id} let super = Js_record_fold.super @@ -138,76 +138,75 @@ let record_scope_pass = (fun self state x -> match x.expression_desc with | Fun {params; body; env} -> - (* Function is the only place to introduce a new scope in - ES5 - TODO: check - {[ try .. catch(exn) {.. }]} - what's the scope of exn - *) - (* Note that [used_idents] is not complete - it ignores some locally defined idents *) - let param_set = Set_ident.of_list params in - let { defined_idents = defined_idents'; used_idents = used_idents' } - = - self.block self - { - init_state with - mutable_values = - Set_ident.of_list (Js_fun_env.get_mutable_params params env); - } - body - in - (* let defined_idents', used_idents' = - obj#get_defined_idents, obj#get_used_idents in *) - (* mark which param is used *) - params - |> List.iteri (fun i v -> - if not (Set_ident.mem used_idents' v) then - Js_fun_env.mark_unused env i); - let closured_idents' = - (* pass param_set down *) - Set_ident.(diff used_idents' (union defined_idents' param_set)) - in + (* Function is the only place to introduce a new scope in + ES5 + TODO: check + {[ try .. catch(exn) {.. }]} + what's the scope of exn + *) + (* Note that [used_idents] is not complete + it ignores some locally defined idents *) + let param_set = Set_ident.of_list params in + let {defined_idents = defined_idents'; used_idents = used_idents'} = + self.block self + { + init_state with + mutable_values = + Set_ident.of_list (Js_fun_env.get_mutable_params params env); + } + body + in + (* let defined_idents', used_idents' = + obj#get_defined_idents, obj#get_used_idents in *) + (* mark which param is used *) + params + |> List.iteri (fun i v -> + if not (Set_ident.mem used_idents' v) then + Js_fun_env.mark_unused env i); + let closured_idents' = + (* pass param_set down *) + Set_ident.(diff used_idents' (union defined_idents' param_set)) + in - (* Noe that we don't know which variables are exactly mutable yet .. - due to the recursive thing - *) - Js_fun_env.set_unbounded env closured_idents'; - (* tailcall , note that these varibles are used in another pass *) - { - state with - used_idents = Set_ident.union state.used_idents closured_idents'; - (* There is a bug in ocaml -dsource*) - closured_idents = - Set_ident.union state.closured_idents closured_idents'; - } + (* Noe that we don't know which variables are exactly mutable yet .. + due to the recursive thing + *) + Js_fun_env.set_unbounded env closured_idents'; + (* tailcall , note that these varibles are used in another pass *) + { + state with + used_idents = Set_ident.union state.used_idents closured_idents'; + (* There is a bug in ocaml -dsource*) + closured_idents = + Set_ident.union state.closured_idents closured_idents'; + } | _ -> ( - let obj = super.expression self state x in - match Js_block_runtime.check_additional_id x with - | None -> obj - | Some id -> add_used_ident obj id)); + let obj = super.expression self state x in + match Js_block_runtime.check_additional_id x with + | None -> obj + | Some id -> add_used_ident obj id)); variable_declaration = (fun self state x -> match x with - | { ident; value; property } -> ( - let obj = - add_defined_ident - (match (state.in_loop, property) with - | true, Variable -> add_loop_mutable_variable state ident - | true, (Strict | StrictOpt | Alias) - (* Not real true immutable in javascript - since it's in the loop + | {ident; value; property} -> ( + let obj = + add_defined_ident + (match (state.in_loop, property) with + | true, Variable -> add_loop_mutable_variable state ident + | true, (Strict | StrictOpt | Alias) + (* Not real true immutable in javascript + since it's in the loop - TODO: we should also - *) -> ( - match value with - | None -> - add_loop_mutable_variable state ident - (* TODO: Check why assertion failure *) - (* self#add_loop_mutable_variable ident *) - (* assert false *) - | Some x -> ( - (* + TODO: we should also + *) -> ( + match value with + | None -> + add_loop_mutable_variable state ident + (* TODO: Check why assertion failure *) + (* self#add_loop_mutable_variable ident *) + (* assert false *) + | Some x -> ( + (* when x is an immediate immutable value, (like integer .. ) not a reference, it should be Immutable @@ -215,84 +214,84 @@ let record_scope_pass = type system might help here TODO: *) - match x.expression_desc with - | Fun _ | Number _ | Str _ -> state - | _ -> - (* if Set_ident.(is_empty @@ *) - (* inter self#get_mutable_values *) - (* ( ({< *) - (* defined_idents = Set_ident.empty; *) - (* used_idents = Set_ident.empty; *) - (* >} # expression x) # get_used_idents)) then *) - (* (\* FIXME: still need to check expression is pure or not*\) *) - (* self *) - (* else *) - add_loop_mutable_variable state ident)) - | false, Variable -> add_mutable_variable state ident - | false, (Strict | StrictOpt | Alias) -> state) - ident - in - match value with - | None -> obj - | Some x -> self.expression self obj x)); + match x.expression_desc with + | Fun _ | Number _ | Str _ -> state + | _ -> + (* if Set_ident.(is_empty @@ *) + (* inter self#get_mutable_values *) + (* ( ({< *) + (* defined_idents = Set_ident.empty; *) + (* used_idents = Set_ident.empty; *) + (* >} # expression x) # get_used_idents)) then *) + (* (\* FIXME: still need to check expression is pure or not*\) *) + (* self *) + (* else *) + add_loop_mutable_variable state ident)) + | false, Variable -> add_mutable_variable state ident + | false, (Strict | StrictOpt | Alias) -> state) + ident + in + match value with + | None -> obj + | Some x -> self.expression self obj x)); statement = (fun self state x -> match x.statement_desc with | ForRange (_, _, loop_id, _, _) -> - (* TODO: simplify definition of For *) - let { - defined_idents = defined_idents'; - used_idents = used_idents'; - closured_idents = closured_idents'; - } = - super.statement self - { - in_loop = true; - loop_mutable_values = Set_ident.singleton loop_id; - used_idents = Set_ident.empty; - (* TODO: if unused, can we generate better code? *) - defined_idents = Set_ident.singleton loop_id; - closured_idents = Set_ident.empty; - (* Think about nested for blocks *) - (* Invariant: Finish id is never used *) - mutable_values = state.mutable_values; - } - x - in + (* TODO: simplify definition of For *) + let { + defined_idents = defined_idents'; + used_idents = used_idents'; + closured_idents = closured_idents'; + } = + super.statement self + { + in_loop = true; + loop_mutable_values = Set_ident.singleton loop_id; + used_idents = Set_ident.empty; + (* TODO: if unused, can we generate better code? *) + defined_idents = Set_ident.singleton loop_id; + closured_idents = Set_ident.empty; + (* Think about nested for blocks *) + (* Invariant: Finish id is never used *) + mutable_values = state.mutable_values; + } + x + in - (* CHECK*) + (* CHECK*) - (* let defined_idents', used_idents', closured_idents' = - obj#get_defined_idents, obj#get_used_idents, obj#get_closured_idents in *) - let lexical_scope = - Set_ident.( - inter - (diff closured_idents' defined_idents') - state.loop_mutable_values) - in - { - state with - used_idents = Set_ident.union state.used_idents used_idents'; - (* walk around ocaml -dsource bug - {[ - Set_ident.(union used_idents used_idents) - ]} - *) - defined_idents = - Set_ident.union state.defined_idents defined_idents'; - (* TODO: if we our generated code also follow lexical scope, - this is not necessary ; - [varaibles] are mutable or not is known at definition - *) - closured_idents = - Set_ident.union state.closured_idents lexical_scope; - } + (* let defined_idents', used_idents', closured_idents' = + obj#get_defined_idents, obj#get_used_idents, obj#get_closured_idents in *) + let lexical_scope = + Set_ident.( + inter + (diff closured_idents' defined_idents') + state.loop_mutable_values) + in + { + state with + used_idents = Set_ident.union state.used_idents used_idents'; + (* walk around ocaml -dsource bug + {[ + Set_ident.(union used_idents used_idents) + ]} + *) + defined_idents = + Set_ident.union state.defined_idents defined_idents'; + (* TODO: if we our generated code also follow lexical scope, + this is not necessary ; + [varaibles] are mutable or not is known at definition + *) + closured_idents = + Set_ident.union state.closured_idents lexical_scope; + } | While (pred, body) -> - with_in_loop - (self.block self - (with_in_loop (self.expression self state pred) true) - body) - state.in_loop + with_in_loop + (self.block self + (with_in_loop (self.expression self state pred) true) + body) + state.in_loop | _ -> super.statement self state x); exception_ident = (fun _ state x -> @@ -318,7 +317,7 @@ let record_scope_pass = ident = (fun _ state x -> if Set_ident.mem state.defined_idents x then state - else { state with used_idents = Set_ident.add state.used_idents x }); + else {state with used_idents = Set_ident.add state.used_idents x}); } let program js = diff --git a/compiler/core/js_pass_tailcall_inline.ml b/compiler/core/js_pass_tailcall_inline.ml index 5bb85c09ad..5a92b05cac 100644 --- a/compiler/core/js_pass_tailcall_inline.ml +++ b/compiler/core/js_pass_tailcall_inline.ml @@ -38,7 +38,7 @@ module S = Js_stmt_make let super = Js_record_map.super let substitue_variables (map : Ident.t Map_ident.t) = - { super with ident = (fun _ id -> Map_ident.find_default map id id) } + {super with ident = (fun _ id -> Map_ident.find_default map id id)} (* 1. recursive value ? let rec x = 1 :: x non-terminating @@ -111,15 +111,14 @@ let subst (export_set : Set_ident.t) stats = statement = (fun self st -> match st.statement_desc with - | Variable { value = _; ident_info = { used_stats = Dead_pure } } -> - S.block [] + | Variable {value = _; ident_info = {used_stats = Dead_pure}} -> + S.block [] | Variable - { ident_info = { used_stats = Dead_non_pure }; value = Some v; _ } - -> - S.exp v + {ident_info = {used_stats = Dead_non_pure}; value = Some v; _} -> + S.exp v | _ -> super.statement self st); variable_declaration = - (fun self ({ ident; value = _; property = _; ident_info = _ } as v) -> + (fun self ({ident; value = _; property = _; ident_info = _} as v) -> (* TODO: replacement is a bit shaky, the problem is the lambda we stored is not consistent after we did some subsititution, and the dead code removal does rely on this (otherwise, when you do beta-reduction you have to regenerate names) @@ -134,63 +133,71 @@ let subst (export_set : Set_ident.t) stats = | ({ statement_desc = Variable - ({ value = Some ({ expression_desc = Fun _; _ } as v) } as vd); + ({value = Some ({expression_desc = Fun _; _} as v)} as vd); comment = _; } as st) :: rest -> ( - let is_export = Set_ident.mem export_set vd.ident in - if is_export then self.statement self st :: self.block self rest - else - match Hash_ident.find_opt stats vd.ident with - (* TODO: could be improved as [mem] *) - | None -> - if Js_analyzer.no_side_effect_expression v then - S.exp v :: self.block self rest - else self.block self rest - | Some _ -> self.statement self st :: self.block self rest) + let is_export = Set_ident.mem export_set vd.ident in + if is_export then self.statement self st :: self.block self rest + else + match Hash_ident.find_opt stats vd.ident with + (* TODO: could be improved as [mem] *) + | None -> + if Js_analyzer.no_side_effect_expression v then + S.exp v :: self.block self rest + else self.block self rest + | Some _ -> self.statement self st :: self.block self rest) | [ ({ statement_desc = Return { expression_desc = - Call ({ expression_desc = Var (Id id) }, args, _info); + Call ({expression_desc = Var (Id id)}, args, _info); }; } as st); ] -> ( - match Hash_ident.find_opt stats id with - | Some - ({ - value = - Some - { - expression_desc = - Fun {is_method=false; params; body; env; async=false; directive=None}; - comment = _; - }; - (*TODO: don't inline method tail call yet, - [this] semantics are weird - *) - property = Alias | StrictOpt | Strict; - ident_info = { used_stats = Once_pure }; - ident = _; - } as v) - when Ext_list.same_length params args -> - Js_op_util.update_used_stats v.ident_info Dead_pure; - let no_tailcall = Js_fun_env.no_tailcall env in - let processed_blocks = - self.block self body - (* see #278 before changes*) - in - inline_call no_tailcall params args processed_blocks - (* Ext_list.fold_right2 - params args processed_blocks - (fun param arg acc -> - S.define_variable ~kind:Variable param arg :: acc) *) - (* Mark a function as dead means it will never be scanned, - here we inline the function - *) - | None | Some _ -> [ self.statement self st ]) + match Hash_ident.find_opt stats id with + | Some + ({ + value = + Some + { + expression_desc = + Fun + { + is_method = false; + params; + body; + env; + async = false; + directive = None; + }; + comment = _; + }; + (*TODO: don't inline method tail call yet, + [this] semantics are weird + *) + property = Alias | StrictOpt | Strict; + ident_info = {used_stats = Once_pure}; + ident = _; + } as v) + when Ext_list.same_length params args -> + Js_op_util.update_used_stats v.ident_info Dead_pure; + let no_tailcall = Js_fun_env.no_tailcall env in + let processed_blocks = + self.block self body + (* see #278 before changes*) + in + inline_call no_tailcall params args processed_blocks + (* Ext_list.fold_right2 + params args processed_blocks + (fun param arg acc -> + S.define_variable ~kind:Variable param arg :: acc) *) + (* Mark a function as dead means it will never be scanned, + here we inline the function + *) + | None | Some _ -> [self.statement self st]) | [ { statement_desc = @@ -200,7 +207,15 @@ let subst (export_set : Set_ident.t) stats = Call ( { expression_desc = - Fun {is_method=false; params; body; env; async=false; directive=None}; + Fun + { + is_method = false; + params; + body; + env; + async = false; + directive = None; + }; }, args, _info ); @@ -208,12 +223,12 @@ let subst (export_set : Set_ident.t) stats = }; ] when Ext_list.same_length params args -> - let no_tailcall = Js_fun_env.no_tailcall env in - let processed_blocks = - self.block self body - (* see #278 before changes*) - in - inline_call no_tailcall params args processed_blocks + let no_tailcall = Js_fun_env.no_tailcall env in + let processed_blocks = + self.block self body + (* see #278 before changes*) + in + inline_call no_tailcall params args processed_blocks | x :: xs -> self.statement self x :: self.block self xs | [] -> []); } diff --git a/compiler/core/js_record_fold.ml b/compiler/core/js_record_fold.ml index 945d6ef5f9..2f4ade7a61 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -27,26 +27,28 @@ open J let[@inline] unknown _ st _ = st let[@inline] option sub self st v = - match v with None -> st | Some v -> sub self st v + match v with + | None -> st + | Some v -> sub self st v let rec list sub self st x = match x with | [] -> st | x :: xs -> - let st = sub self st x in - list sub self st xs + let st = sub self st x in + list sub self st xs type 'state iter = { - ident : ('state, ident) fn; - module_id : ('state, module_id) fn; - vident : ('state, vident) fn; - exception_ident : ('state, exception_ident) fn; - for_ident : ('state, for_ident) fn; - expression : ('state, expression) fn; - statement : ('state, statement) fn; - variable_declaration : ('state, variable_declaration) fn; - block : ('state, block) fn; - program : ('state, program) fn; + ident: ('state, ident) fn; + module_id: ('state, module_id) fn; + vident: ('state, vident) fn; + exception_ident: ('state, exception_ident) fn; + for_ident: ('state, for_ident) fn; + expression: ('state, expression) fn; + statement: ('state, statement) fn; + variable_declaration: ('state, variable_declaration) fn; + block: ('state, block) fn; + program: ('state, program) fn; } and ('state, 'a) fn = 'state iter -> 'state -> 'a -> 'state @@ -54,7 +56,7 @@ and ('state, 'a) fn = 'state iter -> 'state -> 'a -> 'state let ident : 'a. ('a, ident) fn = unknown let module_id : 'a. ('a, module_id) fn = - fun _self st { id = _x0; kind = _x1 } -> + fun _self st {id = _x0; kind = _x1} -> let st = _self.ident _self st _x0 in st @@ -64,11 +66,11 @@ let required_modules : 'a. ('a, required_modules) fn = let vident : 'a. ('a, vident) fn = fun _self st -> function | Id _x0 -> - let st = _self.ident _self st _x0 in - st + let st = _self.ident _self st _x0 in + st | Qualified (_x0, _x1) -> - let st = _self.module_id _self st _x0 in - st + let st = _self.module_id _self st _x0 in + st let exception_ident : 'a. ('a, exception_ident) fn = fun _self arg -> _self.ident _self arg @@ -90,95 +92,95 @@ let length_object : 'a. ('a, length_object) fn = unknown let expression_desc : 'a. ('a, expression_desc) fn = fun _self st -> function | Length (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = length_object _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = length_object _self st _x1 in + st | Is_null_or_undefined _x0 -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | String_append (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = _self.expression _self st _x1 in + st | Bool _ -> st | Typeof _x0 -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | Js_not _x0 -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | Seq (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = _self.expression _self st _x1 in + st | Cond (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - let st = _self.expression _self st _x2 in - st + let st = _self.expression _self st _x0 in + let st = _self.expression _self st _x1 in + let st = _self.expression _self st _x2 in + st | Bin (_x0, _x1, _x2) -> - let st = _self.expression _self st _x1 in - let st = _self.expression _self st _x2 in - st + let st = _self.expression _self st _x1 in + let st = _self.expression _self st _x2 in + st | FlatCall (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = _self.expression _self st _x1 in + st | Call (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = list _self.expression _self st _x1 in - st - | Tagged_template (_xo, _x1, _x2) -> - let st = _self.expression _self st _xo in - let st = list _self.expression _self st _x1 in + let st = _self.expression _self st _x0 in + let st = list _self.expression _self st _x1 in + st + | Tagged_template (_xo, _x1, _x2) -> + let st = _self.expression _self st _xo in + let st = list _self.expression _self st _x1 in let st = list _self.expression _self st _x2 in st | String_index (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = _self.expression _self st _x1 in + st | Array_index (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = _self.expression _self st _x1 in + st | Static_index (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | New (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = - option - (fun _self st arg -> list _self.expression _self st arg) - _self st _x1 - in - st + let st = _self.expression _self st _x0 in + let st = + option + (fun _self st arg -> list _self.expression _self st arg) + _self st _x1 + in + st | Var _x0 -> - let st = _self.vident _self st _x0 in - st + let st = _self.vident _self st _x0 in + st | Fun {params; body} -> - let st = list _self.ident _self st params in - let st = _self.block _self st body in - st + let st = list _self.ident _self st params in + let st = _self.block _self st body in + st | Str _ -> st | Raw_js_code _ -> st | Array (_x0, _x1) -> - let st = list _self.expression _self st _x0 in - st + let st = list _self.expression _self st _x0 in + st | Optional_block (_x0, _x1) -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | Caml_block (_x0, _x1, _x2, _x3) -> - let st = list _self.expression _self st _x0 in - let st = _self.expression _self st _x2 in - st + let st = list _self.expression _self st _x0 in + let st = _self.expression _self st _x2 in + st | Caml_block_tag (_x0, _tag) -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | Number _ -> st | Object (_x0, _x1) -> - let st = option _self.expression _self st _x0 in - let st = property_map _self st _x1 in - st + let st = option _self.expression _self st _x0 in + let st = property_map _self st _x1 in + st | Undefined _ -> st | Null -> st | Await _x0 -> @@ -195,7 +197,7 @@ let finish_ident_expression : 'a. ('a, finish_ident_expression) fn = fun _self arg -> _self.expression _self arg let case_clause : 'a. ('a, case_clause) fn = - fun _self st { switch_body = _x0; should_break = _x1; comment = _x2 } -> + fun _self st {switch_body = _x0; should_break = _x1; comment = _x2} -> let st = _self.block _self st _x0 in st @@ -212,74 +214,74 @@ let int_clause : 'a. ('a, int_clause) fn = let statement_desc : 'a. ('a, statement_desc) fn = fun _self st -> function | Block _x0 -> - let st = _self.block _self st _x0 in - st + let st = _self.block _self st _x0 in + st | Variable _x0 -> - let st = _self.variable_declaration _self st _x0 in - st + let st = _self.variable_declaration _self st _x0 in + st | Exp _x0 -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | If (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = _self.block _self st _x1 in - let st = _self.block _self st _x2 in - st + let st = _self.expression _self st _x0 in + let st = _self.block _self st _x1 in + let st = _self.block _self st _x2 in + st | While (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.block _self st _x1 in - st + let st = _self.expression _self st _x0 in + let st = _self.block _self st _x1 in + st | ForRange (_x0, _x1, _x2, _x3, _x4) -> - let st = option for_ident_expression _self st _x0 in - let st = finish_ident_expression _self st _x1 in - let st = _self.for_ident _self st _x2 in - let st = for_direction _self st _x3 in - let st = _self.block _self st _x4 in - st + let st = option for_ident_expression _self st _x0 in + let st = finish_ident_expression _self st _x1 in + let st = _self.for_ident _self st _x2 in + let st = for_direction _self st _x3 in + let st = _self.block _self st _x4 in + st | Continue -> st | Break -> st | Return _x0 -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | Int_switch (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = list int_clause _self st _x1 in - let st = option _self.block _self st _x2 in - st + let st = _self.expression _self st _x0 in + let st = list int_clause _self st _x1 in + let st = option _self.block _self st _x2 in + st | String_switch (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = list string_clause _self st _x1 in - let st = option _self.block _self st _x2 in - st + let st = _self.expression _self st _x0 in + let st = list string_clause _self st _x1 in + let st = option _self.block _self st _x2 in + st | Throw _x0 -> - let st = _self.expression _self st _x0 in - st + let st = _self.expression _self st _x0 in + st | Try (_x0, _x1, _x2) -> - let st = _self.block _self st _x0 in - let st = - option - (fun _self st (_x0, _x1) -> - let st = _self.exception_ident _self st _x0 in - let st = _self.block _self st _x1 in - st) - _self st _x1 - in - let st = option _self.block _self st _x2 in - st + let st = _self.block _self st _x0 in + let st = + option + (fun _self st (_x0, _x1) -> + let st = _self.exception_ident _self st _x0 in + let st = _self.block _self st _x1 in + st) + _self st _x1 + in + let st = option _self.block _self st _x2 in + st | Debugger -> st let expression : 'a. ('a, expression) fn = - fun _self st { expression_desc = _x0; comment = _x1 } -> + fun _self st {expression_desc = _x0; comment = _x1} -> let st = expression_desc _self st _x0 in st let statement : 'a. ('a, statement) fn = - fun _self st { statement_desc = _x0; comment = _x1 } -> + fun _self st {statement_desc = _x0; comment = _x1} -> let st = statement_desc _self st _x0 in st let variable_declaration : 'a. ('a, variable_declaration) fn = - fun _self st { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> + fun _self st {ident = _x0; value = _x1; property = _x2; ident_info = _x3} -> let st = _self.ident _self st _x0 in let st = option _self.expression _self st _x1 in st @@ -288,12 +290,12 @@ let block : 'a. ('a, block) fn = fun _self st arg -> list _self.statement _self st arg let program : 'a. ('a, program) fn = - fun _self st { block = _x0; exports = _x1; export_set = _x2 } -> + fun _self st {block = _x0; exports = _x1; export_set = _x2} -> let st = _self.block _self st _x0 in st let deps_program : 'a. ('a, deps_program) fn = - fun _self st { program = _x0; modules = _x1; side_effect = _x2 } -> + fun _self st {program = _x0; modules = _x1; side_effect = _x2} -> let st = _self.program _self st _x0 in let st = required_modules _self st _x1 in st @@ -311,4 +313,3 @@ let super : 'state iter = block; program; } - \ No newline at end of file diff --git a/compiler/core/js_record_iter.ml b/compiler/core/js_record_iter.ml index 80fab6da4b..6d30efef1d 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -27,26 +27,28 @@ open J let unknown _ _ = () let[@inline] option sub self v = - match v with None -> () | Some v -> sub self v + match v with + | None -> () + | Some v -> sub self v let rec list sub self x = match x with | [] -> () | x :: xs -> - sub self x; - list sub self xs + sub self x; + list sub self xs type iter = { - ident : ident fn; - module_id : module_id fn; - vident : vident fn; - exception_ident : exception_ident fn; - for_ident : for_ident fn; - expression : expression fn; - statement : statement fn; - variable_declaration : variable_declaration fn; - block : block fn; - program : program fn; + ident: ident fn; + module_id: module_id fn; + vident: vident fn; + exception_ident: exception_ident fn; + for_ident: for_ident fn; + expression: expression fn; + statement: statement fn; + variable_declaration: variable_declaration fn; + block: block fn; + program: program fn; } and 'a fn = iter -> 'a -> unit @@ -54,7 +56,7 @@ and 'a fn = iter -> 'a -> unit let ident : ident fn = unknown let module_id : module_id fn = - fun _self { id = _x0; kind = _x1 } -> _self.ident _self _x0 + fun _self {id = _x0; kind = _x1} -> _self.ident _self _x0 let required_modules : required_modules fn = fun _self arg -> list _self.module_id _self arg @@ -80,61 +82,61 @@ let length_object : length_object fn = unknown let expression_desc : expression_desc fn = fun _self -> function | Length (_x0, _x1) -> - _self.expression _self _x0; - length_object _self _x1 + _self.expression _self _x0; + length_object _self _x1 | Is_null_or_undefined _x0 -> _self.expression _self _x0 | String_append (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 + _self.expression _self _x0; + _self.expression _self _x1 | Bool _ -> () | Typeof _x0 -> _self.expression _self _x0 | Js_not _x0 -> _self.expression _self _x0 | Seq (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 + _self.expression _self _x0; + _self.expression _self _x1 | Cond (_x0, _x1, _x2) -> - _self.expression _self _x0; - _self.expression _self _x1; - _self.expression _self _x2 + _self.expression _self _x0; + _self.expression _self _x1; + _self.expression _self _x2 | Bin (_x0, _x1, _x2) -> - _self.expression _self _x1; - _self.expression _self _x2 + _self.expression _self _x1; + _self.expression _self _x2 | FlatCall (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 + _self.expression _self _x0; + _self.expression _self _x1 | Call (_x0, _x1, _x2) -> - _self.expression _self _x0; - list _self.expression _self _x1 + _self.expression _self _x0; + list _self.expression _self _x1 | Tagged_template (_x0, _x1, _x2) -> _self.expression _self _x0; list _self.expression _self _x1; list _self.expression _self _x2 | String_index (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 + _self.expression _self _x0; + _self.expression _self _x1 | Array_index (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 + _self.expression _self _x0; + _self.expression _self _x1 | Static_index (_x0, _x1, _x2) -> _self.expression _self _x0 | New (_x0, _x1) -> - _self.expression _self _x0; - option (fun _self arg -> list _self.expression _self arg) _self _x1 + _self.expression _self _x0; + option (fun _self arg -> list _self.expression _self arg) _self _x1 | Var _x0 -> _self.vident _self _x0 | Fun {params; body} -> - list _self.ident _self params; - _self.block _self body + list _self.ident _self params; + _self.block _self body | Str _ -> () | Raw_js_code _ -> () | Array (_x0, _x1) -> list _self.expression _self _x0 | Optional_block (_x0, _x1) -> _self.expression _self _x0 | Caml_block (_x0, _x1, _x2, _x3) -> - list _self.expression _self _x0; - _self.expression _self _x2 + list _self.expression _self _x0; + _self.expression _self _x2 | Caml_block_tag (_x0, _tag) -> _self.expression _self _x0 | Number _ -> () | Object (_x0, _x1) -> - option _self.expression _self _x0; - property_map _self _x1 + option _self.expression _self _x0; + property_map _self _x1 | Undefined _ -> () | Null -> () | Await _x0 -> _self.expression _self _x0 @@ -147,7 +149,7 @@ let finish_ident_expression : finish_ident_expression fn = fun _self arg -> _self.expression _self arg let case_clause : case_clause fn = - fun _self { switch_body = _x0; should_break = _x1; comment = _x2 } -> + fun _self {switch_body = _x0; should_break = _x1; comment = _x2} -> _self.block _self _x0 let string_clause : string_clause fn = @@ -161,59 +163,59 @@ let statement_desc : statement_desc fn = | Variable _x0 -> _self.variable_declaration _self _x0 | Exp _x0 -> _self.expression _self _x0 | If (_x0, _x1, _x2) -> - _self.expression _self _x0; - _self.block _self _x1; - _self.block _self _x2 + _self.expression _self _x0; + _self.block _self _x1; + _self.block _self _x2 | While (_x0, _x1) -> - _self.expression _self _x0; - _self.block _self _x1 + _self.expression _self _x0; + _self.block _self _x1 | ForRange (_x0, _x1, _x2, _x3, _x4) -> - option for_ident_expression _self _x0; - finish_ident_expression _self _x1; - _self.for_ident _self _x2; - for_direction _self _x3; - _self.block _self _x4 + option for_ident_expression _self _x0; + finish_ident_expression _self _x1; + _self.for_ident _self _x2; + for_direction _self _x3; + _self.block _self _x4 | Continue -> () | Break -> () | Return _x0 -> _self.expression _self _x0 | Int_switch (_x0, _x1, _x2) -> - _self.expression _self _x0; - list int_clause _self _x1; - option _self.block _self _x2 + _self.expression _self _x0; + list int_clause _self _x1; + option _self.block _self _x2 | String_switch (_x0, _x1, _x2) -> - _self.expression _self _x0; - list string_clause _self _x1; - option _self.block _self _x2 + _self.expression _self _x0; + list string_clause _self _x1; + option _self.block _self _x2 | Throw _x0 -> _self.expression _self _x0 | Try (_x0, _x1, _x2) -> - _self.block _self _x0; - option - (fun _self (_x0, _x1) -> - _self.exception_ident _self _x0; - _self.block _self _x1) - _self _x1; - option _self.block _self _x2 + _self.block _self _x0; + option + (fun _self (_x0, _x1) -> + _self.exception_ident _self _x0; + _self.block _self _x1) + _self _x1; + option _self.block _self _x2 | Debugger -> () let expression : expression fn = - fun _self { expression_desc = _x0; comment = _x1 } -> expression_desc _self _x0 + fun _self {expression_desc = _x0; comment = _x1} -> expression_desc _self _x0 let statement : statement fn = - fun _self { statement_desc = _x0; comment = _x1 } -> statement_desc _self _x0 + fun _self {statement_desc = _x0; comment = _x1} -> statement_desc _self _x0 let variable_declaration : variable_declaration fn = - fun _self { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> + fun _self {ident = _x0; value = _x1; property = _x2; ident_info = _x3} -> _self.ident _self _x0; option _self.expression _self _x1 let block : block fn = fun _self arg -> list _self.statement _self arg let program : program fn = - fun _self { block = _x0; exports = _x1; export_set = _x2 } -> + fun _self {block = _x0; exports = _x1; export_set = _x2} -> _self.block _self _x0 let deps_program : deps_program fn = - fun _self { program = _x0; modules = _x1; side_effect = _x2 } -> + fun _self {program = _x0; modules = _x1; side_effect = _x2} -> _self.program _self _x0; required_modules _self _x1 @@ -230,4 +232,3 @@ let super : iter = block; program; } - \ No newline at end of file diff --git a/compiler/core/js_record_map.ml b/compiler/core/js_record_map.ml index c5f90187a6..0a9ba771b4 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -27,26 +27,28 @@ open J let[@inline] unknown _ x = x let[@inline] option sub self v = - match v with None -> None | Some v -> Some (sub self v) + match v with + | None -> None + | Some v -> Some (sub self v) let rec list sub self x = match x with | [] -> [] | x :: xs -> - let v = sub self x in - v :: list sub self xs + let v = sub self x in + v :: list sub self xs type iter = { - ident : ident fn; - module_id : module_id fn; - vident : vident fn; - exception_ident : exception_ident fn; - for_ident : for_ident fn; - expression : expression fn; - statement : statement fn; - variable_declaration : variable_declaration fn; - block : block fn; - program : program fn; + ident: ident fn; + module_id: module_id fn; + vident: vident fn; + exception_ident: exception_ident fn; + for_ident: for_ident fn; + expression: expression fn; + statement: statement fn; + variable_declaration: variable_declaration fn; + block: block fn; + program: program fn; } and 'a fn = iter -> 'a -> 'a @@ -54,9 +56,9 @@ and 'a fn = iter -> 'a -> 'a let ident : ident fn = unknown let module_id : module_id fn = - fun _self { id = _x0; kind = _x1; dynamic_import = _x2 } -> + fun _self {id = _x0; kind = _x1; dynamic_import = _x2} -> let _x0 = _self.ident _self _x0 in - { id = _x0; kind = _x1; dynamic_import = _x2 } + {id = _x0; kind = _x1; dynamic_import = _x2} let required_modules : required_modules fn = fun _self arg -> list _self.module_id _self arg @@ -64,11 +66,11 @@ let required_modules : required_modules fn = let vident : vident fn = fun _self -> function | Id _x0 -> - let _x0 = _self.ident _self _x0 in - Id _x0 + let _x0 = _self.ident _self _x0 in + Id _x0 | Qualified (_x0, _x1) -> - let _x0 = _self.module_id _self _x0 in - Qualified (_x0, _x1) + let _x0 = _self.module_id _self _x0 in + Qualified (_x0, _x1) let exception_ident : exception_ident fn = fun _self arg -> _self.ident _self arg @@ -90,93 +92,93 @@ let length_object : length_object fn = unknown let expression_desc : expression_desc fn = fun _self -> function | Length (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = length_object _self _x1 in - Length (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = length_object _self _x1 in + Length (_x0, _x1) | Is_null_or_undefined _x0 -> - let _x0 = _self.expression _self _x0 in - Is_null_or_undefined _x0 + let _x0 = _self.expression _self _x0 in + Is_null_or_undefined _x0 | String_append (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - String_append (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.expression _self _x1 in + String_append (_x0, _x1) | Bool _ as v -> v | Typeof _x0 -> - let _x0 = _self.expression _self _x0 in - Typeof _x0 + let _x0 = _self.expression _self _x0 in + Typeof _x0 | Js_not _x0 -> - let _x0 = _self.expression _self _x0 in - Js_not _x0 + let _x0 = _self.expression _self _x0 in + Js_not _x0 | Seq (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - Seq (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.expression _self _x1 in + Seq (_x0, _x1) | Cond (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - let _x2 = _self.expression _self _x2 in - Cond (_x0, _x1, _x2) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.expression _self _x1 in + let _x2 = _self.expression _self _x2 in + Cond (_x0, _x1, _x2) | Bin (_x0, _x1, _x2) -> - let _x1 = _self.expression _self _x1 in - let _x2 = _self.expression _self _x2 in - Bin (_x0, _x1, _x2) + let _x1 = _self.expression _self _x1 in + let _x2 = _self.expression _self _x2 in + Bin (_x0, _x1, _x2) | FlatCall (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - FlatCall (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.expression _self _x1 in + FlatCall (_x0, _x1) | Call (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list _self.expression _self _x1 in - Call (_x0, _x1, _x2) - | Tagged_template (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list _self.expression _self _x1 in - let _x2 = list _self.expression _self _x2 in - Tagged_template (_x0, _x1, _x2) + let _x0 = _self.expression _self _x0 in + let _x1 = list _self.expression _self _x1 in + Call (_x0, _x1, _x2) + | Tagged_template (_x0, _x1, _x2) -> + let _x0 = _self.expression _self _x0 in + let _x1 = list _self.expression _self _x1 in + let _x2 = list _self.expression _self _x2 in + Tagged_template (_x0, _x1, _x2) | String_index (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - String_index (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.expression _self _x1 in + String_index (_x0, _x1) | Array_index (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - Array_index (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.expression _self _x1 in + Array_index (_x0, _x1) | Static_index (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - Static_index (_x0, _x1, _x2) + let _x0 = _self.expression _self _x0 in + Static_index (_x0, _x1, _x2) | New (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = - option (fun _self arg -> list _self.expression _self arg) _self _x1 - in - New (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = + option (fun _self arg -> list _self.expression _self arg) _self _x1 + in + New (_x0, _x1) | Var _x0 -> - let _x0 = _self.vident _self _x0 in - Var _x0 + let _x0 = _self.vident _self _x0 in + Var _x0 | Fun ({params; body} as fun_) -> - let params = list _self.ident _self params in - let body = _self.block _self body in - Fun {fun_ with params; body} + let params = list _self.ident _self params in + let body = _self.block _self body in + Fun {fun_ with params; body} | Str _ as v -> v | Raw_js_code _ as v -> v | Array (_x0, _x1) -> - let _x0 = list _self.expression _self _x0 in - Array (_x0, _x1) + let _x0 = list _self.expression _self _x0 in + Array (_x0, _x1) | Optional_block (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - Optional_block (_x0, _x1) + let _x0 = _self.expression _self _x0 in + Optional_block (_x0, _x1) | Caml_block (_x0, _x1, _x2, _x3) -> - let _x0 = list _self.expression _self _x0 in - let _x2 = _self.expression _self _x2 in - Caml_block (_x0, _x1, _x2, _x3) + let _x0 = list _self.expression _self _x0 in + let _x2 = _self.expression _self _x2 in + Caml_block (_x0, _x1, _x2, _x3) | Caml_block_tag (_x0, tag) -> - let _x0 = _self.expression _self _x0 in - Caml_block_tag (_x0, tag) + let _x0 = _self.expression _self _x0 in + Caml_block_tag (_x0, tag) | Number _ as v -> v | Object (_x0, _x1) -> - let _x0 = option _self.expression _self _x0 in - let _x1 = property_map _self _x1 in - Object (_x0, _x1) + let _x0 = option _self.expression _self _x0 in + let _x1 = property_map _self _x1 in + Object (_x0, _x1) | Undefined _ as v -> v | Null as v -> v | Await _x0 -> @@ -193,9 +195,9 @@ let finish_ident_expression : finish_ident_expression fn = fun _self arg -> _self.expression _self arg let case_clause : case_clause fn = - fun _self { switch_body = _x0; should_break = _x1; comment = _x2 } -> + fun _self {switch_body = _x0; should_break = _x1; comment = _x2} -> let _x0 = _self.block _self _x0 in - { switch_body = _x0; should_break = _x1; comment = _x2 } + {switch_body = _x0; should_break = _x1; comment = _x2} let string_clause : string_clause fn = fun _self (_x0, _x1) -> @@ -210,90 +212,90 @@ let int_clause : int_clause fn = let statement_desc : statement_desc fn = fun _self -> function | Block _x0 -> - let _x0 = _self.block _self _x0 in - Block _x0 + let _x0 = _self.block _self _x0 in + Block _x0 | Variable _x0 -> - let _x0 = _self.variable_declaration _self _x0 in - Variable _x0 + let _x0 = _self.variable_declaration _self _x0 in + Variable _x0 | Exp _x0 -> - let _x0 = _self.expression _self _x0 in - Exp _x0 + let _x0 = _self.expression _self _x0 in + Exp _x0 | If (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.block _self _x1 in - let _x2 = _self.block _self _x2 in - If (_x0, _x1, _x2) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.block _self _x1 in + let _x2 = _self.block _self _x2 in + If (_x0, _x1, _x2) | While (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.block _self _x1 in - While (_x0, _x1) + let _x0 = _self.expression _self _x0 in + let _x1 = _self.block _self _x1 in + While (_x0, _x1) | ForRange (_x0, _x1, _x2, _x3, _x4) -> - let _x0 = option for_ident_expression _self _x0 in - let _x1 = finish_ident_expression _self _x1 in - let _x2 = _self.for_ident _self _x2 in - let _x3 = for_direction _self _x3 in - let _x4 = _self.block _self _x4 in - ForRange (_x0, _x1, _x2, _x3, _x4) + let _x0 = option for_ident_expression _self _x0 in + let _x1 = finish_ident_expression _self _x1 in + let _x2 = _self.for_ident _self _x2 in + let _x3 = for_direction _self _x3 in + let _x4 = _self.block _self _x4 in + ForRange (_x0, _x1, _x2, _x3, _x4) | Continue as v -> v | Break as v -> v | Return _x0 -> - let _x0 = _self.expression _self _x0 in - Return _x0 + let _x0 = _self.expression _self _x0 in + Return _x0 | Int_switch (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list int_clause _self _x1 in - let _x2 = option _self.block _self _x2 in - Int_switch (_x0, _x1, _x2) + let _x0 = _self.expression _self _x0 in + let _x1 = list int_clause _self _x1 in + let _x2 = option _self.block _self _x2 in + Int_switch (_x0, _x1, _x2) | String_switch (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list string_clause _self _x1 in - let _x2 = option _self.block _self _x2 in - String_switch (_x0, _x1, _x2) + let _x0 = _self.expression _self _x0 in + let _x1 = list string_clause _self _x1 in + let _x2 = option _self.block _self _x2 in + String_switch (_x0, _x1, _x2) | Throw _x0 -> - let _x0 = _self.expression _self _x0 in - Throw _x0 + let _x0 = _self.expression _self _x0 in + Throw _x0 | Try (_x0, _x1, _x2) -> - let _x0 = _self.block _self _x0 in - let _x1 = - option - (fun _self (_x0, _x1) -> - let _x0 = _self.exception_ident _self _x0 in - let _x1 = _self.block _self _x1 in - (_x0, _x1)) - _self _x1 - in - let _x2 = option _self.block _self _x2 in - Try (_x0, _x1, _x2) + let _x0 = _self.block _self _x0 in + let _x1 = + option + (fun _self (_x0, _x1) -> + let _x0 = _self.exception_ident _self _x0 in + let _x1 = _self.block _self _x1 in + (_x0, _x1)) + _self _x1 + in + let _x2 = option _self.block _self _x2 in + Try (_x0, _x1, _x2) | Debugger as v -> v let expression : expression fn = - fun _self { expression_desc = _x0; comment = _x1 } -> + fun _self {expression_desc = _x0; comment = _x1} -> let _x0 = expression_desc _self _x0 in - { expression_desc = _x0; comment = _x1 } + {expression_desc = _x0; comment = _x1} let statement : statement fn = - fun _self { statement_desc = _x0; comment = _x1 } -> + fun _self {statement_desc = _x0; comment = _x1} -> let _x0 = statement_desc _self _x0 in - { statement_desc = _x0; comment = _x1 } + {statement_desc = _x0; comment = _x1} let variable_declaration : variable_declaration fn = - fun _self { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> + fun _self {ident = _x0; value = _x1; property = _x2; ident_info = _x3} -> let _x0 = _self.ident _self _x0 in let _x1 = option _self.expression _self _x1 in - { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } + {ident = _x0; value = _x1; property = _x2; ident_info = _x3} let block : block fn = fun _self arg -> list _self.statement _self arg let program : program fn = - fun _self { block = _x0; exports = _x1; export_set = _x2 } -> + fun _self {block = _x0; exports = _x1; export_set = _x2} -> let _x0 = _self.block _self _x0 in - { block = _x0; exports = _x1; export_set = _x2 } + {block = _x0; exports = _x1; export_set = _x2} let deps_program : deps_program fn = - fun _self { program = _x0; modules = _x1; side_effect = _x2 } -> + fun _self {program = _x0; modules = _x1; side_effect = _x2} -> let _x0 = _self.program _self _x0 in let _x1 = required_modules _self _x1 in - { program = _x0; modules = _x1; side_effect = _x2 } + {program = _x0; modules = _x1; side_effect = _x2} let super : iter = { @@ -308,4 +310,3 @@ let super : iter = block; program; } - \ No newline at end of file diff --git a/compiler/core/js_shake.ml b/compiler/core/js_shake.ml index ab8819c5ad..36581e3810 100644 --- a/compiler/core/js_shake.ml +++ b/compiler/core/js_shake.ml @@ -29,34 +29,33 @@ let get_initial_exports count_non_variable_declaration_statement let result = Ext_list.fold_left block export_set (fun acc st -> match st.statement_desc with - | Variable { ident; value; _ } -> ( - if Set_ident.mem acc ident then - match value with - | None -> acc - | Some x -> - (* If not a function, we have to calcuate again and again - TODO: add hashtbl for a cache - *) - Set_ident.( - union (Js_analyzer.free_variables_of_expression x) acc) - else - match value with - | None -> acc - | Some x -> - if Js_analyzer.no_side_effect_expression x then acc - else - Set_ident.( - union - (Js_analyzer.free_variables_of_expression x) - (add acc ident))) + | Variable {ident; value; _} -> ( + if Set_ident.mem acc ident then + match value with + | None -> acc + | Some x -> + (* If not a function, we have to calcuate again and again + TODO: add hashtbl for a cache + *) + Set_ident.(union (Js_analyzer.free_variables_of_expression x) acc) + else + match value with + | None -> acc + | Some x -> + if Js_analyzer.no_side_effect_expression x then acc + else + Set_ident.( + union + (Js_analyzer.free_variables_of_expression x) + (add acc ident))) | _ -> - (* recalcuate again and again ... *) - if - Js_analyzer.no_side_effect_statement st - || not count_non_variable_declaration_statement - then acc - else - Set_ident.(union (Js_analyzer.free_variables_of_statement st) acc)) + (* recalcuate again and again ... *) + if + Js_analyzer.no_side_effect_statement st + || not count_non_variable_declaration_statement + then acc + else + Set_ident.(union (Js_analyzer.free_variables_of_statement st) acc)) in (result, Set_ident.(diff result export_set)) @@ -93,16 +92,16 @@ let shake_program (program : J.program) = let really_set = loop block export_set in Ext_list.fold_right block [] (fun (st : J.statement) acc -> match st.statement_desc with - | Variable { ident; value; _ } -> ( - if Set_ident.mem really_set ident then st :: acc - else - match value with - | None -> acc - | Some x -> - if Js_analyzer.no_side_effect_expression x then acc - else st :: acc) + | Variable {ident; value; _} -> ( + if Set_ident.mem really_set ident then st :: acc + else + match value with + | None -> acc + | Some x -> + if Js_analyzer.no_side_effect_expression x then acc else st :: acc + ) | _ -> - if Js_analyzer.no_side_effect_statement st then acc else st :: acc) + if Js_analyzer.no_side_effect_statement st then acc else st :: acc) in - { program with block = shake_block program.block program.export_set } + {program with block = shake_block program.block program.export_set} diff --git a/compiler/core/js_stmt_make.ml b/compiler/core/js_stmt_make.ml index 0592627c2e..0067e89ccc 100644 --- a/compiler/core/js_stmt_make.ml +++ b/compiler/core/js_stmt_make.ml @@ -26,54 +26,58 @@ module E = Js_exp_make type t = J.statement -let return_stmt ?comment e : t = { statement_desc = Return e; comment } +let return_stmt ?comment e : t = {statement_desc = Return e; comment} -let empty_stmt : t = { statement_desc = Block []; comment = None } +let empty_stmt : t = {statement_desc = Block []; comment = None} (* let empty_block : J.block = [] *) -let throw_stmt ?comment v : t = { statement_desc = Throw v; comment } +let throw_stmt ?comment v : t = {statement_desc = Throw v; comment} (* avoid nested block *) let rec block ?comment (b : J.block) : t = match b with - | [ { statement_desc = Block bs } ] -> block bs - | [ b ] -> b + | [{statement_desc = Block bs}] -> block bs + | [b] -> b | [] -> empty_stmt - | _ -> { statement_desc = Block b; comment } + | _ -> {statement_desc = Block b; comment} (* It's a statement, we can discard some values *) let rec exp ?comment (e : E.t) : t = match e.expression_desc with - | Seq ({ expression_desc = Number _ | Undefined _ }, b) - | Seq (b, { expression_desc = Number _ | Undefined _ }) -> - exp ?comment b + | Seq ({expression_desc = Number _ | Undefined _}, b) + | Seq (b, {expression_desc = Number _ | Undefined _}) -> + exp ?comment b | Number _ | Undefined _ -> block [] (* TODO: we can do more *) (* | _ when is_pure e -> block [] *) - | _ -> { statement_desc = Exp e; comment } + | _ -> {statement_desc = Exp e; comment} let declare_variable ?comment ?ident_info ~kind (ident : Ident.t) : t = let property : J.property = kind in let ident_info : J.ident_info = - match ident_info with None -> { used_stats = NA } | Some x -> x + match ident_info with + | None -> {used_stats = NA} + | Some x -> x in { - statement_desc = Variable { ident; value = None; property; ident_info }; + statement_desc = Variable {ident; value = None; property; ident_info}; comment; } let define_variable ?comment ?ident_info ~kind (v : Ident.t) - (exp : J.expression) : t = match exp.expression_desc with - | Undefined _ -> - declare_variable ?comment ?ident_info ~kind v + (exp : J.expression) : t = + match exp.expression_desc with + | Undefined _ -> declare_variable ?comment ?ident_info ~kind v | _ -> let property : J.property = kind in let ident_info : J.ident_info = - match ident_info with None -> { used_stats = NA } | Some x -> x + match ident_info with + | None -> {used_stats = NA} + | Some x -> x in { statement_desc = - Variable { ident = v; value = Some exp; property; ident_info }; + Variable {ident = v; value = Some exp; property; ident_info}; comment; } @@ -88,99 +92,104 @@ let int_switch ?(comment : string option) ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) (e : J.expression) (clauses : (int * J.case_clause) list) : t = match e.expression_desc with - | Number (Int { i; _ }) -> ( - let continuation = - match - Ext_list.find_opt clauses (fun (switch_case, x) -> - if switch_case = Int32.to_int i then Some x.switch_body else None) - with - | Some case -> case - | None -> ( match default with Some x -> x | None -> assert false) - in - match (declaration, continuation) with - | ( Some (kind, did), - [ - { - statement_desc = - Exp - { - expression_desc = - Bin (Eq, { expression_desc = Var (Id id); _ }, e0); - _; - }; - _; - }; - ] ) - when Ident.same did id -> - define_variable ?comment ~kind id e0 - | Some (kind, did), _ -> - block (declare_variable ?comment ~kind did :: continuation) - | None, _ -> block continuation) + | Number (Int {i; _}) -> ( + let continuation = + match + Ext_list.find_opt clauses (fun (switch_case, x) -> + if switch_case = Int32.to_int i then Some x.switch_body else None) + with + | Some case -> case + | None -> ( + match default with + | Some x -> x + | None -> assert false) + in + match (declaration, continuation) with + | ( Some (kind, did), + [ + { + statement_desc = + Exp + { + expression_desc = + Bin (Eq, {expression_desc = Var (Id id); _}, e0); + _; + }; + _; + }; + ] ) + when Ident.same did id -> + define_variable ?comment ~kind id e0 + | Some (kind, did), _ -> + block (declare_variable ?comment ~kind did :: continuation) + | None, _ -> block continuation) | _ -> ( - match declaration with - | Some (kind, did) -> - block - [ - declare_variable ?comment ~kind did; - { statement_desc = J.Int_switch (e, clauses, default); comment }; - ] - | None -> { statement_desc = J.Int_switch (e, clauses, default); comment } - ) + match declaration with + | Some (kind, did) -> + block + [ + declare_variable ?comment ~kind did; + {statement_desc = J.Int_switch (e, clauses, default); comment}; + ] + | None -> {statement_desc = J.Int_switch (e, clauses, default); comment}) let string_switch ?(comment : string option) ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) - (e : J.expression) (clauses : (Ast_untagged_variants.tag_type * J.case_clause) list) : t = + (e : J.expression) + (clauses : (Ast_untagged_variants.tag_type * J.case_clause) list) : t = match e.expression_desc with | Str {txt} -> ( - let continuation = - match - Ext_list.find_opt clauses (fun (switch_case, x) -> + let continuation = + match + Ext_list.find_opt clauses (fun (switch_case, x) -> match switch_case with - | String s -> - if s = txt then Some x.switch_body else None - | Int _ | Float _ | BigInt _ | Bool _ | Null | Undefined | Untagged _ -> + | String s -> if s = txt then Some x.switch_body else None + | Int _ | Float _ | BigInt _ | Bool _ | Null | Undefined + | Untagged _ -> None) - with - | Some case -> case - | None -> ( match default with Some x -> x | None -> assert false) - in - match (declaration, continuation) with - | ( Some (kind, did), - [ - { - statement_desc = - Exp - { - expression_desc = - Bin (Eq, { expression_desc = Var (Id id); _ }, e0); - _; - }; - _; - }; - ] ) - when Ident.same did id -> - define_variable ?comment ~kind id e0 - | Some (kind, did), _ -> - block @@ (declare_variable ?comment ~kind did :: continuation) - | None, _ -> block continuation) + with + | Some case -> case + | None -> ( + match default with + | Some x -> x + | None -> assert false) + in + match (declaration, continuation) with + | ( Some (kind, did), + [ + { + statement_desc = + Exp + { + expression_desc = + Bin (Eq, {expression_desc = Var (Id id); _}, e0); + _; + }; + _; + }; + ] ) + when Ident.same did id -> + define_variable ?comment ~kind id e0 + | Some (kind, did), _ -> + block @@ (declare_variable ?comment ~kind did :: continuation) + | None, _ -> block continuation) | _ -> ( - match declaration with - | Some (kind, did) -> - block - [ - declare_variable ?comment ~kind did; - { statement_desc = String_switch (e, clauses, default); comment }; - ] - | None -> - { statement_desc = String_switch (e, clauses, default); comment }) + match declaration with + | Some (kind, did) -> + block + [ + declare_variable ?comment ~kind did; + {statement_desc = String_switch (e, clauses, default); comment}; + ] + | None -> {statement_desc = String_switch (e, clauses, default); comment}) let rec block_last_is_return_throw_or_continue (x : J.block) = match x with | [] -> false - | [ x ] -> ( - match x.statement_desc with - | Return _ | Throw _ | Continue -> true - | _ -> false) + | [x] -> ( + match x.statement_desc with + | Return _ | Throw _ | Continue -> true + | _ -> false) | _ :: rest -> block_last_is_return_throw_or_continue rest (* TODO: it also make sense to extract some common statements @@ -231,108 +240,107 @@ let if_ ?comment ?declaration ?else_ (e : J.expression) (then_ : J.block) : t = | Bool boolean, _ -> block (if boolean then ifso else ifnot) | Js_not pred_not, _ :: _ -> aux ?comment pred_not ifnot ifso | _ -> ( - match (ifso, ifnot) with - | [], [] -> exp e - | [], _ -> - aux ?comment (E.not e) ifnot [] (*Make sure no infinite loop*) - | ( [ { statement_desc = Return ret_ifso; _ } ], - [ { statement_desc = Return ret_ifnot; _ } ] ) -> - return_stmt (E.econd e ret_ifso ret_ifnot) - | _, [ { statement_desc = Return _ } ] -> - block ({ statement_desc = If (E.not e, ifnot, []); comment } :: ifso) - | _, _ when block_last_is_return_throw_or_continue ifso -> - block ({ statement_desc = If (e, ifso, []); comment } :: ifnot) - | ( [ - { - statement_desc = - Exp - { - expression_desc = - Bin - ( Eq, - ({ expression_desc = Var (Id var_ifso); _ } as - lhs_ifso), - rhs_ifso ); - _; - }; - _; - }; - ], - [ - { - statement_desc = - Exp - { - expression_desc = - Bin - ( Eq, - { expression_desc = Var (Id var_ifnot); _ }, - lhs_ifnot ); - _; - }; - _; - }; - ] ) - when Ident.same var_ifso var_ifnot -> ( - match declaration with - | Some (kind, id) when Ident.same id var_ifso -> - declared := true; - define_variable ~kind var_ifso (E.econd e rhs_ifso lhs_ifnot) - | _ -> exp (E.assign lhs_ifso (E.econd e rhs_ifso lhs_ifnot))) - | ( [ { statement_desc = Exp exp_ifso; _ } ], - [ { statement_desc = Exp exp_ifnot; _ } ] ) -> - exp (E.econd e exp_ifso exp_ifnot) - | [ { statement_desc = If (pred1, ifso1, ifnot1) } ], _ - when Js_analyzer.eq_block ifnot1 ifnot -> - aux ?comment (E.and_ e pred1) ifso1 ifnot1 - | [ { statement_desc = If (pred1, ifso1, ifnot1) } ], _ - when Js_analyzer.eq_block ifso1 ifnot -> - aux ?comment (E.and_ e (E.not pred1)) ifnot1 ifso1 - | _, [ { statement_desc = If (pred1, ifso1, else_) } ] - when Js_analyzer.eq_block ifso ifso1 -> - aux ?comment (E.or_ e pred1) ifso else_ - | _, [ { statement_desc = If (pred1, ifso1, ifnot1) } ] - when Js_analyzer.eq_block ifso ifnot1 -> - aux ?comment (E.or_ e (E.not pred1)) ifso ifso1 - | ifso1 :: ifso_rest, ifnot1 :: ifnot_rest - when Js_analyzer.eq_statement ifnot1 ifso1 - && Js_analyzer.no_side_effect_expression e -> - (* here we do agressive optimization, because it can help optimization later, - move code outside of branch is generally helpful later - *) - add_prefix ifso1; - aux ?comment e ifso_rest ifnot_rest - | _ -> { statement_desc = If (e, ifso, ifnot); comment }) + match (ifso, ifnot) with + | [], [] -> exp e + | [], _ -> aux ?comment (E.not e) ifnot [] (*Make sure no infinite loop*) + | ( [{statement_desc = Return ret_ifso; _}], + [{statement_desc = Return ret_ifnot; _}] ) -> + return_stmt (E.econd e ret_ifso ret_ifnot) + | _, [{statement_desc = Return _}] -> + block ({statement_desc = If (E.not e, ifnot, []); comment} :: ifso) + | _, _ when block_last_is_return_throw_or_continue ifso -> + block ({statement_desc = If (e, ifso, []); comment} :: ifnot) + | ( [ + { + statement_desc = + Exp + { + expression_desc = + Bin + ( Eq, + ({expression_desc = Var (Id var_ifso); _} as lhs_ifso), + rhs_ifso ); + _; + }; + _; + }; + ], + [ + { + statement_desc = + Exp + { + expression_desc = + Bin + ( Eq, + {expression_desc = Var (Id var_ifnot); _}, + lhs_ifnot ); + _; + }; + _; + }; + ] ) + when Ident.same var_ifso var_ifnot -> ( + match declaration with + | Some (kind, id) when Ident.same id var_ifso -> + declared := true; + define_variable ~kind var_ifso (E.econd e rhs_ifso lhs_ifnot) + | _ -> exp (E.assign lhs_ifso (E.econd e rhs_ifso lhs_ifnot))) + | ( [{statement_desc = Exp exp_ifso; _}], + [{statement_desc = Exp exp_ifnot; _}] ) -> + exp (E.econd e exp_ifso exp_ifnot) + | [{statement_desc = If (pred1, ifso1, ifnot1)}], _ + when Js_analyzer.eq_block ifnot1 ifnot -> + aux ?comment (E.and_ e pred1) ifso1 ifnot1 + | [{statement_desc = If (pred1, ifso1, ifnot1)}], _ + when Js_analyzer.eq_block ifso1 ifnot -> + aux ?comment (E.and_ e (E.not pred1)) ifnot1 ifso1 + | _, [{statement_desc = If (pred1, ifso1, else_)}] + when Js_analyzer.eq_block ifso ifso1 -> + aux ?comment (E.or_ e pred1) ifso else_ + | _, [{statement_desc = If (pred1, ifso1, ifnot1)}] + when Js_analyzer.eq_block ifso ifnot1 -> + aux ?comment (E.or_ e (E.not pred1)) ifso ifso1 + | ifso1 :: ifso_rest, ifnot1 :: ifnot_rest + when Js_analyzer.eq_statement ifnot1 ifso1 + && Js_analyzer.no_side_effect_expression e -> + (* here we do agressive optimization, because it can help optimization later, + move code outside of branch is generally helpful later + *) + add_prefix ifso1; + aux ?comment e ifso_rest ifnot_rest + | _ -> {statement_desc = If (e, ifso, ifnot); comment}) in let if_block = - aux ?comment e then_ (match else_ with None -> [] | Some v -> v) + aux ?comment e then_ + (match else_ with + | None -> [] + | Some v -> v) in let prefix = !common_prefix_blocks in match (!declared, declaration) with | true, _ | _, None -> - if prefix = [] then if_block - else block (List.rev_append prefix [ if_block ]) + if prefix = [] then if_block else block (List.rev_append prefix [if_block]) | false, Some (kind, id) -> - block (declare_variable ~kind id :: List.rev_append prefix [ if_block ]) + block (declare_variable ~kind id :: List.rev_append prefix [if_block]) let assign ?comment id e : t = - { statement_desc = J.Exp (E.assign (E.var id) e); comment } + {statement_desc = J.Exp (E.assign (E.var id) e); comment} let while_ ?comment (e : E.t) (st : J.block) : t = - { statement_desc = While (e, st); comment } + {statement_desc = While (e, st); comment} let for_ ?comment for_ident_expression finish_ident_expression id direction (b : J.block) : t = { statement_desc = - ForRange - (for_ident_expression, finish_ident_expression, id, direction, b); + ForRange (for_ident_expression, finish_ident_expression, id, direction, b); comment; } let try_ ?comment ?with_ ?finally body : t = - { statement_desc = Try (body, with_, finally); comment } + {statement_desc = Try (body, with_, finally); comment} -let continue_ : t = { statement_desc = Continue; comment = None } +let continue_ : t = {statement_desc = Continue; comment = None} -let debugger_block : t list = [ { statement_desc = Debugger; comment = None } ] +let debugger_block : t list = [{statement_desc = Debugger; comment = None}] diff --git a/compiler/core/js_stmt_make.mli b/compiler/core/js_stmt_make.mli index dc36a464e5..00a5daae83 100644 --- a/compiler/core/js_stmt_make.mli +++ b/compiler/core/js_stmt_make.mli @@ -130,11 +130,7 @@ val assign : ?comment:string -> J.ident -> J.expression -> t J.ident -> t *) -val while_ : - ?comment:string -> - J.expression -> - J.block -> - t +val while_ : ?comment:string -> J.expression -> J.block -> t val for_ : ?comment:string -> diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 79a4bdeeab..77f991e181 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -26,27 +26,27 @@ type ident = Ident.t type apply_status = App_na | App_infer_full | App_uncurry type ap_info = { - ap_loc : Location.t; - ap_inlined : Lambda.inline_attribute; - ap_status : apply_status; + ap_loc: Location.t; + ap_inlined: Lambda.inline_attribute; + ap_status: apply_status; } module Types = struct type lambda_switch = { - sw_consts_full : bool; + sw_consts_full: bool; (* TODO: refine its representation *) - sw_consts : (int * t) list; - sw_blocks_full : bool; - sw_blocks : (int * t) list; - sw_failaction : t option; - sw_names : Ast_untagged_variants.switch_names option; + sw_consts: (int * t) list; + sw_blocks_full: bool; + sw_blocks: (int * t) list; + sw_failaction: t option; + sw_names: Ast_untagged_variants.switch_names option; } and lfunction = { - arity : int; - params : ident list; - body : t; - attr : Lambda.function_attribute; + arity: int; + params: ident list; + body: t; + attr: Lambda.function_attribute; } (* @@ -79,13 +79,9 @@ module Types = struct if [= 1] with [some fail] -- called once if [= 0] could not have [some fail] *) - and prim_info = { - primitive : Lam_primitive.t; - args : t list; - loc : Location.t; - } + and prim_info = {primitive: Lam_primitive.t; args: t list; loc: Location.t} - and apply = { ap_func : t; ap_args : t list; ap_info : ap_info } + and apply = {ap_func: t; ap_args: t list; ap_info: ap_info} and t = | Lvar of ident @@ -111,27 +107,27 @@ end module X = struct type lambda_switch = Types.lambda_switch = { - sw_consts_full : bool; - sw_consts : (int * t) list; - sw_blocks_full : bool; - sw_blocks : (int * t) list; - sw_failaction : t option; - sw_names : Ast_untagged_variants.switch_names option; + sw_consts_full: bool; + sw_consts: (int * t) list; + sw_blocks_full: bool; + sw_blocks: (int * t) list; + sw_failaction: t option; + sw_names: Ast_untagged_variants.switch_names option; } and prim_info = Types.prim_info = { - primitive : Lam_primitive.t; - args : t list; - loc : Location.t; + primitive: Lam_primitive.t; + args: t list; + loc: Location.t; } - and apply = Types.apply = { ap_func : t; ap_args : t list; ap_info : ap_info } + and apply = Types.apply = {ap_func: t; ap_args: t list; ap_info: ap_info} and lfunction = Types.lfunction = { - arity : int; - params : ident list; - body : t; - attr : Lambda.function_attribute; + arity: int; + params: ident list; + body: t; + attr: Lambda.function_attribute; } and t = Types.t = @@ -163,25 +159,25 @@ include Types let inner_map (l : t) (f : t -> X.t) : X.t = match l with | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> ((* Obj.magic *) l : X.t) - | Lapply { ap_func; ap_args; ap_info } -> - let ap_func = f ap_func in - let ap_args = Ext_list.map ap_args f in - Lapply { ap_func; ap_args; ap_info } - | Lfunction { body; arity; params; attr } -> - let body = f body in - Lfunction { body; arity; params; attr } + | Lapply {ap_func; ap_args; ap_info} -> + let ap_func = f ap_func in + let ap_args = Ext_list.map ap_args f in + Lapply {ap_func; ap_args; ap_info} + | Lfunction {body; arity; params; attr} -> + let body = f body in + Lfunction {body; arity; params; attr} | Llet (str, id, arg, body) -> - let arg = f arg in - let body = f body in - Llet (str, id, arg, body) + let arg = f arg in + let body = f body in + Llet (str, id, arg, body) | Lletrec (decl, body) -> - let body = f body in - let decl = Ext_list.map_snd decl f in - Lletrec (decl, body) + let body = f body in + let decl = Ext_list.map_snd decl f in + Lletrec (decl, body) | Lglobal_module _ -> (l : X.t) - | Lprim { args; primitive; loc } -> - let args = Ext_list.map args f in - Lprim { args; primitive; loc } + | Lprim {args; primitive; loc} -> + let args = Ext_list.map args f in + Lprim {args; primitive; loc} | Lswitch ( arg, { @@ -192,57 +188,57 @@ let inner_map (l : t) (f : t -> X.t) : X.t = sw_failaction; sw_names; } ) -> - let arg = f arg in - let sw_consts = Ext_list.map_snd sw_consts f in - let sw_blocks = Ext_list.map_snd sw_blocks f in - let sw_failaction = Ext_option.map sw_failaction f in - Lswitch - ( arg, - { - sw_consts; - sw_blocks; - sw_failaction; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) + let arg = f arg in + let sw_consts = Ext_list.map_snd sw_consts f in + let sw_blocks = Ext_list.map_snd sw_blocks f in + let sw_failaction = Ext_option.map sw_failaction f in + Lswitch + ( arg, + { + sw_consts; + sw_blocks; + sw_failaction; + sw_blocks_full; + sw_consts_full; + sw_names; + } ) | Lstringswitch (arg, cases, default) -> - let arg = f arg in - let cases = Ext_list.map_snd cases f in - let default = Ext_option.map default f in - Lstringswitch (arg, cases, default) + let arg = f arg in + let cases = Ext_list.map_snd cases f in + let default = Ext_option.map default f in + Lstringswitch (arg, cases, default) | Lstaticraise (id, args) -> - let args = Ext_list.map args f in - Lstaticraise (id, args) + let args = Ext_list.map args f in + Lstaticraise (id, args) | Lstaticcatch (e1, vars, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lstaticcatch (e1, vars, e2) + let e1 = f e1 in + let e2 = f e2 in + Lstaticcatch (e1, vars, e2) | Ltrywith (e1, exn, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Ltrywith (e1, exn, e2) + let e1 = f e1 in + let e2 = f e2 in + Ltrywith (e1, exn, e2) | Lifthenelse (e1, e2, e3) -> - let e1 = f e1 in - let e2 = f e2 in - let e3 = f e3 in - Lifthenelse (e1, e2, e3) + let e1 = f e1 in + let e2 = f e2 in + let e3 = f e3 in + Lifthenelse (e1, e2, e3) | Lsequence (e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lsequence (e1, e2) + let e1 = f e1 in + let e2 = f e2 in + Lsequence (e1, e2) | Lwhile (e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lwhile (e1, e2) + let e1 = f e1 in + let e2 = f e2 in + Lwhile (e1, e2) | Lfor (v, e1, e2, dir, e3) -> - let e1 = f e1 in - let e2 = f e2 in - let e3 = f e3 in - Lfor (v, e1, e2, dir, e3) + let e1 = f e1 in + let e2 = f e2 in + let e3 = f e3 in + Lfor (v, e1, e2, dir, e3) | Lassign (id, e) -> - let e = f e in - Lassign (id, e) + let e = f e in + Lassign (id, e) (* | Lsend (k, met, obj, args, loc) -> let met = f met in let obj = f obj in @@ -271,12 +267,14 @@ exception Not_simple_form let rec is_eta_conversion_exn params inner_args outer_args : t list = match (params, inner_args, outer_args) with | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> - r :: is_eta_conversion_exn xs ys rest + r :: is_eta_conversion_exn xs ys rest | ( x :: xs, - Lprim ({ primitive = Pjs_fn_make _ | Pjs_fn_make_unit; args = [ Lvar y ] } as p) :: ys, + Lprim + ({primitive = Pjs_fn_make _ | Pjs_fn_make_unit; args = [Lvar y]} as p) + :: ys, r :: rest ) when Ident.same x y -> - Lprim { p with args = [ r ] } :: is_eta_conversion_exn xs ys rest + Lprim {p with args = [r]} :: is_eta_conversion_exn xs ys rest | [], [], [] -> [] | _, _, _ -> raise_notrace Not_simple_form @@ -293,132 +291,136 @@ let rec apply fn args (ap_info : ap_info) : t = ( Pundefined_to_opt | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null | Pis_null_undefined | Ptypeof ) as wrap; args = - [ - Lprim ({ primitive = _; args = inner_args } as primitive_call); - ]; + [Lprim ({primitive = _; args = inner_args} as primitive_call)]; }; } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - let loc = ap_info.ap_loc in - Lprim - { - primitive = wrap; - args = [ Lprim { primitive_call with args; loc } ]; - loc; - } - | exception Not_simple_form -> - Lapply { ap_func = fn; ap_args = args; ap_info }) + match is_eta_conversion_exn params inner_args args with + | args -> + let loc = ap_info.ap_loc in + Lprim + {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} + | exception Not_simple_form -> + Lapply {ap_func = fn; ap_args = args; ap_info}) | Lfunction { params; - body = Lprim ({ primitive = _; args = inner_args } as primitive_call); + body = Lprim ({primitive = _; args = inner_args} as primitive_call); } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> Lprim { primitive_call with args; loc = ap_info.ap_loc } - | exception _ -> Lapply { ap_func = fn; ap_args = args; ap_info }) + match is_eta_conversion_exn params inner_args args with + | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} + | exception _ -> Lapply {ap_func = fn; ap_args = args; ap_info}) | Lfunction { params; body = Lsequence - ( Lprim ({ primitive = _; args = inner_args } as primitive_call), + ( Lprim ({primitive = _; args = inner_args} as primitive_call), (Lconst _ as const) ); } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - Lsequence - (Lprim { primitive_call with args; loc = ap_info.ap_loc }, const) - | exception _ -> - Lapply { ap_func = fn; ap_args = args; ap_info } - (* | Lfunction {params;body} when Ext_list.same_length params args -> - Ext_list.fold_right2 (fun p arg acc -> - Llet(Strict,p,arg,acc) - ) params args body *) - (* TODO: more rigirous analysis on [let_kind] *)) + match is_eta_conversion_exn params inner_args args with + | args -> + Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info} + (* | Lfunction {params;body} when Ext_list.same_length params args -> + Ext_list.fold_right2 (fun p arg acc -> + Llet(Strict,p,arg,acc) + ) params args body *) + (* TODO: more rigirous analysis on [let_kind] *)) | Llet (kind, id, e, (Lfunction _ as fn)) -> - Llet (kind, id, e, apply fn args ap_info) + Llet (kind, id, e, apply fn args ap_info) (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply { ap_func = fn; ap_args = args; ap_info } + | _ -> Lapply {ap_func = fn; ap_args = args; ap_info} let rec eq_approx (l1 : t) (l2 : t) = match l1 with | Lglobal_module (i1, b1) -> ( - match l2 with Lglobal_module (i2, b2) -> Ident.same i1 i2 && b1 = b2 | _ -> false) - | Lvar i1 -> ( match l2 with Lvar i2 -> Ident.same i1 i2 | _ -> false) + match l2 with + | Lglobal_module (i2, b2) -> Ident.same i1 i2 && b1 = b2 + | _ -> false) + | Lvar i1 -> ( + match l2 with + | Lvar i2 -> Ident.same i1 i2 + | _ -> false) | Lconst c1 -> ( - match l2 with Lconst c2 -> Lam_constant.eq_approx c1 c2 | _ -> false) + match l2 with + | Lconst c2 -> Lam_constant.eq_approx c1 c2 + | _ -> false) | Lapply app1 -> ( - match l2 with - | Lapply app2 -> - eq_approx app1.ap_func app2.ap_func - && eq_approx_list app1.ap_args app2.ap_args - | _ -> false) + match l2 with + | Lapply app2 -> + eq_approx app1.ap_func app2.ap_func + && eq_approx_list app1.ap_args app2.ap_args + | _ -> false) | Lifthenelse (a, b, c) -> ( - match l2 with - | Lifthenelse (a0, b0, c0) -> - eq_approx a a0 && eq_approx b b0 && eq_approx c c0 - | _ -> false) + match l2 with + | Lifthenelse (a0, b0, c0) -> + eq_approx a a0 && eq_approx b b0 && eq_approx c c0 + | _ -> false) | Lsequence (a, b) -> ( - match l2 with - | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 - | _ -> false) + match l2 with + | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 + | _ -> false) | Lwhile (p, b) -> ( - match l2 with - | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 - | _ -> false) + match l2 with + | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 + | _ -> false) | Lassign (v0, l0) -> ( - match l2 with - | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 - | _ -> false) + match l2 with + | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 + | _ -> false) | Lstaticraise (id, ls) -> ( - match l2 with - | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 - | _ -> false) + match l2 with + | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 + | _ -> false) | Lprim info1 -> ( - match l2 with - | Lprim info2 -> - Lam_primitive.eq_primitive_approx info1.primitive info2.primitive - && eq_approx_list info1.args info2.args - | _ -> false) + match l2 with + | Lprim info2 -> + Lam_primitive.eq_primitive_approx info1.primitive info2.primitive + && eq_approx_list info1.args info2.args + | _ -> false) | Lstringswitch (arg, patterns, default) -> ( - match l2 with - | Lstringswitch (arg2, patterns2, default2) -> - eq_approx arg arg2 && eq_option default default2 - && Ext_list.for_all2_no_exn patterns patterns2 - (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) - | _ -> false) + match l2 with + | Lstringswitch (arg2, patterns2, default2) -> + eq_approx arg arg2 && eq_option default default2 + && Ext_list.for_all2_no_exn patterns patterns2 + (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) + | _ -> false) | Lfunction _ | Llet (_, _, _, _) | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ | Lfor (_, _, _, _, _) -> - false + false and eq_option l1 l2 = match l1 with | None -> l2 = None - | Some l1 -> ( match l2 with Some l2 -> eq_approx l1 l2 | None -> false) + | Some l1 -> ( + match l2 with + | Some l2 -> eq_approx l1 l2 + | None -> false) and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx let switch lam (lam_switch : lambda_switch) : t = match lam with - | Lconst (Const_int { i }) -> - (* Because of inlining and dead code, we might be looking at a value of unexpected type - e.g. an integer, so the const case might not be found *) - (try - Ext_list.assoc_by_int lam_switch.sw_consts (Int32.to_int i) lam_switch.sw_failaction - with _ -> Lswitch(lam, lam_switch)) - | Lconst (Const_block (i, _, _)) -> - (try Ext_list.assoc_by_int lam_switch.sw_blocks i lam_switch.sw_failaction - with _ -> Lswitch(lam, lam_switch)) + | Lconst (Const_int {i}) -> ( + (* Because of inlining and dead code, we might be looking at a value of unexpected type + e.g. an integer, so the const case might not be found *) + try + Ext_list.assoc_by_int lam_switch.sw_consts (Int32.to_int i) + lam_switch.sw_failaction + with _ -> Lswitch (lam, lam_switch)) + | Lconst (Const_block (i, _, _)) -> ( + try Ext_list.assoc_by_int lam_switch.sw_blocks i lam_switch.sw_failaction + with _ -> Lswitch (lam, lam_switch)) | _ -> Lswitch (lam, lam_switch) let stringswitch (lam : t) cases default : t = match lam with - | Lconst (Const_string { s; unicode = false }) -> - Ext_list.assoc_by_string cases s default + | Lconst (Const_string {s; unicode = false}) -> + Ext_list.assoc_by_string cases s default | _ -> Lstringswitch (lam, cases, default) let true_ : t = Lconst Const_js_true @@ -427,22 +429,23 @@ let unit : t = Lconst (Const_js_undefined {is_unit = true}) let rec seq (a : t) b : t = match a with - | Lprim { primitive = Pmakeblock _; args = x :: xs } -> - seq (Ext_list.fold_left xs x seq) b + | Lprim {primitive = Pmakeblock _; args = x :: xs} -> + seq (Ext_list.fold_left xs x seq) b | Lprim { primitive = Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; - args = [ a ]; + args = [a]; } -> - seq a b + seq a b | _ -> Lsequence (a, b) let var id : t = Lvar id -let global_module ?(dynamic_import = false) id = Lglobal_module (id, dynamic_import) +let global_module ?(dynamic_import = false) id = + Lglobal_module (id, dynamic_import) let const ct : t = Lconst ct let function_ ~attr ~arity ~params ~body : t = - Lfunction { arity; params; body; attr } + Lfunction {arity; params; body; attr} let let_ kind id e body : t = Llet (kind, id, e, body) let letrec bindings body : t = Lletrec (bindings, body) @@ -454,145 +457,140 @@ let staticcatch a b c : t = Lstaticcatch (a, b, c) let staticraise a b : t = Lstaticraise (a, b) module Lift = struct - let int i : t = Lconst (Const_int { i; comment = None }) + let int i : t = Lconst (Const_int {i; comment = None}) (* let int32 i : t = Lconst ((Const_int32 i)) *) let bool b = if b then true_ else false_ - let string s : t = Lconst (Const_string { s; unicode = false }) + let string s : t = Lconst (Const_string {s; unicode = false}) let char b : t = Lconst (Const_char b) end let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = - let default () : t = Lprim { primitive = prim; args; loc } in + let default () : t = Lprim {primitive = prim; args; loc} in match args with - | [ Lconst a ] -> ( - match (prim, a) with - | Pnegint, Const_int { i } -> Lift.int (Int32.neg i) - (* | Pfloatofint, ( (Const_int a)) *) - (* -> Lift.float (float_of_int a) *) - | Pintoffloat, Const_float a -> - Lift.int (Int32.of_float (float_of_string a)) - (* | Pnegfloat -> Lift.float (-. a) *) - (* | Pabsfloat -> Lift.float (abs_float a) *) - | Pstringlength, Const_string { s; unicode = false } -> - Lift.int (Int32.of_int (String.length s)) - (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) - (* -> *) - (* Lift.nativeint (Nativeint.neg i) *) - | Pnot, Const_js_true -> false_ - | Pnot, Const_js_false -> true_ - | _ -> default ()) - | [ Lconst a; Lconst b ] -> ( - match (prim, a, b) with - | Pintcomp cmp, Const_int a, Const_int b -> - Lift.bool (Lam_compat.cmp_int32 cmp a.i b.i) - | Pfloatcomp cmp, Const_float a, Const_float b -> - (* FIXME: could raise? *) - Lift.bool - (Lam_compat.cmp_float cmp (float_of_string a) (float_of_string b)) - | Pbigintcomp cmp, Const_bigint _, Const_bigint _ -> default () - | Pintcomp ((Ceq | Cneq) as op), Const_pointer a, Const_pointer b -> - Lift.bool - (match op with - | Ceq -> a = (b : string) - | Cneq -> a <> b - | _ -> assert false) - | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint - | Pxorint | Plslint | Plsrint | Pasrint ), - Const_int { i = aa }, - Const_int { i = bb } ) -> ( - (* WE SHOULD keep it as [int], to preserve types *) - let int_ = Lift.int in - match prim with - | Paddint -> int_ (Int32.add aa bb) - | Psubint -> int_ (Int32.sub aa bb) - | Pmulint -> int_ (Int32.mul aa bb) - | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) - | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) - | Pandint -> int_ (Int32.logand aa bb) - | Porint -> int_ (Int32.logor aa bb) - | Pxorint -> int_ (Int32.logxor aa bb) - | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) - | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) - | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) - | _ -> default ()) - | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> false_ - | Psequand, Const_js_true, Const_js_true -> true_ - | Psequand, Const_js_true, Const_js_false -> false_ - | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> true_ - | Psequor, Const_js_false, Const_js_true -> true_ - | Psequor, Const_js_false, Const_js_false -> false_ - | ( Pstringadd, - Const_string { s = a; unicode = false }, - Const_string { s = b; unicode = false } ) -> - Lift.string (a ^ b) - | ( (Pstringrefs | Pstringrefu), - Const_string { s = a; unicode = false }, - Const_int { i = b } ) -> ( - try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) + | [Lconst a] -> ( + match (prim, a) with + | Pnegint, Const_int {i} -> Lift.int (Int32.neg i) + (* | Pfloatofint, ( (Const_int a)) *) + (* -> Lift.float (float_of_int a) *) + | Pintoffloat, Const_float a -> + Lift.int (Int32.of_float (float_of_string a)) + (* | Pnegfloat -> Lift.float (-. a) *) + (* | Pabsfloat -> Lift.float (abs_float a) *) + | Pstringlength, Const_string {s; unicode = false} -> + Lift.int (Int32.of_int (String.length s)) + (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) + (* -> *) + (* Lift.nativeint (Nativeint.neg i) *) + | Pnot, Const_js_true -> false_ + | Pnot, Const_js_false -> true_ + | _ -> default ()) + | [Lconst a; Lconst b] -> ( + match (prim, a, b) with + | Pintcomp cmp, Const_int a, Const_int b -> + Lift.bool (Lam_compat.cmp_int32 cmp a.i b.i) + | Pfloatcomp cmp, Const_float a, Const_float b -> + (* FIXME: could raise? *) + Lift.bool + (Lam_compat.cmp_float cmp (float_of_string a) (float_of_string b)) + | Pbigintcomp cmp, Const_bigint _, Const_bigint _ -> default () + | Pintcomp ((Ceq | Cneq) as op), Const_pointer a, Const_pointer b -> + Lift.bool + (match op with + | Ceq -> a = (b : string) + | Cneq -> a <> b + | _ -> assert false) + | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint + | Pxorint | Plslint | Plsrint | Pasrint ), + Const_int {i = aa}, + Const_int {i = bb} ) -> ( + (* WE SHOULD keep it as [int], to preserve types *) + let int_ = Lift.int in + match prim with + | Paddint -> int_ (Int32.add aa bb) + | Psubint -> int_ (Int32.sub aa bb) + | Pmulint -> int_ (Int32.mul aa bb) + | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) + | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) + | Pandint -> int_ (Int32.logand aa bb) + | Porint -> int_ (Int32.logor aa bb) + | Pxorint -> int_ (Int32.logxor aa bb) + | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) + | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) + | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) | _ -> default ()) + | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> false_ + | Psequand, Const_js_true, Const_js_true -> true_ + | Psequand, Const_js_true, Const_js_false -> false_ + | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> true_ + | Psequor, Const_js_false, Const_js_true -> true_ + | Psequor, Const_js_false, Const_js_false -> false_ + | ( Pstringadd, + Const_string {s = a; unicode = false}, + Const_string {s = b; unicode = false} ) -> + Lift.string (a ^ b) + | ( (Pstringrefs | Pstringrefu), + Const_string {s = a; unicode = false}, + Const_int {i = b} ) -> ( + try Lift.char (Char.code (String.get a (Int32.to_int b))) + with _ -> default ()) + | _ -> default ()) | _ -> ( - match prim with - | Pmakeblock (_size, Blk_module fields, _) -> ( - let rec aux fields args (var : Ident.t) i = - match (fields, args) with - | [], [] -> true - | ( f :: fields, - Lprim - { - primitive = Pfield (pos, Fld_module { name = f1 }); - args = [ (Lglobal_module (v1, _) | Lvar v1) ]; - } - :: args ) -> - pos = i && f = f1 && Ident.same var v1 - && aux fields args var (i + 1) - | _, _ -> false - in - match (fields, args) with - | ( field1 :: rest, - Lprim - { - primitive = Pfield (pos, Fld_module { name = f1 }); - args = [ ((Lglobal_module (v1, _) | Lvar v1) as lam) ]; - } - :: args1 ) -> - if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam - else default () - | _ -> default ()) - (* In this level, include is already expanded, so that - {[ - { x0 : y0 ; x1 : y1 } - ]} - such module x can indeed be replaced by module y - *) + match prim with + | Pmakeblock (_size, Blk_module fields, _) -> ( + let rec aux fields args (var : Ident.t) i = + match (fields, args) with + | [], [] -> true + | ( f :: fields, + Lprim + { + primitive = Pfield (pos, Fld_module {name = f1}); + args = [(Lglobal_module (v1, _) | Lvar v1)]; + } + :: args ) -> + pos = i && f = f1 && Ident.same var v1 && aux fields args var (i + 1) + | _, _ -> false + in + match (fields, args) with + | ( field1 :: rest, + Lprim + { + primitive = Pfield (pos, Fld_module {name = f1}); + args = [((Lglobal_module (v1, _) | Lvar v1) as lam)]; + } + :: args1 ) -> + if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam + else default () | _ -> default ()) + (* In this level, include is already expanded, so that + {[ + { x0 : y0 ; x1 : y1 } + ]} + such module x can indeed be replaced by module y + *) + | _ -> default ()) let not_ loc x : t = match x with - | Lprim ({ primitive = Pintcomp Cneq } as prim) -> - Lprim { prim with primitive = Pintcomp Ceq } - | _ -> prim ~primitive:Pnot ~args:[ x ] loc + | Lprim ({primitive = Pintcomp Cneq} as prim) -> + Lprim {prim with primitive = Pintcomp Ceq} + | _ -> prim ~primitive:Pnot ~args:[x] loc let has_boolean_type (x : t) = match x with | Lprim { primitive = - ( Pnot | Psequand | Psequor | Pisout _ | Pis_not_none - | Pobjcomp _ - | Pboolcomp _ - | Pintcomp _ - | Pfloatcomp _ - | Pbigintcomp _ - | Pstringcomp _ - ); + ( Pnot | Psequand | Psequor | Pisout _ | Pis_not_none | Pobjcomp _ + | Pboolcomp _ | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ + | Pstringcomp _ ); loc; } -> - Some loc + Some loc | _ -> None (** [complete_range sw_consts 0 7] @@ -602,112 +600,100 @@ let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = match sw_consts with | [] -> finish < start | (i, _) :: rest -> - start <= finish && i = start - && complete_range rest ~start:(start + 1) ~finish + start <= finish && i = start + && complete_range rest ~start:(start + 1) ~finish let rec eval_const_as_bool (v : Lam_constant.t) : bool = match v with - | Const_int { i = x } -> x <> 0l + | Const_int {i = x} -> x <> 0l | Const_char x -> x <> 0 - | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ -> - false - | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ | Const_bigint _ - | Const_block _ -> true + | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ + -> + false + | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ + | Const_bigint _ | Const_block _ -> + true | Const_some b -> eval_const_as_bool b let if_ (a : t) (b : t) (c : t) : t = match a with | Lconst v -> if eval_const_as_bool v then b else c | _ -> ( - match (b, c) with - | _, Lconst (Const_int { comment = Pt_assertfalse }) -> - seq a b (* TODO: we could customize more cases *) - | Lconst (Const_int { comment = Pt_assertfalse }), _ -> seq a c - | Lconst Const_js_true, Lconst Const_js_false -> - if has_boolean_type a != None then a else Lifthenelse (a, b, c) - | Lconst Const_js_false, Lconst Const_js_true -> ( - match has_boolean_type a with - | Some loc -> not_ loc a - | None -> Lifthenelse (a, b, c)) - | Lprim { primitive = Praise }, _ -> ( - match c with - | Lconst _ -> Lifthenelse (a, b, c) - | _ -> seq (Lifthenelse (a, b, unit)) c) - | _ -> ( - match a with - | Lprim - { - primitive = Pisout off; - args = [ Lconst (Const_int { i = range }); Lvar xx ]; - } -> ( - let range = Int32.to_int range in - match c with - | Lswitch - ( (Lvar yy as switch_arg), - ({ - sw_blocks = []; - sw_blocks_full = true; - sw_consts; - sw_consts_full = _; - sw_failaction = None; - } as body) ) - when Ident.same xx yy - && complete_range sw_consts ~start:(-off) - ~finish:(range - off) -> - Lswitch - ( switch_arg, - { - body with - sw_failaction = Some b; - sw_consts_full = false; - } ) - | _ -> Lifthenelse (a, b, c)) - | Lprim { primitive = Pisint; args = [ Lvar i ]; _ } -> ( - match b with - | Lifthenelse - ( Lprim - { primitive = Pintcomp Ceq; args = [ Lvar j; Lconst _ ] }, - _, - b_f ) - when Ident.same i j && eq_approx b_f c -> - b - | Lprim { primitive = Pintcomp Ceq; args = [ Lvar j; Lconst _ ] } - when Ident.same i j && eq_approx false_ c -> - b - | Lifthenelse - ( Lprim - ({ - primitive = Pintcomp Cneq; - args = [ Lvar j; Lconst _ ]; - } as b_pred), - b_t, - b_f ) - when Ident.same i j && eq_approx b_t c -> - Lifthenelse - (Lprim { b_pred with primitive = Pintcomp Ceq }, b_f, b_t) - | Lprim - { - primitive = Pintcomp Cneq; - args = [ Lvar j; Lconst _ ] as args; - loc; - } - | Lprim - { - primitive = Pnot; - args = - [ - Lprim - { - primitive = Pintcomp Ceq; - args = [ Lvar j; Lconst _ ] as args; - loc; - }; - ]; - } - when Ident.same i j && eq_approx true_ c -> - Lprim { primitive = Pintcomp Cneq; args; loc } - | _ -> Lifthenelse (a, b, c)) - | _ -> Lifthenelse (a, b, c))) + match (b, c) with + | _, Lconst (Const_int {comment = Pt_assertfalse}) -> + seq a b (* TODO: we could customize more cases *) + | Lconst (Const_int {comment = Pt_assertfalse}), _ -> seq a c + | Lconst Const_js_true, Lconst Const_js_false -> + if has_boolean_type a != None then a else Lifthenelse (a, b, c) + | Lconst Const_js_false, Lconst Const_js_true -> ( + match has_boolean_type a with + | Some loc -> not_ loc a + | None -> Lifthenelse (a, b, c)) + | Lprim {primitive = Praise}, _ -> ( + match c with + | Lconst _ -> Lifthenelse (a, b, c) + | _ -> seq (Lifthenelse (a, b, unit)) c) + | _ -> ( + match a with + | Lprim + { + primitive = Pisout off; + args = [Lconst (Const_int {i = range}); Lvar xx]; + } -> ( + let range = Int32.to_int range in + match c with + | Lswitch + ( (Lvar yy as switch_arg), + ({ + sw_blocks = []; + sw_blocks_full = true; + sw_consts; + sw_consts_full = _; + sw_failaction = None; + } as body) ) + when Ident.same xx yy + && complete_range sw_consts ~start:(-off) ~finish:(range - off) + -> + Lswitch + ( switch_arg, + {body with sw_failaction = Some b; sw_consts_full = false} ) + | _ -> Lifthenelse (a, b, c)) + | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( + match b with + | Lifthenelse + (Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]}, _, b_f) + when Ident.same i j && eq_approx b_f c -> + b + | Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]} + when Ident.same i j && eq_approx false_ c -> + b + | Lifthenelse + ( Lprim + ({primitive = Pintcomp Cneq; args = [Lvar j; Lconst _]} as + b_pred), + b_t, + b_f ) + when Ident.same i j && eq_approx b_t c -> + Lifthenelse (Lprim {b_pred with primitive = Pintcomp Ceq}, b_f, b_t) + | Lprim + {primitive = Pintcomp Cneq; args = [Lvar j; Lconst _] as args; loc} + | Lprim + { + primitive = Pnot; + args = + [ + Lprim + { + primitive = Pintcomp Ceq; + args = [Lvar j; Lconst _] as args; + loc; + }; + ]; + } + when Ident.same i j && eq_approx true_ c -> + Lprim {primitive = Pintcomp Cneq; args; loc} + | _ -> Lifthenelse (a, b, c)) + | _ -> Lifthenelse (a, b, c))) (* TODO: the smart constructor is not exploited yet*) (* [l || r ] *) @@ -719,14 +705,17 @@ let sequand l r = if_ l r false_ let result_wrap loc (result_type : External_ffi_types.return_wrapper) result = match result_type with | Return_replaced_with_unit -> seq result unit - | Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[ result ] loc + | Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[result] loc | Return_null_undefined_to_opt -> - prim ~primitive:Pnull_undefined_to_opt ~args:[ result ] loc + prim ~primitive:Pnull_undefined_to_opt ~args:[result] loc | Return_undefined_to_opt -> - prim ~primitive:Pundefined_to_opt ~args:[ result ] loc + prim ~primitive:Pundefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result let handle_bs_non_obj_ffi (arg_types : External_arg_spec.params) - (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ~dynamic_import = - result_wrap loc result_type - (prim ~primitive:(Pjs_call { prim_name; arg_types; ffi; dynamic_import }) ~args loc) + (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name + ~dynamic_import = + result_wrap loc result_type + (prim + ~primitive:(Pjs_call {prim_name; arg_types; ffi; dynamic_import}) + ~args loc) diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index cc76e5b05b..66858ac2a4 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -25,35 +25,35 @@ type apply_status = App_na | App_infer_full | App_uncurry type ap_info = { - ap_loc : Location.t; - ap_inlined : Lambda.inline_attribute; - ap_status : apply_status; + ap_loc: Location.t; + ap_inlined: Lambda.inline_attribute; + ap_status: apply_status; } type ident = Ident.t type lambda_switch = { - sw_consts_full : bool; - sw_consts : (int * t) list; - sw_blocks_full : bool; - sw_blocks : (int * t) list; - sw_failaction : t option; - sw_names : Ast_untagged_variants.switch_names option; + sw_consts_full: bool; + sw_consts: (int * t) list; + sw_blocks_full: bool; + sw_blocks: (int * t) list; + sw_failaction: t option; + sw_names: Ast_untagged_variants.switch_names option; } -and apply = private { ap_func : t; ap_args : t list; ap_info : ap_info } +and apply = private {ap_func: t; ap_args: t list; ap_info: ap_info} and lfunction = { - arity : int; - params : ident list; - body : t; - attr : Lambda.function_attribute; + arity: int; + params: ident list; + body: t; + attr: Lambda.function_attribute; } and prim_info = private { - primitive : Lam_primitive.t; - args : t list; - loc : Location.t; + primitive: Lam_primitive.t; + args: t list; + loc: Location.t; } and t = private @@ -91,7 +91,7 @@ val handle_bs_non_obj_ffi : t list -> Location.t -> string -> - dynamic_import: bool -> + dynamic_import:bool -> t (**************************************************************) diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 879ff913db..a95b382ca2 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -25,7 +25,7 @@ (**used in effect analysis, it is sound but not-complete *) let not_zero_constant (x : Lam_constant.t) = match x with - | Const_int { i } -> i <> 0l + | Const_int {i} -> i <> 0l | Const_bigint (_, i) -> i <> "0" | _ -> false @@ -36,78 +36,70 @@ let rec no_side_effects (lam : Lam.t) : bool = (* we record side effect in the global level, this expression itself is side effect free *) - | Lprim { primitive; args; _ } -> ( - Ext_list.for_all args no_side_effects - && - match primitive with - | Pmodint | Pdivint | Pdivbigint | Pmodbigint -> ( - match args with - | [ _; Lconst cst ] -> not_zero_constant cst - | _ -> false) - | Pcreate_extension _ | Ptypeof | Pis_null | Pis_not_none | Psome - | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt - | Pundefined_to_opt | Pnull_undefined_to_opt | Pjs_fn_make _ | Pjs_fn_make_unit - | Pjs_object_create _ | Pimport - (* TODO: check *) - | Pmakeblock _ - (* whether it's mutable or not *) - | Pfield _ | Pval_from_option | Pval_from_option_not_nest - (* NOP The compiler already [t option] is the same as t *) - | Pduprecord - (* generic primitives *) - | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize - (* bool primitives *) - | Psequand | Psequor | Pnot - | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax - (* int primitives *) - | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint | Pintcomp _ - | Pintorder | Pintmin | Pintmax - (* float primitives *) - | Pintoffloat | Pfloatofint | Pnegfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pmodfloat - | Pfloatcomp _ | Pjscomp _ | Pfloatorder | Pfloatmin | Pfloatmax - (* bigint primitives *) - | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Ppowbigint - | Pandbigint | Porbigint | Pxorbigint | Plslbigint | Pasrbigint - | Pbigintcomp _ | Pbigintorder | Pbigintmin | Pbigintmax - (* string primitives *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pstringcomp _ | Pstringorder | Pstringmin | Pstringmax - (* array primitives *) - | Pmakearray | Parraylength | Parrayrefu | Parrayrefs - (* list primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict - (* Test if the argument is a block or an immediate integer *) - | Pisint | Pis_poly_var_block - (* Test if the (integer) argument is outside an interval *) - | Pisout _ - (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) - (* Compile time constants *) - | Poffsetint _ | Pstringadd | Pfn_arity - | Pwrap_exn - | Phash - | Phash_mixstring - | Phash_mixint - | Phash_finalmix - | Praw_js_code - { - code_info = - Exp (Js_function _ | Js_literal _) | Stmt Js_stmt_comment; - } -> - true - | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod | Pupdate_mod - | Pjs_unsafe_downgrade _ | Pdebugger - | Pjs_fn_method - (* Await promise *) - | Pawait - (* TODO *) - | Praw_js_code _ - (* byte swap *) - | Parraysets | Parraysetu | Poffsetref _ | Praise | Plazyforce | Psetfield _ -> - false) + | Lprim {primitive; args; _} -> ( + Ext_list.for_all args no_side_effects + && + match primitive with + | Pmodint | Pdivint | Pdivbigint | Pmodbigint -> ( + match args with + | [_; Lconst cst] -> not_zero_constant cst + | _ -> false) + | Pcreate_extension _ | Ptypeof | Pis_null | Pis_not_none | Psome + | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt + | Pundefined_to_opt | Pnull_undefined_to_opt | Pjs_fn_make _ + | Pjs_fn_make_unit | Pjs_object_create _ | Pimport + (* TODO: check *) + | Pmakeblock _ + (* whether it's mutable or not *) + | Pfield _ | Pval_from_option | Pval_from_option_not_nest + (* NOP The compiler already [t option] is the same as t *) + | Pduprecord + (* generic primitives *) + | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize + (* bool primitives *) + | Psequand | Psequor | Pnot | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax + (* int primitives *) + | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint | Pintcomp _ | Pintorder | Pintmin | Pintmax + (* float primitives *) + | Pintoffloat | Pfloatofint | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat + | Pdivfloat | Pmodfloat | Pfloatcomp _ | Pjscomp _ | Pfloatorder | Pfloatmin + | Pfloatmax + (* bigint primitives *) + | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Ppowbigint + | Pandbigint | Porbigint | Pxorbigint | Plslbigint | Pasrbigint + | Pbigintcomp _ | Pbigintorder | Pbigintmin | Pbigintmax + (* string primitives *) + | Pstringlength | Pstringrefu | Pstringrefs | Pstringcomp _ | Pstringorder + | Pstringmin | Pstringmax + (* array primitives *) + | Pmakearray | Parraylength | Parrayrefu | Parrayrefs + (* list primitives *) + | Pmakelist + (* dict primitives *) + | Pmakedict + (* Test if the argument is a block or an immediate integer *) + | Pisint | Pis_poly_var_block + (* Test if the (integer) argument is outside an interval *) + | Pisout _ + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + (* Compile time constants *) + | Poffsetint _ | Pstringadd | Pfn_arity | Pwrap_exn | Phash + | Phash_mixstring | Phash_mixint | Phash_finalmix + | Praw_js_code + {code_info = Exp (Js_function _ | Js_literal _) | Stmt Js_stmt_comment} + -> + true + | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod | Pupdate_mod + | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_method + (* Await promise *) + | Pawait + (* TODO *) + | Praw_js_code _ + (* byte swap *) + | Parraysets | Parraysetu | Poffsetref _ | Praise | Plazyforce | Psetfield _ + -> + false) | Llet (_, _, arg, body) -> no_side_effects arg && no_side_effects body | Lswitch (_, _) -> false | Lstringswitch (_, _, _) -> false @@ -118,24 +110,23 @@ let rec no_side_effects (lam : Lam.t) : bool = [Format.make_queue_elem] *) | Ltrywith (body, _exn, handler) -> - no_side_effects body && no_side_effects handler + no_side_effects body && no_side_effects handler | Lifthenelse (a, b, c) -> - no_side_effects a && no_side_effects b && no_side_effects c + no_side_effects a && no_side_effects b && no_side_effects c | Lsequence (a, b) -> no_side_effects a && no_side_effects b | Lletrec (bindings, body) -> - Ext_list.for_all_snd bindings no_side_effects && no_side_effects body + Ext_list.for_all_snd bindings no_side_effects && no_side_effects body | Lwhile _ -> - false (* conservative here, non-terminating loop does have side effect *) + false (* conservative here, non-terminating loop does have side effect *) | Lfor _ -> false | Lassign _ -> false (* actually it depends ... *) (* | Lsend _ -> false *) | Lapply { - ap_func = - Lprim { primitive = Pfield (_, Fld_module { name = "from_fun" }) }; - ap_args = [ arg ]; + ap_func = Lprim {primitive = Pfield (_, Fld_module {name = "from_fun"})}; + ap_args = [arg]; } -> - no_side_effects arg + no_side_effects arg | Lapply _ -> false (* we need purity analysis .. *) @@ -159,14 +150,14 @@ let rec size (lam : Lam.t) = | Lprim { primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; + args = [(Lglobal_module _ | Lvar _)]; _; } -> - 1 - | Lprim { primitive = Praise | Pis_not_none; args = [ l ]; _ } -> size l + 1 + | Lprim {primitive = Praise | Pis_not_none; args = [l]; _} -> size l | Lglobal_module _ -> 1 - | Lprim { primitive = Praw_js_code _ } -> really_big () - | Lprim { args = ll; _ } -> size_lams 1 ll + | Lprim {primitive = Praw_js_code _} -> really_big () + | Lprim {args = ll; _} -> size_lams 1 ll (* complicated 1. inline this function 2. ... @@ -175,13 +166,13 @@ let rec size (lam : Lam.t) = {var $$let=Make(funarg); return [0, $$let[5],... $$let[16]]} *) - | Lapply { ap_func; ap_args; _ } -> size_lams (size ap_func) ap_args + | Lapply {ap_func; ap_args; _} -> size_lams (size ap_func) ap_args (* | Lfunction(_, params, l) -> really_big () *) - | Lfunction { body } -> size body + | Lfunction {body} -> size body | Lswitch _ -> really_big () | Lstringswitch (_, _, _) -> really_big () | Lstaticraise (_i, ls) -> - Ext_list.fold_left ls 1 (fun acc x -> size x + acc) + Ext_list.fold_left ls 1 (fun acc x -> size x + acc) | Lstaticcatch _ -> really_big () | Ltrywith _ -> really_big () | Lifthenelse (l1, l2, l3) -> 1 + size l1 + size l2 + size l3 @@ -195,21 +186,23 @@ let rec size (lam : Lam.t) = and size_constant x = match x with - | Const_int _ | Const_char _ | Const_float _ | Const_bigint _ | Const_pointer _ - | Const_js_null | Const_js_undefined _ | Const_module_alias | Const_js_true - | Const_js_false -> - 1 - | Const_string _ -> - 1 + | Const_int _ | Const_char _ | Const_float _ | Const_bigint _ + | Const_pointer _ | Const_js_null | Const_js_undefined _ | Const_module_alias + | Const_js_true | Const_js_false -> + 1 + | Const_string _ -> 1 | Const_some s -> size_constant s | Const_block (_, _, str) -> - Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) + Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) and size_lams acc (lams : Lam.t list) = Ext_list.fold_left lams acc (fun acc l -> acc + size l) let args_all_const (args : Lam.t list) = - Ext_list.for_all args (fun x -> match x with Lconst _ -> true | _ -> false) + Ext_list.for_all args (fun x -> + match x with + | Lconst _ -> true + | _ -> false) let exit_inline_size = 7 @@ -233,21 +226,21 @@ let destruct_pattern (body : Lam.t) params args = in match body with | Lswitch (Lvar v, switch) -> ( - match aux v params args with - | Some (Lam.Lconst _ as lam) -> - size (Lam.switch lam switch) < small_inline_size - | Some _ | None -> false) + match aux v params args with + | Some (Lam.Lconst _ as lam) -> + size (Lam.switch lam switch) < small_inline_size + | Some _ | None -> false) | Lifthenelse (Lvar v, then_, else_) -> ( - (* -FIXME *) - match aux v params args with - | Some (Lconst _ as lam) -> - size (Lam.if_ lam then_ else_) < small_inline_size - | Some _ | None -> false) + (* -FIXME *) + match aux v params args with + | Some (Lconst _ as lam) -> + size (Lam.if_ lam then_ else_) < small_inline_size + | Some _ | None -> false) | _ -> false (* Async functions cannot be beta reduced *) let lfunction_can_be_inlined (lfunction : Lam.lfunction) = - not lfunction.attr.async && lfunction.attr.directive = None + (not lfunction.attr.async) && lfunction.attr.directive = None (** Hints to inlining *) let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = @@ -255,12 +248,12 @@ let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = | Always_inline -> true | Never_inline -> false | Default_inline -> ( - match m with - | { body; params } -> - let s = size body in - s < small_inline_size - || destruct_pattern body params args - || (args_all_const args && s < 10 && no_side_effects body)) + match m with + | {body; params} -> + let s = size body in + s < small_inline_size + || destruct_pattern body params args + || (args_all_const args && s < 10 && no_side_effects body)) (* TODO: We can relax this a bit later, but decide whether to inline it later in the call site @@ -270,7 +263,7 @@ let safe_to_inline (lam : Lam.t) = | Lfunction _ -> true | Lconst ( Const_pointer _ - | Const_int { comment = Pt_constructor _ } + | Const_int {comment = Pt_constructor _} | Const_js_true | Const_js_false | Const_js_undefined _ ) -> - true + true | _ -> false diff --git a/compiler/core/lam_arity.ml b/compiler/core/lam_arity.ml index 147e0631d9..7998426f08 100644 --- a/compiler/core/lam_arity.ml +++ b/compiler/core/lam_arity.ml @@ -36,10 +36,10 @@ let equal (x : t) y = match x with | Arity_na -> y = Arity_na | Arity_info (xs, a) -> ( - match y with - | Arity_info (ys, b) -> - a = b && Ext_list.for_all2_no_exn xs ys (fun x y -> x = y) - | Arity_na -> false) + match y with + | Arity_info (ys, b) -> + a = b && Ext_list.for_all2_no_exn xs ys (fun x y -> x = y) + | Arity_na -> false) let pp = Format.fprintf @@ -47,14 +47,14 @@ let print (fmt : Format.formatter) (x : t) = match x with | Arity_na -> pp fmt "?" | Arity_info (ls, tail) -> - pp fmt "@["; - pp fmt "["; - Format.pp_print_list - ~pp_sep:(fun fmt () -> pp fmt ",") - (fun fmt x -> Format.pp_print_int fmt x) - fmt ls; - if tail then pp fmt "@ *"; - pp fmt "]@]" + pp fmt "@["; + pp fmt "["; + Format.pp_print_list + ~pp_sep:(fun fmt () -> pp fmt ",") + (fun fmt x -> Format.pp_print_int fmt x) + fmt ls; + if tail then pp fmt "@ *"; + pp fmt "]@]" let print_arities_tbl (fmt : Format.formatter) (arities_tbl : (Ident.t, t ref) Hashtbl.t) = @@ -64,7 +64,7 @@ let print_arities_tbl (fmt : Format.formatter) let merge (n : int) (x : t) : t = match x with - | Arity_na -> Arity_info ([ n ], false) + | Arity_na -> Arity_info ([n], false) | Arity_info (xs, tail) -> Arity_info (n :: xs, tail) let non_function_arity_info = Arity_info ([], false) @@ -76,7 +76,9 @@ let na = Arity_na let info args b1 = Arity_info (args, b1) let first_arity_na (x : t) = - match x with Arity_na | Arity_info ([], _) -> true | _ -> false + match x with + | Arity_na | Arity_info ([], _) -> true + | _ -> false let get_first_arity (x : t) = match x with @@ -84,7 +86,9 @@ let get_first_arity (x : t) = | Arity_info (x :: _, _) -> Some x let extract_arity (x : t) = - match x with Arity_na -> [] | Arity_info (xs, _) -> xs + match x with + | Arity_na -> [] + | Arity_info (xs, _) -> xs (* let update_arity (x : t) xs = *) diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index dcc045858c..6e0027ca5f 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -27,7 +27,7 @@ let arity_of_var (meta : Lam_stats.t) (v : Ident.t) = if it's not from function parameter, we should warn *) match Hash_ident.find_opt meta.ident_tbl v with - | Some (FunctionId { arity; _ }) -> arity + | Some (FunctionId {arity; _}) -> arity | Some _ | None -> Lam_arity.na (* we need record all aliases -- since not all aliases are eliminated, @@ -42,13 +42,15 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = | Llet (_, _, _, l) -> get_arity meta l | Lprim { - primitive = Pfield (_, Fld_module { name }); - args = [ Lglobal_module (id, dynamic_import) ]; + primitive = Pfield (_, Fld_module {name}); + args = [Lglobal_module (id, dynamic_import)]; _; } -> ( - match (Lam_compile_env.query_external_id_info ~dynamic_import id name).arity with - | Single x -> x - | Submodule _ -> Lam_arity.na) + match + (Lam_compile_env.query_external_id_info ~dynamic_import id name).arity + with + | Single x -> x + | Submodule _ -> Lam_arity.na) | Lprim { primitive = Pfield (m, _); @@ -56,22 +58,22 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = [ Lprim { - primitive = Pfield (_, Fld_module { name }); - args = [ Lglobal_module (id, dynamic_import) ]; + primitive = Pfield (_, Fld_module {name}); + args = [Lglobal_module (id, dynamic_import)]; }; ]; _; } -> ( - match (Lam_compile_env.query_external_id_info ~dynamic_import id name).arity with - | Submodule subs -> subs.(m) (* TODO: shall we store it as array?*) - | Single _ -> Lam_arity.na) - | Lprim - { primitive = Praw_js_code { code_info = Exp (Js_function { arity }) } } - -> - Lam_arity.info [ arity ] false - | Lprim { primitive = Praise; _ } -> Lam_arity.raise_arity_info + match + (Lam_compile_env.query_external_id_info ~dynamic_import id name).arity + with + | Submodule subs -> subs.(m) (* TODO: shall we store it as array?*) + | Single _ -> Lam_arity.na) + | Lprim {primitive = Praw_js_code {code_info = Exp (Js_function {arity})}} -> + Lam_arity.info [arity] false + | Lprim {primitive = Praise; _} -> Lam_arity.raise_arity_info | Lglobal_module _ (* TODO: fix me never going to happen *) | Lprim _ -> - Lam_arity.na (* CHECK*) + Lam_arity.na (* CHECK*) (* shall we handle primitive in a direct way, since we know all the information Invariant: all primitive application is fully applied, @@ -85,25 +87,25 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = it can return a function *) | Lletrec (_, body) -> get_arity meta body - | Lapply { ap_func = app; ap_args = args; _ } -> ( - (* detect functor application *) - let fn = get_arity meta app in - match fn with - | Arity_na -> Lam_arity.na - | Arity_info (xs, tail) -> - let rec take (arities : _ list) arg_length = - match arities with - | x :: yys -> - if arg_length = x then Lam_arity.info yys tail - else if arg_length > x then take yys (arg_length - x) - else Lam_arity.info ((x - arg_length) :: yys) tail - | [] -> if tail then Lam_arity.raise_arity_info else Lam_arity.na - (* Actually, you can not have truly deministic arities - for example [fun x -> x ] - *) - in - take xs (List.length args)) - | Lfunction { arity; body } -> Lam_arity.merge arity (get_arity meta body) + | Lapply {ap_func = app; ap_args = args; _} -> ( + (* detect functor application *) + let fn = get_arity meta app in + match fn with + | Arity_na -> Lam_arity.na + | Arity_info (xs, tail) -> + let rec take (arities : _ list) arg_length = + match arities with + | x :: yys -> + if arg_length = x then Lam_arity.info yys tail + else if arg_length > x then take yys (arg_length - x) + else Lam_arity.info ((x - arg_length) :: yys) tail + | [] -> if tail then Lam_arity.raise_arity_info else Lam_arity.na + (* Actually, you can not have truly deministic arities + for example [fun x -> x ] + *) + in + take xs (List.length args)) + | Lfunction {arity; body} -> Lam_arity.merge arity (get_arity meta body) | Lswitch ( _, { @@ -113,18 +115,20 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = sw_blocks_full = _; sw_consts_full = _; } ) -> - all_lambdas meta - (let rest = - Ext_list.map_append sw_consts (Ext_list.map sw_blocks snd) snd - in - match sw_failaction with None -> rest | Some x -> x :: rest) + all_lambdas meta + (let rest = + Ext_list.map_append sw_consts (Ext_list.map sw_blocks snd) snd + in + match sw_failaction with + | None -> rest + | Some x -> x :: rest) | Lstringswitch (_, sw, d) -> ( - match d with - | None -> all_lambdas meta (Ext_list.map sw snd) - | Some v -> all_lambdas meta (v :: Ext_list.map sw snd)) + match d with + | None -> all_lambdas meta (Ext_list.map sw snd) + | Some v -> all_lambdas meta (v :: Ext_list.map sw snd)) | Lstaticcatch (_, _, handler) -> get_arity meta handler - | Ltrywith (l1, _, l2) -> all_lambdas meta [ l1; l2 ] - | Lifthenelse (_, l2, l3) -> all_lambdas meta [ l2; l3 ] + | Ltrywith (l1, _, l2) -> all_lambdas meta [l1; l2] + | Lifthenelse (_, l2, l3) -> all_lambdas meta [l2; l3] | Lsequence (_, l2) -> get_arity meta l2 | Lstaticraise _ (* since it will not be in tail position *) -> Lam_arity.na | Lwhile _ | Lfor _ | Lassign _ -> Lam_arity.non_function_arity_info @@ -132,16 +136,16 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = and all_lambdas meta (xs : Lam.t list) = match xs with | y :: ys -> - let arity = get_arity meta y in - let rec aux (acc : Lam_arity.t) xs = - match (acc, xs) with - | Arity_na, _ -> acc - | _, [] -> acc - | Arity_info (xxxs, tail), y :: ys -> ( - match get_arity meta y with - | Arity_na -> Lam_arity.na - | Arity_info (yyys, tail2) -> - aux (Lam_arity.merge_arities xxxs yyys tail tail2) ys) - in - aux arity ys + let arity = get_arity meta y in + let rec aux (acc : Lam_arity.t) xs = + match (acc, xs) with + | Arity_na, _ -> acc + | _, [] -> acc + | Arity_info (xxxs, tail), y :: ys -> ( + match get_arity meta y with + | Arity_na -> Lam_arity.na + | Arity_info (yyys, tail2) -> + aux (Lam_arity.merge_arities xxxs yyys tail tail2) ys) + in + aux arity ys | [] -> Lam_arity.na diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index 30d3977901..e7f9842bbc 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -49,75 +49,74 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> - let rest_bindings, rev_new_params = - Ext_list.fold_left2 params args ([], []) - (fun old_param arg (rest_bindings, acc) -> - match arg with - | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) - | _ -> - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) - in - let new_body = - Lam_bounded_vars.rewrite - (Hash_ident.of_list2 (List.rev params) rev_new_params) - body - in - Ext_list.fold_right rest_bindings new_body (fun (param, arg) l -> - (match arg with - | Lprim { primitive = Pmakeblock (_, _, Immutable); args; _ } -> - Hash_ident.replace meta.ident_tbl param - (Lam_util.kind_of_lambda_block args) - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ]; _ } -> - Hash_ident.replace meta.ident_tbl param (Normal_optional v) - | _ -> ()); - Lam_util.refine_let ~kind:Strict param arg l) + let rest_bindings, rev_new_params = + Ext_list.fold_left2 params args ([], []) + (fun old_param arg (rest_bindings, acc) -> + match arg with + | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) + | _ -> + let p = Ident.rename old_param in + ((p, arg) :: rest_bindings, Lam.var p :: acc)) + in + let new_body = + Lam_bounded_vars.rewrite + (Hash_ident.of_list2 (List.rev params) rev_new_params) + body + in + Ext_list.fold_right rest_bindings new_body (fun (param, arg) l -> + (match arg with + | Lprim {primitive = Pmakeblock (_, _, Immutable); args; _} -> + Hash_ident.replace meta.ident_tbl param + (Lam_util.kind_of_lambda_block args) + | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> + Hash_ident.replace meta.ident_tbl param (Normal_optional v) + | _ -> ()); + Lam_util.refine_let ~kind:Strict param arg l) let propagate_beta_reduce_with_map (meta : Lam_stats.t) (map : Lam_var_stats.stats Map_ident.t) params body args = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> - let rest_bindings, rev_new_params = - Ext_list.fold_left2 params args ([], []) - (fun old_param arg (rest_bindings, acc) -> - match arg with - | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) - | Lglobal_module _ -> - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) - | _ -> - if Lam_analysis.no_side_effects arg then - match Map_ident.find_exn map old_param with - | stat -> - if Lam_var_stats.top_and_used_zero_or_one stat then - (rest_bindings, arg :: acc) - else - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) + let rest_bindings, rev_new_params = + Ext_list.fold_left2 params args ([], []) + (fun old_param arg (rest_bindings, acc) -> + match arg with + | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) + | Lglobal_module _ -> + let p = Ident.rename old_param in + ((p, arg) :: rest_bindings, Lam.var p :: acc) + | _ -> + if Lam_analysis.no_side_effects arg then + match Map_ident.find_exn map old_param with + | stat -> + if Lam_var_stats.top_and_used_zero_or_one stat then + (rest_bindings, arg :: acc) else let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) - in - let new_body = - Lam_bounded_vars.rewrite - (Hash_ident.of_list2 (List.rev params) rev_new_params) - body - in - Ext_list.fold_right rest_bindings new_body - (fun (param, (arg : Lam.t)) l -> - (match arg with - | Lprim { primitive = Pmakeblock (_, _, Immutable); args } -> - Hash_ident.replace meta.ident_tbl param - (Lam_util.kind_of_lambda_block args) - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ] } -> - Hash_ident.replace meta.ident_tbl param (Normal_optional v) - | _ -> ()); - Lam_util.refine_let ~kind:Strict param arg l) + ((p, arg) :: rest_bindings, Lam.var p :: acc) + else + let p = Ident.rename old_param in + ((p, arg) :: rest_bindings, Lam.var p :: acc)) + in + let new_body = + Lam_bounded_vars.rewrite + (Hash_ident.of_list2 (List.rev params) rev_new_params) + body + in + Ext_list.fold_right rest_bindings new_body (fun (param, (arg : Lam.t)) l -> + (match arg with + | Lprim {primitive = Pmakeblock (_, _, Immutable); args} -> + Hash_ident.replace meta.ident_tbl param + (Lam_util.kind_of_lambda_block args) + | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> + Hash_ident.replace meta.ident_tbl param (Normal_optional v) + | _ -> ()); + Lam_util.refine_let ~kind:Strict param arg l) let no_names_beta_reduce params body args = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> - Ext_list.fold_left2 params args body (fun param arg l -> - Lam_util.refine_let ~kind:Strict param arg l) + Ext_list.fold_left2 params args body (fun param arg l -> + Lam_util.refine_let ~kind:Strict param arg l) diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index eadbed9d19..c1855dec20 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -31,7 +31,7 @@ other wise the evaluation order is tricky (make sure eval order is correct) *) -type value = { mutable used : bool; lambda : Lam.t } +type value = {mutable used: bool; lambda: Lam.t} let param_hash : _ Hash_ident.t = Hash_ident.create 20 @@ -54,8 +54,8 @@ let simple_beta_reduce params body args = let find_param_exn v opt = match Hash_ident.find_opt param_hash v with | Some exp -> - if exp.used then raise_notrace Not_simple_apply else exp.used <- true; - exp.lambda + if exp.used then raise_notrace Not_simple_apply else exp.used <- true; + exp.lambda | None -> opt in let rec aux_exn acc (us : Lam.t list) = @@ -66,59 +66,61 @@ let simple_beta_reduce params body args = | _ :: _ -> raise_notrace Not_simple_apply in match (body : Lam.t) with - | Lprim { primitive; args = ap_args; loc = ap_loc } + | Lprim {primitive; args = ap_args; loc = ap_loc} (* There is no lambda in primitive *) -> ( - (* catch a special case of primitives *) - let () = - List.iter2 - (fun p a -> Hash_ident.add param_hash p { lambda = a; used = false }) - params args + (* catch a special case of primitives *) + let () = + List.iter2 + (fun p a -> Hash_ident.add param_hash p {lambda = a; used = false}) + params args + in + try + let new_args = aux_exn [] ap_args in + let result = + Hash_ident.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) + (fun _param stats acc -> + let {lambda; used} = stats in + if not used then Lam.seq lambda acc else acc) in - try - let new_args = aux_exn [] ap_args in - let result = - Hash_ident.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) - (fun _param stats acc -> - let { lambda; used } = stats in - if not used then Lam.seq lambda acc else acc) - in - Hash_ident.clear param_hash; - Some result - with Not_simple_apply -> - Hash_ident.clear param_hash; - None) + Hash_ident.clear param_hash; + Some result + with Not_simple_apply -> + Hash_ident.clear param_hash; + None) | Lapply { ap_func = - (Lvar _ | Lprim { primitive = Pfield _; args = [ Lglobal_module _ ] }) - as f; + (Lvar _ | Lprim {primitive = Pfield _; args = [Lglobal_module _]}) as + f; ap_args; ap_info; } -> ( - let () = - List.iter2 - (fun p a -> Hash_ident.add param_hash p { lambda = a; used = false }) - params args + let () = + List.iter2 + (fun p a -> Hash_ident.add param_hash p {lambda = a; used = false}) + params args + in + (*since we adde each param only once, + iff it is removed once, no exception, + if it is removed twice there will be exception. + if it is never removed, we have it as rest keys + *) + try + let new_args = aux_exn [] ap_args in + let f = + match f with + | Lvar fn_name -> find_param_exn fn_name f + | _ -> f in - (*since we adde each param only once, - iff it is removed once, no exception, - if it is removed twice there will be exception. - if it is never removed, we have it as rest keys - *) - try - let new_args = aux_exn [] ap_args in - let f = - match f with Lvar fn_name -> find_param_exn fn_name f | _ -> f - in - let result = - Hash_ident.fold param_hash (Lam.apply f new_args ap_info) - (fun _param stat acc -> - let { lambda; used } = stat in - if not used then Lam.seq lambda acc else acc) - in - Hash_ident.clear param_hash; - Some result - with Not_simple_apply -> - Hash_ident.clear param_hash; - None) + let result = + Hash_ident.fold param_hash (Lam.apply f new_args ap_info) + (fun _param stat acc -> + let {lambda; used} = stat in + if not used then Lam.seq lambda acc else acc) + in + Hash_ident.clear param_hash; + Some result + with Not_simple_apply -> + Hash_ident.clear param_hash; + None) | _ -> None diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 59dfab8868..15ee9cff97 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -68,47 +68,50 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = i' in (* order matters, especially for let bindings *) - let rec option_map op = match op with None -> None | Some x -> Some (aux x) + let rec option_map op = + match op with + | None -> None + | Some x -> Some (aux x) and aux (lam : Lam.t) : Lam.t = match lam with | Lvar v -> Hash_ident.find_default map v lam | Llet (str, v, l1, l2) -> - let v = rebind v in - let l1 = aux l1 in - let l2 = aux l2 in - Lam.let_ str v l1 l2 + let v = rebind v in + let l1 = aux l1 in + let l2 = aux l2 in + Lam.let_ str v l1 l2 | Lletrec (bindings, body) -> - (*order matters see GPR #405*) - let vars = Ext_list.map bindings (fun (k, _) -> rebind k) in - let bindings = - Ext_list.map2 vars bindings (fun var (_, l) -> (var, aux l)) - in - let body = aux body in - Lam.letrec bindings body - | Lfunction { arity; params; body; attr } -> - let params = Ext_list.map params rebind in - let body = aux body in - Lam.function_ ~arity ~params ~body ~attr + (*order matters see GPR #405*) + let vars = Ext_list.map bindings (fun (k, _) -> rebind k) in + let bindings = + Ext_list.map2 vars bindings (fun var (_, l) -> (var, aux l)) + in + let body = aux body in + Lam.letrec bindings body + | Lfunction {arity; params; body; attr} -> + let params = Ext_list.map params rebind in + let body = aux body in + Lam.function_ ~arity ~params ~body ~attr | Lstaticcatch (l1, (i, xs), l2) -> - let l1 = aux l1 in - let xs = Ext_list.map xs rebind in - let l2 = aux l2 in - Lam.staticcatch l1 (i, xs) l2 + let l1 = aux l1 in + let xs = Ext_list.map xs rebind in + let l2 = aux l2 in + Lam.staticcatch l1 (i, xs) l2 | Lfor (ident, l1, l2, dir, l3) -> - let ident = rebind ident in - let l1 = aux l1 in - let l2 = aux l2 in - let l3 = aux l3 in - Lam.for_ ident (aux l1) l2 dir l3 + let ident = rebind ident in + let l1 = aux l1 in + let l2 = aux l2 in + let l3 = aux l3 in + Lam.for_ ident (aux l1) l2 dir l3 | Lconst _ -> lam - | Lprim { primitive; args; loc } -> - (* here it makes sure that global vars are not rebound *) - Lam.prim ~primitive ~args:(Ext_list.map args aux) loc + | Lprim {primitive; args; loc} -> + (* here it makes sure that global vars are not rebound *) + Lam.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - let fn = aux ap_func in - let args = Ext_list.map ap_args aux in - Lam.apply fn args ap_info + | Lapply {ap_func; ap_args; ap_info} -> + let fn = aux ap_func in + let args = Ext_list.map ap_args aux in + Lam.apply fn args ap_info | Lswitch ( l, { @@ -119,38 +122,38 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_names; } ) -> - let l = aux l in - Lam.switch l - { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; - sw_consts_full; - sw_blocks_full; - sw_failaction = option_map sw_failaction; - sw_names; - } + let l = aux l in + Lam.switch l + { + sw_consts = Ext_list.map_snd sw_consts aux; + sw_blocks = Ext_list.map_snd sw_blocks aux; + sw_consts_full; + sw_blocks_full; + sw_failaction = option_map sw_failaction; + sw_names; + } | Lstringswitch (l, sw, d) -> - let l = aux l in - Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) + let l = aux l in + Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) | Ltrywith (l1, v, l2) -> - let l1 = aux l1 in - let v = rebind v in - let l2 = aux l2 in - Lam.try_ l1 v l2 + let l1 = aux l1 in + let v = rebind v in + let l2 = aux l2 in + Lam.try_ l1 v l2 | Lifthenelse (l1, l2, l3) -> - let l1 = aux l1 in - let l2 = aux l2 in - let l3 = aux l3 in - Lam.if_ l1 l2 l3 + let l1 = aux l1 in + let l2 = aux l2 in + let l3 = aux l3 in + Lam.if_ l1 l2 l3 | Lsequence (l1, l2) -> - let l1 = aux l1 in - let l2 = aux l2 in - Lam.seq l1 l2 + let l1 = aux l1 in + let l2 = aux l2 in + Lam.seq l1 l2 | Lwhile (l1, l2) -> - let l1 = aux l1 in - let l2 = aux l2 in - Lam.while_ l1 l2 + let l1 = aux l1 in + let l2 = aux l2 in + Lam.while_ l1 l2 | Lassign (v, l) -> Lam.assign v (aux l) in aux lam diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index 1da197c75f..0ef71f2cee 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -51,41 +51,41 @@ let check file lam = and check_staticfails (l : Lam.t) (cxt : Set_int.t) = match l with | Lvar _ | Lconst _ | Lglobal_module _ -> () - | Lprim { args; _ } -> check_list args cxt - | Lapply { ap_func; ap_args; _ } -> check_list (ap_func :: ap_args) cxt + | Lprim {args; _} -> check_list args cxt + | Lapply {ap_func; ap_args; _} -> check_list (ap_func :: ap_args) cxt (* check invariant that staticfaill does not cross function/while/for loop*) - | Lfunction { body; params = _ } -> check_staticfails body Set_int.empty + | Lfunction {body; params = _} -> check_staticfails body Set_int.empty | Lwhile (e1, e2) -> - check_staticfails e1 cxt; - check_staticfails e2 Set_int.empty + check_staticfails e1 cxt; + check_staticfails e2 Set_int.empty | Lfor (_v, e1, e2, _dir, e3) -> - check_staticfails e1 cxt; - check_staticfails e2 cxt; - check_staticfails e3 Set_int.empty - | Llet (_str, _id, arg, body) -> check_list [ arg; body ] cxt + check_staticfails e1 cxt; + check_staticfails e2 cxt; + check_staticfails e3 Set_int.empty + | Llet (_str, _id, arg, body) -> check_list [arg; body] cxt | Lletrec (decl, body) -> - check_list_snd decl cxt; - check_staticfails body cxt + check_list_snd decl cxt; + check_staticfails body cxt | Lswitch (arg, sw) -> - check_staticfails arg cxt; - check_list_snd sw.sw_consts cxt; - check_list_snd sw.sw_blocks cxt; - Ext_option.iter sw.sw_failaction (fun x -> check_staticfails x cxt) + check_staticfails arg cxt; + check_list_snd sw.sw_consts cxt; + check_list_snd sw.sw_blocks cxt; + Ext_option.iter sw.sw_failaction (fun x -> check_staticfails x cxt) | Lstringswitch (arg, cases, default) -> - check_staticfails arg cxt; - check_list_snd cases cxt; - Ext_option.iter default (fun x -> check_staticfails x cxt) + check_staticfails arg cxt; + check_list_snd cases cxt; + Ext_option.iter default (fun x -> check_staticfails x cxt) | Lstaticraise (i, args) -> - if Set_int.mem cxt i then check_list args cxt - else failwith ("exit " ^ string_of_int i ^ " unbound") + if Set_int.mem cxt i then check_list args cxt + else failwith ("exit " ^ string_of_int i ^ " unbound") | Lstaticcatch (e1, (j, _vars), e2) -> - check_staticfails e1 (Set_int.add cxt j); - check_staticfails e2 cxt + check_staticfails e1 (Set_int.add cxt j); + check_staticfails e2 cxt | Ltrywith (e1, _exn, e2) -> - check_staticfails e1 cxt; - check_staticfails e2 cxt - | Lifthenelse (e1, e2, e3) -> check_list [ e1; e2; e3 ] cxt - | Lsequence (e1, e2) -> check_list [ e1; e2 ] cxt + check_staticfails e1 cxt; + check_staticfails e2 cxt + | Lifthenelse (e1, e2, e3) -> check_list [e1; e2; e3] cxt + | Lsequence (e1, e2) -> check_list [e1; e2] cxt | Lassign (_id, e) -> check_staticfails e cxt in let rec iter_list xs = Ext_list.iter xs iter @@ -95,61 +95,60 @@ let check file lam = match l with | Lvar id -> use id | Lglobal_module _ -> () - | Lprim { args; _ } -> iter_list args + | Lprim {args; _} -> iter_list args | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - iter ap_func; - iter_list ap_args - | Lfunction { body; params } -> - List.iter def params; - iter body + | Lapply {ap_func; ap_args; _} -> + iter ap_func; + iter_list ap_args + | Lfunction {body; params} -> + List.iter def params; + iter body | Llet (_str, id, arg, body) -> - iter arg; - def id; - iter body + iter arg; + def id; + iter body | Lletrec (decl, body) -> - Ext_list.iter_fst decl def; - iter_list_snd decl; - iter body + Ext_list.iter_fst decl def; + iter_list_snd decl; + iter body | Lswitch (arg, sw) -> - iter arg; - iter_list_snd sw.sw_consts; - iter_list_snd sw.sw_blocks; - Ext_option.iter sw.sw_failaction iter; - assert ( - not - (sw.sw_failaction <> None && sw.sw_consts_full && sw.sw_blocks_full)) + iter arg; + iter_list_snd sw.sw_consts; + iter_list_snd sw.sw_blocks; + Ext_option.iter sw.sw_failaction iter; + assert ( + not (sw.sw_failaction <> None && sw.sw_consts_full && sw.sw_blocks_full)) | Lstringswitch (arg, cases, default) -> - iter arg; - iter_list_snd cases; - Ext_option.iter default iter + iter arg; + iter_list_snd cases; + Ext_option.iter default iter | Lstaticraise (_i, args) -> iter_list args | Lstaticcatch (e1, (_, vars), e2) -> - iter e1; - List.iter def vars; - iter e2 + iter e1; + List.iter def vars; + iter e2 | Ltrywith (e1, exn, e2) -> - iter e1; - def exn; - iter e2 + iter e1; + def exn; + iter e2 | Lifthenelse (e1, e2, e3) -> - iter e1; - iter e2; - iter e3 + iter e1; + iter e2; + iter e3 | Lsequence (e1, e2) -> - iter e1; - iter e2 + iter e1; + iter e2 | Lwhile (e1, e2) -> - iter e1; - iter e2 + iter e1; + iter e2 | Lfor (v, e1, e2, _dir, e3) -> - iter e1; - iter e2; - def v; - iter e3 + iter e1; + iter e2; + def v; + iter e3 | Lassign (id, e) -> - use id; - iter e + use id; + iter e in check_staticfails lam Set_int.empty; iter lam; diff --git a/compiler/core/lam_closure.ml b/compiler/core/lam_closure.ml index 8b72bfa04d..c02f05b705 100644 --- a/compiler/core/lam_closure.ml +++ b/compiler/core/lam_closure.ml @@ -30,7 +30,9 @@ let adjust (fv : stats Map_ident.t) (pos : position) (v : Ident.t) : stats Map_ident.t = Map_ident.adjust fv v (fun v -> let stat = - match v with None -> Lam_var_stats.fresh_stats | Some v -> v + match v with + | None -> Lam_var_stats.fresh_stats + | Some v -> v in Lam_var_stats.update stat pos) @@ -67,77 +69,74 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) match lam with | Lvar v -> used top v | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - iter top ap_func; - let top = Lam_var_stats.new_position_after_lam ap_func top in - Ext_list.iter ap_args (fun lam -> iter top lam) - | Lprim { args; _ } -> - (* Check: can top be propoaged for all primitives *) - Ext_list.iter args (iter top) + | Lapply {ap_func; ap_args; _} -> + iter top ap_func; + let top = Lam_var_stats.new_position_after_lam ap_func top in + Ext_list.iter ap_args (fun lam -> iter top lam) + | Lprim {args; _} -> + (* Check: can top be propoaged for all primitives *) + Ext_list.iter args (iter top) | Lglobal_module _ -> () - | Lfunction { params; body } -> - local_add_list params; - iter sink_pos body (* Do we need continue *) + | Lfunction {params; body} -> + local_add_list params; + iter sink_pos body (* Do we need continue *) | Llet (_, id, arg, body) -> - iter top arg; - local_add id; - iter sink_pos body + iter top arg; + local_add id; + iter sink_pos body | Lletrec (decl, body) -> - local_set := - Ext_list.fold_left decl !local_set (fun acc (id, _) -> - Set_ident.add acc id); - Ext_list.iter decl (fun (_, exp) -> iter sink_pos exp); - iter sink_pos body + local_set := + Ext_list.fold_left decl !local_set (fun acc (id, _) -> + Set_ident.add acc id); + Ext_list.iter decl (fun (_, exp) -> iter sink_pos exp); + iter sink_pos body | Lswitch ( arg, - { - sw_consts; - sw_blocks; - sw_failaction; - sw_consts_full; - sw_blocks_full; - } ) -> ( - iter top arg; - let top = Lam_var_stats.new_position_after_lam arg top in - List.iter (fun (_, case) -> iter top case) sw_consts; - List.iter (fun (_, case) -> iter top case) sw_blocks; - match sw_failaction with - | None -> () - | Some x -> - if sw_consts_full || sw_blocks_full then iter top x - else iter sink_pos x) + {sw_consts; sw_blocks; sw_failaction; sw_consts_full; sw_blocks_full} + ) -> ( + iter top arg; + let top = Lam_var_stats.new_position_after_lam arg top in + List.iter (fun (_, case) -> iter top case) sw_consts; + List.iter (fun (_, case) -> iter top case) sw_blocks; + match sw_failaction with + | None -> () + | Some x -> + if sw_consts_full || sw_blocks_full then iter top x else iter sink_pos x + ) | Lstringswitch (arg, cases, default) -> ( - iter top arg; - let top = Lam_var_stats.new_position_after_lam arg top in - List.iter (fun (_, act) -> iter top act) cases; - match default with None -> () | Some x -> iter top x) + iter top arg; + let top = Lam_var_stats.new_position_after_lam arg top in + List.iter (fun (_, act) -> iter top act) cases; + match default with + | None -> () + | Some x -> iter top x) | Lstaticraise (_, args) -> List.iter (iter sink_pos) args | Lstaticcatch (e1, (_, vars), e2) -> - iter sink_pos e1; - local_add_list vars; - iter sink_pos e2 + iter sink_pos e1; + local_add_list vars; + iter sink_pos e2 | Ltrywith (e1, _exn, e2) -> - iter top e1; - iter sink_pos e2 + iter top e1; + iter sink_pos e2 | Lifthenelse (e1, e2, e3) -> - iter top e1; - let top = Lam_var_stats.new_position_after_lam e1 top in - iter top e2; - iter top e3 + iter top e1; + let top = Lam_var_stats.new_position_after_lam e1 top in + iter top e2; + iter top e3 | Lsequence (e1, e2) -> - iter top e1; - iter sink_pos e2 + iter top e1; + iter sink_pos e2 | Lwhile (e1, e2) -> - iter sink_pos e1; - iter sink_pos e2 (* in the loop, no substitution any way *) + iter sink_pos e1; + iter sink_pos e2 (* in the loop, no substitution any way *) | Lfor (v, e1, e2, _dir, e3) -> - local_add v; - iter sink_pos e1; - iter sink_pos e2; - iter sink_pos e3 + local_add v; + iter sink_pos e1; + iter sink_pos e2; + iter sink_pos e3 | Lassign (id, e) -> - used top id; - iter top e + used top id; + iter top e in iter Lam_var_stats.fresh_env lam; !fv diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index 84d7f7a6bc..2ddddc7cfd 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -70,12 +70,12 @@ *) type t = { - export_list : Ident.t list; - export_set : Set_ident.t; - export_map : Lam.t Map_ident.t; + export_list: Ident.t list; + export_set: Set_ident.t; + export_map: Lam.t Map_ident.t; (** not used in code generation, mostly used for store some information in cmj files *) - groups : Lam_group.t list; + groups: Lam_group.t list; (* all code to be compiled later = original code + rebound coercions *) } @@ -85,7 +85,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) let (original_export_set : Set_ident.t) = meta.export_idents in let len = List.length original_exports in let tbl = Hash_set_string.create len in - let ({ export_list; export_set } as result) = + let ({export_list; export_set} as result) = Ext_list.fold_right2 original_exports lambda_exports { export_list = []; @@ -98,29 +98,29 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) Bs_exception.error (Bs_duplicate_exports original_name); match lam with | Lvar id -> - if Ident.name id = original_name then - { - acc with - export_list = id :: acc.export_list; - export_set = - (if id.stamp = original_export_id.stamp then acc.export_set - else - Set_ident.add - (Set_ident.remove acc.export_set original_export_id) - id); - } - else - let newid = Ident.rename original_export_id in - let kind : Lam_compat.let_kind = Alias in - Lam_util.alias_ident_or_global meta newid id NA; - { - acc with - export_list = newid :: acc.export_list; - export_map = Map_ident.add acc.export_map newid lam; - groups = Single (kind, newid, lam) :: acc.groups; - } + if Ident.name id = original_name then + { + acc with + export_list = id :: acc.export_list; + export_set = + (if id.stamp = original_export_id.stamp then acc.export_set + else + Set_ident.add + (Set_ident.remove acc.export_set original_export_id) + id); + } + else + let newid = Ident.rename original_export_id in + let kind : Lam_compat.let_kind = Alias in + Lam_util.alias_ident_or_global meta newid id NA; + { + acc with + export_list = newid :: acc.export_list; + export_map = Map_ident.add acc.export_map newid lam; + groups = Single (kind, newid, lam) :: acc.groups; + } | _ -> - (* + (* Example: {[ let N = [a0,a1,a2,a3] @@ -137,24 +137,24 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) Bug manifested: when querying arity info about N, it returns an array of size 4 instead of 2 *) - let newid = Ident.rename original_export_id in - (let arity = Lam_arity_analysis.get_arity meta lam in - if not (Lam_arity.first_arity_na arity) then - Hash_ident.add meta.ident_tbl newid - (FunctionId - { - arity; - lambda = - (match lam with - | Lfunction _ -> Some (lam, Lam_non_rec) - | _ -> None); - })); - { - acc with - export_list = newid :: acc.export_list; - export_map = Map_ident.add acc.export_map newid lam; - groups = Single (Strict, newid, lam) :: acc.groups; - }) + let newid = Ident.rename original_export_id in + (let arity = Lam_arity_analysis.get_arity meta lam in + if not (Lam_arity.first_arity_na arity) then + Hash_ident.add meta.ident_tbl newid + (FunctionId + { + arity; + lambda = + (match lam with + | Lfunction _ -> Some (lam, Lam_non_rec) + | _ -> None); + })); + { + acc with + export_list = newid :: acc.export_list; + export_map = Map_ident.add acc.export_map newid lam; + groups = Single (Strict, newid, lam) :: acc.groups; + }) in let export_map, coerced_input = @@ -162,14 +162,14 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) (fun (export_map, acc) x -> ( (match x with | Single (_, id, lam) when Set_ident.mem export_set id -> - Map_ident.add export_map id lam + Map_ident.add export_map id lam (* relies on the Invariant that [eoid] can not be bound before FIX: such invariant may not hold *) | _ -> export_map), x :: acc )) in - { result with export_map; groups = Lam_dce.remove export_list coerced_input } + {result with export_map; groups = Lam_dce.remove export_list coerced_input} (* TODO: more flattening, - also for function compilation, flattening should be done first @@ -180,12 +180,12 @@ let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : Lam.t * Lam_group.t list = match lam with | Llet (str, id, arg, body) -> - let res, l = flatten acc arg in - flatten (Single (str, id, res) :: l) body + let res, l = flatten acc arg in + flatten (Single (str, id, res) :: l) body | Lletrec (bind_args, body) -> flatten (Recursive bind_args :: acc) body | Lsequence (l, r) -> - let res, l = flatten acc l in - flatten (Lam_group.nop_cons res l) r + let res, l = flatten acc l in + flatten (Lam_group.nop_cons res l) r | x -> (x, acc) (** Invarinat to hold: @@ -195,20 +195,20 @@ let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : *) let coerce_and_group_big_lambda (meta : Lam_stats.t) lam : t * Lam_stats.t = match flatten [] lam with - | Lprim { primitive = Pmakeblock _; args = lambda_exports }, reverse_input -> - let coerced_input = handle_exports meta lambda_exports reverse_input in - ( coerced_input, - { - meta with - export_idents = coerced_input.export_set; - exports = coerced_input.export_list; - } ) + | Lprim {primitive = Pmakeblock _; args = lambda_exports}, reverse_input -> + let coerced_input = handle_exports meta lambda_exports reverse_input in + ( coerced_input, + { + meta with + export_idents = coerced_input.export_set; + exports = coerced_input.export_list; + } ) | _ -> - (* This could happen see #2474*) - (* #3595 - TODO: FIXME later - *) - assert false + (* This could happen see #2474*) + (* #3595 + TODO: FIXME later + *) + assert false (* { export_list = meta.exports; export_set = meta.export_idents; diff --git a/compiler/core/lam_coercion.mli b/compiler/core/lam_coercion.mli index 0acb9bad4c..e9163c9d6b 100644 --- a/compiler/core/lam_coercion.mli +++ b/compiler/core/lam_coercion.mli @@ -23,10 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = { - export_list : Ident.t list; - export_set : Set_ident.t; - export_map : Lam.t Map_ident.t; - groups : Lam_group.t list; + export_list: Ident.t list; + export_set: Set_ident.t; + export_map: Lam.t Map_ident.t; + groups: Lam_group.t list; } val coerce_and_group_big_lambda : Lam_stats.t -> Lam.t -> t * Lam_stats.t diff --git a/compiler/core/lam_compat.ml b/compiler/core/lam_compat.ml index 2bc69baaca..bf7b08157e 100644 --- a/compiler/core/lam_compat.ml +++ b/compiler/core/lam_compat.ml @@ -50,7 +50,7 @@ let cmp_float (cmp : comparison) (a : float) b : bool = | Cle -> a <= b | Clt -> a < b | Cge -> a >= b - + let cmp_int (cmp : comparison) (a : int) b : bool = match cmp with | Ceq -> a = b @@ -63,10 +63,10 @@ let cmp_int (cmp : comparison) (a : int) b : bool = type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of { name : string; mutable_flag : Asttypes.mutable_flag } - | Fld_module of { name : string } - | Fld_record_inline of { name : string } - | Fld_record_extension of { name : string } + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} + | Fld_module of {name: string} + | Fld_record_inline of {name: string} + | Fld_record_extension of {name: string} | Fld_tuple | Fld_poly_var_tag | Fld_poly_var_content @@ -79,12 +79,12 @@ let str_of_field_info (x : field_dbg_info) : string option = match x with | Fld_array | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag | Fld_poly_var_content | Fld_tuple -> - None - | Fld_record { name; _ } - | Fld_module { name; _ } - | Fld_record_inline { name } - | Fld_record_extension { name } -> - Some name + None + | Fld_record {name; _} + | Fld_module {name; _} + | Fld_record_inline {name} + | Fld_record_extension {name} -> + Some name type set_field_dbg_info = Lambda.set_field_dbg_info = | Fld_record_set of string diff --git a/compiler/core/lam_compat.mli b/compiler/core/lam_compat.mli index 58934e0ae0..4a1c94217e 100644 --- a/compiler/core/lam_compat.mli +++ b/compiler/core/lam_compat.mli @@ -27,10 +27,10 @@ type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of { name : string; mutable_flag : Asttypes.mutable_flag } - | Fld_module of { name : string } - | Fld_record_inline of { name : string } - | Fld_record_extension of { name : string } + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} + | Fld_module of {name: string} + | Fld_record_inline of {name: string} + | Fld_record_extension of {name: string} | Fld_tuple | Fld_poly_var_tag | Fld_poly_var_content diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 90467f847d..b773eff0ed 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -27,14 +27,16 @@ module S = Js_stmt_make let args_either_function_or_const (args : Lam.t list) = Ext_list.for_all args (fun x -> - match x with Lfunction _ | Lconst _ -> true | _ -> false) + match x with + | Lfunction _ | Lconst _ -> true + | _ -> false) let call_info_of_ap_status (ap_status : Lam.apply_status) : Js_call_info.t = (* XXX *) match ap_status with - | App_infer_full -> { arity = Full; call_info = Call_ml } - | App_uncurry -> { arity = Full; call_info = Call_na } - | App_na -> { arity = NA; call_info = Call_ml } + | App_infer_full -> {arity = Full; call_info = Call_ml} + | App_uncurry -> {arity = Full; call_info = Call_na} + | App_na -> {arity = NA; call_info = Call_ml} let rec apply_with_arity_aux (fn : J.expression) (arity : int list) (args : E.t list) (len : int) : E.t = @@ -42,35 +44,36 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) else match arity with | x :: rest -> - let x = if x = 0 then 1 else x in - (* Relax when x = 0 *) - if len >= x then - let first_part, continue = Ext_list.split_at args x in - apply_with_arity_aux - (E.call ~info:{ arity = Full; call_info = Call_ml } fn first_part) - rest continue (len - x) - else if - (* GPR #1423 *) - Ext_list.for_all args Js_analyzer.is_okay_to_duplicate - then - let params = - Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") - in - E.ocaml_fun params ~return_unit:false (* unknown info *) ~async:false ~one_unit_arg:false - [ - S.return_stmt - (E.call - ~info:{ arity = Full; call_info = Call_ml } - fn - (Ext_list.append args @@ Ext_list.map params E.var)); - ] - else E.call ~info:Js_call_info.dummy fn args + let x = if x = 0 then 1 else x in + (* Relax when x = 0 *) + if len >= x then + let first_part, continue = Ext_list.split_at args x in + apply_with_arity_aux + (E.call ~info:{arity = Full; call_info = Call_ml} fn first_part) + rest continue (len - x) + else if + (* GPR #1423 *) + Ext_list.for_all args Js_analyzer.is_okay_to_duplicate + then + let params = + Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") + in + E.ocaml_fun params ~return_unit:false (* unknown info *) + ~async:false ~one_unit_arg:false + [ + S.return_stmt + (E.call + ~info:{arity = Full; call_info = Call_ml} + fn + (Ext_list.append args @@ Ext_list.map params E.var)); + ] + else E.call ~info:Js_call_info.dummy fn args (* alpha conversion now? -- Since we did an alpha conversion before so it is not here *) | [] -> - (* can not happen, unless it's an exception ? *) - E.call ~info:Js_call_info.dummy fn args + (* can not happen, unless it's an exception ? *) + E.call ~info:Js_call_info.dummy fn args let apply_with_arity ~arity fn args = apply_with_arity_aux fn arity args (List.length args) @@ -84,8 +87,8 @@ let change_tail_type_in_try (x : Lam_compile_context.tail_type) : let in_staticcatch (x : Lam_compile_context.tail_type) : Lam_compile_context.tail_type = match x with - | Maybe_tail_is_return (Tail_with_name ({ in_staticcatch = false } as x)) -> - Maybe_tail_is_return (Tail_with_name { x with in_staticcatch = true }) + | Maybe_tail_is_return (Tail_with_name ({in_staticcatch = false} as x)) -> + Maybe_tail_is_return (Tail_with_name {x with in_staticcatch = true}) | _ -> x (* let change_tail_type_in_static @@ -107,8 +110,8 @@ let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : || not (Lam_exit_code.has_exit_code handler (fun exit -> Ext_list.exists acc (fun x -> x.label = exit))) -> - (* #1698 should not crush exit code here without checking *) - flat_catches ({ label; handler; bindings } :: acc) l + (* #1698 should not crush exit code here without checking *) + flat_catches ({label; handler; bindings} :: acc) l | _ -> (acc, x) let flatten_nested_caches (x : Lam.t) : Lam_compile_context.handler list * Lam.t @@ -118,7 +121,7 @@ let flatten_nested_caches (x : Lam.t) : Lam_compile_context.handler list * Lam.t let morph_declare_to_assign (cxt : Lam_compile_context.t) k = match cxt.continuation with | Declare (kind, did) -> - k { cxt with continuation = Assign did } (Some (kind, did)) + k {cxt with continuation = Assign did} (Some (kind, did)) | _ -> k cxt None let group_apply ~merge_cases cases callback = @@ -140,55 +143,58 @@ let default_action ~saturated failaction = | Some x -> if saturated then Complete else Default x let get_const_tag i (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with None -> None | Some { consts } -> Some consts.(i) + match sw_names with + | None -> None + | Some {consts} -> Some consts.(i) let get_block i (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with None -> None | Some { blocks } -> Some blocks.(i) + match sw_names with + | None -> None + | Some {blocks} -> Some blocks.(i) let get_tag_name (sw_names : Ast_untagged_variants.switch_names option) = match sw_names with | None -> Js_dump_lit.tag - | Some { blocks } -> - (match Array.find_opt (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) blocks with + | Some {blocks} -> ( + match + Array.find_opt + (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) + blocks + with | Some {tag_name = Some s} -> s - | _ -> Js_dump_lit.tag - ) + | _ -> Js_dump_lit.tag) let get_block_cases (sw_names : Ast_untagged_variants.switch_names option) = let res = ref [] in (match sw_names with | None -> res := [] - | Some { blocks } -> + | Some {blocks} -> Ext_array.iter blocks (function - | {block_type = Some block_type} -> res := block_type :: !res - | {block_type = None} -> () - ) - ); + | {block_type = Some block_type} -> res := block_type :: !res + | {block_type = None} -> ())); !res let get_literal_cases (sw_names : Ast_untagged_variants.switch_names option) = let res = ref [] in (match sw_names with | None -> res := [] - | Some { consts } -> + | Some {consts} -> Ext_array.iter consts (function - | {tag_type = Some t} -> res := t :: !res - | {name; tag_type = None} -> res := String name :: !res - ) - ); + | {tag_type = Some t} -> res := t :: !res + | {name; tag_type = None} -> res := String name :: !res)); !res - -let has_null_undefined_other (sw_names : Ast_untagged_variants.switch_names option) = - let (null, undefined, other) = (ref false, ref false, ref false) in +let has_null_undefined_other + (sw_names : Ast_untagged_variants.switch_names option) = + let null, undefined, other = (ref false, ref false, ref false) in (match sw_names with | None -> () - | Some { consts; blocks } -> - Ext_array.iter consts (fun x -> match x.tag_type with - | Some Undefined -> undefined := true - | Some Null -> null := true - | _ -> other := true); - ); + | Some {consts; blocks} -> + Ext_array.iter consts (fun x -> + match x.tag_type with + | Some Undefined -> undefined := true + | Some Null -> null := true + | _ -> other := true)); (!null, !undefined, !other) let no_effects_const = lazy true @@ -226,53 +232,56 @@ type initialization = J.block non-toplevel, it will explode code very quickly *) -let compile output_prefix = - -let rec compile_external_field (* Like [List.empty]*) - ?(dynamic_import = false) (lamba_cxt : Lam_compile_context.t) (id : Ident.t) name : Js_output.t = - match Lam_compile_env.query_external_id_info ~dynamic_import id name with - | { persistent_closed_lambda = Some lam } when Lam_util.not_function lam -> +let compile output_prefix = + let rec compile_external_field (* Like [List.empty]*) + ?(dynamic_import = false) (lamba_cxt : Lam_compile_context.t) + (id : Ident.t) name : Js_output.t = + match Lam_compile_env.query_external_id_info ~dynamic_import id name with + | {persistent_closed_lambda = Some lam} when Lam_util.not_function lam -> compile_lambda lamba_cxt lam - | _ -> + | _ -> Js_output.output_of_expression lamba_cxt.continuation - ~no_effects:no_effects_const (E.ml_var_dot ~dynamic_import id name) -(* TODO: how nested module call would behave, - In the future, we should keep in track of if - it is fully applied from [Lapply] - Seems that the module dependency is tricky.. - should we depend on [Pervasives] or not? - - we can not do this correctly for the return value, - however we can inline the definition in Pervasives - TODO: - [Pervasives.print_endline] - [Pervasives.prerr_endline] - @param id external module id - @param number the index of the external function - @param env typing environment - @param args arguments -*) - -(* This can not happen since this id should be already consulted by type checker - Worst case - {[ - E.array_index_by_int m pos - ]} -*) + ~no_effects:no_effects_const + (E.ml_var_dot ~dynamic_import id name) + (* TODO: how nested module call would behave, + In the future, we should keep in track of if + it is fully applied from [Lapply] + Seems that the module dependency is tricky.. + should we depend on [Pervasives] or not? + + we can not do this correctly for the return value, + however we can inline the definition in Pervasives + TODO: + [Pervasives.print_endline] + [Pervasives.prerr_endline] + @param id external module id + @param number the index of the external function + @param env typing environment + @param args arguments + *) + (* This can not happen since this id should be already consulted by type checker + Worst case + {[ + E.array_index_by_int m pos + ]} + *) -(* when module is passed as an argument - unpack to an array - for the function, generative module or functor can be a function, - however it can not be global -- global can only module -*) -and compile_external_field_apply ?(dynamic_import = false) (appinfo : Lam.apply) (module_id : Ident.t) - (field_name : string) (lambda_cxt : Lam_compile_context.t) : Js_output.t = - let ident_info = - Lam_compile_env.query_external_id_info ~dynamic_import module_id field_name - in - let ap_args = appinfo.ap_args in - match ident_info.persistent_closed_lambda with - | Some (Lfunction ({ params; body; _ } as lfunction)) - when Ext_list.same_length params ap_args && Lam_analysis.lfunction_can_be_inlined lfunction -> + (* when module is passed as an argument - unpack to an array + for the function, generative module or functor can be a function, + however it can not be global -- global can only module + *) + and compile_external_field_apply ?(dynamic_import = false) + (appinfo : Lam.apply) (module_id : Ident.t) (field_name : string) + (lambda_cxt : Lam_compile_context.t) : Js_output.t = + let ident_info = + Lam_compile_env.query_external_id_info ~dynamic_import module_id + field_name + in + let ap_args = appinfo.ap_args in + match ident_info.persistent_closed_lambda with + | Some (Lfunction ({params; body; _} as lfunction)) + when Ext_list.same_length params ap_args + && Lam_analysis.lfunction_can_be_inlined lfunction -> (* TODO: serialize it when exporting to save compile time *) let _, param_map = Lam_closure.is_closed_with_map Set_ident.empty params body @@ -280,16 +289,16 @@ and compile_external_field_apply ?(dynamic_import = false) (appinfo : Lam.apply) compile_lambda lambda_cxt (Lam_beta_reduce.propagate_beta_reduce_with_map lambda_cxt.meta param_map params body ap_args) - | _ -> + | _ -> let args_code, args = let dummy = ([], []) in if ap_args = [] then dummy else - let arg_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in + let arg_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in Ext_list.fold_right ap_args dummy (fun arg_lambda (args_code, args) -> match compile_lambda arg_cxt arg_lambda with - | { block; value = Some b } -> - (Ext_list.append block args_code, b :: args) + | {block; value = Some b} -> + (Ext_list.append block args_code, b :: args) | _ -> assert false) in @@ -297,18 +306,17 @@ and compile_external_field_apply ?(dynamic_import = false) (appinfo : Lam.apply) let expression = match appinfo.ap_info.ap_status with | (App_infer_full | App_uncurry) as ap_status -> - E.call ~info:(call_info_of_ap_status ap_status) fn args + E.call ~info:(call_info_of_ap_status ap_status) fn args | App_na -> ( - match ident_info.arity with - | Submodule _ | Single Arity_na -> - E.call ~info:Js_call_info.dummy fn args - | Single x -> - apply_with_arity fn ~arity:(Lam_arity.extract_arity x) args) + match ident_info.arity with + | Submodule _ | Single Arity_na -> + E.call ~info:Js_call_info.dummy fn args + | Single x -> + apply_with_arity fn ~arity:(Lam_arity.extract_arity x) args) in Js_output.output_of_block_and_expression lambda_cxt.continuation args_code expression - -(* + (* The second return values are values which need to be wrapped using [update_dummy] @@ -316,10 +324,11 @@ and compile_external_field_apply ?(dynamic_import = false) (appinfo : Lam.apply) here we share env *) -and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lam.t) : Js_output.t * initialization = - match arg with - | Lfunction { params; body; attr = { return_unit; async; one_unit_arg; directive } } -> + and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) + (id : Ident.t) (arg : Lam.t) : Js_output.t * initialization = + match arg with + | Lfunction + {params; body; attr = {return_unit; async; one_unit_arg; directive}} -> (* TODO: Think about recursive value {[ let rec v = ref (fun _ ... @@ -344,7 +353,7 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) continuation = EffectCall (Maybe_tail_is_return - (Tail_with_name { label = Some ret; in_staticcatch = false })); + (Tail_with_name {label = Some ret; in_staticcatch = false})); jmp_table = Lam_compile_context.empty_handler_map; } body @@ -358,7 +367,8 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) it will be renamed into [method] when it is detected by a primitive *) - ~return_unit ~async ~one_unit_arg ?directive ~immutable_mask:ret.immutable_mask + ~return_unit ~async ~one_unit_arg ?directive + ~immutable_mask:ret.immutable_mask (Ext_list.map params (fun x -> Map_ident.find_default ret.new_params x x)) [ @@ -369,37 +379,39 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) ] else (* TODO: save computation of length several times *) - E.ocaml_fun params (Js_output.output_as_block output) ~return_unit ~async ~one_unit_arg ?directive + E.ocaml_fun params + (Js_output.output_as_block output) + ~return_unit ~async ~one_unit_arg ?directive in ( Js_output.output_of_expression (Declare (Alias, id)) result ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), [] ) - | Lprim { primitive = Pmakeblock (_, _, _); args } - when args_either_function_or_const args -> - (compile_lambda { cxt with continuation = Declare (Alias, id) } arg, []) - (* case of lazy blocks, treat it as usual *) - | Lprim - { - primitive = - Pmakeblock - ( _, - (( Blk_record _ - | Blk_constructor { num_nonconst = 1 } - | Blk_record_inlined { num_nonconst = 1 } ) as tag_info), - _ ); - args = ls; - } - when Ext_list.for_all ls (fun x -> - match x with - | Lvar pid -> + | Lprim {primitive = Pmakeblock (_, _, _); args} + when args_either_function_or_const args -> + (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) + (* case of lazy blocks, treat it as usual *) + | Lprim + { + primitive = + Pmakeblock + ( _, + (( Blk_record _ + | Blk_constructor {num_nonconst = 1} + | Blk_record_inlined {num_nonconst = 1} ) as tag_info), + _ ); + args = ls; + } + when Ext_list.for_all ls (fun x -> + match x with + | Lvar pid -> Ident.same pid id || not @@ Ext_list.exists all_bindings (fun (other, _) -> Ident.same other pid) - | Lconst _ -> true - | _ -> false) -> + | Lconst _ -> true + | _ -> false) -> (* capture cases like for {!Queue} {[let rec cell = { content = x; next = cell} ]} #1716: be careful not to optimize such cases: @@ -413,16 +425,15 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) S.exp (Js_of_lam_block.set_field (match tag_info with - | Blk_record { fields = xs } -> Fld_record_set xs.(i) + | Blk_record {fields = xs} -> Fld_record_set xs.(i) | Blk_record_inlined xs -> - Fld_record_inline_set xs.fields.(i) + Fld_record_inline_set xs.fields.(i) | Blk_constructor p -> ( - let is_cons = p.name = Literals.cons in - match (is_cons, i) with - | true, 0 -> Fld_record_inline_set Literals.hd - | true, 1 -> Fld_record_inline_set Literals.tl - | _, _ -> Fld_record_inline_set ("_" ^ string_of_int i) - ) + let is_cons = p.name = Literals.cons in + match (is_cons, i) with + | true, 0 -> Fld_record_inline_set Literals.hd + | true, 1 -> Fld_record_inline_set Literals.tl + | _, _ -> Fld_record_inline_set ("_" ^ string_of_int i)) | _ -> assert false) (E.var id) (Int32.of_int i) (match x with @@ -430,28 +441,26 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) | Lconst x -> Lam_compile_const.translate x | _ -> assert false)))), [] ) - | Lprim { primitive = Pmakeblock (_, tag_info, _) } -> ( + | Lprim {primitive = Pmakeblock (_, tag_info, _)} -> ( (* Lconst should not appear here if we do [scc] optimization, since it's faked recursive value, however it would affect scope issues, we have to declare it first *) - match - compile_lambda { cxt with continuation = NeedValue Not_tail } arg - with - | { block = b; value = Some v } -> - (* TODO: check recursive value .. - could be improved for simple cases - *) - ( Js_output.make - (Ext_list.append b - [ - S.exp - (E.runtime_call Primitive_modules.object_ - "updateDummy" [ E.var id; v ]); - ]), - [ S.define_variable ~kind:Variable id (E.dummy_obj tag_info) ] ) + match compile_lambda {cxt with continuation = NeedValue Not_tail} arg with + | {block = b; value = Some v} -> + (* TODO: check recursive value .. + could be improved for simple cases + *) + ( Js_output.make + (Ext_list.append b + [ + S.exp + (E.runtime_call Primitive_modules.object_ "updateDummy" + [E.var id; v]); + ]), + [S.define_variable ~kind:Variable id (E.dummy_obj tag_info)] ) | _ -> assert false) - | _ -> + | _ -> (* pathological case: fail to capture taill call? {[ let rec a = @@ -473,63 +482,68 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) fun _-> print_endline "hey"; v () ]} *) - (compile_lambda { cxt with continuation = Declare (Alias, id) } arg, []) - -and compile_recursive_lets_aux cxt (id_args : Lam_scc.bindings) : Js_output.t = - (* #1716 *) - let output_code, ids = - Ext_list.fold_right id_args (Js_output.dummy, []) - (fun (ident, arg) (acc, ids) -> - let code, declare_ids = - compile_recursive_let ~all_bindings:id_args cxt ident arg - in - (Js_output.append_output code acc, Ext_list.append declare_ids ids)) - in - match ids with - | [] -> output_code - | _ -> Js_output.append_output (Js_output.make ids) output_code - -and compile_recursive_lets cxt id_args : Js_output.t = - match id_args with - | [] -> Js_output.dummy - | _ -> ( + (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) + and compile_recursive_lets_aux cxt (id_args : Lam_scc.bindings) : Js_output.t + = + (* #1716 *) + let output_code, ids = + Ext_list.fold_right id_args (Js_output.dummy, []) + (fun (ident, arg) (acc, ids) -> + let code, declare_ids = + compile_recursive_let ~all_bindings:id_args cxt ident arg + in + (Js_output.append_output code acc, Ext_list.append declare_ids ids)) + in + match ids with + | [] -> output_code + | _ -> Js_output.append_output (Js_output.make ids) output_code + and compile_recursive_lets cxt id_args : Js_output.t = + match id_args with + | [] -> Js_output.dummy + | _ -> ( let id_args_group = Lam_scc.scc_bindings id_args in match id_args_group with | [] -> assert false | first :: rest -> - let acc = compile_recursive_lets_aux cxt first in - Ext_list.fold_left rest acc (fun acc x -> - Js_output.append_output acc (compile_recursive_lets_aux cxt x))) - -and compile_general_cases : - 'a . - make_exp: ('a -> J.expression) -> - eq_exp: ('a option -> J.expression -> 'a option -> J.expression -> J.expression) -> - cxt: Lam_compile_context.t -> - switch: (?default:J.block -> ?declaration:Lam_compat.let_kind * Ident.t -> - _ -> ('a * J.case_clause) list -> J.statement) -> - switch_exp: J.expression -> - default: default_case -> - ?merge_cases: ('a -> 'a -> bool) -> - ('a * Lam.t) list -> - J.block = - fun (type a) - ~(make_exp : a -> J.expression) - ~(eq_exp : a option -> J.expression -> a option -> J.expression -> J.expression) - ~(cxt : Lam_compile_context.t) - ~(switch : - ?default:J.block -> - ?declaration:Lam_compat.let_kind * Ident.t -> - _ -> (a * J.case_clause) list -> J.statement - ) - ~(switch_exp : J.expression) - ~(default : default_case) - ?(merge_cases = fun _ _ -> true) - (cases : (a * Lam.t) list) -> - match (cases, default) with - | [], Default lam -> Js_output.output_as_block (compile_lambda cxt lam) - | [], (Complete | NonComplete) -> [] - | [ (_, lam) ], Complete -> + let acc = compile_recursive_lets_aux cxt first in + Ext_list.fold_left rest acc (fun acc x -> + Js_output.append_output acc (compile_recursive_lets_aux cxt x))) + and compile_general_cases : + 'a. + make_exp:('a -> J.expression) -> + eq_exp: + ('a option -> + J.expression -> + 'a option -> + J.expression -> + J.expression) -> + cxt:Lam_compile_context.t -> + switch: + (?default:J.block -> + ?declaration:Lam_compat.let_kind * Ident.t -> + _ -> + ('a * J.case_clause) list -> + J.statement) -> + switch_exp:J.expression -> + default:default_case -> + ?merge_cases:('a -> 'a -> bool) -> + ('a * Lam.t) list -> + J.block = + fun (type a) ~(make_exp : a -> J.expression) + ~(eq_exp : + a option -> J.expression -> a option -> J.expression -> J.expression) + ~(cxt : Lam_compile_context.t) + ~(switch : + ?default:J.block -> + ?declaration:Lam_compat.let_kind * Ident.t -> + _ -> + (a * J.case_clause) list -> + J.statement) ~(switch_exp : J.expression) ~(default : default_case) + ?(merge_cases = fun _ _ -> true) (cases : (a * Lam.t) list) -> + match (cases, default) with + | [], Default lam -> Js_output.output_as_block (compile_lambda cxt lam) + | [], (Complete | NonComplete) -> [] + | [(_, lam)], Complete -> (* To take advantage of such optimizations, when we generate code using switch, we should always have a default, @@ -537,15 +551,14 @@ and compile_general_cases : it's also complete *) Js_output.output_as_block (compile_lambda cxt lam) - | [ (id, lam) ], NonComplete -> + | [(id, lam)], NonComplete -> morph_declare_to_assign cxt (fun cxt define -> [ S.if_ ?declaration:define - (eq_exp None switch_exp (Some id) (make_exp id)) (Js_output.output_as_block (compile_lambda cxt lam)); ]) - | [ (id, lam) ], Default x | [ (id, lam); (_, x) ], Complete -> + | [(id, lam)], Default x | [(id, lam); (_, x)], Complete -> morph_declare_to_assign cxt (fun cxt define -> let else_block = Js_output.output_as_block (compile_lambda cxt x) in let then_block = Js_output.output_as_block (compile_lambda cxt lam) in @@ -554,7 +567,7 @@ and compile_general_cases : (eq_exp None switch_exp (Some id) (make_exp id)) then_block ~else_:else_block; ]) - | _, _ -> + | _, _ -> (* TODO: this is not relevant to switch case however, in a subset of switch-case if we can analysis its branch are the same, we can propogate which @@ -575,19 +588,23 @@ and compile_general_cases : TOOD: disabled temporarily since it's not perfect yet *) morph_declare_to_assign cxt (fun cxt declaration -> (* Exclude cases that are the same as the default if the default is defined *) - let cases = match default with - | Default lam -> List.filter (fun (_, lam1) -> not (Lam.eq_approx lam lam1)) cases + let cases = + match default with + | Default lam -> + List.filter (fun (_, lam1) -> not (Lam.eq_approx lam lam1)) cases | _ -> cases in let default = match default with | Complete -> None | NonComplete -> None - | Default lam -> - let statements = Js_output.output_as_block (compile_lambda cxt lam) in - match statements with - | [] -> None - | _ -> Some statements + | Default lam -> ( + let statements = + Js_output.output_as_block (compile_lambda cxt lam) + in + match statements with + | [] -> None + | _ -> Some statements) in let body = group_apply ~merge_cases cases (fun last (switch_case, lam) -> @@ -604,137 +621,136 @@ and compile_general_cases : then should_break else should_break && Lam_exit_code.has_exit lam in - ( switch_case, - J. - { - switch_body; - should_break; - comment = None; - } ) + (switch_case, J.{switch_body; should_break; comment = None}) else ( switch_case, - { - switch_body = []; - should_break = false; - comment = None; - } )) + {switch_body = []; should_break = false; comment = None} )) (* TODO: we should also group default *) (* The last clause does not need [break] common break through, *) in - [ switch ?default ?declaration switch_exp body ]) - -and use_compile_literal_cases table ~(get_tag : _ -> Ast_untagged_variants.tag option) = - List.fold_right (fun (i, lam) acc -> - match get_tag i, acc with - | Some {Ast_untagged_variants.tag_type = Some t}, Some string_table -> - Some ((t, lam) :: string_table) - | Some {name; tag_type = None}, Some string_table -> Some ((String name, lam) :: string_table) - | _, _ -> None - ) table (Some []) -and compile_cases - ?(untagged=false) ~cxt ~(switch_exp : E.t) ?(default = NonComplete) - ?(get_tag = fun _ -> None) ?(block_cases=[]) cases : initialization = + [switch ?default ?declaration switch_exp body]) + and use_compile_literal_cases table + ~(get_tag : _ -> Ast_untagged_variants.tag option) = + List.fold_right + (fun (i, lam) acc -> + match (get_tag i, acc) with + | Some {Ast_untagged_variants.tag_type = Some t}, Some string_table -> + Some ((t, lam) :: string_table) + | Some {name; tag_type = None}, Some string_table -> + Some ((String name, lam) :: string_table) + | _, _ -> None) + table (Some []) + and compile_cases ?(untagged = false) ~cxt ~(switch_exp : E.t) + ?(default = NonComplete) ?(get_tag = fun _ -> None) ?(block_cases = []) + cases : initialization = match use_compile_literal_cases cases ~get_tag with | Some string_cases -> - if untagged - then compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default string_cases + if untagged then + compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default + string_cases else compile_string_cases ~cxt ~switch_exp ~default string_cases | None -> - cases |> compile_general_cases - ~make_exp:(fun i -> match get_tag i with - | None -> E.small_int i - | Some {tag_type = Some(String s)} -> E.str s - | Some {name} -> E.str name) - ~eq_exp: (fun _ x _ y -> E.int_equal x y) - ~cxt - ~switch: (fun ?default ?declaration e clauses -> - S.int_switch ?default ?declaration e clauses) - ~switch_exp - ~default - -and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) - (lambda_cxt : Lam_compile_context.t) = - (* TODO: if default is None, we can do some optimizations - Use switch vs if/then/else - - TODO: switch based optimiztion - hash, group, or using array, - also if last statement is throw -- should we drop remaining - statement? - *) - let ({ - sw_consts_full; - sw_consts; - sw_blocks_full; - sw_blocks; - sw_failaction; - sw_names; - } - : Lam.lambda_switch) = - sw - in - let sw_num_default = default_action ~saturated:sw_consts_full sw_failaction in - let sw_blocks_default = - default_action ~saturated:sw_blocks_full sw_failaction - in - let get_const_tag i = get_const_tag i sw_names in - let get_block i = get_block i sw_names in - let block_cases = get_block_cases sw_names in - let get_block_tag i : Ast_untagged_variants.tag option = match get_block i with - | None -> None - | Some ({tag = {name}; block_type = Some block_type}) -> - Some {name; tag_type = Some (Untagged block_type)} (* untagged block *) - | Some ({block_type = None; tag}) -> (* tagged block *) - Some tag in - let tag_name = get_tag_name sw_names in - let untagged = block_cases <> [] in - let compile_whole (cxt : Lam_compile_context.t) = - match - compile_lambda { cxt with continuation = NeedValue Not_tail } switch_arg - with - | { value = None; _ } -> assert false - | { block; value = Some e } -> ( + cases + |> compile_general_cases + ~make_exp:(fun i -> + match get_tag i with + | None -> E.small_int i + | Some {tag_type = Some (String s)} -> E.str s + | Some {name} -> E.str name) + ~eq_exp:(fun _ x _ y -> E.int_equal x y) + ~cxt + ~switch:(fun ?default ?declaration e clauses -> + S.int_switch ?default ?declaration e clauses) + ~switch_exp ~default + and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) + (lambda_cxt : Lam_compile_context.t) = + (* TODO: if default is None, we can do some optimizations + Use switch vs if/then/else + + TODO: switch based optimiztion - hash, group, or using array, + also if last statement is throw -- should we drop remaining + statement? + *) + let ({ + sw_consts_full; + sw_consts; + sw_blocks_full; + sw_blocks; + sw_failaction; + sw_names; + } + : Lam.lambda_switch) = + sw + in + let sw_num_default = + default_action ~saturated:sw_consts_full sw_failaction + in + let sw_blocks_default = + default_action ~saturated:sw_blocks_full sw_failaction + in + let get_const_tag i = get_const_tag i sw_names in + let get_block i = get_block i sw_names in + let block_cases = get_block_cases sw_names in + let get_block_tag i : Ast_untagged_variants.tag option = + match get_block i with + | None -> None + | Some {tag = {name}; block_type = Some block_type} -> + Some {name; tag_type = Some (Untagged block_type)} (* untagged block *) + | Some {block_type = None; tag} -> + (* tagged block *) + Some tag + in + let tag_name = get_tag_name sw_names in + let untagged = block_cases <> [] in + let compile_whole (cxt : Lam_compile_context.t) = + match + compile_lambda {cxt with continuation = NeedValue Not_tail} switch_arg + with + | {value = None; _} -> assert false + | {block; value = Some e} -> ( block @ if sw_consts_full && sw_consts = [] then - compile_cases ~block_cases - ~untagged ~cxt + compile_cases ~block_cases ~untagged ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~default:sw_blocks_default - ~get_tag:get_block_tag sw_blocks + ~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks else if sw_blocks_full && sw_blocks = [] then - compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts + compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default + ~get_tag:get_const_tag sw_consts else (* [e] will be used twice *) let dispatch e = - let is_a_literal_case = - if block_cases <> [] - then - E.is_a_literal_case ~literal_cases:(get_literal_cases sw_names) ~block_cases e + if block_cases <> [] then + E.is_a_literal_case + ~literal_cases:(get_literal_cases sw_names) + ~block_cases e else - E.is_int_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) e in + E.is_int_tag + ~has_null_undefined_other:(has_null_undefined_other sw_names) + e + in S.if_ is_a_literal_case - (compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts) - ~else_: - (compile_cases - ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~block_cases - ~default:sw_blocks_default - ~get_tag:get_block_tag sw_blocks) + (compile_cases ~cxt ~switch_exp:e ~block_cases + ~default:sw_num_default ~get_tag:get_const_tag sw_consts) + ~else_: + (compile_cases ~untagged ~cxt + ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) + ~block_cases ~default:sw_blocks_default + ~get_tag:get_block_tag sw_blocks) in match e.expression_desc with - | J.Var _ -> [ dispatch e ] + | J.Var _ -> [dispatch e] | _ -> - let v = Ext_ident.create_tmp () in - (* Necessary avoid duplicated computation*) - [ S.define_variable ~kind:Variable v e; dispatch (E.var v) ]) - in - match lambda_cxt.continuation with - (* Needs declare first *) - | NeedValue _ -> + let v = Ext_ident.create_tmp () in + (* Necessary avoid duplicated computation*) + [S.define_variable ~kind:Variable v e; dispatch (E.var v)]) + in + match lambda_cxt.continuation with + (* Needs declare first *) + | NeedValue _ -> (* Necessary since switch is a statement, we need they return the same value for different branches -- can be optmized when branches are minimial (less than 2) @@ -742,92 +758,101 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) let v = Ext_ident.create_tmp () in Js_output.make (S.declare_variable ~kind:Variable v - :: compile_whole { lambda_cxt with continuation = Assign v }) + :: compile_whole {lambda_cxt with continuation = Assign v}) ~value:(E.var v) - | Declare (kind, id) -> + | Declare (kind, id) -> Js_output.make (S.declare_variable ~kind id - :: compile_whole { lambda_cxt with continuation = Assign id }) - | EffectCall _ | Assign _ -> Js_output.make (compile_whole lambda_cxt) - - -and compile_string_cases ~cxt ~switch_exp ~default cases: initialization = - cases |> compile_general_cases - ~make_exp:E.tag_type - ~eq_exp: (fun _ x _ y -> E.string_equal x y) - ~cxt - ~switch: (fun ?default ?declaration e clauses -> - S.string_switch ?default ?declaration e clauses) - ~switch_exp - ~default -and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases cases = - let mk_eq (i : Ast_untagged_variants.tag_type option) x j y = - let check = match i, j with - | Some tag_type, _ -> - Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type ~block_cases (Expr x) (Expr y) - | _, Some tag_type -> - Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type ~block_cases (Expr y) (Expr x) - | _ -> - Ast_untagged_variants.DynamicChecks.(==) (Expr x) (Expr y) + :: compile_whole {lambda_cxt with continuation = Assign id}) + | EffectCall _ | Assign _ -> Js_output.make (compile_whole lambda_cxt) + and compile_string_cases ~cxt ~switch_exp ~default cases : initialization = + cases + |> compile_general_cases ~make_exp:E.tag_type + ~eq_exp:(fun _ x _ y -> E.string_equal x y) + ~cxt + ~switch:(fun ?default ?declaration e clauses -> + S.string_switch ?default ?declaration e clauses) + ~switch_exp ~default + and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases cases = + let mk_eq (i : Ast_untagged_variants.tag_type option) x j y = + let check = + match (i, j) with + | Some tag_type, _ -> + Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type + ~block_cases (Expr x) (Expr y) + | _, Some tag_type -> + Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type + ~block_cases (Expr y) (Expr x) + | _ -> Ast_untagged_variants.DynamicChecks.( == ) (Expr x) (Expr y) + in + E.emit_check check in - E.emit_check check - in - let tag_is_not_typeof = function - | Ast_untagged_variants.Untagged (InstanceType _) -> true - | _ -> false in - let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in - let switch ?default ?declaration e clauses = - let (not_typeof_clauses, typeof_clauses) = List.partition clause_is_not_typeof clauses in - let rec build_if_chain remaining_clauses = (match remaining_clauses with - | (Ast_untagged_variants.Untagged (InstanceType instance_type), {J.switch_body}) :: rest -> - S.if_ (E.emit_check (IsInstanceOf (instance_type, Expr e))) - (switch_body) - ~else_:([build_if_chain rest]) - | _ -> S.string_switch ?default ?declaration (E.typeof e) typeof_clauses) in - build_if_chain not_typeof_clauses in - let merge_cases tag1 tag2 = (* only merge typeof cases, as instanceof cases are pulled out into if-then-else *) - not (tag_is_not_typeof tag1 || tag_is_not_typeof tag2) in - cases |> compile_general_cases - ~make_exp: E.tag_type - ~eq_exp: mk_eq - ~cxt - ~switch - ~switch_exp - ~default - ~merge_cases - -and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = - (* TODO might better optimization according to the number of cases - Be careful: we should avoid multiple evaluation of l, - The [gen] can be elimiated when number of [cases] is less than 3 - *) - let cases = cases |> List.map (fun (s,l) -> Ast_untagged_variants.String s, l) in - match - compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } l - with - | { value = None } -> assert false - | { block; value = Some e } -> ( + let tag_is_not_typeof = function + | Ast_untagged_variants.Untagged (InstanceType _) -> true + | _ -> false + in + let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in + let switch ?default ?declaration e clauses = + let not_typeof_clauses, typeof_clauses = + List.partition clause_is_not_typeof clauses + in + let rec build_if_chain remaining_clauses = + match remaining_clauses with + | ( Ast_untagged_variants.Untagged (InstanceType instance_type), + {J.switch_body} ) + :: rest -> + S.if_ + (E.emit_check (IsInstanceOf (instance_type, Expr e))) + switch_body + ~else_:[build_if_chain rest] + | _ -> S.string_switch ?default ?declaration (E.typeof e) typeof_clauses + in + build_if_chain not_typeof_clauses + in + let merge_cases tag1 tag2 = + (* only merge typeof cases, as instanceof cases are pulled out into if-then-else *) + not (tag_is_not_typeof tag1 || tag_is_not_typeof tag2) + in + cases + |> compile_general_cases ~make_exp:E.tag_type ~eq_exp:mk_eq ~cxt ~switch + ~switch_exp ~default ~merge_cases + and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) + = + (* TODO might better optimization according to the number of cases + Be careful: we should avoid multiple evaluation of l, + The [gen] can be elimiated when number of [cases] is less than 3 + *) + let cases = + cases |> List.map (fun (s, l) -> (Ast_untagged_variants.String s, l)) + in + match + compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} l + with + | {value = None} -> assert false + | {block; value = Some e} -> ( (* when should_return is true -- it's passed down otherwise it's ok *) let default = - match default with Some x -> Default x | None -> Complete + match default with + | Some x -> Default x + | None -> Complete in match lambda_cxt.continuation with (* TODO: can be avoided when cases are less than 3 *) | NeedValue _ -> - let v = Ext_ident.create_tmp () in - Js_output.make - (Ext_list.append block - (compile_string_cases - ~cxt: { lambda_cxt with continuation = Declare (Variable, v) } - ~switch_exp:e ~default cases)) - ~value:(E.var v) + let v = Ext_ident.create_tmp () in + Js_output.make + (Ext_list.append block + (compile_string_cases + ~cxt:{lambda_cxt with continuation = Declare (Variable, v)} + ~switch_exp:e ~default cases)) + ~value:(E.var v) | _ -> - Js_output.make - (Ext_list.append block - (compile_string_cases ~cxt:lambda_cxt ~switch_exp:e ~default cases ))) - -(* + Js_output.make + (Ext_list.append block + (compile_string_cases ~cxt:lambda_cxt ~switch_exp:e ~default cases)) + ) + (* This should be optimized in lambda layer (let (match/1038 = (apply g/1027 x/1028)) (catch @@ -837,66 +862,63 @@ and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = default: (exit 1)) with (1) 2)) *) -and compile_staticraise i (largs : Lam.t list) - (lambda_cxt : Lam_compile_context.t) = - (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) - match Lam_compile_context.find_exn lambda_cxt i with - | { exit_id; bindings; order_id } -> + and compile_staticraise i (largs : Lam.t list) + (lambda_cxt : Lam_compile_context.t) = + (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) + match Lam_compile_context.find_exn lambda_cxt i with + | {exit_id; bindings; order_id} -> Ext_list.fold_right2 largs bindings (Js_output.make - (if order_id >= 0 then [ S.assign exit_id (E.small_int order_id) ] - else [])) + (if order_id >= 0 then [S.assign exit_id (E.small_int order_id)] + else [])) (fun larg bind acc -> let new_output = match larg with - | Lvar id -> Js_output.make [ S.assign bind (E.var id) ] + | Lvar id -> Js_output.make [S.assign bind (E.var id)] | _ -> - (* TODO: should be Assign -- Assign is an optimization *) - compile_lambda - { lambda_cxt with continuation = Assign bind } - larg + (* TODO: should be Assign -- Assign is an optimization *) + compile_lambda {lambda_cxt with continuation = Assign bind} larg in Js_output.append_output new_output acc) - -(* Invariant: exit_code can not be reused - (catch l with (32) - (handler)) - 32 should not be used in another catch - Invariant: - This is true in current ocaml compiler - currently exit only appears in should_return position relative to staticcatch - if not we should use ``javascript break`` or ``continue`` - if exit_code_id == code - handler -- ids are not useful, since - when compiling `largs` we will do the binding there - - when exit_code is undefined internally, - it should PRESERVE ``tail`` property - - if it uses `staticraise` only once - or handler is minimal, we can inline - - always inline also seems to be ok, but it might bloat the code - - another common scenario is that we have nested catch - (catch (catch (catch ..)) - checkout example {!Digest.file}, you can not inline handler there, - we can spot such patten and use finally there? - {[ - let file filename = - let ic = open_in_bin filename in - match channel ic (-1) with - | d -> close_in ic; d - | exception e -> close_in ic; raise e - - ]} -*) -and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = - let code_table, body = flatten_nested_caches lam in - let exit_id = Ext_ident.create_tmp ~name:"exit" () in - match (lambda_cxt.continuation, code_table) with - | ( EffectCall - (Maybe_tail_is_return (Tail_with_name { in_staticcatch = false }) as - tail_type), - [ code_table ] ) - (* tail position and only one exit code *) - when Lam_compile_context.no_static_raise_in_handler code_table -> + (* Invariant: exit_code can not be reused + (catch l with (32) + (handler)) + 32 should not be used in another catch + Invariant: + This is true in current ocaml compiler + currently exit only appears in should_return position relative to staticcatch + if not we should use ``javascript break`` or ``continue`` + if exit_code_id == code + handler -- ids are not useful, since + when compiling `largs` we will do the binding there + - when exit_code is undefined internally, + it should PRESERVE ``tail`` property + - if it uses `staticraise` only once + or handler is minimal, we can inline + - always inline also seems to be ok, but it might bloat the code + - another common scenario is that we have nested catch + (catch (catch (catch ..)) + checkout example {!Digest.file}, you can not inline handler there, + we can spot such patten and use finally there? + {[ + let file filename = + let ic = open_in_bin filename in + match channel ic (-1) with + | d -> close_in ic; d + | exception e -> close_in ic; raise e + + ]} + *) + and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = + let code_table, body = flatten_nested_caches lam in + let exit_id = Ext_ident.create_tmp ~name:"exit" () in + match (lambda_cxt.continuation, code_table) with + | ( EffectCall + (Maybe_tail_is_return (Tail_with_name {in_staticcatch = false}) as + tail_type), + [code_table] ) + (* tail position and only one exit code *) + when Lam_compile_context.no_static_raise_in_handler code_table -> let jmp_table, handler = Lam_compile_context.add_pseudo_jmp lambda_cxt.jmp_table exit_id code_table @@ -916,7 +938,7 @@ and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = in Js_output.append_output (Js_output.make declares) (Js_output.append_output lbody (compile_lambda lambda_cxt handler)) - | _ -> ( + | _ -> ( let exit_expr = E.var exit_id in let jmp_table, handlers = Lam_compile_context.add_jmps lambda_cxt.jmp_table exit_id code_table @@ -926,188 +948,182 @@ and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = let declares = S.define_variable ~kind:Variable exit_id E.zero_int_literal :: (* we should always make it zero here, since [zero] is reserved in our mapping*) - Ext_list.flat_map code_table (fun { bindings } -> + Ext_list.flat_map code_table (fun {bindings} -> Ext_list.map bindings (fun x -> S.declare_variable ~kind:Variable x)) in match lambda_cxt.continuation with (* could be optimized when cases are less than 3 *) | NeedValue _ -> - let v = Ext_ident.create_tmp () in - let new_cxt = - { lambda_cxt with jmp_table; continuation = Assign v } - in - let lbody = compile_lambda new_cxt body in - Js_output.append_output - (Js_output.make (S.declare_variable ~kind:Variable v :: declares)) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers) - ~value:(E.var v))) + let v = Ext_ident.create_tmp () in + let new_cxt = {lambda_cxt with jmp_table; continuation = Assign v} in + let lbody = compile_lambda new_cxt body in + Js_output.append_output + (Js_output.make (S.declare_variable ~kind:Variable v :: declares)) + (Js_output.append_output lbody + (Js_output.make + (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers) + ~value:(E.var v))) | Declare (kind, id) (* declare first this we will do branching*) -> - let declares = S.declare_variable ~kind id :: declares in - let new_cxt = - { lambda_cxt with jmp_table; continuation = Assign id } - in - let lbody = compile_lambda new_cxt body in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers))) + let declares = S.declare_variable ~kind id :: declares in + let new_cxt = {lambda_cxt with jmp_table; continuation = Assign id} in + let lbody = compile_lambda new_cxt body in + Js_output.append_output (Js_output.make declares) + (Js_output.append_output lbody + (Js_output.make + (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers))) (* place holder -- tell the compiler that we don't know if it's complete *) | EffectCall tail_type as cont -> - let continuation = - let new_tail_type = in_staticcatch tail_type in - if new_tail_type == tail_type then cont - else EffectCall new_tail_type - in - let new_cxt = { lambda_cxt with jmp_table; continuation } in - let lbody = compile_lambda new_cxt body in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers))) + let continuation = + let new_tail_type = in_staticcatch tail_type in + if new_tail_type == tail_type then cont else EffectCall new_tail_type + in + let new_cxt = {lambda_cxt with jmp_table; continuation} in + let lbody = compile_lambda new_cxt body in + Js_output.append_output (Js_output.make declares) + (Js_output.append_output lbody + (Js_output.make + (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers))) | Assign _ -> - let new_cxt = { lambda_cxt with jmp_table } in - let lbody = compile_lambda new_cxt body in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers)))) - -and compile_sequand (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) - = - if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequand l r) - else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - match compile_lambda new_cxt l with - | { value = None } -> assert false - | { block = l_block; value = Some l_expr } -> ( + let new_cxt = {lambda_cxt with jmp_table} in + let lbody = compile_lambda new_cxt body in + Js_output.append_output (Js_output.make declares) + (Js_output.append_output lbody + (Js_output.make + (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers)))) + and compile_sequand (l : Lam.t) (r : Lam.t) + (lambda_cxt : Lam_compile_context.t) = + if Lam_compile_context.continuation_is_return lambda_cxt.continuation then + compile_lambda lambda_cxt (Lam.sequand l r) + else + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in + match compile_lambda new_cxt l with + | {value = None} -> assert false + | {block = l_block; value = Some l_expr} -> ( match compile_lambda new_cxt r with - | { value = None } -> assert false - | { block = []; value = Some r_expr } -> - Js_output.output_of_block_and_expression lambda_cxt.continuation - l_block (E.and_ l_expr r_expr) - | { block = r_block; value = Some r_expr } -> ( - match lambda_cxt.continuation with - | Assign v -> - (* Refernece Js_output.output_of_block_and_expression *) - Js_output.make - (l_block - @ [ - S.if_ l_expr - (r_block @ [ S.assign v r_expr ]) - ~else_:[ S.assign v E.false_ ]; - ]) - | Declare (_kind, v) -> - (* Refernece Js_output.output_of_block_and_expression *) - Js_output.make - (l_block - @ [ - S.define_variable ~kind:Variable v E.false_; - S.if_ l_expr (r_block @ [ S.assign v r_expr ]); - ]) - | EffectCall _ | NeedValue _ -> - let v = Ext_ident.create_tmp () in - Js_output.make - ((S.define_variable ~kind:Variable v E.false_ :: l_block) - @ [ S.if_ l_expr (r_block @ [ S.assign v r_expr ]) ]) - ~value:(E.var v))) - -and compile_sequor (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) - = - if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequor l r) - else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - match compile_lambda new_cxt l with - | { value = None } -> assert false - | { block = l_block; value = Some l_expr } -> ( + | {value = None} -> assert false + | {block = []; value = Some r_expr} -> + Js_output.output_of_block_and_expression lambda_cxt.continuation + l_block (E.and_ l_expr r_expr) + | {block = r_block; value = Some r_expr} -> ( + match lambda_cxt.continuation with + | Assign v -> + (* Refernece Js_output.output_of_block_and_expression *) + Js_output.make + (l_block + @ [ + S.if_ l_expr + (r_block @ [S.assign v r_expr]) + ~else_:[S.assign v E.false_]; + ]) + | Declare (_kind, v) -> + (* Refernece Js_output.output_of_block_and_expression *) + Js_output.make + (l_block + @ [ + S.define_variable ~kind:Variable v E.false_; + S.if_ l_expr (r_block @ [S.assign v r_expr]); + ]) + | EffectCall _ | NeedValue _ -> + let v = Ext_ident.create_tmp () in + Js_output.make + ((S.define_variable ~kind:Variable v E.false_ :: l_block) + @ [S.if_ l_expr (r_block @ [S.assign v r_expr])]) + ~value:(E.var v))) + and compile_sequor (l : Lam.t) (r : Lam.t) + (lambda_cxt : Lam_compile_context.t) = + if Lam_compile_context.continuation_is_return lambda_cxt.continuation then + compile_lambda lambda_cxt (Lam.sequor l r) + else + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in + match compile_lambda new_cxt l with + | {value = None} -> assert false + | {block = l_block; value = Some l_expr} -> ( match compile_lambda new_cxt r with - | { value = None } -> assert false - | { block = []; value = Some r_expr } -> - let exp = E.or_ l_expr r_expr in - Js_output.output_of_block_and_expression lambda_cxt.continuation - l_block exp - | { block = r_block; value = Some r_expr } -> ( - match lambda_cxt.continuation with - | Assign v -> - (* Reference Js_output.output_of_block_and_expression *) - Js_output.make - (l_block - @ [ - S.if_ (E.not l_expr) - (r_block @ [ S.assign v r_expr ]) - ~else_:[ S.assign v E.true_ ]; - ]) - | Declare (_kind, v) -> - Js_output.make - (l_block - @ [ - S.define_variable ~kind:Variable v E.true_; - S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]); - ]) - | EffectCall _ | NeedValue _ -> - let v = Ext_ident.create_tmp () in - Js_output.make - (l_block - @ [ - S.define_variable ~kind:Variable v E.true_; - S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]); - ]) - ~value:(E.var v))) - -(* Note that ``J.While(expression * statement )`` - idealy if ocaml expression does not need fresh variables, we can generate - while expression, here we generate for statement, leave optimization later. - (Sine OCaml expression can be really complex..) -*) -and compile_while (predicate : Lam.t) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = - match - compile_lambda - { lambda_cxt with continuation = NeedValue Not_tail } - predicate - with - | { value = None } -> assert false - | { block; value = Some e } -> + | {value = None} -> assert false + | {block = []; value = Some r_expr} -> + let exp = E.or_ l_expr r_expr in + Js_output.output_of_block_and_expression lambda_cxt.continuation + l_block exp + | {block = r_block; value = Some r_expr} -> ( + match lambda_cxt.continuation with + | Assign v -> + (* Reference Js_output.output_of_block_and_expression *) + Js_output.make + (l_block + @ [ + S.if_ (E.not l_expr) + (r_block @ [S.assign v r_expr]) + ~else_:[S.assign v E.true_]; + ]) + | Declare (_kind, v) -> + Js_output.make + (l_block + @ [ + S.define_variable ~kind:Variable v E.true_; + S.if_ (E.not l_expr) (r_block @ [S.assign v r_expr]); + ]) + | EffectCall _ | NeedValue _ -> + let v = Ext_ident.create_tmp () in + Js_output.make + (l_block + @ [ + S.define_variable ~kind:Variable v E.true_; + S.if_ (E.not l_expr) (r_block @ [S.assign v r_expr]); + ]) + ~value:(E.var v))) + (* Note that ``J.While(expression * statement )`` + idealy if ocaml expression does not need fresh variables, we can generate + while expression, here we generate for statement, leave optimization later. + (Sine OCaml expression can be really complex..) + *) + and compile_while (predicate : Lam.t) (body : Lam.t) + (lambda_cxt : Lam_compile_context.t) = + match + compile_lambda + {lambda_cxt with continuation = NeedValue Not_tail} + predicate + with + | {value = None} -> assert false + | {block; value = Some e} -> (* st = NeedValue -- this should be optimized and never happen *) - let e = match block with [] -> e | _ -> E.of_block block ~e in + let e = + match block with + | [] -> e + | _ -> E.of_block block ~e + in let block = [ S.while_ e (Js_output.output_as_block @@ compile_lambda - { lambda_cxt with continuation = EffectCall Not_tail } + {lambda_cxt with continuation = EffectCall Not_tail} body); ] in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit + (* all non-tail + TODO: check semantics should start, finish be executed each time in both + ocaml and js?, also check evaluation order.. + in ocaml id is not in the scope of finish, so it should be safe here -(* all non-tail - TODO: check semantics should start, finish be executed each time in both - ocaml and js?, also check evaluation order.. - in ocaml id is not in the scope of finish, so it should be safe here - - for i = 0 to (print_int 3; 10) do print_int i done;; - 3012345678910- : unit = () - - for(var i = 0 ; i < (console.log(i),10); ++i){console.log('hi')} - print i each time, so they are different semantics... -*) + for i = 0 to (print_int 3; 10) do print_int i done;; + 3012345678910- : unit = () -and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) - (direction : Js_op.direction_flag) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - let block = - match (compile_lambda new_cxt start, compile_lambda new_cxt finish) with - | { value = None }, _ | _, { value = None } -> assert false - | { block = b1; value = Some e1 }, { block = b2; value = Some e2 } -> ( + for(var i = 0 ; i < (console.log(i),10); ++i){console.log('hi')} + print i each time, so they are different semantics... + *) + and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) + (direction : Js_op.direction_flag) (body : Lam.t) + (lambda_cxt : Lam_compile_context.t) = + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in + let block = + match (compile_lambda new_cxt start, compile_lambda new_cxt finish) with + | {value = None}, _ | _, {value = None} -> assert false + | {block = b1; value = Some e1}, {block = b2; value = Some e2} -> ( (* order b1 -- (e1 -- b2 -- e2) in most cases we can shift it into such scenarios b1, b2, [e1, e2] @@ -1119,12 +1135,12 @@ and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) let block_body = Js_output.output_as_block (compile_lambda - { lambda_cxt with continuation = EffectCall Not_tail } + {lambda_cxt with continuation = EffectCall Not_tail} body) in match (b1, b2) with | _, [] -> - Ext_list.append_one b1 (S.for_ (Some e1) e2 id direction block_body) + Ext_list.append_one b1 (S.for_ (Some e1) e2 id direction block_body) | _, _ when Js_analyzer.no_side_effect_expression e1 (* @@ -1133,36 +1149,34 @@ and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) b2 > e1 > e2 *) -> - Ext_list.append b1 - (Ext_list.append_one b2 - (S.for_ (Some e1) e2 id direction block_body)) + Ext_list.append b1 + (Ext_list.append_one b2 + (S.for_ (Some e1) e2 id direction block_body)) | _, _ -> - Ext_list.append b1 - (S.define_variable ~kind:Variable id e1 - :: Ext_list.append_one b2 (S.for_ None e2 id direction block_body) - )) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - -and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = - let block = - match lambda with - | Lprim { primitive = Poffsetint v; args = [ Lvar bid ] } - when Ident.same id bid -> - [ S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v))) ] - | _ -> ( + Ext_list.append b1 + (S.define_variable ~kind:Variable id e1 + :: Ext_list.append_one b2 (S.for_ None e2 id direction block_body))) + in + Js_output.output_of_block_and_expression lambda_cxt.continuation block + E.unit + and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = + let block = + match lambda with + | Lprim {primitive = Poffsetint v; args = [Lvar bid]} + when Ident.same id bid -> + [S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v)))] + | _ -> ( match compile_lambda - { lambda_cxt with continuation = NeedValue Not_tail } + {lambda_cxt with continuation = NeedValue Not_tail} lambda with - | { value = None } -> assert false - | { block; value = Some v } -> Ext_list.append_one block (S.assign id v) - ) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - -(* + | {value = None} -> assert false + | {block; value = Some v} -> Ext_list.append_one block (S.assign id v)) + in + Js_output.output_of_block_and_expression lambda_cxt.continuation block + E.unit + (* tail --> should be renamed to `shouldReturn` in most cases ``shouldReturn`` == ``tail``, however, here is not, should return, but it is not a tail call in js @@ -1175,148 +1189,221 @@ and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = } ]} *) -and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) = - let aux (with_context : Lam_compile_context.t) - (body_context : Lam_compile_context.t) = - (* should_return is passed down - #1701, try should prevent tailcall *) - [ - S.try_ - (Js_output.output_as_block (compile_lambda body_context lam)) - ~with_: - (id, Js_output.output_as_block (compile_lambda with_context catch)); - ] - in - match lambda_cxt.continuation with - | Declare (kind, id) -> - let context = { lambda_cxt with continuation = Assign id } in + and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) = + let aux (with_context : Lam_compile_context.t) + (body_context : Lam_compile_context.t) = + (* should_return is passed down + #1701, try should prevent tailcall *) + [ + S.try_ + (Js_output.output_as_block (compile_lambda body_context lam)) + ~with_: + (id, Js_output.output_as_block (compile_lambda with_context catch)); + ] + in + match lambda_cxt.continuation with + | Declare (kind, id) -> + let context = {lambda_cxt with continuation = Assign id} in Js_output.make (S.declare_variable ~kind id :: aux context context) - | Assign _ -> Js_output.make (aux lambda_cxt lambda_cxt) - | NeedValue _ -> + | Assign _ -> Js_output.make (aux lambda_cxt lambda_cxt) + | NeedValue _ -> let v = Ext_ident.create_tmp () in - let context = { lambda_cxt with continuation = Assign v } in + let context = {lambda_cxt with continuation = Assign v} in Js_output.make (S.declare_variable ~kind:Variable v :: aux context context) ~value:(E.var v) - | EffectCall return_type -> + | EffectCall return_type -> let new_return_type = change_tail_type_in_try return_type in if new_return_type == return_type then Js_output.make (aux lambda_cxt lambda_cxt) else Js_output.make (aux lambda_cxt - { lambda_cxt with continuation = EffectCall new_return_type }) - -(* Note that in [Texp_apply] for [%sendcache] the cache might not be used - see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch - [Texp_apply] when [public_send ], args are simply dropped - - reference - [js_of_ocaml] - 1. GETPUBMET - 2. GETDYNMET - 3. GETMETHOD - [ocaml] - Lsend (bytegen.ml) - For the object layout refer to [camlinternalOO/create_object] - {[ - let create_object table = - (* XXX Appel de [obj_block] *) - let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in - (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.methods); - Obj.obj (set_id obj) - - let create_object_opt obj_0 table = - if (Obj.magic obj_0 : bool) then obj_0 else begin + {lambda_cxt with continuation = EffectCall new_return_type}) + (* Note that in [Texp_apply] for [%sendcache] the cache might not be used + see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch + [Texp_apply] when [public_send ], args are simply dropped + + reference + [js_of_ocaml] + 1. GETPUBMET + 2. GETDYNMET + 3. GETMETHOD + [ocaml] + Lsend (bytegen.ml) + For the object layout refer to [camlinternalOO/create_object] + {[ + let create_object table = (* XXX Appel de [obj_block] *) let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) Obj.set_field obj 0 (Obj.repr table.methods); Obj.obj (set_id obj) - end - ]} - it's a block with tag [248], the first field is [table.methods] which is an array - {[ - type table = - { mutable size: int; - mutable methods: closure array; - mutable methods_by_name: meths; - mutable methods_by_label: labs; - mutable previous_states: - (meths * labs * (label * item) list * vars * - label list * string list) list; - mutable hidden_meths: (label * item) list; - mutable vars: vars; - mutable initializers: (obj -> unit) list } - ]} -*) -and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) (f_branch : Lam.t) - (lambda_cxt : Lam_compile_context.t) = - match - compile_lambda - { lambda_cxt with continuation = NeedValue Not_tail } - predicate - with - | { value = None } -> assert false - | { block = b; value = Some e } -> ( + + let create_object_opt obj_0 table = + if (Obj.magic obj_0 : bool) then obj_0 else begin + (* XXX Appel de [obj_block] *) + let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in + (* XXX Appel de [caml_modify] *) + Obj.set_field obj 0 (Obj.repr table.methods); + Obj.obj (set_id obj) + end + ]} + it's a block with tag [248], the first field is [table.methods] which is an array + {[ + type table = + { mutable size: int; + mutable methods: closure array; + mutable methods_by_name: meths; + mutable methods_by_label: labs; + mutable previous_states: + (meths * labs * (label * item) list * vars * + label list * string list) list; + mutable hidden_meths: (label * item) list; + mutable vars: vars; + mutable initializers: (obj -> unit) list } + ]} + *) + and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) + (f_branch : Lam.t) (lambda_cxt : Lam_compile_context.t) = + match + compile_lambda + {lambda_cxt with continuation = NeedValue Not_tail} + predicate + with + | {value = None} -> assert false + | {block = b; value = Some e} -> ( match lambda_cxt.continuation with | NeedValue _ -> ( + match + ( compile_lambda lambda_cxt t_branch, + compile_lambda lambda_cxt f_branch ) + with + | {block = []; value = Some out1}, {block = []; value = Some out2} -> + (* speical optimization *) + Js_output.make b ~value:(E.econd e out1 out2) + | _, _ -> ( + (* we can not reuse -- here we need they have the same name, + TODO: could be optimized by inspecting assigment statement *) + let id = Ext_ident.create_tmp () in + let assign_cxt = {lambda_cxt with continuation = Assign id} in match - ( compile_lambda lambda_cxt t_branch, - compile_lambda lambda_cxt f_branch ) + ( compile_lambda assign_cxt t_branch, + compile_lambda assign_cxt f_branch ) with - | { block = []; value = Some out1 }, { block = []; value = Some out2 } - -> - (* speical optimization *) - Js_output.make b ~value:(E.econd e out1 out2) - | _, _ -> ( - (* we can not reuse -- here we need they have the same name, - TODO: could be optimized by inspecting assigment statement *) - let id = Ext_ident.create_tmp () in - let assign_cxt = { lambda_cxt with continuation = Assign id } in - match - ( compile_lambda assign_cxt t_branch, - compile_lambda assign_cxt f_branch ) - with - | out1, out2 -> - Js_output.make - (Ext_list.append - (S.declare_variable ~kind:Variable id :: b) - [ - S.if_ e - (Js_output.output_as_block out1) - ~else_:(Js_output.output_as_block out2); - ]) - ~value:(E.var id))) + | out1, out2 -> + Js_output.make + (Ext_list.append + (S.declare_variable ~kind:Variable id :: b) + [ + S.if_ e + (Js_output.output_as_block out1) + ~else_:(Js_output.output_as_block out2); + ]) + ~value:(E.var id))) | Declare (kind, id) -> ( - let declare_cxt = - { lambda_cxt with continuation = NeedValue Not_tail } - in + let declare_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in + match + ( compile_lambda declare_cxt t_branch, + compile_lambda declare_cxt f_branch ) + with + | {block = []; value = Some out1}, {block = []; value = Some out2} -> + (* Invariant: should_return is false*) + Js_output.make + (Ext_list.append_one b + (S.define_variable ~kind id (E.econd e out1 out2))) + | _, _ -> + Js_output.make + (Ext_list.append_one b + (S.if_ ~declaration:(kind, id) e + (Js_output.output_as_block + @@ compile_lambda + {lambda_cxt with continuation = Assign id} + t_branch) + ~else_: + (Js_output.output_as_block + @@ compile_lambda + {lambda_cxt with continuation = Assign id} + f_branch)))) + | Assign _ -> + let then_output = + Js_output.output_as_block (compile_lambda lambda_cxt t_branch) + in + let else_output = + Js_output.output_as_block (compile_lambda lambda_cxt f_branch) + in + Js_output.make + (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)) + | EffectCall should_return -> ( + let context1 = + {lambda_cxt with continuation = NeedValue should_return} + in + match + ( should_return, + compile_lambda context1 t_branch, + compile_lambda context1 f_branch ) + with + (* see PR#83 *) + | ( Not_tail, + {block = []; value = Some out1}, + {block = []; value = Some out2} ) -> ( match - ( compile_lambda declare_cxt t_branch, - compile_lambda declare_cxt f_branch ) + ( Js_exp_make.remove_pure_sub_exp out1, + Js_exp_make.remove_pure_sub_exp out2 ) with - | { block = []; value = Some out1 }, { block = []; value = Some out2 } - -> - (* Invariant: should_return is false*) - Js_output.make - (Ext_list.append_one b - (S.define_variable ~kind id (E.econd e out1 out2))) - | _, _ -> - Js_output.make - (Ext_list.append_one b - (S.if_ ~declaration:(kind, id) e - (Js_output.output_as_block - @@ compile_lambda - { lambda_cxt with continuation = Assign id } - t_branch) - ~else_: - (Js_output.output_as_block - @@ compile_lambda - { lambda_cxt with continuation = Assign id } - f_branch)))) - | Assign _ -> + | None, None -> Js_output.make (Ext_list.append_one b (S.exp e)) + (* FIX #1762 *) + | Some out1, Some out2 -> + Js_output.make b ~value:(E.econd e out1 out2) + | Some out1, None -> + Js_output.make (Ext_list.append_one b (S.if_ e [S.exp out1])) + | None, Some out2 -> + Js_output.make + (Ext_list.append_one b (S.if_ (E.not e) [S.exp out2]))) + | Not_tail, {block = []; value = Some out1}, _ -> + (* assert branch + TODO: here we re-compile two branches since + its context is different -- could be improved + *) + if Js_analyzer.no_side_effect_expression out1 then + Js_output.make + (Ext_list.append b + [ + S.if_ (E.not e) + (Js_output.output_as_block + @@ compile_lambda lambda_cxt f_branch); + ]) + else + Js_output.make + (Ext_list.append b + [ + S.if_ e + (Js_output.output_as_block + @@ compile_lambda lambda_cxt t_branch) + ~else_: + (Js_output.output_as_block + @@ compile_lambda lambda_cxt f_branch); + ]) + | Not_tail, _, {block = []; value = Some out2} -> + let else_ = + if Js_analyzer.no_side_effect_expression out2 then None + else + Some + (Js_output.output_as_block (compile_lambda lambda_cxt f_branch)) + in + Js_output.make + (Ext_list.append_one b + (S.if_ e + (Js_output.output_as_block + (compile_lambda lambda_cxt t_branch)) + ?else_)) + | ( Maybe_tail_is_return _, + {block = []; value = Some out1}, + {block = []; value = Some out2} ) -> + Js_output.make + (Ext_list.append_one b (S.return_stmt (E.econd e out1 out2))) + ~output_finished:True + | _, _, _ -> let then_output = Js_output.output_as_block (compile_lambda lambda_cxt t_branch) in @@ -1324,142 +1411,64 @@ and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) (f_branch : Lam.t) Js_output.output_as_block (compile_lambda lambda_cxt f_branch) in Js_output.make - (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)) - | EffectCall should_return -> ( - let context1 = - { lambda_cxt with continuation = NeedValue should_return } - in - match - ( should_return, - compile_lambda context1 t_branch, - compile_lambda context1 f_branch ) - with - (* see PR#83 *) - | ( Not_tail, - { block = []; value = Some out1 }, - { block = []; value = Some out2 } ) -> ( - match - ( Js_exp_make.remove_pure_sub_exp out1, - Js_exp_make.remove_pure_sub_exp out2 ) - with - | None, None -> Js_output.make (Ext_list.append_one b (S.exp e)) - (* FIX #1762 *) - | Some out1, Some out2 -> - Js_output.make b ~value:(E.econd e out1 out2) - | Some out1, None -> - Js_output.make - (Ext_list.append_one b (S.if_ e [ S.exp out1 ])) - | None, Some out2 -> - Js_output.make - (Ext_list.append_one b (S.if_ (E.not e) [ S.exp out2 ]))) - | Not_tail, { block = []; value = Some out1 }, _ -> - (* assert branch - TODO: here we re-compile two branches since - its context is different -- could be improved - *) - if Js_analyzer.no_side_effect_expression out1 then - Js_output.make - (Ext_list.append b - [ - S.if_ (E.not e) - (Js_output.output_as_block - @@ compile_lambda lambda_cxt f_branch); - ]) - else - Js_output.make - (Ext_list.append b - [ - S.if_ e - (Js_output.output_as_block - @@ compile_lambda lambda_cxt t_branch) - ~else_: - (Js_output.output_as_block - @@ compile_lambda lambda_cxt f_branch); - ]) - | Not_tail, _, { block = []; value = Some out2 } -> - let else_ = - if Js_analyzer.no_side_effect_expression out2 then None - else - Some - (Js_output.output_as_block - (compile_lambda lambda_cxt f_branch)) - in - Js_output.make - (Ext_list.append_one b - (S.if_ e - (Js_output.output_as_block - (compile_lambda lambda_cxt t_branch)) - ?else_)) - | ( Maybe_tail_is_return _, - { block = []; value = Some out1 }, - { block = []; value = Some out2 } ) -> - Js_output.make - (Ext_list.append_one b (S.return_stmt (E.econd e out1 out2))) - ~output_finished:True - | _, _, _ -> - let then_output = - Js_output.output_as_block (compile_lambda lambda_cxt t_branch) - in - let else_output = - Js_output.output_as_block (compile_lambda lambda_cxt f_branch) - in - Js_output.make - (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)) - )) - -and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = - match appinfo with - | { - ap_func = - Lapply { ap_func; ap_args; ap_info = { ap_status = App_na; ap_inlined } }; - ap_info = { ap_status = App_na } as outer_ap_info; - } -> + (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)))) + and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = + match appinfo with + | { + ap_func = + Lapply {ap_func; ap_args; ap_info = {ap_status = App_na; ap_inlined}}; + ap_info = {ap_status = App_na} as outer_ap_info; + } -> (* After inlining, we can generate such code, see {!Ari_regress_test}*) let ap_info = if outer_ap_info.ap_inlined = ap_inlined then outer_ap_info - else { outer_ap_info with ap_inlined } + else {outer_ap_info with ap_inlined} in compile_lambda lambda_cxt (Lam.apply ap_func (Ext_list.append ap_args appinfo.ap_args) ap_info) - (* External function call: it can not be tailcall in this case*) - | { - ap_func = - Lprim { primitive = Pfield (_, fld_info); args = [ Lglobal_module (id, dynamic_import) ]; _ }; - } -> ( + (* External function call: it can not be tailcall in this case*) + | { + ap_func = + Lprim + { + primitive = Pfield (_, fld_info); + args = [Lglobal_module (id, dynamic_import)]; + _; + }; + } -> ( match fld_info with - | Fld_module { name } -> - compile_external_field_apply ~dynamic_import appinfo id name lambda_cxt + | Fld_module {name} -> + compile_external_field_apply ~dynamic_import appinfo id name lambda_cxt | _ -> assert false) - | _ -> ( + | _ -> ( (* TODO: --- 1. check arity, can be simplified for pure expression 2. no need create names *) let ap_func = appinfo.ap_func in - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let[@warning "-8" (* non-exhaustive pattern*)] args_code, fn_code :: args = Ext_list.fold_right (ap_func :: appinfo.ap_args) ([], []) (fun x (args_code, fn_code) -> match compile_lambda new_cxt x with - | { block; value = Some b } -> - (Ext_list.append block args_code, b :: fn_code) - | { value = None } -> assert false) + | {block; value = Some b} -> + (Ext_list.append block args_code, b :: fn_code) + | {value = None} -> assert false) in match (ap_func, lambda_cxt.continuation) with | ( Lvar fn_id, - ( EffectCall - (Maybe_tail_is_return (Tail_with_name { label = Some ret })) - | NeedValue - (Maybe_tail_is_return (Tail_with_name { label = Some ret })) ) ) + ( EffectCall (Maybe_tail_is_return (Tail_with_name {label = Some ret})) + | NeedValue (Maybe_tail_is_return (Tail_with_name {label = Some ret})) + ) ) when Ident.same ret.id fn_id -> - ret.triggered <- true; - (* Here we mark [finished] true, since the continuation - does not make sense any more (due to that we have [continue]) - TODO: [finished] is not a meaningful name, we should use [truncate] - to mean the following statement should be truncated - *) - (* + ret.triggered <- true; + (* Here we mark [finished] true, since the continuation + does not make sense any more (due to that we have [continue]) + TODO: [finished] is not a meaningful name, we should use [truncate] + to mean the following statement should be truncated + *) + (* actually, there is no easy way to determin if the argument depends on an expresion, since it can be a function, then it may depend on anything @@ -1467,66 +1476,68 @@ and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/fe9bc4e23e6dc8c932c8ab34240ff195.en.html *) - (* TODO: use [fold]*) - let _, assigned_params, new_params = - let args = if ret.params = [] then [] else args in - Ext_list.fold_left2 ret.params args (0, [], Map_ident.empty) - (fun param arg (i, assigns, new_params) -> - match arg with - | { expression_desc = Var (Id x); _ } when Ident.same x param -> - (i + 1, assigns, new_params) - | _ -> - let new_param, m = - match Map_ident.find_opt ret.new_params param with - | None -> - ret.immutable_mask.(i) <- false; - let v = Ext_ident.create ("_" ^ param.name) in - (v, Map_ident.add new_params param v) - | Some v -> (v, new_params) - in - (i + 1, (new_param, arg) :: assigns, m)) - in - ret.new_params <- - Map_ident.disjoint_merge_exn new_params ret.new_params (fun _ _ _ -> - assert false); - let block = - Ext_list.map_append assigned_params [ S.continue_ ] - (fun (param, arg) -> S.assign param arg) - in - (* Note true and continue needed to be handled together*) - Js_output.make ~output_finished:True (Ext_list.append args_code block) + (* TODO: use [fold]*) + let _, assigned_params, new_params = + let args = if ret.params = [] then [] else args in + Ext_list.fold_left2 ret.params args (0, [], Map_ident.empty) + (fun param arg (i, assigns, new_params) -> + match arg with + | {expression_desc = Var (Id x); _} when Ident.same x param -> + (i + 1, assigns, new_params) + | _ -> + let new_param, m = + match Map_ident.find_opt ret.new_params param with + | None -> + ret.immutable_mask.(i) <- false; + let v = Ext_ident.create ("_" ^ param.name) in + (v, Map_ident.add new_params param v) + | Some v -> (v, new_params) + in + (i + 1, (new_param, arg) :: assigns, m)) + in + ret.new_params <- + Map_ident.disjoint_merge_exn new_params ret.new_params (fun _ _ _ -> + assert false); + let block = + Ext_list.map_append assigned_params [S.continue_] (fun (param, arg) -> + S.assign param arg) + in + (* Note true and continue needed to be handled together*) + Js_output.make ~output_finished:True (Ext_list.append args_code block) | _ -> - Js_output.output_of_block_and_expression lambda_cxt.continuation - args_code - (E.call - ~info:(call_info_of_ap_status appinfo.ap_info.ap_status) - fn_code args)) - -and compile_prim (prim_info : Lam.prim_info) - (lambda_cxt : Lam_compile_context.t) = - match prim_info with - | { primitive = Pfield (_, fld_info); args = [ Lglobal_module (id, dynamic_import) ]; _ } -> ( + Js_output.output_of_block_and_expression lambda_cxt.continuation + args_code + (E.call + ~info:(call_info_of_ap_status appinfo.ap_info.ap_status) + fn_code args)) + and compile_prim (prim_info : Lam.prim_info) + (lambda_cxt : Lam_compile_context.t) = + match prim_info with + | { + primitive = Pfield (_, fld_info); + args = [Lglobal_module (id, dynamic_import)]; + _; + } -> ( (* should be before Lglobal_global *) match fld_info with - | Fld_module { name = field } -> - compile_external_field ~dynamic_import lambda_cxt id field + | Fld_module {name = field} -> + compile_external_field ~dynamic_import lambda_cxt id field | _ -> assert false) - | { primitive = Praise; args = [ e ]; _ } -> ( + | {primitive = Praise; args = [e]; _} -> ( match - compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } e + compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} e with - | { block; value = Some v } -> - Js_output.make - (Ext_list.append_one block (S.throw_stmt v)) - ~value:E.undefined ~output_finished:True + | {block; value = Some v} -> + Js_output.make + (Ext_list.append_one block (S.throw_stmt v)) + ~value:E.undefined ~output_finished:True (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement while ocaml it's an expression, we should remove such things in lambda optimizations *) - | { value = None } -> assert false) - | { primitive = Psequand; args = [ l; r ]; _ } -> - compile_sequand l r lambda_cxt - | { primitive = Psequor; args = [ l; r ] } -> compile_sequor l r lambda_cxt - | { primitive = Pdebugger; _ } -> + | {value = None} -> assert false) + | {primitive = Psequand; args = [l; r]; _} -> compile_sequand l r lambda_cxt + | {primitive = Psequor; args = [l; r]} -> compile_sequor l r lambda_cxt + | {primitive = Pdebugger; _} -> (* [%debugger] guarantees that the expression does not matter TODO: make it even safer *) Js_output.output_of_block_and_expression lambda_cxt.continuation @@ -1535,31 +1546,33 @@ and compile_prim (prim_info : Lam.prim_info) check the arity of fn before wrapping it we need mark something that such eta-conversion can not be simplified in some cases *) - | { primitive = Pjs_unsafe_downgrade { name = property; setter=false }; - args = [ obj ]; + | { + primitive = Pjs_unsafe_downgrade {name = property; setter = false}; + args = [obj]; } -> ( (* getter {[ x #. height ]} *) match - compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } obj + compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} obj with - | { value = None } -> assert false - | { block; value = Some b } -> - let blocks, ret = - if block = [] then ([], E.dot b property) - else - match Js_ast_util.named_expression b with - | None -> (block, E.dot b property) - | Some (x, b) -> - (Ext_list.append_one block x, E.dot (E.var b) property) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation - blocks ret) - | { primitive = Pjs_unsafe_downgrade { name = property; setter = true }; - args = [ obj; setter_val ]; - } -> ( + | {value = None} -> assert false + | {block; value = Some b} -> + let blocks, ret = + if block = [] then ([], E.dot b property) + else + match Js_ast_util.named_expression b with + | None -> (block, E.dot b property) + | Some (x, b) -> + (Ext_list.append_one block x, E.dot (E.var b) property) + in + Js_output.output_of_block_and_expression lambda_cxt.continuation blocks + ret) + | { + primitive = Pjs_unsafe_downgrade {name = property; setter = true}; + args = [obj; setter_val]; + } -> ( (* setter {[ x ## method_call ]} *) let need_value_no_return_cxt = - { lambda_cxt with continuation = NeedValue Not_tail } + {lambda_cxt with continuation = NeedValue Not_tail} in let obj_output = compile_lambda need_value_no_return_cxt obj in let arg_output = compile_lambda need_value_no_return_cxt setter_val in @@ -1570,54 +1583,53 @@ and compile_prim (prim_info : Lam.prim_info) | Some obj_code -> Ext_list.append obj_block (obj_code :: arg_block)) in match (obj_output, arg_output) with - | { value = None }, _ | _, { value = None } -> assert false - | ( { block = obj_block; value = Some obj }, - { block = arg_block; value = Some value } ) -> ( - match Js_ast_util.named_expression obj with - | None -> - cont obj_block arg_block None - (E.seq (E.assign (E.dot obj property) value) E.unit) - | Some (obj_code, obj) -> - cont obj_block arg_block (Some obj_code) - (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit))) - | { primitive = Pjs_unsafe_downgrade _; args } -> - assert false - | { primitive = Pjs_fn_method; args = args_lambda } -> ( + | {value = None}, _ | _, {value = None} -> assert false + | ( {block = obj_block; value = Some obj}, + {block = arg_block; value = Some value} ) -> ( + match Js_ast_util.named_expression obj with + | None -> + cont obj_block arg_block None + (E.seq (E.assign (E.dot obj property) value) E.unit) + | Some (obj_code, obj) -> + cont obj_block arg_block (Some obj_code) + (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit))) + | {primitive = Pjs_unsafe_downgrade _; args} -> assert false + | {primitive = Pjs_fn_method; args = args_lambda} -> ( match args_lambda with - | [ Lfunction { params; body; attr = { return_unit } } ] -> - Js_output.output_of_block_and_expression lambda_cxt.continuation [] - (E.method_ params ~return_unit - (* Invariant: jmp_table can not across function boundary, - here we share env - *) - (Js_output.output_as_block - (compile_lambda - { - lambda_cxt with - continuation = - EffectCall - (Maybe_tail_is_return - (Tail_with_name - { label = None; in_staticcatch = false })); - jmp_table = Lam_compile_context.empty_handler_map; - } - body))) + | [Lfunction {params; body; attr = {return_unit}}] -> + Js_output.output_of_block_and_expression lambda_cxt.continuation [] + (E.method_ params ~return_unit + (* Invariant: jmp_table can not across function boundary, + here we share env + *) + (Js_output.output_as_block + (compile_lambda + { + lambda_cxt with + continuation = + EffectCall + (Maybe_tail_is_return + (Tail_with_name + {label = None; in_staticcatch = false})); + jmp_table = Lam_compile_context.empty_handler_map; + } + body))) | _ -> assert false) - | { primitive = Pjs_fn_make arity; args = [ fn ]; loc } -> + | {primitive = Pjs_fn_make arity; args = [fn]; loc} -> compile_lambda lambda_cxt (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn) - | { primitive = Pjs_fn_make_unit; args = [ fn ]; loc } -> - compile_lambda lambda_cxt fn - | { primitive = Pjs_fn_make _; args = [] | _ :: _ :: _ } -> assert false - | { primitive = Pjs_object_create labels; args } -> + | {primitive = Pjs_fn_make_unit; args = [fn]; loc} -> + compile_lambda lambda_cxt fn + | {primitive = Pjs_fn_make _; args = [] | _ :: _ :: _} -> assert false + | {primitive = Pjs_object_create labels; args} -> let args_block, args_expr = if args = [] then ([], []) else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in Ext_list.split_map args (fun x -> match compile_lambda new_cxt x with - | { block; value = Some b } -> (block, b) - | { value = None } -> assert false) + | {block; value = Some b} -> (block, b) + | {value = None} -> assert false) in let block, exp = Lam_compile_external_obj.assemble_obj_args labels args_expr @@ -1625,82 +1637,83 @@ and compile_prim (prim_info : Lam.prim_info) Js_output.output_of_block_and_expression lambda_cxt.continuation (Ext_list.concat_append args_block block) exp - | { primitive = Pimport; args = [] | _ :: _ :: _; loc } -> - Location.raise_errorf ~loc - "Missing argument: Dynamic import requires a module or \ - module value that is a file as argument." - | { primitive = Pimport as primitive; args = [ mod_ ]; loc} -> - (match mod_ with - | Lglobal_module _ | Lvar _ - | Lprim { primitive = Pfield _ | Pjs_call _ ; _ } -> + | {primitive = Pimport; args = [] | _ :: _ :: _; loc} -> + Location.raise_errorf ~loc + "Missing argument: Dynamic import requires a module or module value \ + that is a file as argument." + | {primitive = Pimport as primitive; args = [mod_]; loc} -> ( + match mod_ with + | Lglobal_module _ | Lvar _ | Lprim {primitive = Pfield _ | Pjs_call _; _} + -> let args_block, args_expr = - let new_cxt = - { lambda_cxt with continuation = NeedValue Not_tail } - in + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in match compile_lambda new_cxt mod_ with - | { block; value = Some b; _ } -> ([ block ], b) - | { value = None; _ } -> assert false + | {block; value = Some b; _} -> ([block], b) + | {value = None; _} -> assert false in let args_code : J.block = List.concat args_block in let exp = - Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive [args_expr] + Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive + [args_expr] in - Js_output.output_of_block_and_expression lambda_cxt.continuation args_code - exp - | Lfunction { - body = - ( (Lprim _ as body) - | Lsequence ((Lprim _ as body), Lconst Const_js_undefined _) ); - _; - } -> - let body = match body with - | Lprim ({ primitive = Pjs_call prim_info; args; loc }) -> - Lam.prim - ~primitive:(Lam_primitive.Pjs_call { prim_info with dynamic_import = true }) - ~args - loc + Js_output.output_of_block_and_expression lambda_cxt.continuation + args_code exp + | Lfunction + { + body = + ( (Lprim _ as body) + | Lsequence ((Lprim _ as body), Lconst (Const_js_undefined _)) ); + _; + } -> + let body = + match body with + | Lprim {primitive = Pjs_call prim_info; args; loc} -> + Lam.prim + ~primitive: + (Lam_primitive.Pjs_call {prim_info with dynamic_import = true}) + ~args loc | _ -> body in let args_block, args_expr = - let new_cxt = - { lambda_cxt with continuation = NeedValue Not_tail } - in + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in match compile_lambda new_cxt body with - | { block; value = Some b; _ } -> ([ block ], b) - | { value = None; _ } -> assert false + | {block; value = Some b; _} -> ([block], b) + | {value = None; _} -> assert false in let args_code : J.block = List.concat args_block in let exp = - Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive [args_expr] + Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive + [args_expr] in - Js_output.output_of_block_and_expression lambda_cxt.continuation args_code - exp + Js_output.output_of_block_and_expression lambda_cxt.continuation + args_code exp | _ -> Location.raise_errorf ~loc - "Invalid argument: unsupported argument to dynamic import. If \ - you believe this should be supported, please open an issue.") - | { primitive; args; loc } -> + "Invalid argument: unsupported argument to dynamic import. If you \ + believe this should be supported, please open an issue.") + | {primitive; args; loc} -> let args_block, args_expr = if args = [] then ([], []) else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in + let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in Ext_list.split_map args (fun x -> match compile_lambda new_cxt x with - | { block; value = Some b } -> (block, b) - | { value = None } -> assert false) + | {block; value = Some b} -> (block, b) + | {value = None} -> assert false) in let args_code : J.block = List.concat args_block in let exp = (* TODO: all can be done in [compile_primitive] *) - Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive args_expr + Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive + args_expr in Js_output.output_of_block_and_expression lambda_cxt.continuation args_code exp - -and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : - Js_output.t = - match cur_lam with - | Lfunction { params; body; attr = { return_unit; async; one_unit_arg; directive } } -> + and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : + Js_output.t = + match cur_lam with + | Lfunction + {params; body; attr = {return_unit; async; one_unit_arg; directive}} -> Js_output.output_of_expression lambda_cxt.continuation ~no_effects:no_effects_const (E.ocaml_fun params ~return_unit ~async ~one_unit_arg ?directive @@ -1714,21 +1727,20 @@ and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : continuation = EffectCall (Maybe_tail_is_return - (Tail_with_name - { label = None; in_staticcatch = false })); + (Tail_with_name {label = None; in_staticcatch = false})); jmp_table = Lam_compile_context.empty_handler_map; } body))) - | Lapply appinfo -> compile_apply appinfo lambda_cxt - | Llet (let_kind, id, arg, body) -> + | Lapply appinfo -> compile_apply appinfo lambda_cxt + | Llet (let_kind, id, arg, body) -> (* Order matters.. see comment below in [Lletrec] *) let args_code = compile_lambda - { lambda_cxt with continuation = Declare (let_kind, id) } + {lambda_cxt with continuation = Declare (let_kind, id)} arg in Js_output.append_output args_code (compile_lambda lambda_cxt body) - | Lletrec (id_args, body) -> + | Lletrec (id_args, body) -> (* There is a bug in our current design, it requires compile args first (register that some objects are jsidentifiers) and compile body wiht such effect. @@ -1742,55 +1754,56 @@ and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : *) let v = compile_recursive_lets lambda_cxt id_args in Js_output.append_output v (compile_lambda lambda_cxt body) - | Lvar id -> + | Lvar id -> Js_output.output_of_expression lambda_cxt.continuation ~no_effects:no_effects_const (E.var id) - | Lconst c -> + | Lconst c -> Js_output.output_of_expression lambda_cxt.continuation ~no_effects:no_effects_const (Lam_compile_const.translate c) - | Lglobal_module (i, dynamic_import) -> + | Lglobal_module (i, dynamic_import) -> (* introduced by 1. {[ include Array --> let include = Array ]} 2. inline functor application *) Js_output.output_of_block_and_expression lambda_cxt.continuation [] (E.ml_module_as_var ~dynamic_import i) - | Lprim prim_info -> compile_prim prim_info lambda_cxt - | Lsequence (l1, l2) -> + | Lprim prim_info -> compile_prim prim_info lambda_cxt + | Lsequence (l1, l2) -> let output_l1 = - compile_lambda { lambda_cxt with continuation = EffectCall Not_tail } l1 + compile_lambda {lambda_cxt with continuation = EffectCall Not_tail} l1 in let output_l2 = compile_lambda lambda_cxt l2 in Js_output.append_output output_l1 output_l2 - | Lifthenelse (predicate, t_branch, f_branch) -> + | Lifthenelse (predicate, t_branch, f_branch) -> compile_ifthenelse predicate t_branch f_branch lambda_cxt - | Lstringswitch (l, cases, default) -> + | Lstringswitch (l, cases, default) -> compile_stringswitch l cases default lambda_cxt - | Lswitch (switch_arg, sw) -> compile_switch switch_arg sw lambda_cxt - | Lstaticraise (i, largs) -> compile_staticraise i largs lambda_cxt - | Lstaticcatch _ -> compile_staticcatch cur_lam lambda_cxt - | Lwhile (p, body) -> compile_while p body lambda_cxt - | Lfor (id, start, finish, direction, body) -> ( + | Lswitch (switch_arg, sw) -> compile_switch switch_arg sw lambda_cxt + | Lstaticraise (i, largs) -> compile_staticraise i largs lambda_cxt + | Lstaticcatch _ -> compile_staticcatch cur_lam lambda_cxt + | Lwhile (p, body) -> compile_while p body lambda_cxt + | Lfor (id, start, finish, direction, body) -> ( match (direction, finish) with | ( Upto, ( Lprim { primitive = Psubint; - args = [ new_finish; Lconst (Const_int { i = 1l }) ]; + args = [new_finish; Lconst (Const_int {i = 1l})]; } - | Lprim { primitive = Poffsetint -1; args = [ new_finish ] } ) ) -> - compile_for id start new_finish Up body lambda_cxt + | Lprim {primitive = Poffsetint -1; args = [new_finish]} ) ) -> + compile_for id start new_finish Up body lambda_cxt | _ -> - compile_for id start finish - (if direction = Upto then Upto else Downto) - body lambda_cxt) - | Lassign (id, lambda) -> compile_assign id lambda lambda_cxt - | Ltrywith (lam, id, catch) -> + compile_for id start finish + (if direction = Upto then Upto else Downto) + body lambda_cxt) + | Lassign (id, lambda) -> compile_assign id lambda lambda_cxt + | Ltrywith (lam, id, catch) -> (* generate documentation *) compile_trywith lam id catch lambda_cxt + in -in compile_recursive_lets, compile_lambda + (compile_recursive_lets, compile_lambda) let compile_recursive_lets ~output_prefix = fst (compile output_prefix) let compile_lambda ~output_prefix = snd (compile output_prefix) diff --git a/compiler/core/lam_compile.mli b/compiler/core/lam_compile.mli index f3d00c621a..d5ed77b404 100644 --- a/compiler/core/lam_compile.mli +++ b/compiler/core/lam_compile.mli @@ -25,6 +25,10 @@ (** Compile single lambda IR to JS IR *) val compile_recursive_lets : - output_prefix:string -> Lam_compile_context.t -> (Ident.t * Lam.t) list -> Js_output.t + output_prefix:string -> + Lam_compile_context.t -> + (Ident.t * Lam.t) list -> + Js_output.t -val compile_lambda : output_prefix:string -> Lam_compile_context.t -> Lam.t -> Js_output.t +val compile_lambda : + output_prefix:string -> Lam_compile_context.t -> Lam.t -> Js_output.t diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index 1449eeecb8..58603472dd 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -37,7 +37,9 @@ let rec nested_some_none n none = let rec translate_some (x : Lam_constant.t) : J.expression = let depth = is_some_none_aux x 0 in if depth < 0 then E.optional_not_nest_block (translate x) - else nested_some_none depth (E.optional_block (translate (Const_js_undefined {is_unit = false}))) + else + nested_some_none depth + (E.optional_block (translate (Const_js_undefined {is_unit = false}))) and translate (x : Lam_constant.t) : J.expression = match x with @@ -48,21 +50,23 @@ and translate (x : Lam_constant.t) : J.expression = | Const_js_null -> E.nil | Const_js_undefined {is_unit = true} -> E.unit | Const_js_undefined {is_unit = false} -> E.undefined - | Const_int { i; comment = Pt_constructor {cstr_name={name; tag_type=None}}} when name <> "[]" -> - E.str name - | Const_int { i; comment = Pt_constructor {cstr_name={tag_type = Some t}}} -> - E.tag_type t - | Const_int { i; comment } -> - E.int i ?comment:(Lam_constant.string_of_pointer_info comment) + | Const_int + {i; comment = Pt_constructor {cstr_name = {name; tag_type = None}}} + when name <> "[]" -> + E.str name + | Const_int {i; comment = Pt_constructor {cstr_name = {tag_type = Some t}}} -> + E.tag_type t + | Const_int {i; comment} -> + E.int i ?comment:(Lam_constant.string_of_pointer_info comment) | Const_char i -> Js_of_lam_string.const_char i | Const_bigint (sign, i) -> E.bigint sign i | Const_float f -> E.float f (* TODO: preserve float *) - | Const_string { s; unicode = false } -> E.str s - | Const_string { s; unicode = true } -> E.str ~delim:DStarJ s + | Const_string {s; unicode = false} -> E.str s + | Const_string {s; unicode = true} -> E.str ~delim:DStarJ s | Const_pointer name -> E.str name | Const_block (tag, tag_info, xs) -> - Js_of_lam_block.make_block NA tag_info (E.small_int tag) - (Ext_list.map xs translate) + Js_of_lam_block.make_block NA tag_info (E.small_int tag) + (Ext_list.map xs translate) (* E.arr Mutable ~comment:"float array" *) (* (Ext_list.map (fun x -> E.float x ) ars) *) diff --git a/compiler/core/lam_compile_context.ml b/compiler/core/lam_compile_context.ml index b831abecf4..606bae315c 100644 --- a/compiler/core/lam_compile_context.ml +++ b/compiler/core/lam_compile_context.ml @@ -26,20 +26,20 @@ type jbl_label = int module HandlerMap = Map_int -type value = { exit_id : Ident.t; bindings : Ident.t list; order_id : int } +type value = {exit_id: Ident.t; bindings: Ident.t list; order_id: int} (* delegate to the callee to generate expression Invariant: [output] should return a trailing expression *) type return_label = { - id : Ident.t; - params : Ident.t list; - immutable_mask : bool array; - mutable new_params : Ident.t Map_ident.t; - mutable triggered : bool; + id: Ident.t; + params: Ident.t list; + immutable_mask: bool array; + mutable new_params: Ident.t Map_ident.t; + mutable triggered: bool; } -type tail = { label : return_label option; in_staticcatch : bool } +type tail = {label: return_label option; in_staticcatch: bool} type maybe_tail = Tail_in_try | Tail_with_name of tail @@ -68,18 +68,14 @@ type jmp_table = value HandlerMap.t let continuation_is_return (x : continuation) = match x with | EffectCall (Maybe_tail_is_return _) | NeedValue (Maybe_tail_is_return _) -> - true + true | EffectCall Not_tail | NeedValue Not_tail | Declare _ | Assign _ -> false -type t = { - continuation : continuation; - jmp_table : jmp_table; - meta : Lam_stats.t; -} +type t = {continuation: continuation; jmp_table: jmp_table; meta: Lam_stats.t} let empty_handler_map = HandlerMap.empty -type handler = { label : jbl_label; handler : Lam.t; bindings : Ident.t list } +type handler = {label: jbl_label; handler: Lam.t; bindings: Ident.t list} let no_static_raise_in_handler (x : handler) : bool = not (Lam_exit_code.has_exit_code x.handler (fun _code -> true)) @@ -95,8 +91,8 @@ let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : let map, handlers = Ext_list.fold_left_with_offset code_table (m, []) (HandlerMap.cardinal m + 1) - (fun { label; handler; bindings } (acc, handlers) order_id -> - ( HandlerMap.add acc label { exit_id; bindings; order_id }, + (fun {label; handler; bindings} (acc, handlers) order_id -> + ( HandlerMap.add acc label {exit_id; bindings; order_id}, (order_id, handler) :: handlers )) in (map, List.rev handlers) @@ -105,7 +101,7 @@ let add_pseudo_jmp (m : jmp_table) (exit_id : Ident.t) (* TODO not needed, remove it later *) (code_table : handler) : jmp_table * Lam.t = ( HandlerMap.add m code_table.label - { exit_id; bindings = code_table.bindings; order_id = -1 }, + {exit_id; bindings = code_table.bindings; order_id = -1}, code_table.handler ) let find_exn cxt i = Map_int.find_exn cxt.jmp_table i diff --git a/compiler/core/lam_compile_context.mli b/compiler/core/lam_compile_context.mli index 0a848ffa2c..d16905f800 100644 --- a/compiler/core/lam_compile_context.mli +++ b/compiler/core/lam_compile_context.mli @@ -32,18 +32,18 @@ type jbl_label = int type return_label = { - id : Ident.t; - params : Ident.t list; - immutable_mask : bool array; - mutable new_params : Ident.t Map_ident.t; - mutable triggered : bool; + id: Ident.t; + params: Ident.t list; + immutable_mask: bool array; + mutable new_params: Ident.t Map_ident.t; + mutable triggered: bool; } -type value = { exit_id : Ident.t; bindings : Ident.t list; order_id : int } +type value = {exit_id: Ident.t; bindings: Ident.t list; order_id: int} type let_kind = Lam_compat.let_kind -type tail = { label : return_label option; in_staticcatch : bool } +type tail = {label: return_label option; in_staticcatch: bool} type maybe_tail = Tail_in_try | Tail_with_name of tail @@ -67,15 +67,11 @@ type jmp_table = value Map_int.t val continuation_is_return : continuation -> bool -type t = { - continuation : continuation; - jmp_table : jmp_table; - meta : Lam_stats.t; -} +type t = {continuation: continuation; jmp_table: jmp_table; meta: Lam_stats.t} val empty_handler_map : jmp_table -type handler = { label : jbl_label; handler : Lam.t; bindings : Ident.t list } +type handler = {label: jbl_label; handler: Lam.t; bindings: Ident.t list} val no_static_raise_in_handler : handler -> bool diff --git a/compiler/core/lam_compile_env.ml b/compiler/core/lam_compile_env.ml index ff1dadb0af..a23b611680 100644 --- a/compiler/core/lam_compile_env.ml +++ b/compiler/core/lam_compile_env.ml @@ -30,9 +30,9 @@ type env_value = *) type ident_info = Js_cmj_format.keyed_cmj_value = { - name : string; - arity : Js_cmj_format.arity; - persistent_closed_lambda : Lam.t option; + name: string; + arity: Js_cmj_format.arity; + persistent_closed_lambda: Lam.t option; } (* @@ -59,8 +59,9 @@ let reset () = since when we print it in the end, it will be escaped quite ugly *) -let add_js_module ?import_attributes (hint_name : External_ffi_types.module_bind_name) - (module_name : string) default ~dynamic_import : Ident.t = +let add_js_module ?import_attributes + (hint_name : External_ffi_types.module_bind_name) (module_name : string) + default ~dynamic_import : Ident.t = let id = Ident.create (match hint_name with @@ -71,23 +72,28 @@ let add_js_module ?import_attributes (hint_name : External_ffi_types.module_bind | Phint_nothing -> Ext_modulename.js_id_name_of_hint_name module_name) in let lam_module_ident : J.module_id = - { id; kind = External { name = module_name; default; import_attributes }; dynamic_import } + { + id; + kind = External {name = module_name; default; import_attributes}; + dynamic_import; + } in match Lam_module_ident.Hash.find_key_opt cached_tbl lam_module_ident with | None -> - lam_module_ident +> External; - id + lam_module_ident +> External; + id | Some old_key -> old_key.id -let query_external_id_info ?(dynamic_import = false) (module_id : Ident.t) (name : string) : ident_info = +let query_external_id_info ?(dynamic_import = false) (module_id : Ident.t) + (name : string) : ident_info = let oid = Lam_module_ident.of_ml ~dynamic_import module_id in let cmj_table = match Lam_module_ident.Hash.find_opt cached_tbl oid with | None -> - let cmj_load_info = !Js_cmj_load.load_unit module_id.name in - oid +> Ml cmj_load_info; - cmj_load_info.cmj_table - | Some (Ml { cmj_table }) -> cmj_table + let cmj_load_info = !Js_cmj_load.load_unit module_id.name in + oid +> Ml cmj_load_info; + cmj_load_info.cmj_table + | Some (Ml {cmj_table}) -> cmj_table | Some External -> assert false in Js_cmj_format.query_by_name cmj_table name @@ -102,14 +108,12 @@ let get_package_path_from_cmj (id : Lam_module_ident.t) : can not be External *) | None -> ( - match id.kind with - | Runtime | External _ -> assert false - | Ml -> - let cmj_load_info = - !Js_cmj_load.load_unit (Lam_module_ident.name id) - in - id +> Ml cmj_load_info; - cmj_load_info) + match id.kind with + | Runtime | External _ -> assert false + | Ml -> + let cmj_load_info = !Js_cmj_load.load_unit (Lam_module_ident.name id) in + id +> Ml cmj_load_info; + cmj_load_info) in let cmj_table = cmj_load_info.cmj_table in (cmj_load_info.package_path, cmj_table.package_spec, cmj_table.case) @@ -122,15 +126,15 @@ let is_pure_module (oid : Lam_module_ident.t) = | Runtime -> true | External _ -> false | Ml -> ( - match Lam_module_ident.Hash.find_opt cached_tbl oid with - | None -> ( - match !Js_cmj_load.load_unit (Lam_module_ident.name oid) with - | cmj_load_info -> - oid +> Ml cmj_load_info; - cmj_load_info.cmj_table.pure - | exception _ -> false) - | Some (Ml { cmj_table }) -> cmj_table.pure - | Some External -> false) + match Lam_module_ident.Hash.find_opt cached_tbl oid with + | None -> ( + match !Js_cmj_load.load_unit (Lam_module_ident.name oid) with + | cmj_load_info -> + oid +> Ml cmj_load_info; + cmj_load_info.cmj_table.pure + | exception _ -> false) + | Some (Ml {cmj_table}) -> cmj_table.pure + | Some External -> false) let populate_required_modules extras (hard_dependencies : Lam_module_ident.Hash_set.t) = diff --git a/compiler/core/lam_compile_env.mli b/compiler/core/lam_compile_env.mli index c9cfd374b7..75527d0eee 100644 --- a/compiler/core/lam_compile_env.mli +++ b/compiler/core/lam_compile_env.mli @@ -27,7 +27,12 @@ val reset : unit -> unit val add_js_module : - ?import_attributes:External_ffi_types.import_attributes -> External_ffi_types.module_bind_name -> string -> bool -> dynamic_import:bool -> Ident.t + ?import_attributes:External_ffi_types.import_attributes -> + External_ffi_types.module_bind_name -> + string -> + bool -> + dynamic_import:bool -> + Ident.t (** [add_js_module hint_name module_name] Given a js module name and hint name, assign an id to it @@ -59,7 +64,8 @@ val add_js_module : pay attention to for those modules are actually used or not *) -val query_external_id_info : ?dynamic_import:bool -> Ident.t -> string -> Js_cmj_format.keyed_cmj_value +val query_external_id_info : + ?dynamic_import:bool -> Ident.t -> string -> Js_cmj_format.keyed_cmj_value (** [query_external_id_info id pos env found] will raise if not found diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index cf09812e33..6d9056e570 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -38,8 +38,12 @@ module E = Js_exp_make bundle *) let external_var - ({ bundle; module_bind_name; import_attributes } : External_ffi_types.external_module_name) ~dynamic_import = - let id = Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle false ~dynamic_import in + ({bundle; module_bind_name; import_attributes} : + External_ffi_types.external_module_name) ~dynamic_import = + let id = + Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle + false ~dynamic_import + in E.external_var ?import_attributes ~external_name:bundle id (* let handle_external_opt @@ -89,33 +93,32 @@ let ocaml_to_js_eff ~(arg_label : External_arg_spec.label_noname) let arg = match arg_label with | Arg_optional -> - Js_of_lam_option.get_default_undefined_from_optional raw_arg + Js_of_lam_option.get_default_undefined_from_optional raw_arg | Arg_label | Arg_empty -> raw_arg in match arg_type with | Arg_cst _ -> assert false (* has to be preprocessed by {!Lam} module first *) | Extern_unit -> - ( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit), - if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] ) - (* leave up later to decide *) + ( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit), + if Js_analyzer.no_side_effect_expression arg then [] else [arg] ) + (* leave up later to decide *) | Ignore -> - ( Splice0, - if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] ) - | Poly_var_string { descr } -> (Splice1 (Js_of_lam_variant.eval arg descr), []) - | Poly_var { descr } -> (Js_of_lam_variant.eval_as_event arg descr, []) + (Splice0, if Js_analyzer.no_side_effect_expression arg then [] else [arg]) + | Poly_var_string {descr} -> (Splice1 (Js_of_lam_variant.eval arg descr), []) + | Poly_var {descr} -> (Js_of_lam_variant.eval_as_event arg descr, []) (* FIXME: encode invariant below in the signature*) (* length of 2 - the poly var tag - the value *) | Int dispatches -> - (Splice1 (Js_of_lam_variant.eval_as_int arg dispatches), []) + (Splice1 (Js_of_lam_variant.eval_as_int arg dispatches), []) | Unwrap -> - let single_arg = - match arg_label with - | Arg_optional -> - (* + let single_arg = + match arg_label with + | Arg_optional -> + (* If this is an optional arg (like `?arg`), we have to potentially do 2 levels of unwrapping: - if ocaml arg is `None`, let js arg be `undefined` (no unwrapping) @@ -124,15 +127,18 @@ let ocaml_to_js_eff ~(arg_label : External_arg_spec.label_noname) - Here `Some x` is `x` due to the current encoding Lets inline here since it depends on the runtime encoding *) - Js_of_lam_option.option_unwrap raw_arg - | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg - in - (Splice1 single_arg, []) + Js_of_lam_option.option_unwrap raw_arg + | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg + in + (Splice1 single_arg, []) | Nothing -> (Splice1 arg, []) let empty_pair = ([], []) -let add_eff eff e = match eff with None -> e | Some v -> E.seq v e +let add_eff eff e = + match eff with + | None -> e + | Some v -> E.seq v e type specs = External_arg_spec.params @@ -144,7 +150,7 @@ let keep_non_undefined_args (arg_types : specs) (args : exprs) = | ( [{External_arg_spec.arg_label = Arg_optional; _}], [{J.expression_desc = Undefined {is_unit = false}; _}] ) -> true - | ( _ :: arg_types_rest, _ :: args_rest ) -> + | _ :: arg_types_rest, _ :: args_rest -> has_undefined_trailing_args arg_types_rest args_rest | _ -> false in @@ -152,12 +158,12 @@ let keep_non_undefined_args (arg_types : specs) (args : exprs) = match (arg_types, args) with | ( {External_arg_spec.arg_label = Arg_optional; _} :: arg_types_rest, {J.expression_desc = Undefined {is_unit = false}; _} :: args_rest ) -> - aux arg_types_rest args_rest + aux arg_types_rest args_rest | _ -> args in - if (has_undefined_trailing_args arg_types args) then + if has_undefined_trailing_args arg_types args then aux (List.rev arg_types) (List.rev args) |> List.rev - else args + else args (* TODO: fix splice, we need a static guarantee that it is static array construct @@ -171,16 +177,16 @@ let assemble_args_no_splice (arg_types : specs) (args : exprs) : let rec aux (labels : specs) (args : exprs) : exprs * exprs = match (labels, args) with | [], _ -> - assert (args = []); - empty_pair - | { arg_type = Arg_cst cst; _ } :: labels, args -> - (* can not be Optional *) - let accs, eff = aux labels args in - (Lam_compile_const.translate_arg_cst cst :: accs, eff) - | { arg_label; arg_type } :: labels, arg :: args -> - let accs, eff = aux labels args in - let acc, new_eff = ocaml_to_js_eff ~arg_label ~arg_type arg in - (append_list acc accs, Ext_list.append new_eff eff) + assert (args = []); + empty_pair + | {arg_type = Arg_cst cst; _} :: labels, args -> + (* can not be Optional *) + let accs, eff = aux labels args in + (Lam_compile_const.translate_arg_cst cst :: accs, eff) + | {arg_label; arg_type} :: labels, arg :: args -> + let accs, eff = aux labels args in + let acc, new_eff = ocaml_to_js_eff ~arg_label ~arg_type arg in + (append_list acc accs, Ext_list.append new_eff eff) | _ :: _, [] -> assert false in let args, eff = aux arg_types args in @@ -188,8 +194,8 @@ let assemble_args_no_splice (arg_types : specs) (args : exprs) : match eff with | [] -> None | x :: xs -> - (* FIXME: the order of effects? *) - Some (E.fuse_to_seq x xs) ) + (* FIXME: the order of effects? *) + Some (E.fuse_to_seq x xs) ) let assemble_args_has_splice (arg_types : specs) (args : exprs) : exprs * E.t option * bool = @@ -197,20 +203,20 @@ let assemble_args_has_splice (arg_types : specs) (args : exprs) : let rec aux (labels : specs) (args : exprs) = match (labels, args) with | [], _ -> - assert (args = []); - empty_pair - | { arg_type = Arg_cst cst; _ } :: labels, args -> - let accs, eff = aux labels args in - (Lam_compile_const.translate_arg_cst cst :: accs, eff) - | { arg_label; arg_type } :: labels, arg :: args -> ( - let accs, eff = aux labels args in - match (args, (arg : E.t)) with - | [], { expression_desc = Array (ls, _mutable_flag); _ } -> - (Ext_list.append ls accs, eff) - | _ -> - if args = [] then dynamic := true; - let acc, new_eff = ocaml_to_js_eff ~arg_type ~arg_label arg in - (append_list acc accs, Ext_list.append new_eff eff)) + assert (args = []); + empty_pair + | {arg_type = Arg_cst cst; _} :: labels, args -> + let accs, eff = aux labels args in + (Lam_compile_const.translate_arg_cst cst :: accs, eff) + | {arg_label; arg_type} :: labels, arg :: args -> ( + let accs, eff = aux labels args in + match (args, (arg : E.t)) with + | [], {expression_desc = Array (ls, _mutable_flag); _} -> + (Ext_list.append ls accs, eff) + | _ -> + if args = [] then dynamic := true; + let acc, new_eff = ocaml_to_js_eff ~arg_type ~arg_label arg in + (append_list acc accs, Ext_list.append new_eff eff)) | _ :: _, [] -> assert false in let args, eff = aux arg_types args in @@ -218,40 +224,43 @@ let assemble_args_has_splice (arg_types : specs) (args : exprs) : (match eff with | [] -> None | x :: xs -> - (* FIXME: the order of effects? *) - Some (E.fuse_to_seq x xs)), + (* FIXME: the order of effects? *) + Some (E.fuse_to_seq x xs)), !dynamic ) let translate_scoped_module_val (module_name : External_ffi_types.external_module_name option) (fn : string) - (scopes : string list) - ~dynamic_import = + (scopes : string list) ~dynamic_import = match module_name with - | Some { bundle; module_bind_name; import_attributes } -> ( - match scopes with - | [] -> - let default = fn = "default" in - let id = - Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle default ~dynamic_import - in - E.external_var_field ?import_attributes ~external_name:bundle ~field:fn ~default id - | x :: rest -> - (* TODO: what happens when scope contains "default" ?*) - let default = false in - let id = - Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle default ~dynamic_import - in - let start = - E.external_var_field ?import_attributes ~external_name:bundle ~field:x ~default id - in - Ext_list.fold_left (Ext_list.append rest [ fn ]) start E.dot) + | Some {bundle; module_bind_name; import_attributes} -> ( + match scopes with + | [] -> + let default = fn = "default" in + let id = + Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle + default ~dynamic_import + in + E.external_var_field ?import_attributes ~external_name:bundle ~field:fn + ~default id + | x :: rest -> + (* TODO: what happens when scope contains "default" ?*) + let default = false in + let id = + Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle + default ~dynamic_import + in + let start = + E.external_var_field ?import_attributes ~external_name:bundle ~field:x + ~default id + in + Ext_list.fold_left (Ext_list.append rest [fn]) start E.dot) | None -> ( - (* no [@@module], assume it's global *) - match scopes with - | [] -> E.js_global fn - | x :: rest -> - let start = E.js_global x in - Ext_list.fold_left (Ext_list.append_one rest fn) start E.dot) + (* no [@@module], assume it's global *) + match scopes with + | [] -> E.js_global fn + | x :: rest -> + let start = E.js_global x in + Ext_list.fold_left (Ext_list.append_one rest fn) start E.dot) let translate_scoped_access scopes obj = match scopes with @@ -259,144 +268,166 @@ let translate_scoped_access scopes obj = | x :: xs -> Ext_list.fold_left xs (E.dot obj x) E.dot let translate_ffi (cxt : Lam_compile_context.t) arg_types - (ffi : External_ffi_types.external_spec) (args : J.expression list) ~dynamic_import = + (ffi : External_ffi_types.external_spec) (args : J.expression list) + ~dynamic_import = match ffi with - | Js_call { external_module_name; name; splice: _; scopes; tagged_template = true } -> - let fn = translate_scoped_module_val external_module_name name scopes ~dynamic_import in - (match args with - | [ {expression_desc = Array (strings, _); _}; {expression_desc = Array (values, _); _} ] -> - E.tagged_template fn strings values - | _ -> - let args, eff, dynamic = assemble_args_has_splice arg_types args in - let args = if dynamic then E.variadic_args args else args in - add_eff eff ( - E.call ~info:{ arity = Full; call_info = Call_na } fn args)) - | Js_call { external_module_name = module_name; name = fn; splice; scopes; tagged_template = false } -> - let fn = translate_scoped_module_val module_name fn scopes ~dynamic_import in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - let args = if dynamic then E.variadic_args args else args in - add_eff eff ( - E.call ~info:{ arity = Full; call_info = Call_na } fn args) - else - let args, eff = assemble_args_no_splice arg_types args in - add_eff eff - @@ E.call ~info:{ arity = Full; call_info = Call_na } fn args - | Js_module_as_fn { external_module_name; splice } -> - let fn = external_var external_module_name ~dynamic_import in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - let args = if dynamic then E.variadic_args args else args in - add_eff eff ( - E.call ~info:{ arity = Full; call_info = Call_na } fn args) - else - let args, eff = assemble_args_no_splice arg_types args in - (* TODO: fix in rest calling convention *) - add_eff eff (E.call ~info:{ arity = Full; call_info = Call_na } fn args) - | Js_new { external_module_name = module_name; name = fn; splice; scopes } -> - (* handle [@@new]*) - (* This has some side effect, it will - mark its identifier (If it has) as an object, - ATTENTION: - order also matters here, since we mark its jsobject property, - it will affect the code gen later - TODO: we should propagate this property - as much as we can(in alias table) - *) - let mark () = - match cxt.continuation with - | Declare (_, id) | Assign id -> - (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *) - Ext_ident.make_js_object id - | EffectCall _ | NeedValue _ -> () + | Js_call + {external_module_name; name; splice : _; scopes; tagged_template = true} + -> ( + let fn = + translate_scoped_module_val external_module_name name scopes + ~dynamic_import + in + match args with + | [ + {expression_desc = Array (strings, _); _}; + {expression_desc = Array (values, _); _}; + ] -> + E.tagged_template fn strings values + | _ -> + let args, eff, dynamic = assemble_args_has_splice arg_types args in + let args = if dynamic then E.variadic_args args else args in + add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args)) + | Js_call + { + external_module_name = module_name; + name = fn; + splice; + scopes; + tagged_template = false; + } -> + let fn = + translate_scoped_module_val module_name fn scopes ~dynamic_import + in + if splice then + let args, eff, dynamic = assemble_args_has_splice arg_types args in + let args = if dynamic then E.variadic_args args else args in + add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + else + let args, eff = assemble_args_no_splice arg_types args in + add_eff eff @@ E.call ~info:{arity = Full; call_info = Call_na} fn args + | Js_module_as_fn {external_module_name; splice} -> + let fn = external_var external_module_name ~dynamic_import in + if splice then + let args, eff, dynamic = assemble_args_has_splice arg_types args in + let args = if dynamic then E.variadic_args args else args in + add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + else + let args, eff = assemble_args_no_splice arg_types args in + (* TODO: fix in rest calling convention *) + add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + | Js_new {external_module_name = module_name; name = fn; splice; scopes} -> + (* handle [@@new]*) + (* This has some side effect, it will + mark its identifier (If it has) as an object, + ATTENTION: + order also matters here, since we mark its jsobject property, + it will affect the code gen later + TODO: we should propagate this property + as much as we can(in alias table) + *) + let mark () = + match cxt.continuation with + | Declare (_, id) | Assign id -> + (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *) + Ext_ident.make_js_object id + | EffectCall _ | NeedValue _ -> () + in + if splice then + let args, eff, dynamic = assemble_args_has_splice arg_types args in + let args = if dynamic then E.variadic_args args else args in + let fn = + translate_scoped_module_val module_name fn scopes ~dynamic_import in + add_eff eff + (mark (); + E.new_ fn args) + else + let args, eff = assemble_args_no_splice arg_types args in + let fn = + translate_scoped_module_val module_name fn scopes ~dynamic_import + in + add_eff eff + (mark (); + E.new_ fn args) + | Js_send {splice; name; js_send_scopes} -> ( + match args with + | self :: args -> + (* PR2162 [self_type] more checks in syntax: + - should not be [@as] *) + let[@warning "-8"] (_self_type :: arg_types) = arg_types in if splice then let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - let fn = translate_scoped_module_val module_name fn scopes ~dynamic_import in add_eff eff - (mark (); - E.new_ fn args) + (let self = translate_scoped_access js_send_scopes self in + E.call + ~info:{arity = Full; call_info = Call_na} + (E.dot self name) args) else let args, eff = assemble_args_no_splice arg_types args in - let fn = translate_scoped_module_val module_name fn scopes ~dynamic_import in add_eff eff - (mark (); E.new_ fn args) - | Js_send { splice; name; js_send_scopes } -> ( - match args with - | self :: args -> - (* PR2162 [self_type] more checks in syntax: - - should not be [@as] *) - let[@warning "-8"] (_self_type :: arg_types) = arg_types in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - let args = if dynamic then E.variadic_args args else args in - add_eff eff - (let self = translate_scoped_access js_send_scopes self in - E.call - ~info:{ arity = Full; call_info = Call_na } - (E.dot self name) args) - else - let args, eff = assemble_args_no_splice arg_types args in - add_eff eff - (let self = translate_scoped_access js_send_scopes self in - E.call - ~info:{ arity = Full; call_info = Call_na } - (E.dot self name) args) - | _ -> assert false) + (let self = translate_scoped_access js_send_scopes self in + E.call + ~info:{arity = Full; call_info = Call_na} + (E.dot self name) args) + | _ -> assert false) | Js_module_as_var module_name -> external_var module_name ~dynamic_import - | Js_var { name; external_module_name; scopes } -> - (* TODO #11 - 1. check args -- error checking - 2. support [@@scope "window"] - we need know whether we should call [add_js_module] or not - *) - let e = translate_scoped_module_val external_module_name name scopes ~dynamic_import in - if args = [] then e - else E.call ~info:{ arity = Full; call_info = Call_na } e args + | Js_var {name; external_module_name; scopes} -> + (* TODO #11 + 1. check args -- error checking + 2. support [@@scope "window"] + we need know whether we should call [add_js_module] or not + *) + let e = + translate_scoped_module_val external_module_name name scopes + ~dynamic_import + in + if args = [] then e + else E.call ~info:{arity = Full; call_info = Call_na} e args | Js_module_as_class module_name -> - let fn = external_var module_name ~dynamic_import in - let args, eff = assemble_args_no_splice arg_types args in - (* TODO: fix in rest calling convention *) - add_eff eff - ((match cxt.continuation with - | Declare (_, id) | Assign id -> - (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *) - Ext_ident.make_js_object id - | EffectCall _ | NeedValue _ -> ()); - E.new_ fn args) - | Js_get { js_get_name = name; js_get_scopes = scopes } -> ( - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match args with - | [ obj ] -> - let obj = translate_scoped_access scopes obj in - E.dot obj name - | _ -> assert false - (* Note these assertion happens in call site *)) - | Js_set { js_set_name = name; js_set_scopes = scopes } -> ( - (* assert (js_splice = false) ; *) - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match (args, arg_types) with - | [ obj; v ], _ -> - let obj = translate_scoped_access scopes obj in - E.assign (E.dot obj name) v - | _ -> assert false) - | Js_get_index { js_get_index_scopes = scopes } -> ( - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match args with - | [ obj; v ] -> Js_arr.ref_array (translate_scoped_access scopes obj) v - | _ -> assert false) - | Js_set_index { js_set_index_scopes = scopes } -> ( - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match args with - | [ obj; v; value ] -> - Js_arr.set_array (translate_scoped_access scopes obj) v value - | _ -> assert false) + let fn = external_var module_name ~dynamic_import in + let args, eff = assemble_args_no_splice arg_types args in + (* TODO: fix in rest calling convention *) + add_eff eff + ((match cxt.continuation with + | Declare (_, id) | Assign id -> + (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *) + Ext_ident.make_js_object id + | EffectCall _ | NeedValue _ -> ()); + E.new_ fn args) + | Js_get {js_get_name = name; js_get_scopes = scopes} -> ( + let args, cur_eff = assemble_args_no_splice arg_types args in + add_eff cur_eff + @@ + match args with + | [obj] -> + let obj = translate_scoped_access scopes obj in + E.dot obj name + | _ -> assert false + (* Note these assertion happens in call site *)) + | Js_set {js_set_name = name; js_set_scopes = scopes} -> ( + (* assert (js_splice = false) ; *) + let args, cur_eff = assemble_args_no_splice arg_types args in + add_eff cur_eff + @@ + match (args, arg_types) with + | [obj; v], _ -> + let obj = translate_scoped_access scopes obj in + E.assign (E.dot obj name) v + | _ -> assert false) + | Js_get_index {js_get_index_scopes = scopes} -> ( + let args, cur_eff = assemble_args_no_splice arg_types args in + add_eff cur_eff + @@ + match args with + | [obj; v] -> Js_arr.ref_array (translate_scoped_access scopes obj) v + | _ -> assert false) + | Js_set_index {js_set_index_scopes = scopes} -> ( + let args, cur_eff = assemble_args_no_splice arg_types args in + add_eff cur_eff + @@ + match args with + | [obj; v; value] -> + Js_arr.set_array (translate_scoped_access scopes obj) v value + | _ -> assert false) diff --git a/compiler/core/lam_compile_external_obj.ml b/compiler/core/lam_compile_external_obj.ml index 8638e0833c..1a981d1bf4 100644 --- a/compiler/core/lam_compile_external_obj.ml +++ b/compiler/core/lam_compile_external_obj.ml @@ -43,126 +43,120 @@ let assemble_obj_args (labels : External_arg_spec.obj_params) (Js_op.property_name * E.t) list * J.expression list * _ = match (labels, args) with | [], [] -> ([], [], []) - | ( { - obj_arg_label = Obj_label { name = label }; - obj_arg_type = Arg_cst cst; - } + | ( {obj_arg_label = Obj_label {name = label}; obj_arg_type = Arg_cst cst} :: labels, args ) -> - let accs, eff, assign = aux labels args in - ( (Js_op.Lit label, Lam_compile_const.translate_arg_cst cst) :: accs, - eff, - assign ) + let accs, eff, assign = aux labels args in + ( (Js_op.Lit label, Lam_compile_const.translate_arg_cst cst) :: accs, + eff, + assign ) (* | {obj_arg_label = EmptyCst _ } :: rest , args -> assert false *) - | { obj_arg_label = Obj_empty } :: labels, arg :: args -> - (* unit type*) - let ((accs, eff, assign) as r) = aux labels args in - if Js_analyzer.no_side_effect_expression arg then r - else (accs, arg :: eff, assign) - | ( ({ obj_arg_label = Obj_label { name = label } } as arg_kind) :: labels, + | {obj_arg_label = Obj_empty} :: labels, arg :: args -> + (* unit type*) + let ((accs, eff, assign) as r) = aux labels args in + if Js_analyzer.no_side_effect_expression arg then r + else (accs, arg :: eff, assign) + | ( ({obj_arg_label = Obj_label {name = label}} as arg_kind) :: labels, arg :: args ) -> ( - let accs, eff, assign = aux labels args in - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label - ~arg_type:arg_kind.obj_arg_type arg - in - match acc with - | Splice2 _ | Splice0 -> assert false - | Splice1 x -> - ((Js_op.Lit label, x) :: accs, Ext_list.append new_eff eff, assign) - (* evaluation order is undefined *)) - | ( ({ obj_arg_label = Obj_optional { name = label }; obj_arg_type } as - arg_kind) + let accs, eff, assign = aux labels args in + let acc, new_eff = + Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label + ~arg_type:arg_kind.obj_arg_type arg + in + match acc with + | Splice2 _ | Splice0 -> assert false + | Splice1 x -> + ((Js_op.Lit label, x) :: accs, Ext_list.append new_eff eff, assign) + (* evaluation order is undefined *)) + | ( ({obj_arg_label = Obj_optional {name = label}; obj_arg_type} as arg_kind) :: labels, arg :: args ) -> - let ((accs, eff, assign) as r) = aux labels args in - Js_of_lam_option.destruct_optional arg ~for_sure_none:r - ~for_sure_some:(fun x -> - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label - ~arg_type:obj_arg_type x - in - match acc with - | Splice2 _ | Splice0 -> assert false - | Splice1 x -> - ( (Js_op.Lit label, x) :: accs, - Ext_list.append new_eff eff, - assign )) - ~not_sure:(fun _ -> (accs, eff, (arg_kind, arg) :: assign)) - | { obj_arg_label = Obj_empty | Obj_label _ | Obj_optional _ } :: _, [] -> - assert false + let ((accs, eff, assign) as r) = aux labels args in + Js_of_lam_option.destruct_optional arg ~for_sure_none:r + ~for_sure_some:(fun x -> + let acc, new_eff = + Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label + ~arg_type:obj_arg_type x + in + match acc with + | Splice2 _ | Splice0 -> assert false + | Splice1 x -> + ((Js_op.Lit label, x) :: accs, Ext_list.append new_eff eff, assign)) + ~not_sure:(fun _ -> (accs, eff, (arg_kind, arg) :: assign)) + | {obj_arg_label = Obj_empty | Obj_label _ | Obj_optional _} :: _, [] -> + assert false | [], _ :: _ -> assert false in let map, eff, assignment = aux labels args in match assignment with - | [] -> ( - ( [], - match eff with - | [] -> E.obj map - | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map) )) + | [] -> + ( [], + match eff with + | [] -> E.obj map + | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map) ) | _ -> - let v = Ext_ident.create_tmp () in - let var_v = E.var v in - ( S.define_variable ~kind:Variable v - (match eff with - | [] -> E.obj map - | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)) - :: Ext_list.flat_map assignment - (fun ((xlabel : External_arg_spec.obj_param), (arg : J.expression)) - -> - match xlabel with - | { - obj_arg_label = - Obj_optional { name = label; for_sure_no_nested_option }; - } -> ( - (* Need make sure whether assignment is effectful or not - to avoid code duplication - *) - match Js_ast_util.named_expression arg with - | None -> ( - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff - ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type - (if for_sure_no_nested_option then arg - else Js_of_lam_option.val_from_option arg) - in - match acc with - | Splice1 v -> - [ - S.if_ - (Js_of_lam_option.is_not_none arg) - [ - S.exp - (E.assign (E.dot var_v label) - (match new_eff with - | [] -> v - | x :: xs -> E.seq (E.fuse_to_seq x xs) v)); - ]; - ] - | Splice0 | Splice2 _ -> assert false) - | Some (st, id) -> ( - (* FIXME: see #2503 *) - let arg = E.var id in - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff - ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type - (if for_sure_no_nested_option then arg - else Js_of_lam_option.val_from_option arg) - in - match acc with - | Splice1 v -> - [ - st; - S.if_ - (Js_of_lam_option.is_not_none arg) - [ - S.exp - (E.assign (E.dot var_v label) - (match new_eff with - | [] -> v - | x :: xs -> E.seq (E.fuse_to_seq x xs) v)); - ]; - ] - | Splice0 | Splice2 _ -> assert false)) - | _ -> assert false), - var_v ) + let v = Ext_ident.create_tmp () in + let var_v = E.var v in + ( S.define_variable ~kind:Variable v + (match eff with + | [] -> E.obj map + | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)) + :: Ext_list.flat_map assignment + (fun + ((xlabel : External_arg_spec.obj_param), (arg : J.expression)) -> + match xlabel with + | { + obj_arg_label = + Obj_optional {name = label; for_sure_no_nested_option}; + } -> ( + (* Need make sure whether assignment is effectful or not + to avoid code duplication + *) + match Js_ast_util.named_expression arg with + | None -> ( + let acc, new_eff = + Lam_compile_external_call.ocaml_to_js_eff + ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type + (if for_sure_no_nested_option then arg + else Js_of_lam_option.val_from_option arg) + in + match acc with + | Splice1 v -> + [ + S.if_ + (Js_of_lam_option.is_not_none arg) + [ + S.exp + (E.assign (E.dot var_v label) + (match new_eff with + | [] -> v + | x :: xs -> E.seq (E.fuse_to_seq x xs) v)); + ]; + ] + | Splice0 | Splice2 _ -> assert false) + | Some (st, id) -> ( + (* FIXME: see #2503 *) + let arg = E.var id in + let acc, new_eff = + Lam_compile_external_call.ocaml_to_js_eff + ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type + (if for_sure_no_nested_option then arg + else Js_of_lam_option.val_from_option arg) + in + match acc with + | Splice1 v -> + [ + st; + S.if_ + (Js_of_lam_option.is_not_none arg) + [ + S.exp + (E.assign (E.dot var_v label) + (match new_eff with + | [] -> v + | x :: xs -> E.seq (E.fuse_to_seq x xs) v)); + ]; + ] + | Splice0 | Splice2 _ -> assert false)) + | _ -> assert false), + var_v ) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index da69377810..efea6c977b 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -32,45 +32,42 @@ let ensure_value_unit (st : Lam_compile_context.continuation) e : E.t = | EffectCall (Maybe_tail_is_return _) | NeedValue (Maybe_tail_is_return _) | Assign _ | Declare _ | NeedValue _ -> - E.seq e E.unit + E.seq e E.unit | EffectCall Not_tail -> e (* NeedValue should return a meaningful expression*) let module_of_expression = function - | J.Var (J.Qualified (module_id, value)) -> [ (module_id, value) ] - | J.Call ({expression_desc = (J.Var (J.Qualified (module_id, value)))}, _, _) -> [ (module_id, value) ] + | J.Var (J.Qualified (module_id, value)) -> [(module_id, value)] + | J.Call ({expression_desc = J.Var (J.Qualified (module_id, value))}, _, _) -> + [(module_id, value)] | _ -> [] let get_module_system () = - let package_info = Js_packages_state.get_packages_info () in - let module_system = - if Js_packages_info.is_empty package_info && !Js_config.js_stdout then - [Ext_module_system.Commonjs] - else Js_packages_info.map package_info (fun {module_system} -> module_system) - in - match module_system with - | [module_system] -> module_system - | _ -> Commonjs + let package_info = Js_packages_state.get_packages_info () in + let module_system = + if Js_packages_info.is_empty package_info && !Js_config.js_stdout then + [Ext_module_system.Commonjs] + else + Js_packages_info.map package_info (fun {module_system} -> module_system) + in + match module_system with + | [module_system] -> module_system + | _ -> Commonjs let import_of_path path = E.call - ~info:{ arity = Full; call_info = Call_na } + ~info:{arity = Full; call_info = Call_na} (E.js_global "import") - [ E.str path ] + [E.str path] let wrap_then import value = let arg = Ident.create "m" in E.call - ~info:{ arity = Full; call_info = Call_na } + ~info:{arity = Full; call_info = Call_na} (E.dot import "then") [ - E.ocaml_fun ~return_unit:false ~async:false ~one_unit_arg:false [ arg ] - [ - { - statement_desc = J.Return (E.dot (E.var arg) value); - comment = None; - }; - ]; + E.ocaml_fun ~return_unit:false ~async:false ~one_unit_arg:false [arg] + [{statement_desc = J.Return (E.dot (E.var arg) value); comment = None}]; ] let translate output_prefix loc (cxt : Lam_compile_context.t) @@ -79,408 +76,502 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Pis_not_none -> Js_of_lam_option.is_not_none (Ext_list.singleton_exn args) | Pcreate_extension s -> E.make_exception s | Pwrap_exn -> - E.runtime_call Primitive_modules.exceptions - "internalToException" args - | Praw_js_code { code; code_info } -> E.raw_js_code code_info code + E.runtime_call Primitive_modules.exceptions "internalToException" args + | Praw_js_code {code; code_info} -> E.raw_js_code code_info code (* FIXME: save one allocation trim can not be done before syntax checking otherwise location is incorrect *) | Pjs_runtime_apply -> ( - match args with [ f; args ] -> E.flat_call f args | _ -> assert false) + match args with + | [f; args] -> E.flat_call f args + | _ -> assert false) | Pjs_apply -> ( - match args with - | fn :: rest -> E.call ~info:{ arity = Full; call_info = Call_na } fn rest - | _ -> assert false) + match args with + | fn :: rest -> E.call ~info:{arity = Full; call_info = Call_na} fn rest + | _ -> assert false) | Pnull_to_opt -> ( - match args with - | [ e ] -> ( - match e.expression_desc with - | Var _ | Undefined _ | Null -> Js_of_lam_option.null_to_opt e - | _ -> E.runtime_call Primitive_modules.option "fromNull" args) - | _ -> assert false) + match args with + | [e] -> ( + match e.expression_desc with + | Var _ | Undefined _ | Null -> Js_of_lam_option.null_to_opt e + | _ -> E.runtime_call Primitive_modules.option "fromNull" args) + | _ -> assert false) | Pundefined_to_opt -> ( - match args with - | [ e ] -> ( - match e.expression_desc with - | Var _ | Undefined _ | Null -> Js_of_lam_option.undef_to_opt e - | _ -> - E.runtime_call Primitive_modules.option "fromUndefined" args) - | _ -> assert false) + match args with + | [e] -> ( + match e.expression_desc with + | Var _ | Undefined _ | Null -> Js_of_lam_option.undef_to_opt e + | _ -> E.runtime_call Primitive_modules.option "fromUndefined" args) + | _ -> assert false) | Pnull_undefined_to_opt -> ( - match args with - | [ e ] -> ( - match e.expression_desc with - | Var _ | Undefined _ | Null -> Js_of_lam_option.null_undef_to_opt e - | _ -> E.runtime_call Primitive_modules.option "fromNullable" args - ) - | _ -> assert false) + match args with + | [e] -> ( + match e.expression_desc with + | Var _ | Undefined _ | Null -> Js_of_lam_option.null_undef_to_opt e + | _ -> E.runtime_call Primitive_modules.option "fromNullable" args) + | _ -> assert false) (* Compile %import: The module argument for dynamic import is represented as a path, and the module value is expressed through wrapping it with promise.then *) | Pimport -> ( - match args with - | [ e ] -> ( - let output_dir = Filename.dirname output_prefix in + match args with + | [e] -> ( + let output_dir = Filename.dirname output_prefix in - let module_id, module_value = - match module_of_expression e.expression_desc with - | [ module_ ] -> module_ - | _ -> Location.raise_errorf ~loc - "Invalid argument: Dynamic import requires a module or module value that is a file as argument. Passing a value or local module is not allowed." - in + let module_id, module_value = + match module_of_expression e.expression_desc with + | [module_] -> module_ + | _ -> + Location.raise_errorf ~loc + "Invalid argument: Dynamic import requires a module or module \ + value that is a file as argument. Passing a value or local module \ + is not allowed." + in - let path = - let module_system = get_module_system () in - Js_name_of_module_id.string_of_module_id {module_id with dynamic_import = true} ~output_dir module_system - in + let path = + let module_system = get_module_system () in + Js_name_of_module_id.string_of_module_id + {module_id with dynamic_import = true} + ~output_dir module_system + in - match module_value with - | Some value -> wrap_then (import_of_path path) value - | None -> import_of_path path) - | [] | _ -> - Location.raise_errorf ~loc - "Invalid argument: Dynamic import must take a single module or module value as its argument.") + match module_value with + | Some value -> wrap_then (import_of_path path) value + | None -> import_of_path path) + | [] | _ -> + Location.raise_errorf ~loc + "Invalid argument: Dynamic import must take a single module or module \ + value as its argument.") | Pfn_arity -> E.function_length (Ext_list.singleton_exn args) | Pobjsize -> E.obj_length (Ext_list.singleton_exn args) | Pis_null -> E.is_null (Ext_list.singleton_exn args) | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args) | Ptypeof -> E.typeof (Ext_list.singleton_exn args) - | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_make _ | Pjs_fn_make_unit | Pjs_fn_method - -> - assert false (* already handled by {!Lam_compile} *) + | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_make _ | Pjs_fn_make_unit + | Pjs_fn_method -> + assert false (* already handled by {!Lam_compile} *) | Pstringadd -> ( - match args with [ a; b ] -> E.string_append a b | _ -> assert false) + match args with + | [a; b] -> E.string_append a b + | _ -> assert false) | Pinit_mod -> E.runtime_call Primitive_modules.module_ "init" args | Pupdate_mod -> E.runtime_call Primitive_modules.module_ "update" args | Psome -> ( - let arg = Ext_list.singleton_exn args in - match arg.expression_desc with - | Null | Object _ | Number _ | Caml_block _ | Array _ | Str _ -> - (* This makes sense when type info - is not available at the definition - site, and inline recovered it - *) - E.optional_not_nest_block arg - | _ -> E.optional_block arg) + let arg = Ext_list.singleton_exn args in + match arg.expression_desc with + | Null | Object _ | Number _ | Caml_block _ | Array _ | Str _ -> + (* This makes sense when type info + is not available at the definition + site, and inline recovered it + *) + E.optional_not_nest_block arg + | _ -> E.optional_block arg) | Psome_not_nest -> E.optional_not_nest_block (Ext_list.singleton_exn args) | Pmakeblock (tag, tag_info, mutable_flag) -> - (* RUNTIME *) - Js_of_lam_block.make_block - (Js_op_util.of_lam_mutable_flag mutable_flag) - tag_info (E.small_int tag) args + (* RUNTIME *) + Js_of_lam_block.make_block + (Js_op_util.of_lam_mutable_flag mutable_flag) + tag_info (E.small_int tag) args | Pval_from_option -> - Js_of_lam_option.val_from_option (Ext_list.singleton_exn args) + Js_of_lam_option.val_from_option (Ext_list.singleton_exn args) | Pval_from_option_not_nest -> Ext_list.singleton_exn args | Pfield (i, fld_info) -> - Js_of_lam_block.field fld_info - (Ext_list.singleton_exn args) - (Int32.of_int i) + Js_of_lam_block.field fld_info + (Ext_list.singleton_exn args) + (Int32.of_int i) (* Invariant depends on runtime *) (* Negate boxed int *) | Pnegint -> - (* #977 *) - E.int32_minus E.zero_int_literal (Ext_list.singleton_exn args) + (* #977 *) + E.int32_minus E.zero_int_literal (Ext_list.singleton_exn args) | Pnegfloat -> E.float_minus E.zero_float_lit (Ext_list.singleton_exn args) - | Pnegbigint -> E.bigint_op Minus E.zero_bigint_literal (Ext_list.singleton_exn args) + | Pnegbigint -> + E.bigint_op Minus E.zero_bigint_literal (Ext_list.singleton_exn args) (* Negate boxed int end*) (* Int addition and subtraction *) | Paddint -> ( - match args with [ e1; e2 ] -> E.int32_add e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_add e1 e2 + | _ -> assert false) | Paddfloat -> ( - match args with [ e1; e2 ] -> E.float_add e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.float_add e1 e2 + | _ -> assert false) | Paddbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Plus e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Plus e1 e2 + | _ -> assert false) | Psubint -> ( - match args with [ e1; e2 ] -> E.int32_minus e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_minus e1 e2 + | _ -> assert false) | Psubfloat -> ( - match args with [ e1; e2 ] -> E.float_minus e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.float_minus e1 e2 + | _ -> assert false) | Psubbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Minus e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Minus e1 e2 + | _ -> assert false) | Pmulint -> ( - match args with [ e1; e2 ] -> E.int32_mul e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_mul e1 e2 + | _ -> assert false) | Pmulfloat -> ( - match args with [ e1; e2 ] -> E.float_mul e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.float_mul e1 e2 + | _ -> assert false) | Pmulbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Mul e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Mul e1 e2 + | _ -> assert false) | Pdivfloat -> ( - match args with [ e1; e2 ] -> E.float_div e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.float_div e1 e2 + | _ -> assert false) | Pmodfloat -> ( - match args with [ e1; e2 ] -> E.float_mod e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.float_mod e1 e2 + | _ -> assert false) | Pdivint -> ( - match args with - | [ e1; e2 ] -> E.int32_div ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) + match args with + | [e1; e2] -> E.int32_div ~checked:!Js_config.check_div_by_zero e1 e2 + | _ -> assert false) | Pdivbigint -> ( - match args with - | [ e1; e2 ] -> E.bigint_div ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_div ~checked:!Js_config.check_div_by_zero e1 e2 + | _ -> assert false) | Pmodint -> ( - match args with - | [ e1; e2 ] -> E.int32_mod ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) + match args with + | [e1; e2] -> E.int32_mod ~checked:!Js_config.check_div_by_zero e1 e2 + | _ -> assert false) | Pmodbigint -> ( - match args with - | [ e1; e2 ] -> E.bigint_mod ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) - | Ppowbigint -> (match args with [ e1; e2 ] -> E.bigint_op Pow e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_mod ~checked:!Js_config.check_div_by_zero e1 e2 + | _ -> assert false) + | Ppowbigint -> ( + match args with + | [e1; e2] -> E.bigint_op Pow e1 e2 + | _ -> assert false) | Plslint -> ( - match args with [ e1; e2 ] -> E.int32_lsl e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_lsl e1 e2 + | _ -> assert false) | Plslbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Lsl e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Lsl e1 e2 + | _ -> assert false) | Plsrint -> ( - match args with - | [ e1; { J.expression_desc = Number (Int { i = 0l; _ }); _ } ] - -> - e1 - | [ e1; e2 ] -> E.to_int32 @@ E.int32_lsr e1 e2 - | _ -> assert false) + match args with + | [e1; {J.expression_desc = Number (Int {i = 0l; _}); _}] -> e1 + | [e1; e2] -> E.to_int32 @@ E.int32_lsr e1 e2 + | _ -> assert false) | Pasrint -> ( - match args with [ e1; e2 ] -> E.int32_asr e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_asr e1 e2 + | _ -> assert false) | Pasrbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Asr e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Asr e1 e2 + | _ -> assert false) | Pandint -> ( - match args with [ e1; e2 ] -> E.int32_band e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_band e1 e2 + | _ -> assert false) | Pandbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Band e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Band e1 e2 + | _ -> assert false) | Porint -> ( - match args with [ e1; e2 ] -> E.int32_bor e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_bor e1 e2 + | _ -> assert false) | Porbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Bor e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Bor e1 e2 + | _ -> assert false) | Pxorint -> ( - match args with [ e1; e2 ] -> E.int32_bxor e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.int32_bxor e1 e2 + | _ -> assert false) | Pxorbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Bxor e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_op Bxor e1 e2 + | _ -> assert false) | Pjscomp cmp -> ( - match args with [ l; r ] -> E.js_comp cmp l r | _ -> assert false) + match args with + | [l; r] -> E.js_comp cmp l r + | _ -> assert false) | Pboolcomp cmp -> ( - match args with [ e1; e2 ] -> E.bool_comp cmp e1 e2 | _ -> assert false - ) + match args with + | [e1; e2] -> E.bool_comp cmp e1 e2 + | _ -> assert false) | Pfloatcomp cmp | Pintcomp cmp -> ( - (* Global Builtin Exception is an int, like - [Not_found] or [Invalid_argument] ? - *) - match args with [ e1; e2 ] -> E.int_comp cmp e1 e2 | _ -> assert false) + (* Global Builtin Exception is an int, like + [Not_found] or [Invalid_argument] ? + *) + match args with + | [e1; e2] -> E.int_comp cmp e1 e2 + | _ -> assert false) | Pbigintcomp cmp -> ( - match args with [ e1; e2 ] -> E.bigint_comp cmp e1 e2 | _ -> assert false) + match args with + | [e1; e2] -> E.bigint_comp cmp e1 e2 + | _ -> assert false) (* List --> stamp = 0 Assert_false --> stamp = 26 *) | Pstringcomp cmp -> ( - match args with [ e1; e2 ] -> E.string_comp cmp e1 e2 | _ -> assert false - ) + match args with + | [e1; e2] -> E.string_comp cmp e1 e2 + | _ -> assert false) | Pintoffloat -> ( - match args with [ e ] -> E.to_int32 e | _ -> assert false) + match args with + | [e] -> E.to_int32 e + | _ -> assert false) | Pfloatofint -> Ext_list.singleton_exn args | Pnot -> E.not (Ext_list.singleton_exn args) | Poffsetint n -> E.offset (Ext_list.singleton_exn args) n | Poffsetref n -> - let v = - Js_of_lam_block.field Lambda.ref_field_info - (Ext_list.singleton_exn args) - 0l - in - E.seq (E.assign v (E.offset v n)) E.unit + let v = + Js_of_lam_block.field Lambda.ref_field_info + (Ext_list.singleton_exn args) + 0l + in + E.seq (E.assign v (E.offset v n)) E.unit | Psequand -> ( - (* TODO: rhs is possibly a tail call *) - match args with [ e1; e2 ] -> E.and_ e1 e2 | _ -> assert false) + (* TODO: rhs is possibly a tail call *) + match args with + | [e1; e2] -> E.and_ e1 e2 + | _ -> assert false) | Psequor -> ( - (* TODO: rhs is possibly a tail call *) - match args with [ e1; e2 ] -> E.or_ e1 e2 | _ -> assert false) + (* TODO: rhs is possibly a tail call *) + match args with + | [e1; e2] -> E.or_ e1 e2 + | _ -> assert false) | Pisout off -> ( - match args with - (* predicate: [x > range or x < 0 ] - can be simplified if x is positive , x > range - if x is negative, fine, its uint is for sure larger than range, - the output is not readable, we might change it back. + match args with + (* predicate: [x > range or x < 0 ] + can be simplified if x is positive , x > range + if x is negative, fine, its uint is for sure larger than range, + the output is not readable, we might change it back. - Note that if range is small like [1], then the negative of - it can be more precise (given integer) - a normal case of the compiler is that it will do a shift - in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ] - *) - | [ range; e ] -> E.is_out (E.offset e off) range - | _ -> assert false) + Note that if range is small like [1], then the negative of + it can be more precise (given integer) + a normal case of the compiler is that it will do a shift + in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ] + *) + | [range; e] -> E.is_out (E.offset e off) range + | _ -> assert false) | Pstringlength -> E.string_length (Ext_list.singleton_exn args) | Pstringrefs | Pstringrefu -> ( - match args with - | [ e; e1 ] -> E.runtime_call Primitive_modules.string "getChar" args - | _ -> assert false) + match args with + | [e; e1] -> E.runtime_call Primitive_modules.string "getChar" args + | _ -> assert false) (* polymorphic operations *) | Pobjcomp cmp -> ( - match args with - | [ e1; e2 ] - when cmp = Ceq && (E.for_sure_js_null_undefined e1 || E.for_sure_js_null_undefined e2) - -> - E.eq_null_undefined_boolean e1 e2 - | [ e1; e2 ] - when cmp = Cneq && (E.for_sure_js_null_undefined e1 || E.for_sure_js_null_undefined e2) - -> - E.neq_null_undefined_boolean e1 e2 - | [ e1; e2 ] -> - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - E.runtime_call Primitive_modules.object_ - (Lam_compile_util.runtime_of_comp cmp) args - | _ -> assert false) - | Pobjorder -> ( + match args with + | [e1; e2] + when cmp = Ceq + && (E.for_sure_js_null_undefined e1 + || E.for_sure_js_null_undefined e2) -> + E.eq_null_undefined_boolean e1 e2 + | [e1; e2] + when cmp = Cneq + && (E.for_sure_js_null_undefined e1 + || E.for_sure_js_null_undefined e2) -> + E.neq_null_undefined_boolean e1 e2 + | [e1; e2] -> Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - match args with - | [ a; b ] -> E.runtime_call Primitive_modules.object_ "compare" args - | _ -> assert false) + E.runtime_call Primitive_modules.object_ + (Lam_compile_util.runtime_of_comp cmp) + args + | _ -> assert false) + | Pobjorder -> ( + Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; + match args with + | [a; b] -> E.runtime_call Primitive_modules.object_ "compare" args + | _ -> assert false) | Pobjmin -> ( - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - match args with - | [ a; b ] -> E.runtime_call Primitive_modules.object_ "min" args - | _ -> assert false) + Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; + match args with + | [a; b] -> E.runtime_call Primitive_modules.object_ "min" args + | _ -> assert false) | Pobjmax -> ( - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - match args with - | [ a; b ] -> E.runtime_call Primitive_modules.object_ "max" args - | _ -> assert false) + Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; + match args with + | [a; b] -> E.runtime_call Primitive_modules.object_ "max" args + | _ -> assert false) | Pobjtag -> ( - (* Note that in ocaml, [int] has tag [1000] and [string] has tag [252] - also now we need do nullary check - *) - match args with [ e ] -> E.tag e | _ -> assert false) + (* Note that in ocaml, [int] has tag [1000] and [string] has tag [252] + also now we need do nullary check + *) + match args with + | [e] -> E.tag e + | _ -> assert false) | Pboolorder -> ( - match args with - | [ { expression_desc = Bool a }; { expression_desc = Bool b } ] -> - let c = compare (a : bool) b in - E.int (if c = 0 then 0l else if c > 0 then 1l else -1l) - | [ a; b ] -> E.runtime_call Primitive_modules.bool "compare" args - | _ -> assert false) + match args with + | [{expression_desc = Bool a}; {expression_desc = Bool b}] -> + let c = compare (a : bool) b in + E.int (if c = 0 then 0l else if c > 0 then 1l else -1l) + | [a; b] -> E.runtime_call Primitive_modules.bool "compare" args + | _ -> assert false) | Pboolmin -> ( - match args with - | [ { expression_desc = Bool _ } as a; { expression_desc = Bool _ } as b ] -> - if - Js_analyzer.is_okay_to_duplicate a - && Js_analyzer.is_okay_to_duplicate b - then E.econd (E.js_comp Clt a b) a b - else E.runtime_call Primitive_modules.bool "min" args - | [ a; b ] -> E.runtime_call Primitive_modules.bool "min" args - | _ -> assert false) + match args with + | [({expression_desc = Bool _} as a); ({expression_desc = Bool _} as b)] -> + if + Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b + then E.econd (E.js_comp Clt a b) a b + else E.runtime_call Primitive_modules.bool "min" args + | [a; b] -> E.runtime_call Primitive_modules.bool "min" args + | _ -> assert false) | Pboolmax -> ( - match args with - | [ { expression_desc = Bool _ } as a; { expression_desc = Bool _ } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Cgt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.bool "max" args - | _ -> assert false) + match args with + | [({expression_desc = Bool _} as a); ({expression_desc = Bool _} as b)] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Cgt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.bool "max" args + | _ -> assert false) | Pintorder -> ( - match args with - | [ a; b ] -> E.runtime_call Primitive_modules.int "compare" args - | _ -> assert false) + match args with + | [a; b] -> E.runtime_call Primitive_modules.int "compare" args + | _ -> assert false) | Pintmin -> ( - match args with - | [ { expression_desc = Number (Int _) } as a; { expression_desc = Number (Int _) } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Clt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.int "min" args - | _ -> assert false) + match args with + | [ + ({expression_desc = Number (Int _)} as a); + ({expression_desc = Number (Int _)} as b); + ] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Clt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.int "min" args + | _ -> assert false) | Pintmax -> ( - match args with - | [ { expression_desc = Number (Int _) } as a; { expression_desc = Number (Int _) } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Cgt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.int "max" args - | _ -> assert false) + match args with + | [ + ({expression_desc = Number (Int _)} as a); + ({expression_desc = Number (Int _)} as b); + ] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Cgt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.int "max" args + | _ -> assert false) | Pfloatorder -> ( - match args with - | [ a; b ] as args -> - E.runtime_call Primitive_modules.float "compare" args - | _ -> assert false) + match args with + | [a; b] as args -> E.runtime_call Primitive_modules.float "compare" args + | _ -> assert false) | Pfloatmin -> ( - match args with - | [ { expression_desc = Number (Float _) } as a; { expression_desc = Number (Float _) } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Clt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.float "min" args - | _ -> assert false) + match args with + | [ + ({expression_desc = Number (Float _)} as a); + ({expression_desc = Number (Float _)} as b); + ] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Clt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.float "min" args + | _ -> assert false) | Pfloatmax -> ( - match args with - | [ { expression_desc = Number (Float _) } as a; { expression_desc = Number (Float _) } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Cgt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.float "max" args - | _ -> assert false) + match args with + | [ + ({expression_desc = Number (Float _)} as a); + ({expression_desc = Number (Float _)} as b); + ] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Cgt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.float "max" args + | _ -> assert false) | Pbigintorder -> ( - match args with - | [ a; b ] -> E.runtime_call Primitive_modules.bigint "compare" args - | _ -> assert false) + match args with + | [a; b] -> E.runtime_call Primitive_modules.bigint "compare" args + | _ -> assert false) | Pbigintmin -> ( - match args with - | [ { expression_desc = Number (BigInt _) } as a; { expression_desc = Number (BigInt _) } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.bigint_comp Clt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.bigint "min" args - | _ -> assert false) + match args with + | [ + ({expression_desc = Number (BigInt _)} as a); + ({expression_desc = Number (BigInt _)} as b); + ] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.bigint_comp Clt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.bigint "min" args + | _ -> assert false) | Pbigintmax -> ( - match args with - | [ { expression_desc = Number (BigInt _) } as a; { expression_desc = Number (BigInt _) } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.bigint_comp Cgt a b) a b - | [ a; b ] -> E.runtime_call Primitive_modules.bigint "max" args - | _ -> assert false) + match args with + | [ + ({expression_desc = Number (BigInt _)} as a); + ({expression_desc = Number (BigInt _)} as b); + ] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.bigint_comp Cgt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.bigint "max" args + | _ -> assert false) | Pstringorder -> ( - match args with - | [ a; b ] -> E.runtime_call Primitive_modules.string "compare" args - | _ -> assert false) + match args with + | [a; b] -> E.runtime_call Primitive_modules.string "compare" args + | _ -> assert false) | Pstringmin -> ( - match args with - | [ { expression_desc = Str _ } as a; { expression_desc = Str _ } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Clt a b) a b - | [a; b] -> E.runtime_call Primitive_modules.string "min" args - | _ -> assert false) + match args with + | [({expression_desc = Str _} as a); ({expression_desc = Str _} as b)] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Clt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.string "min" args + | _ -> assert false) | Pstringmax -> ( - match args with - | [ { expression_desc = Str _ } as a; { expression_desc = Str _ } as b ] - when Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b -> - E.econd (E.js_comp Cgt a b) a b - | [a; b] -> E.runtime_call Primitive_modules.string "max" args - | _ -> assert false) + match args with + | [({expression_desc = Str _} as a); ({expression_desc = Str _} as b)] + when Js_analyzer.is_okay_to_duplicate a + && Js_analyzer.is_okay_to_duplicate b -> + E.econd (E.js_comp Cgt a b) a b + | [a; b] -> E.runtime_call Primitive_modules.string "max" args + | _ -> assert false) (* only when Lapply -> expand = true*) | Praise -> assert false (* handled before here *) (* Runtime encoding relevant *) | Parraylength -> E.array_length (Ext_list.singleton_exn args) | Psetfield (i, field_info) -> ( - match args with - | [ e0; e1 ] -> - (* RUNTIME *) - ensure_value_unit cxt.continuation - (Js_of_lam_block.set_field field_info e0 (Int32.of_int i) e1) - (*TODO: get rid of [E.unit ()]*) - | _ -> assert false) + match args with + | [e0; e1] -> + (* RUNTIME *) + ensure_value_unit cxt.continuation + (Js_of_lam_block.set_field field_info e0 (Int32.of_int i) e1) + (*TODO: get rid of [E.unit ()]*) + | _ -> assert false) | Parrayrefu -> ( - match args with - | [ e; e1 ] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *) - | _ -> assert false) + match args with + | [e; e1] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *) + | _ -> assert false) | Parrayrefs -> E.runtime_call Primitive_modules.array "get" args | Parraysets -> E.runtime_call Primitive_modules.array "set" args | Pmakearray -> Js_of_lam_array.make_array Mutable args | Pmakelist -> - Js_of_lam_block.make_block - (Js_op_util.of_lam_mutable_flag Mutable) - (Blk_constructor { name = "::"; num_nonconst = 1; tag = 0; attrs = [] }) - (E.small_int 0) - args + Js_of_lam_block.make_block + (Js_op_util.of_lam_mutable_flag Mutable) + (Blk_constructor {name = "::"; num_nonconst = 1; tag = 0; attrs = []}) + (E.small_int 0) args | Pmakedict -> ( match args with | [{expression_desc = Array (items, _)}] -> - E.obj + E.obj (items |> List.filter_map (fun (exp : J.expression) -> - match exp.expression_desc with - | Caml_block ([{expression_desc = Str {txt}}; expr], _, _, _) -> - Some (Js_op.Lit txt, expr) - | _ -> None)) + match exp.expression_desc with + | Caml_block ([{expression_desc = Str {txt}}; expr], _, _, _) -> + Some (Js_op.Lit txt, expr) + | _ -> None)) | _ -> assert false) | Parraysetu -> ( - match args with - (* wrong*) - | [ e; e0; e1 ] -> - ensure_value_unit cxt.continuation (Js_of_lam_array.set_array e e0 e1) - | _ -> assert false) + match args with + (* wrong*) + | [e; e0; e1] -> + ensure_value_unit cxt.continuation (Js_of_lam_array.set_array e e0 e1) + | _ -> assert false) | Pawait -> ( match args with | [e] -> {e with expression_desc = Await e} @@ -488,30 +579,31 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) (* Lam_compile_external_call.translate loc cxt prim args *) (* Test if the argument is a block or an immediate integer *) | Pjs_object_create _ -> assert false - | Pjs_call { arg_types; ffi; dynamic_import } -> - Lam_compile_external_call.translate_ffi cxt arg_types ffi args ~dynamic_import + | Pjs_call {arg_types; ffi; dynamic_import} -> + Lam_compile_external_call.translate_ffi cxt arg_types ffi args + ~dynamic_import (* FIXME, this can be removed later *) | Pisint -> E.is_type_number (Ext_list.singleton_exn args) | Pis_poly_var_block -> E.is_type_object (Ext_list.singleton_exn args) | Pduprecord -> ( - match args with - | [ e1 ] -> E.obj ~dup:e1 [] - | _ -> assert false) + match args with + | [e1] -> E.obj ~dup:e1 [] + | _ -> assert false) | Phash -> ( match args with - | [ e1; e2; e3; e4 ] -> E.runtime_call Primitive_modules.hash "hash" args + | [e1; e2; e3; e4] -> E.runtime_call Primitive_modules.hash "hash" args | _ -> assert false) | Phash_mixint -> ( match args with - | [ e1; e2 ] -> E.runtime_call Primitive_modules.hash "hash_mix_int" args + | [e1; e2] -> E.runtime_call Primitive_modules.hash "hash_mix_int" args | _ -> assert false) | Phash_mixstring -> ( match args with - | [ e1; e2 ] -> E.runtime_call Primitive_modules.hash "hash_mix_string" args + | [e1; e2] -> E.runtime_call Primitive_modules.hash "hash_mix_string" args | _ -> assert false) | Phash_finalmix -> ( match args with - | [ e1 ] -> E.runtime_call Primitive_modules.hash "hash_final_mix" args + | [e1] -> E.runtime_call Primitive_modules.hash "hash_final_mix" args | _ -> assert false) | Plazyforce (* FIXME: we don't inline lazy force or at least diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index 7d1f1c5ce2..6f132e9453 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -24,63 +24,60 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match const with - | Const_base (Const_int i) -> Const_int { i = Int32.of_int i; comment = None } + | Const_base (Const_int i) -> Const_int {i = Int32.of_int i; comment = None} | Const_base (Const_char i) -> Const_char i | Const_base (Const_string (s, opt)) -> - let unicode = - match opt with - | Some opt -> Ast_utf8_string_interp.is_unicode_string opt - | _ -> false - in - Const_string { s; unicode } + let unicode = + match opt with + | Some opt -> Ast_utf8_string_interp.is_unicode_string opt + | _ -> false + in + Const_string {s; unicode} | Const_base (Const_float i) -> Const_float i - | Const_base (Const_int32 i) -> Const_int { i; comment = None } + | Const_base (Const_int32 i) -> Const_int {i; comment = None} | Const_base (Const_int64 _) -> assert false | Const_base (Const_bigint (sign, i)) -> Const_bigint (sign, i) - | Const_pointer (0, Pt_constructor { name = "()"; const = 1; non_const = 0 }) - -> - Const_js_undefined {is_unit = true} + | Const_pointer (0, Pt_constructor {name = "()"; const = 1; non_const = 0}) -> + Const_js_undefined {is_unit = true} | Const_false -> Const_js_false | Const_true -> Const_js_true | Const_pointer (i, p) -> ( - match p with - | Pt_module_alias -> Const_module_alias - | Pt_shape_none -> Lam_constant.lam_none - | Pt_assertfalse -> - Const_int { i = Int32.of_int i; comment = Pt_assertfalse } - | Pt_constructor { name; const; non_const; attrs } -> - let tag_type = Ast_untagged_variants.process_tag_type attrs in - Const_int - { - i = Int32.of_int i; - comment = Pt_constructor { cstr_name={name; tag_type}; const; non_const }; - } - | Pt_variant { name } -> - if Ext_string.is_valid_hash_number name then - Const_int - { i = Ext_string.hash_number_as_i32_exn name; comment = None } - else Const_pointer name) + match p with + | Pt_module_alias -> Const_module_alias + | Pt_shape_none -> Lam_constant.lam_none + | Pt_assertfalse -> Const_int {i = Int32.of_int i; comment = Pt_assertfalse} + | Pt_constructor {name; const; non_const; attrs} -> + let tag_type = Ast_untagged_variants.process_tag_type attrs in + Const_int + { + i = Int32.of_int i; + comment = + Pt_constructor {cstr_name = {name; tag_type}; const; non_const}; + } + | Pt_variant {name} -> + if Ext_string.is_valid_hash_number name then + Const_int {i = Ext_string.hash_number_as_i32_exn name; comment = None} + else Const_pointer name) | Const_float_array s -> assert false - | Const_immstring s -> Const_string { s; unicode = false } + | Const_immstring s -> Const_string {s; unicode = false} | Const_block (t, xs) -> ( - let tag = Lambda.tag_of_tag_info t in - match t with - | Blk_some_not_nested -> - Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_record_inlined _ - | Blk_record_ext _ -> - Const_block (tag, t, Ext_list.map xs convert_constant) - | Blk_poly_var s -> ( - match xs with - | [ _; value ] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int - { i = Ext_string.hash_number_as_i32_exn s; comment = None } - else Const_string { s; unicode = false } - in - Const_block (tag, t, [ tag_val; convert_constant value ]) - | _ -> assert false) - | Blk_lazy_general -> assert false) + let tag = Lambda.tag_of_tag_info t in + match t with + | Blk_some_not_nested -> + Const_some (convert_constant (Ext_list.singleton_exn xs)) + | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs)) + | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ + | Blk_module_export _ | Blk_extension | Blk_record_inlined _ + | Blk_record_ext _ -> + Const_block (tag, t, Ext_list.map xs convert_constant) + | Blk_poly_var s -> ( + match xs with + | [_; value] -> + let tag_val : Lam_constant.t = + if Ext_string.is_valid_hash_number s then + Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None} + else Const_string {s; unicode = false} + in + Const_block (tag, t, [tag_val; convert_constant value]) + | _ -> assert false) + | Blk_lazy_general -> assert false) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 92651252c2..74131236ab 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -23,18 +23,18 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let caml_id_field_info : Lambda.field_dbg_info = - Fld_record { name = Literals.exception_id; mutable_flag = Immutable } + Fld_record {name = Literals.exception_id; mutable_flag = Immutable} let lam_caml_id : Lam_primitive.t = Pfield (0, caml_id_field_info) let prim = Lam.prim let lam_extension_id loc (head : Lam.t) = - prim ~primitive:lam_caml_id ~args:[ head ] loc + prim ~primitive:lam_caml_id ~args:[head] loc let lazy_block_info : Lam_tag_info.t = Blk_record { - fields = [| Literals.lazy_done; Literals.lazy_val |]; + fields = [|Literals.lazy_done; Literals.lazy_val|]; mutable_flag = Mutable; record_repr = Record_regular; } @@ -70,7 +70,9 @@ let lazy_block_info : Lam_tag_info.t = *) let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = let rec hit_opt (x : _ option) = - match x with None -> false | Some a -> hit a + match x with + | None -> false + | Some a -> hit a and hit_list_snd : 'a. ('a * _) list -> bool = fun x -> Ext_list.exists_snd x hit and hit_list xs = Ext_list.exists xs hit @@ -85,24 +87,24 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = | _, _ -> hit x || hit y end *) (* FIXME: this can be uncovered after we do the unboxing *) - | Lprim { primitive = Praise; args = [ Lvar _ ] } -> false - | Lprim { primitive = _; args; _ } -> hit_list args + | Lprim {primitive = Praise; args = [Lvar _]} -> false + | Lprim {primitive = _; args; _} -> hit_list args | Lvar id -> Ident.same id fv | Lassign (id, e) -> Ident.same id fv || hit e | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body + | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args + | Lapply {ap_func; ap_args; _} -> hit ap_func || hit_list ap_args | Lglobal_module _ (* global persistent module, play safe *) -> false | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction + hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks + || hit_opt sw.sw_failaction | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default + hit arg || hit_list_snd cases || hit_opt default | Lstaticraise (_, args) -> hit_list args | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 | Lsequence (e1, e2) -> hit e1 || hit e2 @@ -114,35 +116,33 @@ let abs_int x = if x < 0 then -x else x let no_over_flow x = abs_int x < 0x1fff_ffff let lam_is_var (x : Lam.t) (y : Ident.t) = - match x with Lvar y2 -> Ident.same y2 y | _ -> false + match x with + | Lvar y2 -> Ident.same y2 y + | _ -> false (** Make sure no int range overflow happens also we only check [int] *) -let happens_to_be_diff (sw_consts : (int * Lambda.lambda) list) sw_names : int option = +let happens_to_be_diff (sw_consts : (int * Lambda.lambda) list) sw_names : + int option = match sw_consts with - | ( a, - Lconst (Const_base (Const_int a0)) - ) - :: ( b, - Lconst - (Const_base (Const_int b0)) ) + | (a, Lconst (Const_base (Const_int a0))) + :: (b, Lconst (Const_base (Const_int b0))) :: rest - when sw_names = None && no_over_flow a && no_over_flow a0 && no_over_flow b && no_over_flow b0 - -> - let diff = a0 - a in - if b0 - b = diff then - if - Ext_list.for_all rest (fun (x, lam) -> - match lam with - | Lconst - ( Const_base (Const_int x0) ) - when no_over_flow x0 && no_over_flow x -> - x0 - x = diff - | _ -> false) - then Some diff - else None + when sw_names = None && no_over_flow a && no_over_flow a0 && no_over_flow b + && no_over_flow b0 -> + let diff = a0 - a in + if b0 - b = diff then + if + Ext_list.for_all rest (fun (x, lam) -> + match lam with + | Lconst (Const_base (Const_int x0)) + when no_over_flow x0 && no_over_flow x -> + x0 - x = diff + | _ -> false) + then Some diff else None + else None | _ -> None (* type required_modules = Lam_module_ident.Hash_set.t *) @@ -159,68 +159,62 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with | Pidentity -> Ext_list.singleton_exn args | Pnull -> Lam.const Const_js_null - | Pundefined -> Lam.const (Const_js_undefined { is_unit = false }) + | Pundefined -> Lam.const (Const_js_undefined {is_unit = false}) | Pccall _ -> assert false | Prevapply -> assert false | Pdirapply -> assert false | Ploc _ -> assert false (* already compiled away here*) | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc | Pextension_slot_eq -> ( - match args with - | [ lhs; rhs ] -> - prim - ~primitive:(Pstringcomp Ceq) - ~args:[ lam_extension_id loc lhs; rhs ] - loc - | _ -> assert false) + match args with + | [lhs; rhs] -> + prim ~primitive:(Pstringcomp Ceq) + ~args:[lam_extension_id loc lhs; rhs] + loc + | _ -> assert false) | Pwrap_exn -> prim ~primitive:Pwrap_exn ~args loc | Pignore -> - (* Pignore means return unit, it is not an nop *) - seq (Ext_list.singleton_exn args) unit + (* Pignore means return unit, it is not an nop *) + seq (Ext_list.singleton_exn args) unit | Pgetglobal _ -> assert false | Pmakeblock info -> ( - let tag = Lambda.tag_of_tag_info info in - let mutable_flag = Lambda.mutable_flag_of_tag_info info in - match info with - | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc - | Blk_some -> prim ~primitive:Psome ~args loc - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ -> - prim ~primitive:(Pmakeblock (tag, info, mutable_flag)) ~args loc - | Blk_poly_var s -> ( - match args with - | [ _; value ] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int - { i = Ext_string.hash_number_as_i32_exn s; comment = None } - else Const_string { s; unicode = false } - in - prim - ~primitive:(Pmakeblock (tag, info, mutable_flag)) - ~args:[ Lam.const tag_val; value ] - loc - | _ -> assert false) - | Blk_lazy_general -> ( - match args with - | [ ((Lvar _ | Lconst _ | Lfunction _) as result) ] -> - let args = [ Lam.const Const_js_true; result ] in - prim - ~primitive:(Pmakeblock (tag, lazy_block_info, Mutable)) - ~args loc - | [ computation ] -> - let args = - [ - Lam.const Const_js_false; - (* FIXME: arity 0 does not get proper supported*) - Lam.function_ ~arity:0 ~params:[] ~body:computation - ~attr:Lambda.default_function_attribute; - ] - in - prim - ~primitive:(Pmakeblock (tag, lazy_block_info, Mutable)) - ~args loc - | _ -> assert false)) + let tag = Lambda.tag_of_tag_info info in + let mutable_flag = Lambda.mutable_flag_of_tag_info info in + match info with + | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc + | Blk_some -> prim ~primitive:Psome ~args loc + | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ + | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ -> + prim ~primitive:(Pmakeblock (tag, info, mutable_flag)) ~args loc + | Blk_poly_var s -> ( + match args with + | [_; value] -> + let tag_val : Lam_constant.t = + if Ext_string.is_valid_hash_number s then + Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None} + else Const_string {s; unicode = false} + in + prim + ~primitive:(Pmakeblock (tag, info, mutable_flag)) + ~args:[Lam.const tag_val; value] + loc + | _ -> assert false) + | Blk_lazy_general -> ( + match args with + | [((Lvar _ | Lconst _ | Lfunction _) as result)] -> + let args = [Lam.const Const_js_true; result] in + prim ~primitive:(Pmakeblock (tag, lazy_block_info, Mutable)) ~args loc + | [computation] -> + let args = + [ + Lam.const Const_js_false; + (* FIXME: arity 0 does not get proper supported*) + Lam.function_ ~arity:0 ~params:[] ~body:computation + ~attr:Lambda.default_function_attribute; + ] + in + prim ~primitive:(Pmakeblock (tag, lazy_block_info, Mutable)) ~args loc + | _ -> assert false)) | Pfn_arity -> prim ~primitive:Pfn_arity ~args loc | Pdebugger -> prim ~primitive:Pdebugger ~args loc | Ptypeof -> prim ~primitive:Ptypeof ~args loc @@ -230,7 +224,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pundefined_to_opt -> prim ~primitive:Pundefined_to_opt ~args loc | Pis_not_none -> prim ~primitive:Pis_not_none ~args loc | Pval_from_option -> prim ~primitive:Pval_from_option ~args loc - | Pval_from_option_not_nest -> prim ~primitive:Pval_from_option_not_nest ~args loc + | Pval_from_option_not_nest -> + prim ~primitive:Pval_from_option_not_nest ~args loc | Pjscomp x -> prim ~primitive:(Pjscomp x) ~args loc | Pfield (id, info) -> prim ~primitive:(Pfield (id, info)) ~args loc | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc @@ -276,10 +271,10 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc | Pisint -> prim ~primitive:Pisint ~args loc | Pisout -> ( - match args with - | [ range; Lprim { primitive = Poffsetint i; args = [ x ] } ] -> - prim ~primitive:(Pisout i) ~args:[ range; x ] loc - | _ -> prim ~primitive:(Pisout 0) ~args loc) + match args with + | [range; Lprim {primitive = Poffsetint i; args = [x]}] -> + prim ~primitive:(Pisout i) ~args:[range; x] loc + | _ -> prim ~primitive:(Pisout 0) ~args loc) | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc @@ -323,13 +318,11 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pimport -> prim ~primitive:Pimport ~args loc | Pinit_mod -> ( match args with - | [ _loc; Lconst (Const_block (0, _, [ Const_block (0, _, []) ])) ] -> - Lam.unit + | [_loc; Lconst (Const_block (0, _, [Const_block (0, _, [])]))] -> Lam.unit | _ -> prim ~primitive:Pinit_mod ~args loc) | Pupdate_mod -> ( match args with - | [ Lconst (Const_block (0, _, [ Const_block (0, _, []) ])); _; _ ] -> - Lam.unit + | [Lconst (Const_block (0, _, [Const_block (0, _, [])])); _; _] -> Lam.unit | _ -> prim ~primitive:Pupdate_mod ~args loc) | Phash -> prim ~primitive:Phash ~args loc | Phash_mixint -> prim ~primitive:Phash_mixint ~args loc @@ -343,10 +336,10 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pjs_fn_make_unit -> prim ~primitive:Pjs_fn_make_unit ~args loc | Pjs_fn_method -> prim ~primitive:Pjs_fn_method ~args loc | Pjs_unsafe_downgrade -> - let primitive: Lam_primitive.t = - Pjs_unsafe_downgrade { name = Ext_string.empty; setter = false } - in - prim ~primitive ~args loc + let primitive : Lam_primitive.t = + Pjs_unsafe_downgrade {name = Ext_string.empty; setter = false} + in + prim ~primitive ~args loc (* Does not exist since we compile array in js backend unlike native backend *) @@ -359,23 +352,23 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [ Lvar ({ name = "*opt*" } as opt) ], p_loc), - Lprim (p1, [ Lvar ({ name = "*opt*" } as opt2) ], x_loc), + ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc), + Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc), f ), rest ) when Ident.same opt opt2 && List.mem opt params -> - let map, rest = rename_optional_parameters map params rest in - let new_id = Ident.create (id.name ^ "Opt") in - ( Map_ident.add map opt new_id, - Lambda.Llet - ( k, - value_kind, - id, - Lifthenelse - ( Lprim (p, [ Lvar new_id ], p_loc), - Lprim (p1, [ Lvar new_id ], x_loc), - f ), - rest ) ) + let map, rest = rename_optional_parameters map params rest in + let new_id = Ident.create (id.name ^ "Opt") in + ( Map_ident.add map opt new_id, + Lambda.Llet + ( k, + value_kind, + id, + Lifthenelse + ( Lprim (p, [Lvar new_id], p_loc), + Lprim (p1, [Lvar new_id], x_loc), + f ), + rest ) ) | _ -> (map, body) let convert (exports : Set_ident.t) (lam : Lambda.lambda) : @@ -389,151 +382,147 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let prim_name = a_prim.prim_name in match External_ffi_types.from_string a_prim.prim_native_name with | Ffi_obj_create labels -> - let args = Ext_list.map args convert_aux in - prim ~primitive:(Pjs_object_create labels) ~args loc + let args = Ext_list.map args convert_aux in + prim ~primitive:(Pjs_object_create labels) ~args loc | Ffi_bs (arg_types, result_type, ffi) -> - let arg_types = - match arg_types with - | Params ls -> ls - | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) - in - let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi arg_types result_type ffi args loc prim_name ~dynamic_import + let arg_types = + match arg_types with + | Params ls -> ls + | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) + in + let args = Ext_list.map args convert_aux in + Lam.handle_bs_non_obj_ffi arg_types result_type ffi args loc prim_name + ~dynamic_import | Ffi_inline_const i -> Lam.const i - | Ffi_normal -> Location.raise_errorf ~loc - "@{Error:@} internal error, using unrecognized \ - primitive %s" + | Ffi_normal -> + Location.raise_errorf ~loc + "@{Error:@} internal error, using unrecognized primitive %s" prim_name - and convert_aux ?(dynamic_import = false) (lam : Lambda.lambda) : Lam.t = match lam with | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x) | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) - | Lapply { ap_func = ((Lsend (name, obj, loc))); ap_args } when Ext_string.ends_with name Literals.setter_suffix -> + | Lapply {ap_func = Lsend (name, obj, loc); ap_args} + when Ext_string.ends_with name Literals.setter_suffix -> let obj = convert_aux obj in - let args = obj :: (Ext_list.map ap_args convert_aux) in + let args = obj :: Ext_list.map ap_args convert_aux in let property = - (String.sub name 0 - (String.length name - Literals.setter_suffix_len)) + String.sub name 0 (String.length name - Literals.setter_suffix_len) in prim - ~primitive:(Pjs_unsafe_downgrade { name = property; setter=true }) + ~primitive:(Pjs_unsafe_downgrade {name = property; setter = true}) ~args loc | Lsend (name, obj, loc) -> - let obj = convert_aux obj in - let args = [ obj ] in - let setter = Ext_string.ends_with name Literals.setter_suffix in - let _ = assert (not setter) in - prim - ~primitive:(Pjs_unsafe_downgrade { name; setter }) - ~args loc - | Lapply { ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined } -> - (* we need do this eargly in case [aux fn] add some wrapper *) - Lam.apply (convert_aux fn) - (Ext_list.map args convert_aux) - { ap_loc = loc; ap_inlined; ap_status = App_uncurry } - | Lfunction { params; body; attr } -> - let new_map, body = - rename_optional_parameters Map_ident.empty params body + let obj = convert_aux obj in + let args = [obj] in + let setter = Ext_string.ends_with name Literals.setter_suffix in + let _ = assert (not setter) in + prim ~primitive:(Pjs_unsafe_downgrade {name; setter}) ~args loc + | Lapply {ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined} -> + (* we need do this eargly in case [aux fn] add some wrapper *) + Lam.apply (convert_aux fn) + (Ext_list.map args convert_aux) + {ap_loc = loc; ap_inlined; ap_status = App_uncurry} + | Lfunction {params; body; attr} -> + let new_map, body = + rename_optional_parameters Map_ident.empty params body + in + if Map_ident.is_empty new_map then + Lam.function_ ~attr ~arity:(List.length params) ~params + ~body:(convert_aux body) + else + let params = + Ext_list.map params (fun x -> Map_ident.find_default new_map x x) in - if Map_ident.is_empty new_map then - Lam.function_ ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) - else - let params = - Ext_list.map params (fun x -> Map_ident.find_default new_map x x) - in - Lam.function_ ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) + Lam.function_ ~attr ~arity:(List.length params) ~params + ~body:(convert_aux body) | Llet (kind, Pgenval, id, e, body) (*FIXME*) -> convert_let kind id e body | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings convert_aux in - let body = convert_aux body in - let lam = Lam.letrec bindings body in - Lam_scc.scc bindings lam body + let bindings = Ext_list.map_snd bindings convert_aux in + let body = convert_aux body in + let lam = Lam.letrec bindings body in + Lam_scc.scc bindings lam body (* inlining will affect how mututal recursive behave *) - | Lprim (Prevapply, [ x; f ], outer_loc) - | Lprim (Pdirapply, [ f; x ], outer_loc) -> - convert_pipe f x outer_loc + | Lprim (Prevapply, [x; f], outer_loc) | Lprim (Pdirapply, [f; x], outer_loc) + -> + convert_pipe f x outer_loc | Lprim (Prevapply, _, _) -> assert false | Lprim (Pdirapply, _, _) -> assert false | Lprim (Pccall a, args, loc) -> convert_ccall a args loc ~dynamic_import | Lprim (Pjs_raw_expr, args, loc) -> ( - match args with - | [ Lconst (Const_base (Const_string (code, _))) ] -> - (* js parsing here *) - let kind = Classify_function.classify code in - prim - ~primitive:(Praw_js_code { code; code_info = Exp kind }) - ~args:[] loc - | _ -> assert false) - | Lprim(Pjs_raw_stmt, args, loc) -> ( - match args with - | [ Lconst (Const_base (Const_string (code, _))) ] -> - let kind = Classify_function.classify_stmt code in - prim - ~primitive:(Praw_js_code { code; code_info = Stmt kind }) - ~args:[] loc - | _ -> assert false) + match args with + | [Lconst (Const_base (Const_string (code, _)))] -> + (* js parsing here *) + let kind = Classify_function.classify code in + prim ~primitive:(Praw_js_code {code; code_info = Exp kind}) ~args:[] loc + | _ -> assert false) + | Lprim (Pjs_raw_stmt, args, loc) -> ( + match args with + | [Lconst (Const_base (Const_string (code, _)))] -> + let kind = Classify_function.classify_stmt code in + prim + ~primitive:(Praw_js_code {code; code_info = Stmt kind}) + ~args:[] loc + | _ -> assert false) | Lprim (Pgetglobal id, args, _) -> - let args = Ext_list.map args convert_aux in - if Ident.is_predef_exn id then - Lam.const (Const_string { s = id.name; unicode = false }) - else ( - may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); - assert (args = []); - Lam.global_module ~dynamic_import id) + let args = Ext_list.map args convert_aux in + if Ident.is_predef_exn id then + Lam.const (Const_string {s = id.name; unicode = false}) + else ( + may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); + assert (args = []); + Lam.global_module ~dynamic_import id) | Lprim (Pimport, args, loc) -> - let args = Ext_list.map args (convert_aux ~dynamic_import:true) in - lam_prim ~primitive:Pimport ~args loc + let args = Ext_list.map args (convert_aux ~dynamic_import:true) in + lam_prim ~primitive:Pimport ~args loc | Lprim (primitive, args, loc) -> - let args = Ext_list.map args (convert_aux ~dynamic_import) in - lam_prim ~primitive ~args loc + let args = Ext_list.map args (convert_aux ~dynamic_import) in + lam_prim ~primitive ~args loc | Lswitch (e, s, _loc) -> convert_switch e s | Lstringswitch (e, cases, default, _) -> - Lam.stringswitch (convert_aux e) - (Ext_list.map_snd cases convert_aux) - (Ext_option.map default convert_aux) + Lam.stringswitch (convert_aux e) + (Ext_list.map_snd cases convert_aux) + (Ext_option.map default convert_aux) | Lstaticraise (id, []) -> - Lam.staticraise (Hash_int.find_default exit_map id id) [] + Lam.staticraise (Hash_int.find_default exit_map id id) [] | Lstaticraise (id, args) -> - Lam.staticraise id (Ext_list.map args convert_aux) + Lam.staticraise id (Ext_list.map args convert_aux) | Lstaticcatch (b, (i, []), Lstaticraise (j, [])) -> - (* peep-hole [i] aliased to [j] *) - Hash_int.add exit_map i (Hash_int.find_default exit_map j j); - convert_aux b + (* peep-hole [i] aliased to [j] *) + Hash_int.add exit_map i (Hash_int.find_default exit_map j j); + convert_aux b | Lstaticcatch (b, (i, ids), handler) -> - Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) + Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) | Ltrywith (b, id, handler) -> - let body = convert_aux b in - let handler = convert_aux handler in - if exception_id_destructed handler id then - let new_id = Ident.create ("raw_" ^ id.name) in - Lam.try_ body new_id - (Lam.let_ StrictOpt id - (prim ~primitive:Pwrap_exn ~args:[ Lam.var new_id ] Location.none) - handler) - else Lam.try_ body id handler + let body = convert_aux b in + let handler = convert_aux handler in + if exception_id_destructed handler id then + let new_id = Ident.create ("raw_" ^ id.name) in + Lam.try_ body new_id + (Lam.let_ StrictOpt id + (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none) + handler) + else Lam.try_ body id handler | Lifthenelse (b, then_, else_) -> - Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_) + Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_) | Lsequence (a, b) -> Lam.seq (convert_aux a) (convert_aux b) | Lwhile (b, body) -> Lam.while_ (convert_aux b) (convert_aux body) | Lfor (id, from_, to_, dir, loop) -> - Lam.for_ id (convert_aux from_) (convert_aux to_) dir (convert_aux loop) + Lam.for_ id (convert_aux from_) (convert_aux to_) dir (convert_aux loop) | Lassign (id, body) -> Lam.assign id (convert_aux body) and convert_let (kind : Lam_compat.let_kind) id (e : Lambda.lambda) body : Lam.t = match (kind, e) with | Alias, Lvar u -> - let new_u = Hash_ident.find_default alias_tbl u u in - Hash_ident.add alias_tbl id new_u; - if Set_ident.mem exports id then - Lam.let_ kind id (Lam.var new_u) (convert_aux body) - else convert_aux body + let new_u = Hash_ident.find_default alias_tbl u u in + Hash_ident.add alias_tbl id new_u; + if Set_ident.mem exports id then + Lam.let_ kind id (Lam.var new_u) (convert_aux body) + else convert_aux body | _, _ -> ( - let new_e = convert_aux e in - let new_body = convert_aux body in - (* + let new_e = convert_aux e in + let new_body = convert_aux body in + (* reverse engineering cases as {[ (let (switcher/1013 =a (-1+ match/1012)) (if (isout 2 switcher/1013) (exit 1) @@ -547,65 +536,56 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : To advance this case, when [sw_failaction] is None *) - match (kind, new_e, new_body) with - | ( Alias, - Lprim - { primitive = Poffsetint offset; args = [ (Lvar _ as matcher) ] }, - Lswitch - ( Lvar switcher3, - ({ - sw_consts_full = false; - sw_consts; - sw_blocks = []; - sw_blocks_full = true; - sw_failaction = Some ifso; - } as px) ) ) - when Ident.same switcher3 id - && (not (Lam_hit.hit_variable id ifso)) - && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) - -> - Lam.switch matcher - { - px with - sw_consts = - Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); - } - | _ -> Lam.let_ kind id new_e new_body) + match (kind, new_e, new_body) with + | ( Alias, + Lprim {primitive = Poffsetint offset; args = [(Lvar _ as matcher)]}, + Lswitch + ( Lvar switcher3, + ({ + sw_consts_full = false; + sw_consts; + sw_blocks = []; + sw_blocks_full = true; + sw_failaction = Some ifso; + } as px) ) ) + when Ident.same switcher3 id + && (not (Lam_hit.hit_variable id ifso)) + && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) -> + Lam.switch matcher + { + px with + sw_consts = + Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); + } + | _ -> Lam.let_ kind id new_e new_body) and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = let x = convert_aux x in let f = convert_aux f in match f with | Lfunction - { - params = [ param ]; - body = Lprim { primitive; args = [ Lvar inner_arg ] }; - } + {params = [param]; body = Lprim {primitive; args = [Lvar inner_arg]}} when Ident.same param inner_arg -> - Lam.prim ~primitive ~args:[ x ] outer_loc + Lam.prim ~primitive ~args:[x] outer_loc | Lapply { ap_func = - Lfunction { params; body = Lprim { primitive; args = inner_args } }; + Lfunction {params; body = Lprim {primitive; args = inner_args}}; ap_args = args; } when Ext_list.for_all2_no_exn inner_args params lam_is_var && Ext_list.length_larger_than_n inner_args args 1 -> - Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply ap_func - (Ext_list.append_one ap_args x) - { - ap_loc = outer_loc; - ap_inlined = ap_info.ap_inlined; - ap_status = App_na; - } + Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc + | Lapply {ap_func; ap_args; ap_info} -> + Lam.apply ap_func + (Ext_list.append_one ap_args x) + { + ap_loc = outer_loc; + ap_inlined = ap_info.ap_inlined; + ap_status = App_na; + } | _ -> - Lam.apply f [ x ] - { - ap_loc = outer_loc; - ap_inlined = Default_inline; - ap_status = App_na; - } + Lam.apply f [x] + {ap_loc = outer_loc; ap_inlined = Default_inline; ap_status = App_na} and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = let e = convert_aux e in match s with @@ -617,36 +597,32 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : sw_numconsts; sw_names; } -> ( - match happens_to_be_diff sw_consts sw_names with - | Some 0 -> e - | Some i -> - prim ~primitive:Paddint - ~args: - [ - e; - Lam.const (Const_int { i = Int32.of_int i; comment = None }); - ] - Location.none - | _ -> - Lam.switch e - { - sw_failaction = None; - sw_blocks = []; - sw_blocks_full = true; - sw_consts = Ext_list.map_snd sw_consts convert_aux; - sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; - sw_names = s.sw_names; - }) - | _ -> + match happens_to_be_diff sw_consts sw_names with + | Some 0 -> e + | Some i -> + prim ~primitive:Paddint + ~args:[e; Lam.const (Const_int {i = Int32.of_int i; comment = None})] + Location.none + | _ -> Lam.switch e { - sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; - sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; - sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; - sw_failaction = Ext_option.map s.sw_failaction convert_aux; + sw_failaction = None; + sw_blocks = []; + sw_blocks_full = true; + sw_consts = Ext_list.map_snd sw_consts convert_aux; + sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; sw_names = s.sw_names; - } + }) + | _ -> + Lam.switch e + { + sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; + sw_consts = Ext_list.map_snd s.sw_consts convert_aux; + sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; + sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; + sw_failaction = Ext_option.map s.sw_failaction convert_aux; + sw_names = s.sw_names; + } in (convert_aux lam, may_depends) diff --git a/compiler/core/lam_dce.ml b/compiler/core/lam_dce.ml index a51cabbc0c..ee476b3da8 100644 --- a/compiler/core/lam_dce.ml +++ b/compiler/core/lam_dce.ml @@ -30,8 +30,8 @@ let transitive_closure (initial_idents : Ident.t list) Hash_set_ident.add visited id; match Hash_ident.find_opt ident_freevars id with | None -> - Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found" (Ident.name id) - id.stamp + Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found" (Ident.name id) + id.stamp | Some e -> Set_ident.iter e dfs) in Ext_list.iter initial_idents dfs; @@ -46,33 +46,37 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = Ext_list.fold_left rest export_idents (fun acc x -> match x with | Single (kind, id, lam) -> ( - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); - match kind with - | Alias | StrictOpt -> acc - | Strict | Variable -> id :: acc) + Hash_ident.add ident_free_vars id + (Lam_free_variables.pass_free_variables lam); + match kind with + | Alias | StrictOpt -> acc + | Strict | Variable -> id :: acc) | Recursive bindings -> - Ext_list.fold_left bindings acc (fun acc (id, lam) -> - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); - match lam with Lfunction _ -> acc | _ -> id :: acc) + Ext_list.fold_left bindings acc (fun acc (id, lam) -> + Hash_ident.add ident_free_vars id + (Lam_free_variables.pass_free_variables lam); + match lam with + | Lfunction _ -> acc + | _ -> id :: acc) | Nop lam -> - if Lam_analysis.no_side_effects lam then acc - else - (* its free varaibles here will be defined above *) - Set_ident.fold (Lam_free_variables.pass_free_variables lam) acc - (fun x acc -> x :: acc)) + if Lam_analysis.no_side_effects lam then acc + else + (* its free varaibles here will be defined above *) + Set_ident.fold (Lam_free_variables.pass_free_variables lam) acc + (fun x acc -> x :: acc)) in let visited = transitive_closure initial_idents ident_free_vars in Ext_list.fold_left rest [] (fun acc x -> match x with | Single (_, id, _) -> - if Hash_set_ident.mem visited id then x :: acc else acc + if Hash_set_ident.mem visited id then x :: acc else acc | Nop _ -> x :: acc | Recursive bindings -> ( - let b = - Ext_list.fold_right bindings [] (fun ((id, _) as v) acc -> - if Hash_set_ident.mem visited id then v :: acc else acc) - in - match b with [] -> acc | _ -> Recursive b :: acc)) + let b = + Ext_list.fold_right bindings [] (fun ((id, _) as v) acc -> + if Hash_set_ident.mem visited id then v :: acc else acc) + in + match b with + | [] -> acc + | _ -> Recursive b :: acc)) |> List.rev diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml index 50ec2e8357..220fa76022 100644 --- a/compiler/core/lam_eta_conversion.ml +++ b/compiler/core/lam_eta_conversion.ml @@ -42,36 +42,36 @@ let transform_under_supply n ap_info fn args = match lam with | Lvar _ | Lconst - ( Const_int _ | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ - | Const_pointer _ | Const_js_true | Const_js_false + ( Const_int _ | Const_char _ | Const_string _ | Const_float _ + | Const_bigint _ | Const_pointer _ | Const_js_true | Const_js_false | Const_js_undefined _ ) - | Lprim { primitive = Pfield (_, Fld_module _); _ } + | Lprim {primitive = Pfield (_, Fld_module _); _} | Lfunction _ -> - (lam :: acc, bind) + (lam :: acc, bind) | _ -> - let v = Ident.create Literals.partial_arg in - (Lam.var v :: acc, (v, lam) :: bind)) + let v = Ident.create Literals.partial_arg in + (Lam.var v :: acc, (v, lam) :: bind)) with | fn :: args, [] -> - (* More than no side effect in the [args], - we try to avoid computation, so even if - [x + y] is side effect free, we need eval it only once - *) - (* TODO: Note we could adjust [fn] if [fn] is already a function - But it is dangerous to change the arity - of an existing function which may cause inconsistency - *) + (* More than no side effect in the [args], + we try to avoid computation, so even if + [x + y] is side effect free, we need eval it only once + *) + (* TODO: Note we could adjust [fn] if [fn] is already a function + But it is dangerous to change the arity + of an existing function which may cause inconsistency + *) + Lam.function_ ~arity:n ~params:extra_args + ~attr:Lambda.default_function_attribute + ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) + | fn :: args, bindings -> + let rest : Lam.t = Lam.function_ ~arity:n ~params:extra_args ~attr:Lambda.default_function_attribute ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - | fn :: args, bindings -> - let rest : Lam.t = - Lam.function_ ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - in - Ext_list.fold_left bindings rest (fun lam (id, x) -> - Lam.let_ Strict id x lam) + in + Ext_list.fold_left bindings rest (fun lam (id, x) -> + Lam.let_ Strict id x lam) | _, _ -> assert false (* Invariant: mk0 : (unit -> 'a0) -> 'a0 t @@ -111,188 +111,189 @@ let transform_under_supply n ap_info fn args = let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : Lam.t = let ap_info : Lam.ap_info = - { ap_loc = loc; ap_inlined = Default_inline; ap_status = App_na } + {ap_loc = loc; ap_inlined = Default_inline; ap_status = App_na} + in + let is_async_fn = + match fn with + | Lfunction {attr = {async}} -> async + | _ -> false in - let is_async_fn = match fn with - | Lfunction { attr = {async}} -> async - | _ -> false in match (from, fn) with - | Some from, _ | None, Lfunction { arity = from } -> ( - if from = to_ || is_async_fn then fn - else if to_ = 0 then - match fn with - | Lfunction { params = [ param ]; body } -> - Lam.function_ ~arity:0 ~attr:Lambda.default_function_attribute - ~params:[] - ~body:(Lam.let_ Alias param Lam.unit body) - (* could be only introduced by - {[ Pjs_fn_make 0 ]} <- - {[ fun [@bs] () -> .. ]} - *) - | _ -> ( - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - - let cont = - Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 - ~params:[] - ~body:(Lam.apply new_fn [ Lam.unit ] ap_info) - in - - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) - else if to_ > from then - match fn with - | Lfunction { params; body } -> - (* {[fun x -> f]} -> - {[ fun x y -> f y ]} - *) - let extra_args = - Ext_list.init (to_ - from) (fun _ -> Ident.create Literals.param) - in - let rec mk_apply body vars = match vars with - | [] -> body - | var :: vars -> - mk_apply (Lam.apply body [var] ap_info) vars in - Lam.function_ ~attr:Lambda.default_function_attribute ~arity:to_ - ~params:(Ext_list.append params extra_args) - ~body:(mk_apply body (Ext_list.map extra_args Lam.var)) - | _ -> ( - let arity = to_ in - let extra_args = - Ext_list.init to_ (fun _ -> Ident.create Literals.param) - in - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - let cont = - Lam.function_ ~arity ~attr:Lambda.default_function_attribute - ~params:extra_args - ~body: - (let first_args, rest_args = - Ext_list.split_at extra_args from - in - Lam.apply - (Lam.apply new_fn - (Ext_list.map first_args Lam.var) - { ap_info with ap_status = App_infer_full }) - (Ext_list.map rest_args Lam.var) - ap_info) - in - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) - else - (* add3 --adjust to arity 1 -> - fun x -> (fun y z -> add3 x y z ) - - [fun x y z -> f x y z ] - [fun x -> [fun y z -> f x y z ]] - This is okay if the function is not held by other.. + | Some from, _ | None, Lfunction {arity = from} -> ( + if from = to_ || is_async_fn then fn + else if to_ = 0 then + match fn with + | Lfunction {params = [param]; body} -> + Lam.function_ ~arity:0 ~attr:Lambda.default_function_attribute + ~params:[] + ~body:(Lam.let_ Alias param Lam.unit body) + (* could be only introduced by + {[ Pjs_fn_make 0 ]} <- + {[ fun [@bs] () -> .. ]} *) - match fn with - | Lfunction { params; body } - (* TODO check arity = List.length params in debug mode *) -> - let arity = to_ in - let extra_outer_args, extra_inner_args = - Ext_list.split_at params arity - in - Lam.function_ ~arity ~attr:Lambda.default_function_attribute - ~params:extra_outer_args - ~body: - (Lam.function_ ~arity:(from - to_) - ~attr:Lambda.default_function_attribute - ~params:extra_inner_args ~body) - | _ -> ( - let extra_outer_args = - Ext_list.init to_ (fun _ -> Ident.create Literals.param) - in - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - let cont = - Lam.function_ ~arity:to_ ~params:extra_outer_args - ~attr:Lambda.default_function_attribute - ~body: - (let arity = from - to_ in - let extra_inner_args = - Ext_list.init arity (fun _ -> Ident.create Literals.param) - in - Lam.function_ ~arity ~params:extra_inner_args - ~attr:Lambda.default_function_attribute - ~body: - (Lam.apply new_fn - (Ext_list.map_append extra_outer_args - (Ext_list.map extra_inner_args Lam.var) - Lam.var) - { ap_info with ap_status = App_infer_full })) - in - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont)) - | None, _ -> - (* In this case [fn] is not [Lfunction], otherwise we would get [arity] *) - if to_ = 0 then + | _ -> ( let wrapper, new_fn = match fn with | Lvar _ | Lprim { primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; + args = [(Lglobal_module _ | Lvar _)]; _; } -> - (None, fn) + (None, fn) | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) + let partial_arg = Ext_ident.create Literals.partial_arg in + (Some partial_arg, Lam.var partial_arg) in let cont = Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 ~params:[] - ~body:(Lam.apply new_fn [ Lam.unit ] ap_info) + ~body:(Lam.apply new_fn [Lam.unit] ap_info) in match wrapper with | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont - else transform_under_supply to_ ap_info fn [] + | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) + else if to_ > from then + match fn with + | Lfunction {params; body} -> + (* {[fun x -> f]} -> + {[ fun x y -> f y ]} + *) + let extra_args = + Ext_list.init (to_ - from) (fun _ -> Ident.create Literals.param) + in + let rec mk_apply body vars = + match vars with + | [] -> body + | var :: vars -> mk_apply (Lam.apply body [var] ap_info) vars + in + Lam.function_ ~attr:Lambda.default_function_attribute ~arity:to_ + ~params:(Ext_list.append params extra_args) + ~body:(mk_apply body (Ext_list.map extra_args Lam.var)) + | _ -> ( + let arity = to_ in + let extra_args = + Ext_list.init to_ (fun _ -> Ident.create Literals.param) + in + let wrapper, new_fn = + match fn with + | Lvar _ + | Lprim + { + primitive = Pfield (_, Fld_module _); + args = [(Lglobal_module _ | Lvar _)]; + _; + } -> + (None, fn) + | _ -> + let partial_arg = Ext_ident.create Literals.partial_arg in + (Some partial_arg, Lam.var partial_arg) + in + let cont = + Lam.function_ ~arity ~attr:Lambda.default_function_attribute + ~params:extra_args + ~body: + (let first_args, rest_args = Ext_list.split_at extra_args from in + Lam.apply + (Lam.apply new_fn + (Ext_list.map first_args Lam.var) + {ap_info with ap_status = App_infer_full}) + (Ext_list.map rest_args Lam.var) + ap_info) + in + match wrapper with + | None -> cont + | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) + else + (* add3 --adjust to arity 1 -> + fun x -> (fun y z -> add3 x y z ) + + [fun x y z -> f x y z ] + [fun x -> [fun y z -> f x y z ]] + This is okay if the function is not held by other.. + *) + match fn with + | Lfunction {params; body} + (* TODO check arity = List.length params in debug mode *) -> + let arity = to_ in + let extra_outer_args, extra_inner_args = + Ext_list.split_at params arity + in + Lam.function_ ~arity ~attr:Lambda.default_function_attribute + ~params:extra_outer_args + ~body: + (Lam.function_ ~arity:(from - to_) + ~attr:Lambda.default_function_attribute ~params:extra_inner_args + ~body) + | _ -> ( + let extra_outer_args = + Ext_list.init to_ (fun _ -> Ident.create Literals.param) + in + let wrapper, new_fn = + match fn with + | Lvar _ + | Lprim + { + primitive = Pfield (_, Fld_module _); + args = [(Lglobal_module _ | Lvar _)]; + _; + } -> + (None, fn) + | _ -> + let partial_arg = Ext_ident.create Literals.partial_arg in + (Some partial_arg, Lam.var partial_arg) + in + let cont = + Lam.function_ ~arity:to_ ~params:extra_outer_args + ~attr:Lambda.default_function_attribute + ~body: + (let arity = from - to_ in + let extra_inner_args = + Ext_list.init arity (fun _ -> Ident.create Literals.param) + in + Lam.function_ ~arity ~params:extra_inner_args + ~attr:Lambda.default_function_attribute + ~body: + (Lam.apply new_fn + (Ext_list.map_append extra_outer_args + (Ext_list.map extra_inner_args Lam.var) + Lam.var) + {ap_info with ap_status = App_infer_full})) + in + match wrapper with + | None -> cont + | Some partial_arg -> Lam.let_ Strict partial_arg fn cont)) + | None, _ -> + (* In this case [fn] is not [Lfunction], otherwise we would get [arity] *) + if to_ = 0 then + let wrapper, new_fn = + match fn with + | Lvar _ + | Lprim + { + primitive = Pfield (_, Fld_module _); + args = [(Lglobal_module _ | Lvar _)]; + _; + } -> + (None, fn) + | _ -> + let partial_arg = Ext_ident.create Literals.partial_arg in + (Some partial_arg, Lam.var partial_arg) + in + + let cont = + Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 + ~params:[] + ~body:(Lam.apply new_fn [Lam.unit] ap_info) + in + + match wrapper with + | None -> cont + | Some partial_arg -> Lam.let_ Strict partial_arg fn cont + else transform_under_supply to_ ap_info fn [] (* | _ -> let partial_arg = Ext_ident.create Literals.partial_arg in diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index 10bee18a03..d9535ac2ee 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -53,58 +53,58 @@ let count_helper (lam : Lam.t) : collection = let rec count (lam : Lam.t) = match lam with | Lstaticraise (i, ls) -> - incr_exit exits i; - Ext_list.iter ls count + incr_exit exits i; + Ext_list.iter ls count | Lstaticcatch (l1, (i, _), l2) -> - count l1; - if count_exit exits i > 0 then count l2 + count l1; + if count_exit exits i > 0 then count l2 | Lstringswitch (l, sw, d) -> - count l; - Ext_list.iter_snd sw count; - Ext_option.iter d count + count l; + Ext_list.iter_snd sw count; + Ext_option.iter d count | Lglobal_module _ | Lvar _ | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - count ap_func; - Ext_list.iter ap_args count - | Lfunction { body } -> count body + | Lapply {ap_func; ap_args; _} -> + count ap_func; + Ext_list.iter ap_args count + | Lfunction {body} -> count body | Llet (_, _, l1, l2) -> - count l2; - count l1 + count l2; + count l1 | Lletrec (bindings, body) -> - Ext_list.iter_snd bindings count; - count body - | Lprim { args; _ } -> List.iter count args + Ext_list.iter_snd bindings count; + count body + | Lprim {args; _} -> List.iter count args | Lswitch (l, sw) -> - count_default sw; - count l; - Ext_list.iter_snd sw.sw_consts count; - Ext_list.iter_snd sw.sw_blocks count + count_default sw; + count l; + Ext_list.iter_snd sw.sw_consts count; + Ext_list.iter_snd sw.sw_blocks count | Ltrywith (l1, _v, l2) -> - count l1; - count l2 + count l1; + count l2 | Lifthenelse (l1, l2, l3) -> - count l1; - count l2; - count l3 + count l1; + count l2; + count l3 | Lsequence (l1, l2) -> - count l1; - count l2 + count l1; + count l2 | Lwhile (l1, l2) -> - count l1; - count l2 + count l1; + count l2 | Lfor (_, l1, l2, _dir, l3) -> - count l1; - count l2; - count l3 + count l1; + count l2; + count l3 | Lassign (_, l) -> count l and count_default sw = match sw.sw_failaction with | None -> () | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - count al; - count al) - else count al + if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( + count al; + count al) + else count al in count lam; exits diff --git a/compiler/core/lam_free_variables.ml b/compiler/core/lam_free_variables.ml index f832848304..1fdd31f1c6 100644 --- a/compiler/core/lam_free_variables.ml +++ b/compiler/core/lam_free_variables.ml @@ -31,61 +31,61 @@ let pass_free_variables (l : Lam.t) : Set_ident.t = match l with | Lvar id -> fv := Set_ident.add !fv id | Lassign (id, e) -> - free e; - fv := Set_ident.add !fv id + free e; + fv := Set_ident.add !fv id | Lstaticcatch (e1, (_, vars), e2) -> - free e1; - free e2; - Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id) + free e1; + free e2; + Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id) | Ltrywith (e1, exn, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv exn - | Lfunction { body; params } -> - free body; - Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) + free e1; + free e2; + fv := Set_ident.remove !fv exn + | Lfunction {body; params} -> + free body; + Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) | Llet (_str, id, arg, body) -> - free arg; - free body; - fv := Set_ident.remove !fv id + free arg; + free body; + fv := Set_ident.remove !fv id | Lletrec (decl, body) -> - free body; - free_list_snd decl; - Ext_list.iter decl (fun (id, _exp) -> fv := Set_ident.remove !fv id) + free body; + free_list_snd decl; + Ext_list.iter decl (fun (id, _exp) -> fv := Set_ident.remove !fv id) | Lfor (v, e1, e2, _dir, e3) -> - free e1; - free e2; - free e3; - fv := Set_ident.remove !fv v + free e1; + free e2; + free e3; + fv := Set_ident.remove !fv v | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - free ap_func; - free_list ap_args + | Lapply {ap_func; ap_args; _} -> + free ap_func; + free_list ap_args | Lglobal_module _ -> () (* according to the existing semantics: [primitive] is not counted *) - | Lprim { args; _ } -> free_list args + | Lprim {args; _} -> free_list args | Lswitch (arg, sw) -> - free arg; - free_list_snd sw.sw_consts; - free_list_snd sw.sw_blocks; - Ext_option.iter sw.sw_failaction free + free arg; + free_list_snd sw.sw_consts; + free_list_snd sw.sw_blocks; + Ext_option.iter sw.sw_failaction free | Lstringswitch (arg, cases, default) -> - free arg; - free_list_snd cases; - Ext_option.iter default free + free arg; + free_list_snd cases; + Ext_option.iter default free | Lstaticraise (_, args) -> free_list args | Lifthenelse (e1, e2, e3) -> - free e1; - free e2; - free e3 + free e1; + free e2; + free e3 | Lsequence (e1, e2) -> - free e1; - free e2 + free e1; + free e2 | Lwhile (e1, e2) -> - free e1; - free e2 + free e1; + free e2 in free l; !fv diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 58b24f9844..357222cd64 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -34,7 +34,9 @@ let single (kind : Lam_compat.let_kind) id (body : Lam.t) = | _ -> Single (kind, id, body) let nop_cons (x : Lam.t) acc = - match x with Lvar _ | Lconst _ | Lfunction _ -> acc | _ -> Nop x :: acc + match x with + | Lvar _ | Lconst _ | Lfunction _ -> acc + | _ -> Nop x :: acc (* let pp = Format.fprintf *) @@ -48,12 +50,12 @@ let str_of_kind (kind : Lam_compat.let_kind) = let pp_group fmt (x : t) = match x with | Single (kind, id, lam) -> - Format.fprintf fmt "@[let@ %a@ =%s@ @[%a@]@ @]" Ident.print id - (str_of_kind kind) Lam_print.lambda lam + Format.fprintf fmt "@[let@ %a@ =%s@ @[%a@]@ @]" Ident.print id + (str_of_kind kind) Lam_print.lambda lam | Recursive lst -> - List.iter - (fun (id, lam) -> - Format.fprintf fmt "@[let %a@ =r@ %a@ @]" Ident.print id - Lam_print.lambda lam) - lst + List.iter + (fun (id, lam) -> + Format.fprintf fmt "@[let %a@ =r@ %a@ @]" Ident.print id + Lam_print.lambda lam) + lst | Nop lam -> Lam_print.lambda fmt lam diff --git a/compiler/core/lam_hit.ml b/compiler/core/lam_hit.ml index 032fb3202c..dd1c2c9270 100644 --- a/compiler/core/lam_hit.ml +++ b/compiler/core/lam_hit.ml @@ -26,7 +26,9 @@ type t = Lam.t let hit_variables (fv : Set_ident.t) (l : t) : bool = let rec hit_opt (x : t option) = - match x with None -> false | Some a -> hit a + match x with + | None -> false + | Some a -> hit a and hit_var (id : Ident.t) = Set_ident.mem fv id and hit_list_snd : 'a. ('a * t) list -> bool = fun x -> Ext_list.exists_snd x hit @@ -37,19 +39,19 @@ let hit_variables (fv : Set_ident.t) (l : t) : bool = | Lassign (id, e) -> hit_var id || hit e | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body + | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args + | Lapply {ap_func; ap_args; _} -> hit ap_func || hit_list ap_args | Lglobal_module _ (* global persistent module, play safe *) -> false - | Lprim { args; _ } -> hit_list args + | Lprim {args; _} -> hit_list args | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction + hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks + || hit_opt sw.sw_failaction | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default + hit arg || hit_list_snd cases || hit_opt default | Lstaticraise (_, args) -> hit_list args | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 | Lsequence (e1, e2) -> hit e1 || hit e2 @@ -59,7 +61,9 @@ let hit_variables (fv : Set_ident.t) (l : t) : bool = let hit_variable (fv : Ident.t) (l : t) : bool = let rec hit_opt (x : t option) = - match x with None -> false | Some a -> hit a + match x with + | None -> false + | Some a -> hit a and hit_var (id : Ident.t) = Ident.same id fv and hit_list_snd : 'a. ('a * t) list -> bool = fun x -> Ext_list.exists_snd x hit @@ -70,19 +74,19 @@ let hit_variable (fv : Ident.t) (l : t) : bool = | Lassign (id, e) -> hit_var id || hit e | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body + | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args + | Lapply {ap_func; ap_args; _} -> hit ap_func || hit_list ap_args | Lglobal_module _ (* global persistent module, play safe *) -> false - | Lprim { args; _ } -> hit_list args + | Lprim {args; _} -> hit_list args | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction + hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks + || hit_opt sw.sw_failaction | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default + hit arg || hit_list_snd cases || hit_opt default | Lstaticraise (_, args) -> hit_list args | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 | Lsequence (e1, e2) -> hit e1 || hit e2 diff --git a/compiler/core/lam_id_kind.ml b/compiler/core/lam_id_kind.ml index 4a74ffbda9..b7967fb15f 100644 --- a/compiler/core/lam_id_kind.ml +++ b/compiler/core/lam_id_kind.ml @@ -43,11 +43,11 @@ type t = | Constant of Lam_constant.t | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { - mutable arity : Lam_arity.t; + mutable arity: Lam_arity.t; (* TODO: This may contain some closure environment, check how it will interact with dead code elimination *) - lambda : (Lam.t * rec_flag) option; + lambda: (Lam.t * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_id_kind.mli b/compiler/core/lam_id_kind.mli index 0709a5357d..040a63a417 100644 --- a/compiler/core/lam_id_kind.mli +++ b/compiler/core/lam_id_kind.mli @@ -55,8 +55,8 @@ type t = | Constant of Lam_constant.t | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { - mutable arity : Lam_arity.t; - lambda : (Lam.t * rec_flag) option; + mutable arity: Lam_arity.t; + lambda: (Lam.t * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml index 56632a18d1..94b8729eca 100644 --- a/compiler/core/lam_iter.ml +++ b/compiler/core/lam_iter.ml @@ -29,16 +29,16 @@ type ident = Ident.t let inner_iter (l : t) (f : t -> unit) : unit = match l with | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> () - | Lapply { ap_func; ap_args; ap_info = _ } -> - f ap_func; - List.iter f ap_args - | Lfunction { body; arity = _; params = _ } -> f body + | Lapply {ap_func; ap_args; ap_info = _} -> + f ap_func; + List.iter f ap_args + | Lfunction {body; arity = _; params = _} -> f body | Llet (_str, _id, arg, body) -> - f arg; - f body + f arg; + f body | Lletrec (decl, body) -> - f body; - Ext_list.iter_snd decl f + f body; + Ext_list.iter_snd decl f | Lswitch ( arg, { @@ -48,45 +48,45 @@ let inner_iter (l : t) (f : t -> unit) : unit = sw_blocks_full = _; sw_failaction; } ) -> - f arg; - Ext_list.iter_snd sw_consts f; - Ext_list.iter_snd sw_blocks f; - Ext_option.iter sw_failaction f + f arg; + Ext_list.iter_snd sw_consts f; + Ext_list.iter_snd sw_blocks f; + Ext_option.iter sw_failaction f | Lstringswitch (arg, cases, default) -> - f arg; - Ext_list.iter_snd cases f; - Ext_option.iter default f + f arg; + Ext_list.iter_snd cases f; + Ext_option.iter default f | Lglobal_module _ -> () - | Lprim { args; primitive = _; loc = _ } -> List.iter f args + | Lprim {args; primitive = _; loc = _} -> List.iter f args | Lstaticraise (_id, args) -> List.iter f args | Lstaticcatch (e1, _vars, e2) -> - f e1; - f e2 + f e1; + f e2 | Ltrywith (e1, _exn, e2) -> - f e1; - f e2 + f e1; + f e2 | Lifthenelse (e1, e2, e3) -> - f e1; - f e2; - f e3 + f e1; + f e2; + f e3 | Lsequence (e1, e2) -> - f e1; - f e2 + f e1; + f e2 | Lwhile (e1, e2) -> - f e1; - f e2 + f e1; + f e2 | Lfor (_v, e1, e2, _dir, e3) -> - f e1; - f e2; - f e3 + f e1; + f e2; + f e3 | Lassign (_id, e) -> f e let inner_exists (l : t) (f : t -> bool) : bool = match l with | Lvar (_ : ident) | Lglobal_module _ | Lconst (_ : Lam_constant.t) -> false - | Lapply { ap_func; ap_args; ap_info = _ } -> - f ap_func || Ext_list.exists ap_args f - | Lfunction { body; arity = _; params = _ } -> f body + | Lapply {ap_func; ap_args; ap_info = _} -> + f ap_func || Ext_list.exists ap_args f + | Lfunction {body; arity = _; params = _} -> f body | Llet (_str, _id, arg, body) -> f arg || f body | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f | Lswitch @@ -98,13 +98,13 @@ let inner_exists (l : t) (f : t -> bool) : bool = sw_blocks_full = _; sw_failaction; } ) -> - f arg - || Ext_list.exists_snd sw_consts f - || Ext_list.exists_snd sw_blocks f - || Ext_option.exists sw_failaction f + f arg + || Ext_list.exists_snd sw_consts f + || Ext_list.exists_snd sw_blocks f + || Ext_option.exists sw_failaction f | Lstringswitch (arg, cases, default) -> - f arg || Ext_list.exists_snd cases f || Ext_option.exists default f - | Lprim { args; primitive = _; loc = _ } -> Ext_list.exists args f + f arg || Ext_list.exists_snd cases f || Ext_option.exists default f + | Lprim {args; primitive = _; loc = _} -> Ext_list.exists args f | Lstaticraise (_id, args) -> Ext_list.exists args f | Lstaticcatch (e1, _vars, e2) -> f e1 || f e2 | Ltrywith (e1, _exn, e2) -> f e1 || f e2 diff --git a/compiler/core/lam_module_ident.ml b/compiler/core/lam_module_ident.ml index 797258db1f..e92cdb4db0 100644 --- a/compiler/core/lam_module_ident.ml +++ b/compiler/core/lam_module_ident.ml @@ -22,70 +22,54 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +type t = J.module_id = {id: Ident.t; kind: Js_op.kind; dynamic_import: bool} +let id x = x.id +let of_ml ?(dynamic_import = false) id = {id; kind = Ml; dynamic_import} +let of_runtime id = {id; kind = Runtime; dynamic_import = false} +let name (x : t) : string = + match x.kind with + | Ml | Runtime -> x.id.name + | External {name = v} -> v - - - -type t = J.module_id = - { id : Ident.t ; kind : Js_op.kind ; dynamic_import : bool } - - - -let id x = x.id - -let of_ml ?(dynamic_import = false) id = { id ; kind = Ml ; dynamic_import } - - -let of_runtime id = { id ; kind = Runtime ; dynamic_import = false } - -let name (x : t) : string = - match x.kind with - | Ml | Runtime -> x.id.name - | External {name = v} -> v - -module Cmp = struct - [@@@warning "+9"] +module Cmp = struct + [@@@warning "+9"] type nonrec t = t - let equal (x : t) y = - match x.kind with - | External {name = x_kind; default = x_default; _} -> - begin match y.kind with - | External {name = y_kind; default = y_default; _} -> - x_kind = (y_kind : string) && x_default = y_default - | _ -> false - end - | Ml - | Runtime -> Ext_ident.equal x.id y.id + let equal (x : t) y = + match x.kind with + | External {name = x_kind; default = x_default; _} -> ( + match y.kind with + | External {name = y_kind; default = y_default; _} -> + x_kind = (y_kind : string) && x_default = y_default + | _ -> false) + | Ml | Runtime -> Ext_ident.equal x.id y.id + (* #1556 - Note the main difference between [Ml] and [Runtime] is - that we have more assumptions about [Runtime] module, - like its purity etc, and its name uniqueues, in the pattern match + Note the main difference between [Ml] and [Runtime] is + that we have more assumptions about [Runtime] module, + like its purity etc, and its name uniqueues, in the pattern match {[ {Runtime, "caml_int_compare"} ]} and we could do more optimziations. - However, here if it is [hit] - (an Ml module = an Runtime module), which means both exists, + However, here if it is [hit] + (an Ml module = an Runtime module), which means both exists, so adding either does not matter if it is not hit, fine *) - let hash (x : t) = - match x.kind with - | External {name = x_kind ; _} -> + let hash (x : t) = + match x.kind with + | External {name = x_kind; _} -> (* The hash collision is rare? *) - Bs_hash_stubs.hash_string x_kind - | Ml - | Runtime -> - let x_id = x.id in - Bs_hash_stubs.hash_stamp_and_name x_id.stamp x_id.name + Bs_hash_stubs.hash_string x_kind + | Ml | Runtime -> + let x_id = x.id in + Bs_hash_stubs.hash_stamp_and_name x_id.stamp x_id.name end module Hash = Hash.Make (Cmp) module Hash_set = Hash_set.Make (Cmp) - - diff --git a/compiler/core/lam_module_ident.mli b/compiler/core/lam_module_ident.mli index 24e117e02f..46ae23b06c 100644 --- a/compiler/core/lam_module_ident.mli +++ b/compiler/core/lam_module_ident.mli @@ -22,39 +22,22 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - - - - (** A type for qualified identifiers in Lambda IR *) - -type t = J.module_id = - (*private*) { - id : Ident.t ; - kind : Js_op.kind ; - dynamic_import : bool ; +type t = J.module_id = { + (*private*) id: Ident.t; + kind: Js_op.kind; + dynamic_import: bool; } - -val id : t -> Ident.t +val id : t -> Ident.t val name : t -> string - - val of_ml : ?dynamic_import:bool -> Ident.t -> t - - -val of_runtime : Ident.t -> t +val of_runtime : Ident.t -> t module Hash : Hash_gen.S with type key = t module Hash_set : Hash_set_gen.S with type key = t diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index e00ccf8d3a..3beadbeb0e 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -28,58 +28,62 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match args_arity with | 0 :: _ | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info | x :: _ -> - if x = len then - Lam.apply (simpl fn) (Ext_list.map args simpl) - { ap_info with ap_status = App_infer_full } - else if x > len then - let fn = simpl fn in - let args = Ext_list.map args simpl in - Lam_eta_conversion.transform_under_supply (x - len) - { ap_info with ap_status = App_infer_full } - fn args - else - let first, rest = Ext_list.split_at args x in - Lam.apply - (Lam.apply (simpl fn) (Ext_list.map first simpl) - { ap_info with ap_status = App_infer_full }) - (Ext_list.map rest simpl) ap_info + if x = len then + Lam.apply (simpl fn) (Ext_list.map args simpl) + {ap_info with ap_status = App_infer_full} + else if x > len then + let fn = simpl fn in + let args = Ext_list.map args simpl in + Lam_eta_conversion.transform_under_supply (x - len) + {ap_info with ap_status = App_infer_full} + fn args + else + let first, rest = Ext_list.split_at args x in + Lam.apply + (Lam.apply (simpl fn) (Ext_list.map first simpl) + {ap_info with ap_status = App_infer_full}) + (Ext_list.map rest simpl) ap_info (* TODO refien *) and simpl (lam : Lam.t) = match lam with | Lconst _ -> lam | Lvar _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - (* detect functor application *) - let args_arity = - Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) - in - let len = List.length ap_args in - populate_apply_info args_arity len ap_func ap_args ap_info + | Lapply {ap_func; ap_args; ap_info} -> + (* detect functor application *) + let args_arity = + Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) + in + let len = List.length ap_args in + populate_apply_info args_arity len ap_func ap_args ap_info | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) + let bindings = Ext_list.map_snd bindings simpl in + Lam.letrec bindings (simpl body) | Lglobal_module _ -> lam - | Lprim { primitive = Pjs_fn_make len as primitive; args = [ arg ]; loc } - -> ( - match - Lam_arity.get_first_arity (Lam_arity_analysis.get_arity meta arg) - with - | Some x -> - let arg = simpl arg in - Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg - | None -> Lam.prim ~primitive ~args:[ simpl arg ] loc) - | Lprim { primitive = Pjs_fn_make_unit; args = [ arg ]; loc } -> - let arg = match arg with - | Lfunction ({arity=1; params=[x]; attr; body}) when Ident.name x = "param" (* "()" *) -> - Lam.function_ ~params:[x] ~attr:{attr with one_unit_arg=true} ~body ~arity:1 - | _ -> arg in + | Lprim {primitive = Pjs_fn_make len as primitive; args = [arg]; loc} -> ( + match + Lam_arity.get_first_arity (Lam_arity_analysis.get_arity meta arg) + with + | Some x -> + let arg = simpl arg in + Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg + | None -> Lam.prim ~primitive ~args:[simpl arg] loc) + | Lprim {primitive = Pjs_fn_make_unit; args = [arg]; loc} -> + let arg = + match arg with + | Lfunction {arity = 1; params = [x]; attr; body} + when Ident.name x = "param" (* "()" *) -> + Lam.function_ ~params:[x] + ~attr:{attr with one_unit_arg = true} + ~body ~arity:1 + | _ -> arg + in simpl arg - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lfunction { arity; params; body; attr } -> - (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ ~arity ~params ~body:(simpl body) ~attr + | Lprim {primitive; args; loc} -> + Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc + | Lfunction {arity; params; body; attr} -> + (* Lam_mk.lfunction kind params (simpl l) *) + Lam.function_ ~arity ~params ~body:(simpl body) ~attr | Lswitch ( l, { @@ -90,19 +94,19 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_names; } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; - } + Lam.switch (simpl l) + { + sw_consts = Ext_list.map_snd sw_consts simpl; + sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts_full; + sw_blocks_full; + sw_failaction = Ext_option.map sw_failaction simpl; + sw_names; + } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simpl l) - (Ext_list.map_snd sw simpl) - (Ext_option.map d simpl) + Lam.stringswitch (simpl l) + (Ext_list.map_snd sw simpl) + (Ext_option.map d simpl) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) @@ -110,11 +114,11 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) + (* Lalias-bound variables are never assigned, so don't increase + v's refsimpl *) + Lam.assign v (simpl l) in simpl lam diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index b65825ed6c..5f4a0d46e5 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -34,7 +34,7 @@ let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) lambda = Hash_ident.add meta.ident_tbl k - (FunctionId { arity; lambda = Some (lambda, rec_flag) }) + (FunctionId {arity; lambda = Some (lambda, rec_flag)}) (* see #3609 we have to update since bounded function lambda may contain stale unbounded varaibles @@ -58,105 +58,104 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) - | Lprim { primitive = Pmakeblock (_, _, Immutable); args = ls } -> - Hash_ident.replace meta.ident_tbl ident - (Lam_util.kind_of_lambda_block ls); - List.iter collect ls - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ] } -> - Hash_ident.replace meta.ident_tbl ident (Normal_optional v); - collect v + | Lprim {primitive = Pmakeblock (_, _, Immutable); args = ls} -> + Hash_ident.replace meta.ident_tbl ident (Lam_util.kind_of_lambda_block ls); + List.iter collect ls + | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> + Hash_ident.replace meta.ident_tbl ident (Normal_optional v); + collect v | Lprim { - primitive = Praw_js_code { code_info = Exp (Js_function { arity }) }; + primitive = Praw_js_code {code_info = Exp (Js_function {arity})}; args = _; } -> - Hash_ident.replace meta.ident_tbl ident - (FunctionId { arity = Lam_arity.info [ arity ] false; lambda = None }) - | Lprim { primitive = Pnull_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Null)) - | Lprim { primitive = Pundefined_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) - | Lprim { primitive = Pnull_undefined_to_opt; args = [ (Lvar _ as l) ] } -> - Hash_ident.replace meta.ident_tbl ident - (OptionalBlock (l, Null_undefined)) - | Lglobal_module (v, _) -> Lam_util.alias_ident_or_global meta ident v (Module v) + Hash_ident.replace meta.ident_tbl ident + (FunctionId {arity = Lam_arity.info [arity] false; lambda = None}) + | Lprim {primitive = Pnull_to_opt; args = [(Lvar _ as l)]; _} -> + Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Null)) + | Lprim {primitive = Pundefined_to_opt; args = [(Lvar _ as l)]; _} -> + Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) + | Lprim {primitive = Pnull_undefined_to_opt; args = [(Lvar _ as l)]} -> + Hash_ident.replace meta.ident_tbl ident + (OptionalBlock (l, Null_undefined)) + | Lglobal_module (v, _) -> + Lam_util.alias_ident_or_global meta ident v (Module v) | Lvar v -> - (* if Ident.global v then *) - Lam_util.alias_ident_or_global meta ident v NA - (* enven for not subsitution, it still propogate some properties *) - (* else () *) - | Lfunction { params; body } + (* if Ident.global v then *) + Lam_util.alias_ident_or_global meta ident v NA + (* enven for not subsitution, it still propogate some properties *) + (* else () *) + | Lfunction {params; body} (* TODO record parameters ident ?, but it will be broken after inlining *) -> - (* TODO could be optimized in one pass? - -- since collect would iter everywhere, - so -- it would still iterate internally - *) - Ext_list.iter params (fun p -> - Hash_ident.add meta.ident_tbl p Parameter); - let arity = Lam_arity_analysis.get_arity meta lam in - annotate meta rec_flag ident arity lam; - collect body + (* TODO could be optimized in one pass? + -- since collect would iter everywhere, + so -- it would still iterate internally + *) + Ext_list.iter params (fun p -> Hash_ident.add meta.ident_tbl p Parameter); + let arity = Lam_arity_analysis.get_arity meta lam in + annotate meta rec_flag ident arity lam; + collect body | x -> - collect x; - if Set_ident.mem meta.export_idents ident then - annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam + collect x; + if Set_ident.mem meta.export_idents ident then + annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam and collect (lam : Lam.t) = match lam with | Lconst _ -> () | Lvar _ -> () - | Lapply { ap_func = l1; ap_args = ll; _ } -> - collect l1; - List.iter collect ll - | Lfunction { params; body = l } -> - (* functor ? *) - List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; - collect l + | Lapply {ap_func = l1; ap_args = ll; _} -> + collect l1; + List.iter collect ll + | Lfunction {params; body = l} -> + (* functor ? *) + List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; + collect l | Llet (_kind, ident, arg, body) -> - collect_bind Lam_non_rec ident arg; - collect body + collect_bind Lam_non_rec ident arg; + collect body | Lletrec (bindings, body) -> - (match bindings with - | [ (ident, arg) ] -> collect_bind Lam_self_rec ident arg - | _ -> - Ext_list.iter bindings (fun (ident, arg) -> - collect_bind Lam_rec ident arg)); - collect body + (match bindings with + | [(ident, arg)] -> collect_bind Lam_self_rec ident arg + | _ -> + Ext_list.iter bindings (fun (ident, arg) -> + collect_bind Lam_rec ident arg)); + collect body | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter collect args - | Lswitch (l, { sw_failaction; sw_consts; sw_blocks }) -> - collect l; - Ext_list.iter_snd sw_consts collect; - Ext_list.iter_snd sw_blocks collect; - Ext_option.iter sw_failaction collect + | Lprim {args; _} -> List.iter collect args + | Lswitch (l, {sw_failaction; sw_consts; sw_blocks}) -> + collect l; + Ext_list.iter_snd sw_consts collect; + Ext_list.iter_snd sw_blocks collect; + Ext_option.iter sw_failaction collect | Lstringswitch (l, sw, d) -> - collect l; - Ext_list.iter_snd sw collect; - Ext_option.iter d collect + collect l; + Ext_list.iter_snd sw collect; + Ext_option.iter d collect | Lstaticraise (_code, ls) -> List.iter collect ls | Lstaticcatch (l1, (_, _), l2) -> - collect l1; - collect l2 + collect l1; + collect l2 | Ltrywith (l1, _, l2) -> - collect l1; - collect l2 + collect l1; + collect l2 | Lifthenelse (l1, l2, l3) -> - collect l1; - collect l2; - collect l3 + collect l1; + collect l2; + collect l3 | Lsequence (l1, l2) -> - collect l1; - collect l2 + collect l1; + collect l2 | Lwhile (l1, l2) -> - collect l1; - collect l2 + collect l1; + collect l2 | Lfor (_, l1, l2, _dir, l3) -> - collect l1; - collect l2; - collect l3 + collect l1; + collect l2; + collect l3 | Lassign (_v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcollect *) - collect l + (* Lalias-bound variables are never assigned, so don't increase + v's refcollect *) + collect l in collect lam diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 88eed56e79..3fc3a89090 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -13,8 +13,8 @@ (*A naive dead code elimination *) type used_info = { - mutable times : int; - mutable captured : bool; + mutable times: int; + mutable captured: bool; (* captured in functon or loop, inline in such cases should be careful 1. can not inline mutable values @@ -27,14 +27,14 @@ type occ_tbl = used_info Hash_ident.t type local_tbl = used_info Map_ident.t -let dummy_info () = { times = 0; captured = false } +let dummy_info () = {times = 0; captured = false} (* y is untouched *) let absorb_info (x : used_info) (y : used_info) = match (x, y) with - | { times = x0 }, { times = y0; captured } -> - x.times <- x0 + y0; - if captured then x.captured <- true + | {times = x0}, {times = y0; captured} -> + x.times <- x0 + y0; + if captured then x.captured <- true let pp_info fmt (x : used_info) = Format.fprintf fmt "(:%d)" x.captured x.times @@ -63,7 +63,7 @@ let collect_occurs lam : occ_tbl = let used v = match Hash_ident.find_opt occ v with | None -> false - | Some { times; _ } -> times > 0 + | Some {times; _} -> times > 0 in (* Entering a [let]. Returns updated [bv]. *) @@ -78,14 +78,14 @@ let collect_occurs lam : occ_tbl = match Map_ident.find_opt bv ident with | Some r -> r.times <- r.times + 1 | None -> ( - (* ident is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with - | Some r -> absorb_info r { times = 1; captured = true } - | None -> - (* Not a let-bound variable, ignore *) - ()) + (* ident is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) + match Hash_ident.find_opt occ ident with + | Some r -> absorb_info r {times = 1; captured = true} + | None -> + (* Not a let-bound variable, ignore *) + ()) in let inherit_use bv ident bid = @@ -97,72 +97,76 @@ let collect_occurs lam : occ_tbl = match Map_ident.find_opt bv ident with | Some r -> absorb_info r n | None -> ( - (* ident is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with - | Some r -> absorb_info r { n with captured = true } - | None -> - (* Not a let-bound variable, ignore *) - ()) + (* ident is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) + match Hash_ident.find_opt occ ident with + | Some r -> absorb_info r {n with captured = true} + | None -> + (* Not a let-bound variable, ignore *) + ()) in let rec count (bv : local_tbl) (lam : Lam.t) = match lam with - | Lfunction { body = l } -> count Map_ident.empty l + | Lfunction {body = l} -> count Map_ident.empty l (* when entering a function local [bv] is cleaned up, so that all closure variables will not be carried over, since the parameters are never rebound, so it is fine to kep it empty *) | Lfor (_, l1, l2, _dir, l3) -> - count bv l1; - count bv l2; - count Map_ident.empty l3 + count bv l1; + count bv l2; + count Map_ident.empty l3 | Lwhile (l1, l2) -> - count Map_ident.empty l1; - count Map_ident.empty l2 + count Map_ident.empty l1; + count Map_ident.empty l2 | Lvar v -> add_one_use bv v | Llet (_, v, Lvar w, l2) -> - (* v will be replaced by w in l2, so each occurrence of v in l2 - increases w's refcount *) - count (bind_var bv v) l2; - inherit_use bv w v + (* v will be replaced by w in l2, so each occurrence of v in l2 + increases w's refcount *) + count (bind_var bv v) l2; + inherit_use bv w v | Llet (kind, v, l1, l2) -> - count (bind_var bv v) l2; - (* count [l2] first, - If v is unused, l1 will be removed, so don't count its variables *) - if kind = Strict || used v then count bv l1 + count (bind_var bv v) l2; + (* count [l2] first, + If v is unused, l1 will be removed, so don't count its variables *) + if kind = Strict || used v then count bv l1 | Lassign (_, l) -> - (* Lalias-bound variables are never assigned, so don't increase - this ident's refcount *) - count bv l + (* Lalias-bound variables are never assigned, so don't increase + this ident's refcount *) + count bv l | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter (count bv) args + | Lprim {args; _} -> List.iter (count bv) args | Lletrec (bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; - count bv body + List.iter (fun (_v, l) -> count bv l) bindings; + count bv body (* Note there is a difference here when do beta reduction for *) - | Lapply { ap_func = Lfunction ({ params; body } as lfunction); ap_args = args; _ } - when Ext_list.same_length params args && Lam_analysis.lfunction_can_be_inlined lfunction -> - count bv (Lam_beta_reduce.no_names_beta_reduce params body args) + | Lapply + {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} + when Ext_list.same_length params args + && Lam_analysis.lfunction_can_be_inlined lfunction -> + count bv (Lam_beta_reduce.no_names_beta_reduce params body args) (* | Lapply{fn = Lfunction{function_kind = Tupled; params; body}; *) (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) (* when Ext_list.same_length params args -> *) (* count bv (Lam_beta_reduce.beta_reduce params body args) *) - | Lapply { ap_func = l1; ap_args = ll; _ } -> - count bv l1; - List.iter (count bv) ll + | Lapply {ap_func = l1; ap_args = ll; _} -> + count bv l1; + List.iter (count bv) ll | Lconst _cst -> () | Lswitch (l, sw) -> - count_default bv sw; - count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks + count_default bv sw; + count bv l; + List.iter (fun (_, l) -> count bv l) sw.sw_consts; + List.iter (fun (_, l) -> count bv l) sw.sw_blocks | Lstringswitch (l, sw, d) -> ( - count bv l; - List.iter (fun (_, l) -> count bv l) sw; - match d with Some d -> count bv d | None -> ()) + count bv l; + List.iter (fun (_, l) -> count bv l) sw; + match d with + | Some d -> count bv d + | None -> ()) (* x2 for native backend *) (* begin match sw with *) (* | []|[_] -> count bv d *) @@ -170,30 +174,30 @@ let collect_occurs lam : occ_tbl = (* end *) | Lstaticraise (_i, ls) -> List.iter (count bv) ls | Lstaticcatch (l1, (_i, _), l2) -> - count bv l1; - count bv l2 + count bv l1; + count bv l2 | Ltrywith (l1, _v, l2) -> - count bv l1; - count bv l2 + count bv l1; + count bv l2 | Lifthenelse (l1, l2, l3) -> - count bv l1; - count bv l2; - count bv l3 + count bv l1; + count bv l2; + count bv l3 | Lsequence (l1, l2) -> - count bv l1; - count bv l2 + count bv l1; + count bv l2 and count_default bv sw = match sw.sw_failaction with | None -> () | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - (* default action will occur twice in native code *) - count bv al; - count bv al) - else ( - (* default action will occur once *) - assert ((not sw.sw_consts_full) || not sw.sw_blocks_full); - count bv al) + if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( + (* default action will occur twice in native code *) + count bv al; + count bv al) + else ( + (* default action will occur once *) + assert ((not sw.sw_consts_full) || not sw.sw_blocks_full); + count bv al) in count Map_ident.empty lam; occ diff --git a/compiler/core/lam_pass_count.mli b/compiler/core/lam_pass_count.mli index c8cc1f875e..547551b0dc 100644 --- a/compiler/core/lam_pass_count.mli +++ b/compiler/core/lam_pass_count.mli @@ -12,8 +12,8 @@ (* Adapted for Javascript backend : Hongbo Zhang, *) type used_info = { - mutable times : int; - mutable captured : bool; + mutable times: int; + mutable captured: bool; (* captured in functon or loop, inline in such cases should be careful 1. can not inline mutable values diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index c33a1e869b..c55aeec841 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -28,10 +28,9 @@ let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = match lam with - | Llet - (Alias, v, Lprim { primitive = Pfield (i, _); args = [ Lvar tuple ] }, e2) + | Llet (Alias, v, Lprim {primitive = Pfield (i, _); args = [Lvar tuple]}, e2) when Ident.same tuple id -> - eliminate_tuple id e2 (Map_int.add acc i v) + eliminate_tuple id e2 (Map_int.add acc i v) (* it is okay to have duplicates*) | _ -> if Lam_hit.hit_variable id lam then None else Some (acc, lam) (* [groups] are in reverse order *) @@ -126,10 +125,10 @@ let deep_flatten (lam : Lam.t) : Lam.t = { primitive = Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; - args = [ Lvar _ ]; + args = [Lvar _]; } as arg), body ) -> - flatten (Single (str, id, aux arg) :: acc) body + flatten (Single (str, id, aux arg) :: acc) body | Llet ( str, id, @@ -138,82 +137,82 @@ let deep_flatten (lam : Lam.t) : Lam.t = primitive = (Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt) as primitive; - args = [ arg ]; + args = [arg]; }, body ) -> - let new_id = Ident.rename id in - flatten acc - (Lam.let_ str new_id arg - (Lam.let_ Alias id - (Lam.prim ~primitive ~args:[ Lam.var new_id ] - Location.none (* FIXME*)) - body)) + let new_id = Ident.rename id in + flatten acc + (Lam.let_ str new_id arg + (Lam.let_ Alias id + (Lam.prim ~primitive + ~args:[Lam.var new_id] + Location.none (* FIXME*)) + body)) | Llet (str, id, arg, body) -> ( - (* + (* {[ let match = (a,b,c) let d = (match/1) let e = (match/2) .. ]} *) - let res, accux = flatten acc arg in - match (id.name, str, res) with - | ( ("match" | "include" | "param"), - (Alias | Strict | StrictOpt), - Lprim { primitive = Pmakeblock (_, _, Immutable); args } ) -> ( - match eliminate_tuple id body Map_int.empty with - | Some (tuple_mapping, body) -> - flatten - (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> - match Map_int.find_opt tuple_mapping i with - | None -> Lam_group.nop_cons arg acc - | Some key -> Lam_group.single str key arg :: acc)) - body - | None -> flatten (Single (str, id, res) :: accux) body) - | _ -> flatten (Single (str, id, res) :: accux) body) + let res, accux = flatten acc arg in + match (id.name, str, res) with + | ( ("match" | "include" | "param"), + (Alias | Strict | StrictOpt), + Lprim {primitive = Pmakeblock (_, _, Immutable); args} ) -> ( + match eliminate_tuple id body Map_int.empty with + | Some (tuple_mapping, body) -> + flatten + (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> + match Map_int.find_opt tuple_mapping i with + | None -> Lam_group.nop_cons arg acc + | Some key -> Lam_group.single str key arg :: acc)) + body + | None -> flatten (Single (str, id, res) :: accux) body) + | _ -> flatten (Single (str, id, res) :: accux) body) | Lletrec (bind_args, body) -> - flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body + flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body | Lsequence (l, r) -> - let res, l = flatten acc l in - flatten (Lam_group.nop_cons res l) r + let res, l = flatten acc l in + flatten (Lam_group.nop_cons res l) r | x -> (aux x, acc) and aux (lam : Lam.t) : Lam.t = match lam with | Llet _ -> - let res, groups = flatten [] lam in - lambda_of_groups res ~rev_bindings:groups + let res, groups = flatten [] lam in + lambda_of_groups res ~rev_bindings:groups | Lletrec (bind_args, body) -> - (* Attention: don't mess up with internal {let rec} *) - let rec iter bind_args groups set = - match bind_args with - | [] -> (List.rev groups, set) - | (id, arg) :: rest -> - iter rest ((id, aux arg) :: groups) (Set_ident.add set id) - in - let groups, collections = iter bind_args [] Set_ident.empty in - (* Try to extract some value definitions from recursive values as [wrap], - it will stop whenever it find it could not move forward - {[ - let rec x = - let y = 1 in - let z = 2 in - ... - ]} - *) - let rev_bindings, rev_wrap, _ = - Ext_list.fold_left groups ([], [], false) - (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> - if stop || Lam_hit.hit_variables collections lam then - ((id, lam) :: inner_recursive_bindings, wrap, true) - else - ( inner_recursive_bindings, - Lam_group.Single (Strict, id, lam) :: wrap, - false )) - in - lambda_of_groups - ~rev_bindings: - rev_wrap (* These bindings are extracted from [letrec] *) - (Lam.letrec (List.rev rev_bindings) (aux body)) + (* Attention: don't mess up with internal {let rec} *) + let rec iter bind_args groups set = + match bind_args with + | [] -> (List.rev groups, set) + | (id, arg) :: rest -> + iter rest ((id, aux arg) :: groups) (Set_ident.add set id) + in + let groups, collections = iter bind_args [] Set_ident.empty in + (* Try to extract some value definitions from recursive values as [wrap], + it will stop whenever it find it could not move forward + {[ + let rec x = + let y = 1 in + let z = 2 in + ... + ]} + *) + let rev_bindings, rev_wrap, _ = + Ext_list.fold_left groups ([], [], false) + (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> + if stop || Lam_hit.hit_variables collections lam then + ((id, lam) :: inner_recursive_bindings, wrap, true) + else + ( inner_recursive_bindings, + Lam_group.Single (Strict, id, lam) :: wrap, + false )) + in + lambda_of_groups + ~rev_bindings:rev_wrap (* These bindings are extracted from [letrec] *) + (Lam.letrec (List.rev rev_bindings) (aux body)) | Lsequence (l, r) -> Lam.seq (aux l) (aux r) | Lconst _ -> lam | Lvar _ -> lam @@ -225,16 +224,16 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* can we switch to the tupled backend? *\) *) (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) - | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info + | Lapply {ap_func = l1; ap_args = ll; ap_info} -> + Lam.apply (aux l1) (Ext_list.map ll aux) ap_info (* This kind of simple optimizations should be done each time and as early as possible *) | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - let args = Ext_list.map args aux in - Lam.prim ~primitive ~args loc - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(aux body) ~attr + | Lprim {primitive; args; loc} -> + let args = Ext_list.map args aux in + Lam.prim ~primitive ~args loc + | Lfunction {arity; params; body; attr} -> + Lam.function_ ~arity ~params ~body:(aux body) ~attr | Lswitch ( l, { @@ -245,28 +244,27 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_consts_full; sw_names; } ) -> - Lam.switch (aux l) - { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction aux; - sw_names; - } + Lam.switch (aux l) + { + sw_consts = Ext_list.map_snd sw_consts aux; + sw_blocks = Ext_list.map_snd sw_blocks aux; + sw_consts_full; + sw_blocks_full; + sw_failaction = Ext_option.map sw_failaction aux; + sw_names; + } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) - (Ext_option.map d aux) + Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) (Ext_option.map d aux) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (aux l1) (aux l2) dir (aux l3) + Lam.for_ flag (aux l1) (aux l2) dir (aux l3) | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refaux *) - Lam.assign v (aux l) + (* Lalias-bound variables are never assigned, so don't increase + v's refaux *) + Lam.assign v (aux l) in aux lam diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index c5325c1968..4a251c1877 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -17,11 +17,10 @@ let rec eliminate_ref id (lam : Lam.t) = match lam with (* we can do better escape analysis in Javascript backend *) | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam - | Lprim { primitive = Pfield (0, _); args = [ Lvar v ] } when Ident.same v id - -> - Lam.var id + | Lprim {primitive = Pfield (0, _); args = [Lvar v]} when Ident.same v id -> + Lam.var id | Lfunction _ -> - if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam + if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam (* In Javascript backend, its okay, we can reify it later a failed case {[ @@ -45,59 +44,57 @@ let rec eliminate_ref id (lam : Lam.t) = TODO: we can refine analysis in later *) (* Lfunction(kind, params, eliminate_ref id body) *) - | Lprim { primitive = Psetfield (0, _); args = [ Lvar v; e ] } + | Lprim {primitive = Psetfield (0, _); args = [Lvar v; e]} when Ident.same v id -> - Lam.assign id (eliminate_ref id e) - | Lprim { primitive = Poffsetref delta; args = [ Lvar v ]; loc } + Lam.assign id (eliminate_ref id e) + | Lprim {primitive = Poffsetref delta; args = [Lvar v]; loc} when Ident.same v id -> - Lam.assign id - (Lam.prim ~primitive:(Poffsetint delta) ~args:[ Lam.var id ] loc) + Lam.assign id + (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id] loc) | Lconst _ -> lam - | Lapply { ap_func = e1; ap_args = el; ap_info } -> - Lam.apply (eliminate_ref id e1) - (Ext_list.map el (eliminate_ref id)) - ap_info + | Lapply {ap_func = e1; ap_args = el; ap_info} -> + Lam.apply (eliminate_ref id e1) (Ext_list.map el (eliminate_ref id)) ap_info | Llet (str, v, e1, e2) -> - Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) + Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) | Lletrec (idel, e2) -> - Lam.letrec - (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) - (eliminate_ref id e2) + Lam.letrec + (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) + (eliminate_ref id e2) | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc + | Lprim {primitive; args; loc} -> + Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc | Lswitch (e, sw) -> - Lam.switch (eliminate_ref id e) - { - sw_consts_full = sw.sw_consts_full; - sw_consts = - Ext_list.map sw.sw_consts (fun (n, e) -> (n, eliminate_ref id e)); - sw_blocks_full = sw.sw_blocks_full; - sw_blocks = - Ext_list.map sw.sw_blocks (fun (n, e) -> (n, eliminate_ref id e)); - sw_failaction = - (match sw.sw_failaction with - | None -> None - | Some x -> Some (eliminate_ref id x)); - sw_names = sw.sw_names; - } + Lam.switch (eliminate_ref id e) + { + sw_consts_full = sw.sw_consts_full; + sw_consts = + Ext_list.map sw.sw_consts (fun (n, e) -> (n, eliminate_ref id e)); + sw_blocks_full = sw.sw_blocks_full; + sw_blocks = + Ext_list.map sw.sw_blocks (fun (n, e) -> (n, eliminate_ref id e)); + sw_failaction = + (match sw.sw_failaction with + | None -> None + | Some x -> Some (eliminate_ref id x)); + sw_names = sw.sw_names; + } | Lstringswitch (e, sw, default) -> - Lam.stringswitch (eliminate_ref id e) - (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) - (match default with - | None -> None - | Some x -> Some (eliminate_ref id x)) + Lam.stringswitch (eliminate_ref id e) + (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) + (match default with + | None -> None + | Some x -> Some (eliminate_ref id x)) | Lstaticraise (i, args) -> - Lam.staticraise i (Ext_list.map args (eliminate_ref id)) + Lam.staticraise i (Ext_list.map args (eliminate_ref id)) | Lstaticcatch (e1, i, e2) -> - Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) + Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) | Ltrywith (e1, v, e2) -> - Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) + Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) | Lifthenelse (e1, e2, e3) -> - Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) + Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) | Lwhile (e1, e2) -> Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2) | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir - (eliminate_ref id e3) + Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir + (eliminate_ref id e3) | Lassign (v, e) -> Lam.assign v (eliminate_ref id e) diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index e89032771c..ceba4af6e5 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -24,31 +24,34 @@ let rec no_list args = Ext_list.for_all args no_bounded_variables and no_list_snd : 'a. ('a * Lam.t) list -> bool = fun args -> Ext_list.for_all_snd args no_bounded_variables -and no_opt x = match x with None -> true | Some a -> no_bounded_variables a +and no_opt x = + match x with + | None -> true + | Some a -> no_bounded_variables a and no_bounded_variables (l : Lam.t) = match l with | Lvar _ -> true | Lconst _ -> true | Lassign (_id, e) -> no_bounded_variables e - | Lapply { ap_func; ap_args; _ } -> - no_bounded_variables ap_func && no_list ap_args + | Lapply {ap_func; ap_args; _} -> + no_bounded_variables ap_func && no_list ap_args | Lglobal_module _ -> true - | Lprim { args; primitive = _ } -> no_list args + | Lprim {args; primitive = _} -> no_list args | Lswitch (arg, sw) -> - no_bounded_variables arg && no_list_snd sw.sw_consts - && no_list_snd sw.sw_blocks && no_opt sw.sw_failaction + no_bounded_variables arg && no_list_snd sw.sw_consts + && no_list_snd sw.sw_blocks && no_opt sw.sw_failaction | Lstringswitch (arg, cases, default) -> - no_bounded_variables arg && no_list_snd cases && no_opt default + no_bounded_variables arg && no_list_snd cases && no_opt default | Lstaticraise (_, args) -> no_list args | Lifthenelse (e1, e2, e3) -> - no_bounded_variables e1 && no_bounded_variables e2 - && no_bounded_variables e3 + no_bounded_variables e1 && no_bounded_variables e2 + && no_bounded_variables e3 | Lsequence (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 | Lwhile (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 | Lstaticcatch (e1, (_, vars), e2) -> - vars = [] && no_bounded_variables e1 && no_bounded_variables e2 - | Lfunction { body; params } -> params = [] && no_bounded_variables body + vars = [] && no_bounded_variables e1 && no_bounded_variables e2 + | Lfunction {body; params} -> params = [] && no_bounded_variables body | Lfor _ -> false | Ltrywith _ -> false | Llet _ -> false @@ -82,7 +85,9 @@ type lam_subst = Id of Lam.t [@@unboxed] type subst_tbl = (Ident.t list * lam_subst) Hash_int.t -let to_lam x = match x with Id x -> x +let to_lam x = + match x with + | Id x -> x (* | Refresh x -> Lam_bounded_vars.refresh x *) (** @@ -150,83 +155,83 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t let rec simplif (lam : Lam.t) = match lam with | Lstaticcatch (l1, (i, xs), l2) -> ( - let i_occur = query i in - match (i_occur, l2) with - | 0, _ -> simplif l1 - | _, Lvar _ | _, Lconst _ (* when i >= 0 # 2316 *) -> - Hash_int.add subst i (xs, Id (simplif l2)); - simplif l1 (* l1 will inline *) - | 1, _ when i >= 0 -> - (* Ask: Note that we have predicate i >=0 *) - Hash_int.add subst i (xs, Id (simplif l2)); - simplif l1 (* l1 will inline *) - | _ -> - let l2 = simplif l2 in - (* we only inline when [l2] does not contain bound variables - no need to refresh - *) - let ok_to_inline = - i >= 0 && no_bounded_variables l2 - && - let lam_size = Lam_analysis.size l2 in - (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size) - || lam_size < 5 - in - if ok_to_inline then ( - Hash_int.add subst i (xs, Id l2); - simplif l1) - else Lam.staticcatch (simplif l1) (i, xs) l2) + let i_occur = query i in + match (i_occur, l2) with + | 0, _ -> simplif l1 + | _, Lvar _ | _, Lconst _ (* when i >= 0 # 2316 *) -> + Hash_int.add subst i (xs, Id (simplif l2)); + simplif l1 (* l1 will inline *) + | 1, _ when i >= 0 -> + (* Ask: Note that we have predicate i >=0 *) + Hash_int.add subst i (xs, Id (simplif l2)); + simplif l1 (* l1 will inline *) + | _ -> + let l2 = simplif l2 in + (* we only inline when [l2] does not contain bound variables + no need to refresh + *) + let ok_to_inline = + i >= 0 && no_bounded_variables l2 + && + let lam_size = Lam_analysis.size l2 in + (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size) + || lam_size < 5 + in + if ok_to_inline then ( + Hash_int.add subst i (xs, Id l2); + simplif l1) + else Lam.staticcatch (simplif l1) (i, xs) l2) | Lstaticraise (i, []) -> ( - match Hash_int.find_opt subst i with - | Some (_, handler) -> to_lam handler - | None -> lam) + match Hash_int.find_opt subst i with + | Some (_, handler) -> to_lam handler + | None -> lam) | Lstaticraise (i, ls) -> ( - let ls = Ext_list.map ls simplif in - match Hash_int.find_opt subst i with - | Some (xs, handler) -> - let handler = to_lam handler in - let ys = Ext_list.map xs Ident.rename in - let env = - Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> - Map_ident.add t x (Lam.var y)) - in - Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) - (fun y l r -> Lam.let_ Strict y l r) - | None -> Lam.staticraise i ls) + let ls = Ext_list.map ls simplif in + match Hash_int.find_opt subst i with + | Some (xs, handler) -> + let handler = to_lam handler in + let ys = Ext_list.map xs Ident.rename in + let env = + Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> + Map_ident.add t x (Lam.var y)) + in + Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) (fun y l r -> + Lam.let_ Strict y l r) + | None -> Lam.staticraise i ls) | Lvar _ | Lconst _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr + | Lapply {ap_func; ap_args; ap_info} -> + Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info + | Lfunction {arity; params; body; attr} -> + Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - let args = Ext_list.map args simplif in - Lam.prim ~primitive ~args loc + | Lprim {primitive; args; loc} -> + let args = Ext_list.map args simplif in + Lam.prim ~primitive ~args loc | Lswitch (l, sw) -> - let new_l = simplif l in - let new_consts = Ext_list.map_snd sw.sw_consts simplif in - let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in - let new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l - { - sw with - sw_consts = new_consts; - sw_blocks = new_blocks; - sw_failaction = new_fail; - } + let new_l = simplif l in + let new_consts = Ext_list.map_snd sw.sw_consts simplif in + let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in + let new_fail = Ext_option.map sw.sw_failaction simplif in + Lam.switch new_l + { + sw with + sw_consts = new_consts; + sw_blocks = new_blocks; + sw_failaction = new_fail; + } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) - (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) + Lam.stringswitch (simplif l) + (Ext_list.map_snd sw simplif) + (Ext_option.map d simplif) | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) + Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) | Lassign (v, l) -> Lam.assign v (simplif l) in simplif lam diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 0833c8f73a..62e54ccc4a 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -11,228 +11,208 @@ (***********************************************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) - -let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = +let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in - let string_table : string Hash_ident.t = Hash_ident.create 32 in - let used v = (count_var v ).times > 0 in - let rec simplif (lam : Lam.t) = - match lam with - | Lvar v -> Hash_ident.find_default subst v lam - | Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2) - -> + let string_table : string Hash_ident.t = Hash_ident.create 32 in + let used v = (count_var v).times > 0 in + let rec simplif (lam : Lam.t) = + match lam with + | Lvar v -> Hash_ident.find_default subst v lam + | Llet ((Strict | Alias | StrictOpt), v, Lvar w, l2) -> Hash_ident.add subst v (simplif (Lam.var w)); simplif l2 - | Llet(Strict as kind, - v, (Lprim {primitive = (Pmakeblock(0, _, Mutable) - as primitive); - args = [linit] ; loc}), lbody) - -> + | Llet + ( (Strict as kind), + v, + Lprim + { + primitive = Pmakeblock (0, _, Mutable) as primitive; + args = [linit]; + loc; + }, + lbody ) -> ( let slinit = simplif linit in let slbody = simplif lbody in - begin - try (* TODO: record all references variables *) - Lam_util.refine_let - ~kind:Variable v slinit - (Lam_pass_eliminate_ref.eliminate_ref v slbody) - with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let - ~kind v (Lam.prim ~primitive ~args:[slinit] loc) - slbody - end - | Llet(Alias, v, l1, l2) -> + try + (* TODO: record all references variables *) + Lam_util.refine_let ~kind:Variable v slinit + (Lam_pass_eliminate_ref.eliminate_ref v slbody) + with Lam_pass_eliminate_ref.Real_reference -> + Lam_util.refine_let ~kind v + (Lam.prim ~primitive ~args:[slinit] loc) + slbody) + | Llet (Alias, v, l1, l2) -> ( (* For alias, [l1] is pure, we can always inline, when captured, we should avoid recomputation *) - begin - match count_var v, l1 with - | {times = 0; _}, _ -> simplif l2 - | {times = 1; captured = false }, _ - | {times = 1; captured = true }, (Lconst _ | Lvar _) - | _, (Lconst - (( - Const_int _ | Const_char _ | Const_float _ | Const_bigint _ - ) - | Const_pointer _ |Const_js_true | Const_js_false | Const_js_undefined _) (* could be poly-variant [`A] -> [65a]*) - | Lprim {primitive = Pfield (_); - args = [ - Lglobal_module _ - ]} - ) - (* Const_int64 is no longer primitive - Note for some constant which is not - inlined, we can still record it and - do constant folding independently - *) - -> - Hash_ident.add subst v (simplif l1); simplif l2 - | _, Lconst (Const_string {s; unicode = false} ) -> - (* only "" added for later inlining *) - Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) - (* we need move [simplif l2] later, since adding Hash does have side effect *) - | _ -> Lam.let_ Alias v (simplif l1) (simplif l2) - (* for Alias, in most cases [l1] is already simplified *) - end - | Llet(StrictOpt as kind, v, l1, lbody) -> - (* can not be inlined since [l1] depend on the store - {[ - let v = [|1;2;3|] - ]} - get [StrictOpt] here, we can not inline v, - since the value of [v] can be changed + match (count_var v, l1) with + | {times = 0; _}, _ -> simplif l2 + | {times = 1; captured = false}, _ + | {times = 1; captured = true}, (Lconst _ | Lvar _) + | ( _, + ( Lconst + ( Const_int _ | Const_char _ | Const_float _ | Const_bigint _ + | Const_pointer _ | Const_js_true | Const_js_false + | Const_js_undefined _ ) (* could be poly-variant [`A] -> [65a]*) + | Lprim {primitive = Pfield _; args = [Lglobal_module _]} ) ) + (* Const_int64 is no longer primitive + Note for some constant which is not + inlined, we can still record it and + do constant folding independently + *) -> + Hash_ident.add subst v (simplif l1); + simplif l2 + | _, Lconst (Const_string {s; unicode = false}) -> + (* only "" added for later inlining *) + Hash_ident.add string_table v s; + Lam.let_ Alias v l1 (simplif l2) + (* we need move [simplif l2] later, since adding Hash does have side effect *) + | _ -> + Lam.let_ Alias v (simplif l1) (simplif l2) + (* for Alias, in most cases [l1] is already simplified *)) + | Llet ((StrictOpt as kind), v, l1, lbody) -> ( + if + (* can not be inlined since [l1] depend on the store + {[ + let v = [|1;2;3|] + ]} + get [StrictOpt] here, we can not inline v, + since the value of [v] can be changed - GPR #1476 - Note to pass the sanitizer, we do need remove dead code (not just best effort) - This logic is tied to {!Lam_pass_count.count} - {[ - if kind = Strict || used v then count bv l1 - ]} - If the code which should be removed is not removed, it will hold references - to other variables which is already removed. - *) - if not (used v) + GPR #1476 + Note to pass the sanitizer, we do need remove dead code (not just best effort) + This logic is tied to {!Lam_pass_count.count} + {[ + if kind = Strict || used v then count bv l1 + ]} + If the code which should be removed is not removed, it will hold references + to other variables which is already removed. + *) + not (used v) then simplif lbody (* GPR #1476 *) else - begin match l1 with - | (Lprim {primitive = (Pmakeblock(0, _, Mutable) - as primitive); - args = [linit] ; loc}) - -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin - try (* TODO: record all references variables *) - Lam_util.refine_let - ~kind:Variable v slinit - (Lam_pass_eliminate_ref.eliminate_ref v slbody) - with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let - ~kind v (Lam.prim ~primitive ~args:[slinit] loc) - slbody - end - - | _ -> - let l1 = simplif l1 in - begin match l1 with - | Lconst(Const_string { s; unicode = false }) -> - Hash_ident.add string_table v s; - (* we need move [simplif lbody] later, since adding Hash does have side effect *) - Lam.let_ Alias v l1 (simplif lbody) - | _ -> - Lam_util.refine_let ~kind v l1 (simplif lbody) - end - end - (* TODO: check if it is correct rollback to [StrictOpt]? *) - - | Llet((Strict | Variable as kind), v, l1, l2) -> - if not (used v) - then + match l1 with + | Lprim + { + primitive = Pmakeblock (0, _, Mutable) as primitive; + args = [linit]; + loc; + } -> ( + let slinit = simplif linit in + let slbody = simplif lbody in + try + (* TODO: record all references variables *) + Lam_util.refine_let ~kind:Variable v slinit + (Lam_pass_eliminate_ref.eliminate_ref v slbody) + with Lam_pass_eliminate_ref.Real_reference -> + Lam_util.refine_let ~kind v + (Lam.prim ~primitive ~args:[slinit] loc) + slbody) + | _ -> ( + let l1 = simplif l1 in + match l1 with + | Lconst (Const_string {s; unicode = false}) -> + Hash_ident.add string_table v s; + (* we need move [simplif lbody] later, since adding Hash does have side effect *) + Lam.let_ Alias v l1 (simplif lbody) + | _ -> Lam_util.refine_let ~kind v l1 (simplif lbody)) + (* TODO: check if it is correct rollback to [StrictOpt]? *)) + | Llet (((Strict | Variable) as kind), v, l1, l2) -> ( + if not (used v) then let l1 = simplif l1 in let l2 = simplif l2 in - if Lam_analysis.no_side_effects l1 - then l2 - else Lam.seq l1 l2 - else - let l1 = (simplif l1) in - - begin match kind, l1 with - | Strict, Lconst((Const_string { s; unicode = false })) - -> - Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) - | _ -> - Lam_util.refine_let ~kind v l1 (simplif l2) - end - | Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2) - - | Lapply{ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} - when Ext_list.same_length params args && Lam_analysis.lfunction_can_be_inlined lfunction -> - simplif (Lam_beta_reduce.no_names_beta_reduce params body args) - (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *) - (* *\) *) - (* when Ext_list.same_length params args -> *) - (* simplif (Lam_beta_reduce.beta_reduce params body args) *) + if Lam_analysis.no_side_effects l1 then l2 else Lam.seq l1 l2 + else + let l1 = simplif l1 in - | Lapply{ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info - | Lfunction{arity; params; body; attr} -> + match (kind, l1) with + | Strict, Lconst (Const_string {s; unicode = false}) -> + Hash_ident.add string_table v s; + Lam.let_ Alias v l1 (simplif l2) + | _ -> Lam_util.refine_let ~kind v l1 (simplif l2)) + | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) + | Lapply + {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} + when Ext_list.same_length params args + && Lam_analysis.lfunction_can_be_inlined lfunction -> + simplif (Lam_beta_reduce.no_names_beta_reduce params body args) + (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) + (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) + (* (\** TODO: keep track of this parameter in ocaml trunk, *) + (* can we switch to the tupled backend? *) + (* *\) *) + (* when Ext_list.same_length params args -> *) + (* simplif (Lam_beta_reduce.beta_reduce params body args) *) + | Lapply {ap_func = l1; ap_args = ll; ap_info} -> + Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info + | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Lconst _ -> lam - | Lletrec(bindings, body) -> - Lam.letrec - (Ext_list.map_snd bindings simplif) - (simplif body) - | Lprim {primitive=Pstringadd; args = [l;r]; loc } -> - begin - let l' = simplif l in - let r' = simplif r in - let opt_l = - match l' with - | Lconst(Const_string { s = ls; unicode = false }) -> Some ls - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - match opt_l with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc - | Some l_s -> - let opt_r = - match r' with - | Lconst (Const_string {s = rs; unicode = false}) -> Some rs - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - begin match opt_r with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc - | Some r_s -> - Lam.const (Const_string { s = l_s^r_s; unicode = false }) - end - end - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} - -> Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc - | Lswitch(l, sw) -> - let new_l = simplif l - and new_consts = Ext_list.map_snd sw.sw_consts simplif - and new_blocks = Ext_list.map_snd sw.sw_blocks simplif - and new_fail = Ext_option.map sw.sw_failaction simplif + | Lletrec (bindings, body) -> + Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + | Lprim {primitive = Pstringadd; args = [l; r]; loc} -> ( + let l' = simplif l in + let r' = simplif r in + let opt_l = + match l' with + | Lconst (Const_string {s = ls; unicode = false}) -> Some ls + | Lvar i -> Hash_ident.find_opt string_table i + | _ -> None in - Lam.switch - new_l - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail} - | Lstringswitch (l,sw,d) -> - Lam.stringswitch - (simplif l) (Ext_list.map_snd sw simplif) + match opt_l with + | None -> Lam.prim ~primitive:Pstringadd ~args:[l'; r'] loc + | Some l_s -> ( + let opt_r = + match r' with + | Lconst (Const_string {s = rs; unicode = false}) -> Some rs + | Lvar i -> Hash_ident.find_opt string_table i + | _ -> None + in + match opt_r with + | None -> Lam.prim ~primitive:Pstringadd ~args:[l'; r'] loc + | Some r_s -> Lam.const (Const_string {s = l_s ^ r_s; unicode = false})) + ) + | Lglobal_module _ -> lam + | Lprim {primitive; args; loc} -> + Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc + | Lswitch (l, sw) -> + let new_l = simplif l + and new_consts = Ext_list.map_snd sw.sw_consts simplif + and new_blocks = Ext_list.map_snd sw.sw_blocks simplif + and new_fail = Ext_option.map sw.sw_failaction simplif in + Lam.switch new_l + { + sw with + sw_consts = new_consts; + sw_blocks = new_blocks; + sw_failaction = new_fail; + } + | Lstringswitch (l, sw, d) -> + Lam.stringswitch (simplif l) + (Ext_list.map_snd sw simplif) (Ext_option.map d simplif) - | Lstaticraise (i,ls) -> - Lam.staticraise i (Ext_list.map ls simplif) - | Lstaticcatch(l1, (i,args), l2) -> - Lam.staticcatch (simplif l1) (i,args) (simplif l2) - | Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse(l1, l2, l3) -> - Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lwhile(l1, l2) - -> - Lam.while_ (simplif l1) (simplif l2) - | Lfor(v, l1, l2, dir, l3) -> + | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simplif) + | Lstaticcatch (l1, (i, args), l2) -> + Lam.staticcatch (simplif l1) (i, args) (simplif l2) + | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) + | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) + | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) + | Lfor (v, l1, l2, dir, l3) -> Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lassign(v, l) -> Lam.assign v (simplif l) - in simplif lam - + | Lassign (v, l) -> Lam.assign v (simplif l) + in + simplif lam (* To transform let-bound references into variables *) -let apply_lets occ lambda = +let apply_lets occ lambda = let count_var v = - match - Hash_ident.find_opt occ v - with + match Hash_ident.find_opt occ v with | None -> Lam_pass_count.dummy_info () - | Some v -> v in - lets_helper count_var lambda + | Some v -> v + in + lets_helper count_var lambda -let simplify_lets (lam : Lam.t) : Lam.t = - let occ = Lam_pass_count.collect_occurs lam in +let simplify_lets (lam : Lam.t) : Lam.t = + let occ = Lam_pass_count.collect_occurs lam in (* Ext_log.dwarn ~__POS__ "@[%a@]@." Lam_pass_count.pp_occ_tbl occ ; *) - apply_lets occ lam + apply_lets occ lam diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 47f5385d66..9d1f411e1c 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -30,83 +30,79 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = | Some (Normal_optional _) | Some (MutableBlock _) | Some (Constant (Const_block _ | Const_js_true)) -> - Eval_true - | Some (Constant (Const_int { i })) -> - if i = 0l then Eval_false else Eval_true + Eval_true + | Some (Constant (Const_int {i})) -> if i = 0l then Eval_false else Eval_true | Some (Constant (Const_js_false | Const_js_null | Const_js_undefined _)) -> - Eval_false + Eval_false | Some ( Constant _ | Module _ | FunctionId _ | Exception | Parameter | NA | OptionalBlock (_, (Undefined | Null | Null_undefined)) ) | None -> - Eval_unknown + Eval_unknown let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = let rec simpl (lam : Lam.t) : Lam.t = match lam with | Lvar _ -> lam - | Lprim { primitive = Pfield (i, info) as primitive; args = [ arg ]; loc } - -> ( - (* ATTENTION: - Main use case, we should detect inline all immutable block .. *) - match simpl arg with - | Lvar v as l -> - Lam_util.field_flatten_get - (fun _ -> Lam.prim ~primitive ~args:[ l ] loc) - v i info meta.ident_tbl - | l -> Lam.prim ~primitive ~args:[ l ] loc) + | Lprim {primitive = Pfield (i, info) as primitive; args = [arg]; loc} -> ( + (* ATTENTION: + Main use case, we should detect inline all immutable block .. *) + match simpl arg with + | Lvar v as l -> + Lam_util.field_flatten_get + (fun _ -> Lam.prim ~primitive ~args:[l] loc) + v i info meta.ident_tbl + | l -> Lam.prim ~primitive ~args:[l] loc) | Lprim { primitive = (Pval_from_option | Pval_from_option_not_nest) as p; - args = [ (Lvar v as lvar) ]; + args = [(Lvar v as lvar)]; } as x -> ( - match Hash_ident.find_opt meta.ident_tbl v with - | Some (OptionalBlock (l, _)) -> l - | _ -> if p = Pval_from_option_not_nest then lvar else x) + match Hash_ident.find_opt meta.ident_tbl v with + | Some (OptionalBlock (l, _)) -> l + | _ -> if p = Pval_from_option_not_nest then lvar else x) | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc + | Lprim {primitive; args; loc} -> + Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc | Lifthenelse - ((Lprim { primitive = Pis_not_none; args = [ Lvar id ] } as l1), l2, l3) + ((Lprim {primitive = Pis_not_none; args = [Lvar id]} as l1), l2, l3) -> ( - match Hash_ident.find_opt meta.ident_tbl id with - | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> - simpl l2 - | Some (OptionalBlock (l, Null)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null ~args:[ l ] Location.none)) - (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_undefined ~args:[ l ] Location.none)) - (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Null_undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null_undefined ~args:[ l ] - Location.none)) - (simpl l2) (simpl l3) - | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) + match Hash_ident.find_opt meta.ident_tbl id with + | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> simpl l2 + | Some (OptionalBlock (l, Null)) -> + Lam.if_ + (Lam.not_ Location.none + (Lam.prim ~primitive:Pis_null ~args:[l] Location.none)) + (simpl l2) (simpl l3) + | Some (OptionalBlock (l, Undefined)) -> + Lam.if_ + (Lam.not_ Location.none + (Lam.prim ~primitive:Pis_undefined ~args:[l] Location.none)) + (simpl l2) (simpl l3) + | Some (OptionalBlock (l, Null_undefined)) -> + Lam.if_ + (Lam.not_ Location.none + (Lam.prim ~primitive:Pis_null_undefined ~args:[l] Location.none)) + (simpl l2) (simpl l3) + | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) (* could be the code path {[ match x with | h::hs -> ]} *) | Lifthenelse (l1, l2, l3) -> ( - match l1 with - | Lvar id -> ( - match id_is_for_sure_true_in_boolean meta.ident_tbl id with - | Eval_true -> simpl l2 - | Eval_false -> simpl l3 - | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) + match l1 with + | Lvar id -> ( + match id_is_for_sure_true_in_boolean meta.ident_tbl id with + | Eval_true -> simpl l2 + | Eval_false -> simpl l3 + | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) + | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) | Lconst _ -> lam | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) + let bindings = Ext_list.map_snd bindings simpl in + Lam.letrec bindings (simpl body) (* complicated 1. inline this function 2. ... @@ -120,111 +116,105 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = ap_func = Lprim { - primitive = Pfield (_, Fld_module { name = fld_name }); - args = [ Lglobal_module (ident, dynamic_import) ]; + primitive = Pfield (_, Fld_module {name = fld_name}); + args = [Lglobal_module (ident, dynamic_import)]; _; } as l1; ap_args = args; ap_info; } -> ( - match Lam_compile_env.query_external_id_info ~dynamic_import ident fld_name with - | { - persistent_closed_lambda = - Some (Lfunction ({ params; body } as lfunction)); - } - (* be more cautious when do cross module inlining *) - when Ext_list.same_length params args - && Ext_list.for_all args (fun arg -> - match arg with - | Lvar p -> ( - match Hash_ident.find_opt meta.ident_tbl p with - | Some v -> v <> Parameter - | None -> true) - | _ -> true) - && Lam_analysis.lfunction_can_be_inlined lfunction -> - simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) - | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) + match + Lam_compile_env.query_external_id_info ~dynamic_import ident fld_name + with + | { + persistent_closed_lambda = Some (Lfunction ({params; body} as lfunction)); + } + (* be more cautious when do cross module inlining *) + when Ext_list.same_length params args + && Ext_list.for_all args (fun arg -> + match arg with + | Lvar p -> ( + match Hash_ident.find_opt meta.ident_tbl p with + | Some v -> v <> Parameter + | None -> true) + | _ -> true) + && Lam_analysis.lfunction_can_be_inlined lfunction -> + simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) + | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) (* Function inlining interact with other optimizations... - parameter attributes - scope issues - code bloat *) - | Lapply { ap_func = Lvar v as fn; ap_args; ap_info } -> ( - (* Check info for always inlining *) + | Lapply {ap_func = Lvar v as fn; ap_args; ap_info} -> ( + (* Check info for always inlining *) - (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) - let ap_args = Ext_list.map ap_args simpl in - let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in - match Hash_ident.find_opt meta.ident_tbl v with - | Some - (FunctionId - { - lambda = - Some - ( Lfunction ({ params; body; attr = { is_a_functor } } as m), - rec_flag ); - }) - when Lam_analysis.lfunction_can_be_inlined m -> - if Ext_list.same_length ap_args params then - if - is_a_functor - (* && (Set_ident.mem v meta.export_idents) && false *) - then - (* TODO: check l1 if it is exported, - if so, maybe not since in that case, - we are going to have two copy? - *) + (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) + let ap_args = Ext_list.map ap_args simpl in + let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in + match Hash_ident.find_opt meta.ident_tbl v with + | Some + (FunctionId + { + lambda = + Some + ( Lfunction ({params; body; attr = {is_a_functor}} as m), + rec_flag ); + }) + when Lam_analysis.lfunction_can_be_inlined m -> + if Ext_list.same_length ap_args params then + if is_a_functor (* && (Set_ident.mem v meta.export_idents) && false *) + then + (* TODO: check l1 if it is exported, + if so, maybe not since in that case, + we are going to have two copy? + *) - (* Check: recursive applying may result in non-termination *) - (* Ext_log.dwarn __LOC__ "beta .. %s/%d" v.name v.stamp ; *) - simpl - (Lam_beta_reduce.propagate_beta_reduce meta params body - ap_args) - else if - (* Lam_analysis.size body < Lam_analysis.small_inline_size *) - (* ap_inlined = Always_inline || *) - Lam_analysis.ok_to_inline_fun_when_app m ap_args - then - (* let param_map = *) - (* Lam_analysis.free_variables meta.export_idents *) - (* (Lam_analysis.param_map_of_list params) body in *) - (* let old_count = List.length params in *) - (* let new_count = Map_ident.cardinal param_map in *) - let param_map = - Lam_closure.is_closed_with_map meta.export_idents params body - in - let is_export_id = Set_ident.mem meta.export_idents v in - match (is_export_id, param_map) with - | false, (_, param_map) | true, (true, param_map) -> ( - match rec_flag with - | Lam_rec -> - Lam_beta_reduce.propagate_beta_reduce_with_map meta - param_map params body ap_args - | Lam_self_rec -> normal () - | Lam_non_rec -> - if - Ext_list.exists ap_args (fun lam -> - Lam_hit.hit_variable v lam) - (*avoid nontermination, e.g, `g(g)`*) - then normal () - else - simpl - (Lam_beta_reduce.propagate_beta_reduce_with_map meta - param_map params body ap_args)) - | _ -> normal () - else normal () - else normal () - | Some _ | None -> normal ()) + (* Check: recursive applying may result in non-termination *) + (* Ext_log.dwarn __LOC__ "beta .. %s/%d" v.name v.stamp ; *) + simpl + (Lam_beta_reduce.propagate_beta_reduce meta params body ap_args) + else if + (* Lam_analysis.size body < Lam_analysis.small_inline_size *) + (* ap_inlined = Always_inline || *) + Lam_analysis.ok_to_inline_fun_when_app m ap_args + then + (* let param_map = *) + (* Lam_analysis.free_variables meta.export_idents *) + (* (Lam_analysis.param_map_of_list params) body in *) + (* let old_count = List.length params in *) + (* let new_count = Map_ident.cardinal param_map in *) + let param_map = + Lam_closure.is_closed_with_map meta.export_idents params body + in + let is_export_id = Set_ident.mem meta.export_idents v in + match (is_export_id, param_map) with + | false, (_, param_map) | true, (true, param_map) -> ( + match rec_flag with + | Lam_rec -> + Lam_beta_reduce.propagate_beta_reduce_with_map meta param_map + params body ap_args + | Lam_self_rec -> normal () + | Lam_non_rec -> + if + Ext_list.exists ap_args (fun lam -> + Lam_hit.hit_variable v lam) + (*avoid nontermination, e.g, `g(g)`*) + then normal () + else + simpl + (Lam_beta_reduce.propagate_beta_reduce_with_map meta + param_map params body ap_args)) + | _ -> normal () + else normal () + else normal () + | Some _ | None -> normal ()) | Lapply - { - ap_func = Lfunction ({ params; body } as lfunction); - ap_args = args; - _; - } + {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} when Ext_list.same_length params args && Lam_analysis.lfunction_can_be_inlined lfunction -> - simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) + simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) (* (\** TODO: keep track of this parameter in ocaml trunk, *) @@ -232,10 +222,10 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* *\) *) (* when Ext_list.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) - | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(simpl body) ~attr + | Lapply {ap_func = l1; ap_args = ll; ap_info} -> + Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info + | Lfunction {arity; params; body; attr} -> + Lam.function_ ~arity ~params ~body:(simpl body) ~attr | Lswitch ( l, { @@ -246,35 +236,35 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_names; } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; - } + Lam.switch (simpl l) + { + sw_consts = Ext_list.map_snd sw_consts simpl; + sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts_full; + sw_blocks_full; + sw_failaction = Ext_option.map sw_failaction simpl; + sw_names; + } | Lstringswitch (l, sw, d) -> - let l = - match l with - | Lvar s -> ( - match Hash_ident.find_opt meta.ident_tbl s with - | Some (Constant s) -> Lam.const s - | Some _ | None -> simpl l) - | _ -> simpl l - in - Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) + let l = + match l with + | Lvar s -> ( + match Hash_ident.find_opt meta.ident_tbl s with + | Some (Constant s) -> Lam.const s + | Some _ | None -> simpl l) + | _ -> simpl l + in + Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) + (* Lalias-bound variables are never assigned, so don't increase + v's refsimpl *) + Lam.assign v (simpl l) in simpl lam diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index dca75bce3c..21cedb23e5 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -28,7 +28,8 @@ type ident = Ident.t type record_representation = | Record_regular - | Record_inlined of { tag : int; name : string; num_nonconsts : int } (* Inlined record *) + | Record_inlined of {tag: int; name: string; num_nonconsts: int} + (* Inlined record *) | Record_extension (* Inlined record under extension *) @@ -37,25 +38,20 @@ type t = | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag | Pfield of int * Lam_compat.field_dbg_info | Psetfield of int * Lam_compat.set_field_dbg_info - (* could have field info at least for record *) | Pduprecord - (* Force lazy values *) | Plazyforce - (* External call *) | Pjs_call of { - prim_name : string; - arg_types : External_arg_spec.params; - ffi : External_ffi_types.external_spec; + prim_name: string; + arg_types: External_arg_spec.params; + ffi: External_ffi_types.external_spec; dynamic_import: bool; } | Pjs_object_create of External_arg_spec.obj_params - (* Exceptions *) | Praise - (* object primitives *) | Pobjcomp of Lam_compat.comparison | Pobjorder @@ -63,7 +59,6 @@ type t = | Pobjmax | Pobjtag | Pobjsize - (* Boolean primitives *) | Psequand | Psequor @@ -72,7 +67,6 @@ type t = | Pboolorder | Pboolmin | Pboolmax - (* Integer primitives *) | Pisint | Pnegint @@ -93,7 +87,6 @@ type t = | Pintorder | Pintmin | Pintmax - (* Float primitives *) | Pintoffloat | Pfloatofint @@ -107,7 +100,6 @@ type t = | Pfloatorder | Pfloatmin | Pfloatmax - (* BigInt operations *) | Pnegbigint | Paddbigint @@ -125,7 +117,6 @@ type t = | Pbigintorder | Pbigintmin | Pbigintmax - (* String primitives *) | Pstringlength | Pstringrefu @@ -135,7 +126,6 @@ type t = | Pstringorder | Pstringmin | Pstringmax - (* Array primitives *) | Pmakearray | Parraylength @@ -143,16 +133,12 @@ type t = | Parraysetu | Parrayrefs | Parraysets - (* List primitives *) | Pmakelist - (* dict primitives *) | Pmakedict - (* promise *) | Pawait - (* etc or deprecated *) | Pis_poly_var_block | Pisout of int @@ -160,7 +146,7 @@ type t = | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger - | Pjs_unsafe_downgrade of { name : string; setter : bool } + | Pjs_unsafe_downgrade of {name: string; setter: bool} | Pinit_mod | Pupdate_mod | Praw_js_code of Js_raw_info.t @@ -180,7 +166,8 @@ type t = | Pimport | Ptypeof | Pfn_arity - | Pwrap_exn (* convert either JS exception or OCaml exception into OCaml format *) + | Pwrap_exn + (* convert either JS exception or OCaml exception into OCaml format *) | Pcreate_extension of string | Pis_not_none (* no info about its type *) | Pval_from_option @@ -206,76 +193,25 @@ let eq_tag_info (x : Lam_tag_info.t) y = x = y let eq_primitive_approx (lhs : t) (rhs : t) = match lhs with - | Pwrap_exn - | Praise + | Pwrap_exn | Praise (* generic comparison *) - | Pobjorder - | Pobjmin - | Pobjmax - | Pobjtag - | Pobjsize + | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize (* bool primitives *) - | Psequand - | Psequor - | Pnot - | Pboolcomp _ - | Pboolorder - | Pboolmin - | Pboolmax + | Psequand | Psequor | Pnot | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax (* int primitives *) - | Pisint - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Pandint - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Pintorder - | Pintmin + | Pisint | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint + | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintorder | Pintmin | Pintmax (* float primitives *) - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pmodfloat - | Pfloatorder - | Pfloatmin - | Pfloatmax + | Pintoffloat | Pfloatofint | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat + | Pdivfloat | Pmodfloat | Pfloatorder | Pfloatmin | Pfloatmax (* bigint primitives *) - | Pnegbigint - | Paddbigint - | Psubbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Ppowbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Plslbigint - | Pasrbigint - | Pbigintorder - | Pbigintmin - | Pbigintmax + | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Pdivbigint | Pmodbigint + | Ppowbigint | Pandbigint | Porbigint | Pxorbigint | Plslbigint | Pasrbigint + | Pbigintorder | Pbigintmin | Pbigintmax (* string primitives *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringadd - | Pstringcomp _ - | Pstringorder - | Pstringmin - | Pstringmax + | Pstringlength | Pstringrefu | Pstringrefs | Pstringadd | Pstringcomp _ + | Pstringorder | Pstringmin | Pstringmax (* List primitives *) | Pmakelist (* dict primitives *) @@ -283,97 +219,81 @@ let eq_primitive_approx (lhs : t) (rhs : t) = (* promise *) | Pawait (* etc *) - | Pjs_apply - | Pjs_runtime_apply - | Pval_from_option - | Pval_from_option_not_nest - | Pundefined_to_opt - | Pnull_to_opt - | Pnull_undefined_to_opt - | Pis_null - | Pis_not_none - | Psome - | Psome_not_nest - | Pis_undefined - | Pis_null_undefined - | Pimport - | Ptypeof - | Pfn_arity - | Plazyforce - | Pis_poly_var_block - | Pdebugger - | Pinit_mod - | Pupdate_mod - | Pduprecord - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - | Pjs_fn_make_unit - | Pjs_fn_method - | Phash - | Phash_mixstring - | Phash_mixint - | Phash_finalmix - -> rhs = lhs + | Pjs_apply | Pjs_runtime_apply | Pval_from_option | Pval_from_option_not_nest + | Pundefined_to_opt | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null + | Pis_not_none | Psome | Psome_not_nest | Pis_undefined | Pis_null_undefined + | Pimport | Ptypeof | Pfn_arity | Plazyforce | Pis_poly_var_block | Pdebugger + | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength + | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_make_unit + | Pjs_fn_method | Phash | Phash_mixstring | Phash_mixint | Phash_finalmix -> + rhs = lhs | Pcreate_extension a -> ( - match rhs with Pcreate_extension b -> a = (b : string) | _ -> false) - | Pisout l -> ( match rhs with Pisout r -> l = r | _ -> false) + match rhs with + | Pcreate_extension b -> a = (b : string) + | _ -> false) + | Pisout l -> ( + match rhs with + | Pisout r -> l = r + | _ -> false) (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) | Pfield (n0, info0) -> ( - match rhs with - | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 - | _ -> false) + match rhs with + | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 + | _ -> false) | Psetfield (i0, info0) -> ( - match rhs with - | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 - | _ -> false) + match rhs with + | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 + | _ -> false) | Pmakeblock (i0, info0, flag0) -> ( - match rhs with - | Pmakeblock (i1, info1, flag1) -> - i0 = i1 && flag0 = flag1 && eq_tag_info info0 info1 - | _ -> false) - | Pjs_call { prim_name; arg_types; ffi; dynamic_import } -> ( - match rhs with - | Pjs_call rhs -> - prim_name = rhs.prim_name && arg_types = rhs.arg_types - && ffi = rhs.ffi && dynamic_import = rhs.dynamic_import - | _ -> false) + match rhs with + | Pmakeblock (i1, info1, flag1) -> + i0 = i1 && flag0 = flag1 && eq_tag_info info0 info1 + | _ -> false) + | Pjs_call {prim_name; arg_types; ffi; dynamic_import} -> ( + match rhs with + | Pjs_call rhs -> + prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi + && dynamic_import = rhs.dynamic_import + | _ -> false) | Pjs_object_create obj_create -> ( - match rhs with - | Pjs_object_create obj_create1 -> obj_create = obj_create1 - | _ -> false) + match rhs with + | Pjs_object_create obj_create1 -> obj_create = obj_create1 + | _ -> false) | Pobjcomp comparison -> ( - match rhs with - | Pobjcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) + match rhs with + | Pobjcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 + | _ -> false) | Pintcomp comparison -> ( - match rhs with - | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) + match rhs with + | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 + | _ -> false) | Pfloatcomp comparison -> ( - match rhs with - | Pfloatcomp comparison1 -> - Lam_compat.eq_comparison comparison comparison1 - | _ -> false) + match rhs with + | Pfloatcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 + | _ -> false) | Pbigintcomp comparison -> ( - match rhs with - | Pbigintcomp comparison1 -> - Lam_compat.eq_comparison comparison comparison1 - | _ -> false) + match rhs with + | Pbigintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 + | _ -> false) | Pjscomp comparison -> ( - match rhs with - | Pjscomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Poffsetint i0 -> ( match rhs with Poffsetint i1 -> i0 = i1 | _ -> false) - | Poffsetref i0 -> ( match rhs with Poffsetref i1 -> i0 = i1 | _ -> false) - | Pjs_unsafe_downgrade { name; setter } -> ( - match rhs with - | Pjs_unsafe_downgrade rhs -> name = rhs.name && setter = rhs.setter - | _ -> false) - | Pjs_fn_make i -> ( match rhs with Pjs_fn_make i1 -> i = i1 | _ -> false) - + match rhs with + | Pjscomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 + | _ -> false) + | Poffsetint i0 -> ( + match rhs with + | Poffsetint i1 -> i0 = i1 + | _ -> false) + | Poffsetref i0 -> ( + match rhs with + | Poffsetref i1 -> i0 = i1 + | _ -> false) + | Pjs_unsafe_downgrade {name; setter} -> ( + match rhs with + | Pjs_unsafe_downgrade rhs -> name = rhs.name && setter = rhs.setter + | _ -> false) + | Pjs_fn_make i -> ( + match rhs with + | Pjs_fn_make i1 -> i = i1 + | _ -> false) | Praw_js_code _ -> false (* TOO lazy, here comparison is only approximation*) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 7d29d6afa1..4f358b525a 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -26,7 +26,8 @@ type ident = Ident.t type record_representation = | Record_regular - | Record_inlined of { tag : int; name : string; num_nonconsts : int } (* Inlined record *) + | Record_inlined of {tag: int; name: string; num_nonconsts: int} + (* Inlined record *) | Record_extension (* Inlined record under extension *) @@ -38,14 +39,13 @@ type t = | Plazyforce | Pjs_call of { (* Location.t * [loc] is passed down *) - prim_name : string; - arg_types : External_arg_spec.params; - ffi : External_ffi_types.external_spec; + prim_name: string; + arg_types: External_arg_spec.params; + ffi: External_ffi_types.external_spec; dynamic_import: bool; } | Pjs_object_create of External_arg_spec.obj_params | Praise - (* object primitives *) | Pobjcomp of Lam_compat.comparison | Pobjorder @@ -53,7 +53,6 @@ type t = | Pobjmax | Pobjtag | Pobjsize - (* bool primitives *) | Psequand | Psequor @@ -62,7 +61,6 @@ type t = | Pboolorder | Pboolmin | Pboolmax - (* int primitives *) | Pisint | Pnegint @@ -83,7 +81,6 @@ type t = | Pintorder | Pintmin | Pintmax - (* float primitives *) | Pintoffloat | Pfloatofint @@ -97,7 +94,6 @@ type t = | Pfloatorder | Pfloatmin | Pfloatmax - (* bigint primitives *) | Pnegbigint | Paddbigint @@ -115,7 +111,6 @@ type t = | Pbigintorder | Pbigintmin | Pbigintmax - (* string primitives *) | Pstringlength | Pstringrefu @@ -125,7 +120,6 @@ type t = | Pstringorder | Pstringmin | Pstringmax - (* Array primitives *) | Pmakearray | Parraylength @@ -133,16 +127,12 @@ type t = | Parraysetu | Parrayrefs | Parraysets - (* List primitives *) | Pmakelist - (* dict primitives *) | Pmakedict - (* promise *) | Pawait - (* etc or deprecated *) | Pis_poly_var_block | Pisout of int @@ -150,7 +140,7 @@ type t = | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger - | Pjs_unsafe_downgrade of { name : string; setter : bool } + | Pjs_unsafe_downgrade of {name: string; setter: bool} | Pinit_mod | Pupdate_mod | Praw_js_code of Js_raw_info.t @@ -166,7 +156,8 @@ type t = | Pimport | Ptypeof | Pfn_arity - | Pwrap_exn (* convert either JS exception or OCaml exception into OCaml format *) + | Pwrap_exn + (* convert either JS exception or OCaml exception into OCaml format *) | Pcreate_extension of string | Pis_not_none | Pval_from_option diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index df76a4636b..17c18d6108 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -20,19 +20,19 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_js_null -> fprintf ppf "#null" | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined _ -> fprintf ppf "#undefined" - | Const_int { i } -> fprintf ppf "%ld" i + | Const_int {i} -> fprintf ppf "%ld" i | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) - | Const_string { s } -> fprintf ppf "%S" s + | Const_string {s} -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_bigint (sign, i) -> fprintf ppf "%sn" (Bigint_utils.to_string sign i) | Const_pointer name -> fprintf ppf "`%s" name | Const_some n -> fprintf ppf "[some-c]%a" struct_const n | Const_block (tag, _, []) -> fprintf ppf "[%i]" tag | Const_block (tag, _, sc1 :: scl) -> - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl - in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl + in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl (* let string_of_loc_kind (loc : Lambda.loc_kind) = match loc with @@ -51,8 +51,8 @@ let primitive ppf (prim : Lam_primitive.t) = | Pupdate_mod -> fprintf ppf "update_mod!" | Pjs_apply -> fprintf ppf "#apply" | Pjs_runtime_apply -> fprintf ppf "#runtime_apply" - | Pjs_unsafe_downgrade { name; setter } -> - if setter then fprintf ppf "##%s#=" name else fprintf ppf "##%s" name + | Pjs_unsafe_downgrade {name; setter} -> + if setter then fprintf ppf "##%s#=" name else fprintf ppf "##%s" name | Pfn_arity -> fprintf ppf "fn.length" | Pjs_fn_make i -> fprintf ppf "js_fn_make_%i" i | Pjs_fn_make_unit -> fprintf ppf "js_fn_make_unit" @@ -75,15 +75,15 @@ let primitive ppf (prim : Lam_primitive.t) = | Pmakeblock (tag, _, Immutable) -> fprintf ppf "makeblock %i" tag | Pmakeblock (tag, _, Mutable) -> fprintf ppf "makemutable %i" tag | Pfield (n, field_info) -> ( - match Lam_compat.str_of_field_info field_info with - | None -> fprintf ppf "field %i" n - | Some s -> fprintf ppf "field %s/%i" s n) + match Lam_compat.str_of_field_info field_info with + | None -> fprintf ppf "field %i" n + | Some s -> fprintf ppf "field %s/%i" s n) | Psetfield (n, _) -> - let instr = "setfield " in - fprintf ppf "%s%i" instr n + let instr = "setfield " in + fprintf ppf "%s%i" instr n | Pduprecord -> fprintf ppf "duprecord" | Plazyforce -> fprintf ppf "force" - | Pjs_call { prim_name } -> fprintf ppf "%s[js]" prim_name + | Pjs_call {prim_name} -> fprintf ppf "%s[js]" prim_name | Pjs_object_create _ -> fprintf ppf "[js.obj]" | Praise -> fprintf ppf "raise" | Pobjcomp Ceq -> fprintf ppf "==" @@ -225,11 +225,11 @@ let to_print_kind (k : Lam_compat.let_kind) : print_kind = let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = match lam with | Llet (str3, id3, arg3, body3) -> - aux ((to_print_kind str3, id3, arg3) :: acc) body3 + aux ((to_print_kind str3, id3, arg3) :: acc) body3 | Lletrec (bind_args, body) -> - aux - (Ext_list.map_append bind_args acc (fun (id, l) -> (Recursive, id, l))) - body + aux + (Ext_list.map_append bind_args acc (fun (id, l) -> (Recursive, id, l))) + body | e -> (acc, e) (* type left_var = @@ -244,9 +244,9 @@ let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = let flatten (lam : Lam.t) : (print_kind * Ident.t * Lam.t) list * Lam.t = match lam with - | Llet (str, id, arg, body) -> aux [ (to_print_kind str, id, arg) ] body + | Llet (str, id, arg, body) -> aux [(to_print_kind str, id, arg)] body | Lletrec (bind_args, body) -> - aux (Ext_list.map bind_args (fun (id, l) -> (Recursive, id, l))) body + aux (Ext_list.map bind_args (fun (id, l) -> (Recursive, id, l))) body | _ -> assert false (* let get_string ((id : Ident.t), (pos : int)) (env : Env.t) : string = @@ -280,121 +280,134 @@ let lambda ppf v = let rec lam ppf (l : Lam.t) = match l with | Lvar id -> Ident.print ppf id - | Lglobal_module (id, dynamic_import) -> fprintf ppf (if dynamic_import then "dynamic global %a" else "global %a") Ident.print id + | Lglobal_module (id, dynamic_import) -> + fprintf ppf + (if dynamic_import then "dynamic global %a" else "global %a") + Ident.print id | Lconst cst -> struct_const ppf cst - | Lapply { ap_func; ap_args; ap_info = { ap_inlined } } -> - let lams ppf args = - List.iter (fun l -> fprintf ppf "@ %a" lam l) args - in - fprintf ppf "@[<2>(apply%s@ %a%a)@]" - (match ap_inlined with Always_inline -> "%inlned" | _ -> "") - lam ap_func lams ap_args - | Lfunction { params; body; _ } -> - let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params - (* | Tupled -> *) - (* fprintf ppf " ("; *) - (* let first = ref true in *) - (* List.iter *) - (* (fun param -> *) - (* if !first then first := false else fprintf ppf ",@ "; *) - (* Ident.print ppf param) *) - (* params; *) - (* fprintf ppf ")" *) - in - fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body + | Lapply {ap_func; ap_args; ap_info = {ap_inlined}} -> + let lams ppf args = List.iter (fun l -> fprintf ppf "@ %a" lam l) args in + fprintf ppf "@[<2>(apply%s@ %a%a)@]" + (match ap_inlined with + | Always_inline -> "%inlned" + | _ -> "") + lam ap_func lams ap_args + | Lfunction {params; body; _} -> + let pr_params ppf params = + List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params + (* | Tupled -> *) + (* fprintf ppf " ("; *) + (* let first = ref true in *) + (* List.iter *) + (* (fun param -> *) + (* if !first then first := false else fprintf ppf ",@ "; *) + (* Ident.print ppf param) *) + (* params; *) + (* fprintf ppf ")" *) + in + fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body | (Llet _ | Lletrec _) as x -> - let args, body = flatten x in - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (k, id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a =%s@ %a@]" Ident.print id (kind k) lam l) - id_arg_list - in - fprintf ppf "@[<2>(let@ (@[%a@]" bindings (List.rev args); - fprintf ppf ")@ %a)@]" lam body + let args, body = flatten x in + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (k, id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a =%s@ %a@]" Ident.print id (kind k) lam l) + id_arg_list + in + fprintf ppf "@[<2>(let@ (@[%a@]" bindings (List.rev args); + fprintf ppf ")@ %a)@]" lam body | Lprim { - primitive = Pfield (n, Fld_module { name = s }); - args = [ Lglobal_module (id, dynamic_import) ]; + primitive = Pfield (n, Fld_module {name = s}); + args = [Lglobal_module (id, dynamic_import)]; _; } -> - fprintf ppf (if dynamic_import then "dynamic %s.%s/%d" else "%s.%s/%d") id.name s n - | Lprim { primitive = prim; args = largs; _ } -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs + fprintf ppf + (if dynamic_import then "dynamic %s.%s/%d" else "%s.%s/%d") + id.name s n + | Lprim {primitive = prim; args = largs; _} -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs + in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch (larg, sw) -> - let switch ppf (sw : Lam.lambda_switch) = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i %S:@ %a@]" n - (match sw.sw_names with None -> "" | Some x -> x.consts.(n).name) - lam l) - sw.sw_consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i %S:@ %a@]" n - (match sw.sw_names with None -> "" | Some x -> x.blocks.(n).tag.name) - lam l) - sw.sw_blocks; - match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with None -> "switch*" | _ -> "switch") - lam larg switch sw + let switch ppf (sw : Lam.lambda_switch) = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i %S:@ %a@]" n + (match sw.sw_names with + | None -> "" + | Some x -> x.consts.(n).name) + lam l) + sw.sw_consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i %S:@ %a@]" n + (match sw.sw_names with + | None -> "" + | Some x -> x.blocks.(n).tag.name) + lam l) + sw.sw_blocks; + match sw.sw_failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + in + fprintf ppf "@[<1>(%s %a@ @[%a@])@]" + (match sw.sw_failaction with + | None -> "switch*" + | _ -> "switch") + lam larg switch sw | Lstringswitch (arg, cases, default) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - in - fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + in + fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs + in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls | Lstaticcatch (lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i - (fun ppf vars -> - match vars with - | [] -> () - | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) - vars lam lhandler + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i + (fun ppf vars -> + match vars with + | [] -> () + | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) + vars lam lhandler | Ltrywith (lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print - param lam lhandler + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print + param lam lhandler | Lifthenelse (lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse | Lsequence (l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 | Lwhile (lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody | Lfor (param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo + (match dir with + | Upto -> "to" + | Downto -> "downto") + lam hi lam body | Lassign (id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr and sequence ppf = function | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 | l -> lam ppf l diff --git a/compiler/core/lam_scc.ml b/compiler/core/lam_scc.ml index f1efa4d745..556feed559 100644 --- a/compiler/core/lam_scc.ml +++ b/compiler/core/lam_scc.ml @@ -30,7 +30,9 @@ *) let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = let rec hit_opt (x : Lam.t option) = - match x with None -> false | Some a -> hit a + match x with + | None -> false + | Some a -> hit a and hit_var (id : Ident.t) = Hash_set_ident_mask.mask_and_check_all_hit mask id and hit_list_snd : 'a. ('a * Lam.t) list -> bool = @@ -42,19 +44,19 @@ let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = | Lassign (id, e) -> hit_var id || hit e | Lstaticcatch (e1, (_, _), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body + | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args + | Lapply {ap_func; ap_args; _} -> hit ap_func || hit_list ap_args | Lglobal_module _ (* playsafe *) -> false - | Lprim { args; _ } -> hit_list args + | Lprim {args; _} -> hit_list args | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction + hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks + || hit_opt sw.sw_failaction | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default + hit arg || hit_list_snd cases || hit_opt default | Lstaticraise (_, args) -> hit_list args | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 | Lsequence (e1, e2) -> hit e1 || hit e2 @@ -85,7 +87,9 @@ let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = (domain, int_mapping, node_vec) let is_function_bind (_, (x : Lam.t)) = - match x with Lfunction _ -> true | _ -> false + match x with + | Lfunction _ -> true + | _ -> false let sort_single_binding_group (group : bindings) = if Ext_list.for_all group is_function_bind then group @@ -102,53 +106,52 @@ let sort_single_binding_group (group : bindings) = (** TODO: even for a singleton recursive function, tell whehter it is recursive or not ? *) let scc_bindings (groups : bindings) : bindings list = match groups with - | [ _ ] -> [ sort_single_binding_group groups ] + | [_] -> [sort_single_binding_group groups] | _ -> - let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters : Int_vec_vec.t = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then - [ sort_single_binding_group groups ] - else - Int_vec_vec.fold_right - (fun (v : Vec_int.t) acc -> - let bindings = - Vec_int.map_into_list - (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map_local_ident.find_value domain id in - (id, lam)) - v - in - sort_single_binding_group bindings :: acc) - clusters [] + let domain, int_mapping, node_vec = preprocess_deps groups in + let clusters : Int_vec_vec.t = Ext_scc.graph node_vec in + if Int_vec_vec.length clusters <= 1 then [sort_single_binding_group groups] + else + Int_vec_vec.fold_right + (fun (v : Vec_int.t) acc -> + let bindings = + Vec_int.map_into_list + (fun i -> + let id = int_mapping.(i) in + let lam = Ordered_hash_map_local_ident.find_value domain id in + (id, lam)) + v + in + sort_single_binding_group bindings :: acc) + clusters [] (* single binding, it does not make sense to do scc, we can eliminate {[ let rec f x = x + x ]}, but it happens rarely in real world *) let scc (groups : bindings) (lam : Lam.t) (body : Lam.t) = match groups with - | [ (id, bind) ] -> - if Lam_hit.hit_variable id bind then lam else Lam.let_ Strict id bind body + | [(id, bind)] -> + if Lam_hit.hit_variable id bind then lam else Lam.let_ Strict id bind body | _ -> - let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then lam - else - Int_vec_vec.fold_right - (fun (v : Vec_int.t) acc -> - let bindings = - Vec_int.map_into_list - (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map_local_ident.find_value domain id in - (id, lam)) - v - in - match bindings with - | [ (id, lam) ] -> - let base_key = Ordered_hash_map_local_ident.rank domain id in - if Int_vec_util.mem base_key node_vec.(base_key) then - Lam.letrec bindings acc - else Lam.let_ Strict id lam acc - | _ -> Lam.letrec bindings acc) - clusters body + let domain, int_mapping, node_vec = preprocess_deps groups in + let clusters = Ext_scc.graph node_vec in + if Int_vec_vec.length clusters <= 1 then lam + else + Int_vec_vec.fold_right + (fun (v : Vec_int.t) acc -> + let bindings = + Vec_int.map_into_list + (fun i -> + let id = int_mapping.(i) in + let lam = Ordered_hash_map_local_ident.find_value domain id in + (id, lam)) + v + in + match bindings with + | [(id, lam)] -> + let base_key = Ordered_hash_map_local_ident.rank domain id in + if Int_vec_util.mem base_key node_vec.(base_key) then + Lam.letrec bindings acc + else Lam.let_ Strict id lam acc + | _ -> Lam.letrec bindings acc) + clusters body diff --git a/compiler/core/lam_stats.ml b/compiler/core/lam_stats.ml index 8ca1b05162..0a99af9393 100644 --- a/compiler/core/lam_stats.ml +++ b/compiler/core/lam_stats.ml @@ -41,10 +41,10 @@ type ident_tbl = Lam_id_kind.t Hash_ident.t type t = { - export_idents : Set_ident.t; - exports : Ident.t list; + export_idents: Set_ident.t; + exports: Ident.t list; (*It is kept since order matters? *) - ident_tbl : ident_tbl; + ident_tbl: ident_tbl; (** we don't need count arities for all identifiers, for identifiers for sure it's not a function, there is no need to count them *) diff --git a/compiler/core/lam_stats.mli b/compiler/core/lam_stats.mli index d8a3d34c7d..e2246eefc6 100644 --- a/compiler/core/lam_stats.mli +++ b/compiler/core/lam_stats.mli @@ -30,9 +30,9 @@ type ident_tbl = Lam_id_kind.t Hash_ident.t type t = { - export_idents : Set_ident.t; - exports : Ident.t list; - ident_tbl : ident_tbl; + export_idents: Set_ident.t; + exports: Ident.t list; + ident_tbl: ident_tbl; (** we don't need count arities for all identifiers, for identifiers for sure it's not a function, there is no need to count them *) diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index c4b98bbb87..8a67454f83 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -34,21 +34,21 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> let arity : Js_cmj_format.arity = match Hash_ident.find_opt meta.ident_tbl x with - | Some (FunctionId { arity; _ }) -> Single arity + | Some (FunctionId {arity; _}) -> Single arity | Some (ImmutableBlock elems) -> - (* FIXME: field name for dumping*) - Submodule - (Ext_array.map elems (fun x -> - match x with - | NA -> Lam_arity.na - | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) + (* FIXME: field name for dumping*) + Submodule + (Ext_array.map elems (fun x -> + match x with + | NA -> Lam_arity.na + | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) | Some _ | None -> ( - match Map_ident.find_opt export_map x with - | Some (Lprim { primitive = Pmakeblock (_, _, Immutable); args }) -> - Submodule - (Ext_array.of_list_map args (fun lam -> - Lam_arity_analysis.get_arity meta lam)) - | Some _ | None -> single_na) + match Map_ident.find_opt export_map x with + | Some (Lprim {primitive = Pmakeblock (_, _, Immutable); args}) -> + Submodule + (Ext_array.of_list_map args (fun lam -> + Lam_arity_analysis.get_arity meta lam)) + | Some _ | None -> single_na) in let persistent_closed_lambda = let optlam = Map_ident.find_opt export_map x in @@ -58,52 +58,52 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : ( Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false )) | None -> - optlam + optlam | Some lambda -> - if not !Js_config.cross_module_inline then None - else if - Lam_analysis.safe_to_inline lambda - (* when inlning a non function, we have to be very careful, - only truly immutable values can be inlined - *) - then - match lambda with - | Lfunction { attr = { inline = Always_inline } } - (* FIXME: is_closed lambda is too restrictive - It precludes ues cases - - inline forEach but not forEachU + if not !Js_config.cross_module_inline then None + else if + Lam_analysis.safe_to_inline lambda + (* when inlning a non function, we have to be very careful, + only truly immutable values can be inlined + *) + then + match lambda with + | Lfunction {attr = {inline = Always_inline}} + (* FIXME: is_closed lambda is too restrictive + It precludes ues cases + - inline forEach but not forEachU + *) + | Lfunction {attr = {is_a_functor = true}} -> + if Lam_closure.is_closed lambda (* TODO: seriealize more*) then + optlam + else None + | _ -> + let lam_size = Lam_analysis.size lambda in + (* TODO: + 1. global need re-assocate when do the beta reduction + 2. [lambda_exports] is not precise *) - | Lfunction { attr = { is_a_functor = true } } -> - if Lam_closure.is_closed lambda (* TODO: seriealize more*) - then optlam - else None - | _ -> - let lam_size = Lam_analysis.size lambda in - (* TODO: - 1. global need re-assocate when do the beta reduction - 2. [lambda_exports] is not precise - *) - let free_variables = - Lam_closure.free_variables Set_ident.empty Map_ident.empty - lambda - in - if - lam_size < Lam_analysis.small_inline_size - && Map_ident.is_empty free_variables - then ( - Ext_log.dwarn ~__POS__ "%s recorded for inlining @." x.name; - optlam) - else None - else None + let free_variables = + Lam_closure.free_variables Set_ident.empty Map_ident.empty + lambda + in + if + lam_size < Lam_analysis.small_inline_size + && Map_ident.is_empty free_variables + then ( + Ext_log.dwarn ~__POS__ "%s recorded for inlining @." x.name; + optlam) + else None + else None in match (arity, persistent_closed_lambda) with | Single Arity_na, (None | Some (Lconst Const_module_alias)) -> acc | Submodule [||], None -> acc | _ -> - let cmj_value : Js_cmj_format.cmj_value = - { arity; persistent_closed_lambda } - in - Map_string.add acc x.name cmj_value) + let cmj_value : Js_cmj_format.cmj_value = + {arity; persistent_closed_lambda} + in + Map_string.add acc x.name cmj_value) (* ATTENTION: all runtime modules, if it is not hard required, it should be okay to not reference it diff --git a/compiler/core/lam_subst.ml b/compiler/core/lam_subst.ml index 0d189ed73c..d5469619a3 100644 --- a/compiler/core/lam_subst.ml +++ b/compiler/core/lam_subst.ml @@ -33,42 +33,45 @@ let subst (s : Lam.t Map_ident.t) lam = match x with | Lvar id -> Map_ident.find_default s id x | Lconst _ -> x - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr + | Lapply {ap_func; ap_args; ap_info} -> + Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info + | Lfunction {arity; params; body; attr} -> + Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr | Llet (str, id, arg, body) -> - Lam.let_ str id (subst_aux arg) (subst_aux body) + Lam.let_ str id (subst_aux arg) (subst_aux body) | Lletrec (decl, body) -> - Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc + Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) + | Lprim {primitive; args; loc} -> + Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc | Lglobal_module _ -> x | Lswitch (arg, sw) -> - Lam.switch (subst_aux arg) - { - sw with - sw_consts = Ext_list.map sw.sw_consts subst_case; - sw_blocks = Ext_list.map sw.sw_blocks subst_case; - sw_failaction = subst_opt sw.sw_failaction; - } + Lam.switch (subst_aux arg) + { + sw with + sw_consts = Ext_list.map sw.sw_consts subst_case; + sw_blocks = Ext_list.map sw.sw_blocks subst_case; + sw_failaction = subst_opt sw.sw_failaction; + } | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (subst_aux arg) - (Ext_list.map cases subst_strcase) - (subst_opt default) + Lam.stringswitch (subst_aux arg) + (Ext_list.map cases subst_strcase) + (subst_opt default) | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) | Lstaticcatch (e1, io, e2) -> - Lam.staticcatch (subst_aux e1) io (subst_aux e2) + Lam.staticcatch (subst_aux e1) io (subst_aux e2) | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) | Lifthenelse (e1, e2, e3) -> - Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) + Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) | Lwhile (e1, e2) -> Lam.while_ (subst_aux e1) (subst_aux e2) | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) + Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) | Lassign (id, e) -> Lam.assign id (subst_aux e) and subst_decl (id, exp) = (id, subst_aux exp) and subst_case (key, case) = (key, subst_aux case) and subst_strcase (key, case) = (key, subst_aux case) - and subst_opt = function None -> None | Some e -> Some (subst_aux e) in + and subst_opt = function + | None -> None + | Some e -> Some (subst_aux e) + in subst_aux lam diff --git a/compiler/core/lam_var_stats.ml b/compiler/core/lam_var_stats.ml index db39605f92..28c9c8fe5a 100644 --- a/compiler/core/lam_var_stats.ml +++ b/compiler/core/lam_var_stats.ml @@ -26,7 +26,7 @@ let loop_use = 100 type stats = { - top : bool; + top: bool; (* all appearances are in the top, substitution is fine whether it is pure or not {[ @@ -36,16 +36,18 @@ type stats = { since in ocaml, the application order is intentionally undefined, note if [times] is not one, this field does not make sense *) - times : int; + times: int; } -let fresh_stats : stats = { top = true; times = 0 } +let fresh_stats : stats = {top = true; times = 0} -let sink_stats : stats = { top = false; times = loop_use } +let sink_stats : stats = {top = false; times = loop_use} (* let stats top times = {top; times} *) let top_and_used_zero_or_one x = - match x with { top = true; times = 0 | 1 } -> true | _ -> false + match x with + | {top = true; times = 0 | 1} -> true + | _ -> false type position = | Begin (* top = true ; loop = false *) @@ -55,8 +57,8 @@ type position = let update (v : stats) (pos : position) : stats = match pos with - | Begin -> { v with times = v.times + 1 } - | Not_begin -> { top = false; times = v.times + 1 } + | Begin -> {v with times = v.times + 1} + | Not_begin -> {top = false; times = v.times + 1} | Sink -> sink_stats let sink : position = Sink diff --git a/compiler/core/matching_polyfill.ml b/compiler/core/matching_polyfill.ml index 8955813581..f96bc712dd 100644 --- a/compiler/core/matching_polyfill.ml +++ b/compiler/core/matching_polyfill.ml @@ -22,20 +22,22 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let () = Ast_untagged_variants.extract_concrete_typedecl := Ctype.extract_concrete_typedecl +let () = + Ast_untagged_variants.extract_concrete_typedecl := + Ctype.extract_concrete_typedecl let () = Ast_untagged_variants.expand_head := Ctype.expand_head let names_from_construct_pattern (pat : Typedtree.pattern) = let rec resolve_path n (path : Path.t) = match Env.find_type path pat.pat_env with - | { type_kind = Type_variant cstrs; _ } -> Ast_untagged_variants.names_from_type_variant ~env:pat.pat_env cstrs - | { type_kind = Type_abstract; type_manifest = Some t; _ } -> ( - match (Ctype.unalias t).desc with - | Tconstr (pathn, _, _) -> - resolve_path (n + 1) pathn - | _ -> None) - | { type_kind = Type_abstract; type_manifest = None; _ } -> None - | { type_kind = Type_record _ | Type_open (* Exceptions *); _ } -> None + | {type_kind = Type_variant cstrs; _} -> + Ast_untagged_variants.names_from_type_variant ~env:pat.pat_env cstrs + | {type_kind = Type_abstract; type_manifest = Some t; _} -> ( + match (Ctype.unalias t).desc with + | Tconstr (pathn, _, _) -> resolve_path (n + 1) pathn + | _ -> None) + | {type_kind = Type_abstract; type_manifest = None; _} -> None + | {type_kind = Type_record _ | Type_open (* Exceptions *); _} -> None in match (Btype.repr pat.pat_type).desc with @@ -54,16 +56,16 @@ let variant_is_subtype (env : Env.t) (row_desc : Types.row_desc) row_fixed = _; row_fields = (name, (Rabsent | Rpresent None)) :: rest; } -> - if Ext_string.is_valid_hash_number name then - Ext_list.for_all rest (function - | name, (Rabsent | Rpresent None) -> - Ext_string.is_valid_hash_number name - | _ -> false) - && Typeopt.is_base_type env ty Predef.path_int - else - Ext_list.for_all rest (function - | name, (Rabsent | Rpresent None) -> - not (Ext_string.is_valid_hash_number name) - | _ -> false) - && Typeopt.is_base_type env ty Predef.path_string + if Ext_string.is_valid_hash_number name then + Ext_list.for_all rest (function + | name, (Rabsent | Rpresent None) -> + Ext_string.is_valid_hash_number name + | _ -> false) + && Typeopt.is_base_type env ty Predef.path_int + else + Ext_list.for_all rest (function + | name, (Rabsent | Rpresent None) -> + not (Ext_string.is_valid_hash_number name) + | _ -> false) + && Typeopt.is_base_type env ty Predef.path_string | _ -> false diff --git a/compiler/core/outcome_printer_ns.ml b/compiler/core/outcome_printer_ns.ml index 41c68716e2..9ded0bf3b7 100644 --- a/compiler/core/outcome_printer_ns.ml +++ b/compiler/core/outcome_printer_ns.ml @@ -78,6 +78,6 @@ let out_ident ppf s = | "Belt_HashMapInt" -> "Belt.HashMap.Int" | "Belt_Debug" -> "Belt.Debug" | s -> ( - match Ext_namespace.try_split_module_name s with - | None -> s - | Some (ns, m) -> ns ^ "." ^ m)) + match Ext_namespace.try_split_module_name s with + | None -> s + | Some (ns, m) -> ns ^ "." ^ m)) diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index ff785d80fc..fea0b53f1d 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -38,7 +38,7 @@ module Coll = Hash.Make (struct let hash = Hashtbl.hash end) -type value = { stamp : int; hash_names_act : hash_names * lam } +type value = {stamp: int; hash_names_act: hash_names * lam} let convert (xs : input) : output = let coll = Coll.create 63 in @@ -47,13 +47,12 @@ let convert (xs : input) : output = |> List.iteri (fun i (hash, (name, act)) -> match Lambda.make_key act with | None -> - os := - { stamp = i; hash_names_act = ([ (hash, name) ], act) } :: !os + os := {stamp = i; hash_names_act = ([(hash, name)], act)} :: !os | Some key -> - Coll.add_or_update coll key - ~update:(fun ({ hash_names_act = hash_names, act } as acc) -> - { acc with hash_names_act = ((hash, name) :: hash_names, act) }) - { hash_names_act = ([ (hash, name) ], act); stamp = i }); + Coll.add_or_update coll key + ~update:(fun ({hash_names_act = hash_names, act} as acc) -> + {acc with hash_names_act = ((hash, name) :: hash_names, act)}) + {hash_names_act = ([(hash, name)], act); stamp = i}); let result = Coll.to_list coll (fun _ value -> value) @ !os in Ext_list.sort_via_arrayf result (fun x y -> compare x.stamp y.stamp) @@ -62,23 +61,23 @@ let convert (xs : input) : output = let or_list (arg : lam) (hash_names : (int * string) list) = match hash_names with | (hash, name) :: rest -> - let init : lam = - Lprim - ( Pintcomp Ceq, - [ arg; Lconst (Const_pointer (hash, Pt_variant { name })) ], - Location.none ) - in - Ext_list.fold_left rest init (fun acc (hash, name) -> - Lambda.Lprim - ( Psequor, - [ - acc; - Lprim - ( Pintcomp Ceq, - [ arg; Lconst (Const_pointer (hash, Pt_variant { name })) ], - Location.none ); - ], - Location.none )) + let init : lam = + Lprim + ( Pintcomp Ceq, + [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], + Location.none ) + in + Ext_list.fold_left rest init (fun acc (hash, name) -> + Lambda.Lprim + ( Psequor, + [ + acc; + Lprim + ( Pintcomp Ceq, + [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], + Location.none ); + ], + Location.none )) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -88,9 +87,9 @@ let make_test_sequence_variant_constant (fail : lam option) (arg : lam) in match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> - Ext_list.fold_right rest act (fun (hash_names, act1) acc -> - let predicate : lam = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) + Ext_list.fold_right rest act (fun (hash_names, act1) acc -> + let predicate : lam = or_list arg hash_names in + Lifthenelse (predicate, act1, acc)) | [], None -> assert false let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) @@ -99,17 +98,18 @@ let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) let int_lambda_list = convert int_lambda_list in match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> - Ext_list.fold_right rest act (fun (hash_names, act1) acc -> - let predicate = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) + Ext_list.fold_right rest act (fun (hash_names, act1) acc -> + let predicate = or_list arg hash_names in + Lifthenelse (predicate, act1, acc)) | [], None -> assert false let call_switcher_variant_constr (loc : Location.t) (fail : lam option) - (arg : lam) int_lambda_list (names : Ast_untagged_variants.switch_names option) : lam = + (arg : lam) int_lambda_list + (names : Ast_untagged_variants.switch_names option) : lam = let v = Ident.create "variant" in Llet ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [ arg ], loc), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/compiler/core/record_attributes_check.ml b/compiler/core/record_attributes_check.ml index b759096424..4f8befeb9d 100644 --- a/compiler/core/record_attributes_check.ml +++ b/compiler/core/record_attributes_check.ml @@ -29,15 +29,15 @@ let find_name = Lambda.find_name let find_name_with_loc (attr : Parsetree.attribute) : string Asttypes.loc option = match attr with - | ( { txt = "as"; loc }, + | ( {txt = "as"; loc}, PStr [ { pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _); + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _); }; ] ) -> - Some { txt = s; loc } + Some {txt = s; loc} | _ -> None let check_bs_attributes_inclusion (attrs1 : Parsetree.attributes) @@ -50,21 +50,20 @@ let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) (coll : Set_string.t) = match lbls with | [] -> None - | { pld_name = { txt } as pld_name; pld_attributes } :: rest -> ( - if Set_string.mem coll txt && txt <> "..." then Some pld_name - else - let coll_with_lbl = Set_string.add coll txt in - match Ext_list.find_opt pld_attributes find_name_with_loc with - | None -> check_duplicated_labels_aux rest coll_with_lbl - | Some ({ txt = s } as l) -> - if - Set_string.mem coll s - (*use coll to make check a bit looser - allow cases like [ x : int [@as "x"]] - *) - then Some l - else - check_duplicated_labels_aux rest (Set_string.add coll_with_lbl s)) + | {pld_name = {txt} as pld_name; pld_attributes} :: rest -> ( + if Set_string.mem coll txt && txt <> "..." then Some pld_name + else + let coll_with_lbl = Set_string.add coll txt in + match Ext_list.find_opt pld_attributes find_name_with_loc with + | None -> check_duplicated_labels_aux rest coll_with_lbl + | Some ({txt = s} as l) -> + if + Set_string.mem coll s + (*use coll to make check a bit looser + allow cases like [ x : int [@as "x"]] + *) + then Some l + else check_duplicated_labels_aux rest (Set_string.add coll_with_lbl s)) let check_duplicated_labels lbls = check_duplicated_labels_aux lbls Set_string.empty diff --git a/compiler/core/res_compmisc.ml b/compiler/core/res_compmisc.ml index f5889a520e..3f8650858a 100644 --- a/compiler/core/res_compmisc.ml +++ b/compiler/core/res_compmisc.ml @@ -29,7 +29,7 @@ let init_path () = in Config.load_path := if !Js_config.no_stdlib then exp_dirs - else (List.rev_append exp_dirs [Config.standard_library]); + else List.rev_append exp_dirs [Config.standard_library]; Env.reset_cache () (* Return the initial environment in which compilation proceeds. *) @@ -39,17 +39,18 @@ let init_path () = let open_implicit_module m env = let lid = - { Asttypes.loc = Location.in_file "command line"; txt = Longident.parse m } + {Asttypes.loc = Location.in_file "command line"; txt = Longident.parse m} in snd (Typemod.type_open_ Override env lid.loc lid) -let initial_env ?(modulename) () = +let initial_env ?modulename () = Ident.reinit (); - let open_modules = (match modulename with - | None -> !Clflags.open_modules - | Some modulename -> - !Clflags.open_modules |> List.filter(fun m -> m <> modulename) - ) in + let open_modules = + match modulename with + | None -> !Clflags.open_modules + | Some modulename -> + !Clflags.open_modules |> List.filter (fun m -> m <> modulename) + in let initial = Env.initial_safe_string in let env = if !Clflags.nopervasives then initial @@ -57,5 +58,4 @@ let initial_env ?(modulename) () = in List.fold_left (fun env m -> open_implicit_module m env) - env - (List.rev open_modules) + env (List.rev open_modules) diff --git a/compiler/core/res_compmisc.mli b/compiler/core/res_compmisc.mli index 0f17e43e9c..117c7b2899 100644 --- a/compiler/core/res_compmisc.mli +++ b/compiler/core/res_compmisc.mli @@ -24,4 +24,4 @@ val init_path : unit -> unit -val initial_env : ?modulename : string -> unit -> Env.t +val initial_env : ?modulename:string -> unit -> Env.t diff --git a/compiler/depends/.ocamlformat b/compiler/depends/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/depends/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/depends/binary_ast.mli b/compiler/depends/binary_ast.mli index c349be4536..97c98cb12b 100644 --- a/compiler/depends/binary_ast.mli +++ b/compiler/depends/binary_ast.mli @@ -24,8 +24,7 @@ type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind -val read_ast_exn : - fname:string -> 'a kind -> 'a +val read_ast_exn : fname:string -> 'a kind -> 'a val magic_sep_char : char diff --git a/compiler/depends/bs_exception.ml b/compiler/depends/bs_exception.ml index fa667c505f..d04ffca880 100644 --- a/compiler/depends/bs_exception.ml +++ b/compiler/depends/bs_exception.ml @@ -41,34 +41,32 @@ let error err = raise (Error err) let report_error ppf = function | Dependency_script_module_dependent_not s -> - Format.fprintf ppf - "%s is compiled in script mode while its dependent is not" s + Format.fprintf ppf + "%s is compiled in script mode while its dependent is not" s | Missing_ml_dependency s -> - Format.fprintf ppf "Missing dependency %s in search path" s + Format.fprintf ppf "Missing dependency %s in search path" s | Cmj_not_found s -> - Format.fprintf ppf - "%s not found, it means either the module does not exist or it is a \ - namespace" - s + Format.fprintf ppf + "%s not found, it means either the module does not exist or it is a \ + namespace" + s | Js_not_found s -> - Format.fprintf ppf "%s not found, needed in script mode " s + Format.fprintf ppf "%s not found, needed in script mode " s | Bs_cyclic_depends str -> - Format.fprintf ppf "Cyclic depends : @[%a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space - Format.pp_print_string) - str - | Bs_duplicate_exports str -> - Format.fprintf ppf "%s is exported twice" str + Format.fprintf ppf "Cyclic depends : @[%a@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) + str + | Bs_duplicate_exports str -> Format.fprintf ppf "%s is exported twice" str | Bs_duplicated_module (a, b) -> - Format.fprintf ppf - "The build system does not support two files with same names yet %s, %s" - a b + Format.fprintf ppf + "The build system does not support two files with same names yet %s, %s" a + b | Bs_main_not_exist main -> Format.fprintf ppf "File %s not found " main | Bs_package_not_found package -> - Format.fprintf ppf - "Package %s not found or %s/lib/ocaml does not exist or please set \ - npm_config_prefix correctly" - package package + Format.fprintf ppf + "Package %s not found or %s/lib/ocaml does not exist or please set \ + npm_config_prefix correctly" + package package | Bs_invalid_path path -> Format.pp_print_string ppf ("Invalid path: " ^ path) let () = diff --git a/compiler/ext/.ocamlformat b/compiler/ext/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/ext/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/ext/bsb_db.ml b/compiler/ext/bsb_db.ml index 6ce515499c..b08e6943b5 100644 --- a/compiler/ext/bsb_db.ml +++ b/compiler/ext/bsb_db.ml @@ -31,17 +31,16 @@ type info = | Impl | Impl_intf - type module_info = { - mutable info : info; - dir : string; - case : bool; - name_sans_extension : string; + mutable info: info; + dir: string; + case: bool; + name_sans_extension: string; } type map = module_info Map_string.t -type 'a cat = { mutable lib : 'a; mutable dev : 'a } +type 'a cat = {mutable lib: 'a; mutable dev: 'a} type t = map cat (** indexed by the group *) diff --git a/compiler/ext/bsb_db.mli b/compiler/ext/bsb_db.mli index d4a8cfe43a..3b54f9f1c6 100644 --- a/compiler/ext/bsb_db.mli +++ b/compiler/ext/bsb_db.mli @@ -37,17 +37,16 @@ type info = | Impl | Impl_intf - type module_info = { - mutable info : info; - dir : string; - case : bool; - name_sans_extension : string; + mutable info: info; + dir: string; + case: bool; + name_sans_extension: string; } type map = module_info Map_string.t -type 'a cat = { mutable lib : 'a; mutable dev : 'a } +type 'a cat = {mutable lib: 'a; mutable dev: 'a} type t = map cat diff --git a/compiler/ext/bsc_args.ml b/compiler/ext/bsc_args.ml index 5f1fd2e19c..1f907eb26b 100644 --- a/compiler/ext/bsc_args.ml +++ b/compiler/ext/bsc_args.ml @@ -64,17 +64,17 @@ let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) = while !cur < doc_length do match String.index_from_opt doc !cur '\n' with | None -> - if !cur <> 0 then ( - buf +> "\n"; - buf +> String.make (!max_col + 4) ' '); - buf +> String.sub doc !cur (String.length doc - !cur); - cur := doc_length + if !cur <> 0 then ( + buf +> "\n"; + buf +> String.make (!max_col + 4) ' '); + buf +> String.sub doc !cur (String.length doc - !cur); + cur := doc_length | Some new_line_pos -> - if !cur <> 0 then ( - buf +> "\n"; - buf +> String.make (!max_col + 4) ' '); - buf +> String.sub doc !cur (new_line_pos - !cur); - cur := new_line_pos + 1 + if !cur <> 0 then ( + buf +> "\n"; + buf +> String.make (!max_col + 4) ' '); + buf +> String.sub doc !cur (new_line_pos - !cur); + cur := new_line_pos + 1 done; buf +> "\n")) @@ -82,17 +82,17 @@ let stop_raise ~usage ~(error : error) (speclist : t) = let b = Ext_buffer.create 200 in (match error with | Unknown ("-help" | "--help" | "-h") -> - usage_b b ~usage speclist; - Ext_buffer.output_buffer stdout b; - exit 0 + usage_b b ~usage speclist; + Ext_buffer.output_buffer stdout b; + exit 0 | Unknown s -> - b +> "Unknown option \""; - b +> s; - b +> "\".\n" + b +> "Unknown option \""; + b +> s; + b +> "\".\n" | Missing s -> - b +> "Option \""; - b +> s; - b +> "\" needs an argument.\n"); + b +> "Option \""; + b +> s; + b +> "\" needs an argument.\n"); usage_b b ~usage speclist; bad_arg (Ext_buffer.contents b) @@ -106,25 +106,25 @@ let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) if s <> "" && s.[0] = '-' then match Ext_spec.assoc3 speclist s with | Some action -> ( - match action with - | Unit_dummy -> () - | Unit r -> ( - match r with - | Unit_set r -> r := true - | Unit_clear r -> r := false - | Unit_call f -> f () - | Unit_lazy f -> Lazy.force f) - | String f -> ( - if !current >= finish then - stop_raise ~usage ~error:(Missing s) speclist - else - let arg = argv.(!current) in - incr current; - match f with - | String_call f -> f arg - | String_set u -> u := arg - | String_optional_set s -> s := Some arg - | String_list_add s -> s := arg :: !s)) + match action with + | Unit_dummy -> () + | Unit r -> ( + match r with + | Unit_set r -> r := true + | Unit_clear r -> r := false + | Unit_call f -> f () + | Unit_lazy f -> Lazy.force f) + | String f -> ( + if !current >= finish then + stop_raise ~usage ~error:(Missing s) speclist + else + let arg = argv.(!current) in + incr current; + match f with + | String_call f -> f arg + | String_set u -> u := arg + | String_optional_set s -> s := Some arg + | String_list_add s -> s := arg :: !s)) | None -> stop_raise ~usage ~error:(Unknown s) speclist else rev_list := s :: !rev_list done; diff --git a/compiler/ext/ext_array.ml b/compiler/ext/ext_array.ml index da643cec6e..9a416e5b0a 100644 --- a/compiler/ext/ext_array.ml +++ b/compiler/ext/ext_array.ml @@ -50,15 +50,15 @@ let reverse a = let reverse_of_list = function | [] -> [||] | hd :: tl -> - let len = List.length tl in - let a = Array.make (len + 1) hd in - let rec fill i = function - | [] -> a - | hd :: tl -> - Array.unsafe_set a i hd; - fill (i - 1) tl - in - fill (len - 1) tl + let len = List.length tl in + let a = Array.make (len + 1) hd in + let rec fill i = function + | [] -> a + | hd :: tl -> + Array.unsafe_set a i hd; + fill (i - 1) tl + in + fill (len - 1) tl let filter a f = let arr_len = Array.length a in @@ -76,7 +76,9 @@ let filter_map a (f : _ -> _ option) = if i = arr_len then reverse_of_list acc else let v = Array.unsafe_get a i in - match f v with Some v -> aux (v :: acc) (i + 1) | None -> aux acc (i + 1) + match f v with + | Some v -> aux (v :: acc) (i + 1) + | None -> aux acc (i + 1) in aux [] 0 @@ -86,7 +88,9 @@ let filter_mapi a (f : _ -> _ -> _ option) = if i = arr_len then reverse_of_list acc else let v = Array.unsafe_get a i in - match f i v with Some v -> aux (v :: acc) (i + 1) | None -> aux acc (i + 1) + match f i v with + | Some v -> aux (v :: acc) (i + 1) + | None -> aux acc (i + 1) in aux [] 0 @@ -111,7 +115,9 @@ let rec tolist_aux a f i res = if i < 0 then res else tolist_aux a f (i - 1) - (match f a.!(i) with Some v -> v :: res | None -> res) + (match f a.!(i) with + | Some v -> v :: res + | None -> res) let to_list_map a f = tolist_aux a f (Array.length a - 1) [] @@ -120,50 +126,50 @@ let to_list_map_acc a acc f = tolist_aux a f (Array.length a - 1) acc let of_list_map a f = match a with | [] -> [||] - | [ a0 ] -> - let b0 = f a0 in - [| b0 |] - | [ a0; a1 ] -> - let b0 = f a0 in - let b1 = f a1 in - [| b0; b1 |] - | [ a0; a1; a2 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - [| b0; b1; b2 |] - | [ a0; a1; a2; a3 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - [| b0; b1; b2; b3 |] - | [ a0; a1; a2; a3; a4 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - [| b0; b1; b2; b3; b4 |] + | [a0] -> + let b0 = f a0 in + [|b0|] + | [a0; a1] -> + let b0 = f a0 in + let b1 = f a1 in + [|b0; b1|] + | [a0; a1; a2] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + [|b0; b1; b2|] + | [a0; a1; a2; a3] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + [|b0; b1; b2; b3|] + | [a0; a1; a2; a3; a4] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + [|b0; b1; b2; b3; b4|] | a0 :: a1 :: a2 :: a3 :: a4 :: tl -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - let len = List.length tl + 5 in - let arr = Array.make len b0 in - Array.unsafe_set arr 1 b1; - Array.unsafe_set arr 2 b2; - Array.unsafe_set arr 3 b3; - Array.unsafe_set arr 4 b4; - let rec fill i = function - | [] -> arr - | hd :: tl -> - Array.unsafe_set arr i (f hd); - fill (i + 1) tl - in - fill 5 tl + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + let len = List.length tl + 5 in + let arr = Array.make len b0 in + Array.unsafe_set arr 1 b1; + Array.unsafe_set arr 2 b2; + Array.unsafe_set arr 3 b3; + Array.unsafe_set arr 4 b4; + let rec fill i = function + | [] -> arr + | hd :: tl -> + Array.unsafe_set arr i (f hd); + fill (i + 1) tl + in + fill 5 tl (** {[ diff --git a/compiler/ext/ext_buffer.ml b/compiler/ext/ext_buffer.ml index 1e478b354f..5dbb8396df 100644 --- a/compiler/ext/ext_buffer.ml +++ b/compiler/ext/ext_buffer.ml @@ -15,16 +15,12 @@ (* Extensible buffers *) -type t = { - mutable buffer : bytes; - mutable position : int; - mutable length : int; -} +type t = {mutable buffer: bytes; mutable position: int; mutable length: int} let create n = let n = if n < 1 then 1 else n in let s = Bytes.create n in - { buffer = s; position = 0; length = n } + {buffer = s; position = 0; length = n} let contents b = Bytes.sub_string b.buffer 0 b.position (* let to_bytes b = Bytes.sub b.buffer 0 b.position *) diff --git a/compiler/ext/ext_bytes.ml b/compiler/ext/ext_bytes.ml index f4148ebbae..68808ab422 100644 --- a/compiler/ext/ext_bytes.ml +++ b/compiler/ext/ext_bytes.ml @@ -24,4 +24,4 @@ external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" - [@@noalloc] +[@@noalloc] diff --git a/compiler/ext/ext_bytes.mli b/compiler/ext/ext_bytes.mli index f4148ebbae..68808ab422 100644 --- a/compiler/ext/ext_bytes.mli +++ b/compiler/ext/ext_bytes.mli @@ -24,4 +24,4 @@ external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" - [@@noalloc] +[@@noalloc] diff --git a/compiler/ext/ext_char.ml b/compiler/ext/ext_char.ml index 9dcb31a730..3754665a69 100644 --- a/compiler/ext/ext_char.ml +++ b/compiler/ext/ext_char.ml @@ -27,7 +27,9 @@ *) let valid_hex x = - match x with '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false + match x with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false let is_lower_case c = (c >= 'a' && c <= 'z') diff --git a/compiler/ext/ext_color.ml b/compiler/ext/ext_color.ml index d5ed3bb166..db926ead03 100644 --- a/compiler/ext/ext_color.ml +++ b/compiler/ext/ext_color.ml @@ -59,11 +59,11 @@ let code_of_style = function (** TODO: add more styles later *) let style_of_tag s = match s with - | Format.String_tag "error" -> [ Bold; FG Red ] - | Format.String_tag "warning" -> [ Bold; FG Magenta ] - | Format.String_tag "info" -> [ Bold; FG Yellow ] - | Format.String_tag "dim" -> [ Dim ] - | Format.String_tag "filename" -> [ FG Cyan ] + | Format.String_tag "error" -> [Bold; FG Red] + | Format.String_tag "warning" -> [Bold; FG Magenta] + | Format.String_tag "info" -> [Bold; FG Yellow] + | Format.String_tag "dim" -> [Dim] + | Format.String_tag "filename" -> [FG Cyan] | _ -> [] let ansi_of_tag s = diff --git a/compiler/ext/ext_file_extensions.ml b/compiler/ext/ext_file_extensions.ml index 8cd52c5691..9004b5821b 100644 --- a/compiler/ext/ext_file_extensions.ml +++ b/compiler/ext/ext_file_extensions.ml @@ -1,11 +1,4 @@ -type valid_input = - | Res - | Resi - | Intf_ast - | Impl_ast - | Mlmap - | Cmi - | Unknown +type valid_input = Res | Resi | Intf_ast | Impl_ast | Mlmap | Cmi | Unknown (** This is per-file based, when [ocamlc] [-c -o another_dir/xx.cmi] diff --git a/compiler/ext/ext_filename.ml b/compiler/ext/ext_filename.ml index a12e0ccf3b..cb3302bac4 100644 --- a/compiler/ext/ext_filename.ml +++ b/compiler/ext/ext_filename.ml @@ -34,7 +34,7 @@ let maybe_quote (s : string) = Ext_string.for_all s (function | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' | '+' | '-' | '.' | '/' | '@' -> - true + true | _ -> false) in if noneed_quote then s else Filename.quote s @@ -59,7 +59,9 @@ let get_extension_maybe name = let chop_all_extensions_maybe name = let rec search_dot i last = if i < 0 || is_dir_sep (String.unsafe_get name i) then - match last with None -> name | Some i -> String.sub name 0 i + match last with + | None -> name + | Some i -> String.sub name 0 i else if String.unsafe_get name i = '.' then search_dot (i - 1) (Some i) else search_dot (i - 1) last in @@ -95,7 +97,7 @@ let module_name name = let name_len = String.length name in search_dot (name_len - 1) name -type module_info = { module_name : string; case : bool } +type module_info = {module_name: string; case: bool} let rec valid_module_name_aux name off len = if off >= len then true @@ -103,7 +105,7 @@ let rec valid_module_name_aux name off len = let c = String.unsafe_get name off in match c with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' | '.' | '[' | ']' -> - valid_module_name_aux name (off + 1) len + valid_module_name_aux name (off + 1) len | _ -> false type state = Invalid | Upper | Lower @@ -115,7 +117,7 @@ let valid_module_name name len = match c with | 'A' .. 'Z' -> if valid_module_name_aux name 1 len then Upper else Invalid | 'a' .. 'z' | '0' .. '9' | '_' | '[' | ']' -> - if valid_module_name_aux name 1 len then Lower else Invalid + if valid_module_name_aux name 1 len then Lower else Invalid | _ -> Invalid let as_module ~basename = @@ -124,17 +126,17 @@ let as_module ~basename = (* Input e.g, [a_b] *) match valid_module_name name name_len with | Invalid -> None - | Upper -> Some { module_name = name; case = true } + | Upper -> Some {module_name = name; case = true} | Lower -> - Some { module_name = Ext_string.capitalize_ascii name; case = false } + Some {module_name = Ext_string.capitalize_ascii name; case = false} else if String.unsafe_get name i = '.' then (*Input e.g, [A_b] *) match valid_module_name name i with | Invalid -> None | Upper -> - Some { module_name = Ext_string.capitalize_sub name i; case = true } + Some {module_name = Ext_string.capitalize_sub name i; case = true} | Lower -> - Some { module_name = Ext_string.capitalize_sub name i; case = false } + Some {module_name = Ext_string.capitalize_sub name i; case = false} else search_dot (i - 1) name name_len in let name_len = String.length basename in diff --git a/compiler/ext/ext_filename.mli b/compiler/ext/ext_filename.mli index e95c3f217b..e111ee2002 100644 --- a/compiler/ext/ext_filename.mli +++ b/compiler/ext/ext_filename.mli @@ -47,6 +47,6 @@ val chop_all_extensions_maybe : string -> string (* OCaml specific abstraction*) val module_name : string -> string -type module_info = { module_name : string; case : bool } +type module_info = {module_name: string; case: bool} val as_module : basename:string -> module_info option diff --git a/compiler/ext/ext_ident.ml b/compiler/ext/ext_ident.ml index 4f1e6dfa7a..8a7910ca38 100644 --- a/compiler/ext/ext_ident.ml +++ b/compiler/ext/ext_ident.ml @@ -22,7 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - let js_flag = 0b1_000 (* check with ocaml compiler *) (* let js_module_flag = 0b10_000 (\* javascript external modules *\) *) @@ -35,30 +34,23 @@ let js_flag = 0b1_000 (* check with ocaml compiler *) *) let js_object_flag = 0b100_000 (* javascript object flags *) -let is_js (i : Ident.t) = - i.flags land js_flag <> 0 - -let is_js_or_global (i : Ident.t) = - i.flags land (8 lor 1) <> 0 +let is_js (i : Ident.t) = i.flags land js_flag <> 0 +let is_js_or_global (i : Ident.t) = i.flags land (8 lor 1) <> 0 -let is_js_object (i : Ident.t) = - i.flags land js_object_flag <> 0 +let is_js_object (i : Ident.t) = i.flags land js_object_flag <> 0 -let make_js_object (i : Ident.t) = - i.flags <- i.flags lor js_object_flag +let make_js_object (i : Ident.t) = i.flags <- i.flags lor js_object_flag (* It's a js function hard coded by js api, so when printing, it should preserve the name *) -let create_js (name : string) : Ident.t = - { name = name; flags = js_flag ; stamp = 0} +let create_js (name : string) : Ident.t = {name; flags = js_flag; stamp = 0} let create = Ident.create (* FIXME: no need for `$' operator *) -let create_tmp ?(name=Literals.tmp) () = create name - +let create_tmp ?(name = Literals.tmp) () = create name let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 @@ -72,58 +64,54 @@ let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 Given a name, if duplicated, they should have the same id *) (* let create_js_module (name : string) : Ident.t = - let name = - String.concat "" @@ Ext_list.map - (Ext_string.split name '-') Ext_string.capitalize_ascii in - (* TODO: if we do such transformation, we should avoid collision for example: - react-dom - react--dom - check collision later - *) - match Hash_string.find_exn js_module_table name with - | exception Not_found -> - let ans = Ident.create name in - (* let ans = { v with flags = js_module_flag} in *) - Hash_string.add js_module_table name ans; - ans - | v -> (* v *) Ident.rename v - - + let name = + String.concat "" @@ Ext_list.map + (Ext_string.split name '-') Ext_string.capitalize_ascii in + (* TODO: if we do such transformation, we should avoid collision for example: + react-dom + react--dom + check collision later + *) + match Hash_string.find_exn js_module_table name with + | exception Not_found -> + let ans = Ident.create name in + (* let ans = { v with flags = js_module_flag} in *) + Hash_string.add js_module_table name ans; + ans + | v -> (* v *) Ident.rename v *) -let [@inline] convert ?(op=false) (c : char) : string = - (match c with - | '*' -> "$star" - | '\'' -> "$p" - | '!' -> "$bang" - | '>' -> "$great" - | '<' -> "$less" - | '=' -> "$eq" - | '+' -> "$plus" - | '-' -> if op then "$neg" else "$" - | '@' -> "$at" - | '^' -> "$caret" - | '/' -> "$slash" - | '|' -> "$pipe" - | '.' -> "$dot" - | '%' -> "$percent" - | '~' -> "$tilde" - | '#' -> "$hash" - | ':' -> "$colon" - | '?' -> "$question" - | '&' -> "$amp" - | '(' -> "$lpar" - | ')' -> "$rpar" - | '{' -> "$lbrace" - | '}' -> "$lbrace" - | '[' -> "$lbrack" - | ']' -> "$rbrack" - - | _ -> "$unknown") -let [@inline] no_escape (c : char) = - match c with - | 'a' .. 'z' | 'A' .. 'Z' - | '0' .. '9' | '_' | '$' -> true +let[@inline] convert ?(op = false) (c : char) : string = + match c with + | '*' -> "$star" + | '\'' -> "$p" + | '!' -> "$bang" + | '>' -> "$great" + | '<' -> "$less" + | '=' -> "$eq" + | '+' -> "$plus" + | '-' -> if op then "$neg" else "$" + | '@' -> "$at" + | '^' -> "$caret" + | '/' -> "$slash" + | '|' -> "$pipe" + | '.' -> "$dot" + | '%' -> "$percent" + | '~' -> "$tilde" + | '#' -> "$hash" + | ':' -> "$colon" + | '?' -> "$question" + | '&' -> "$amp" + | '(' -> "$lpar" + | ')' -> "$rpar" + | '{' -> "$lbrace" + | '}' -> "$lbrace" + | '[' -> "$lbrack" + | ']' -> "$rbrack" + | _ -> "$unknown" +let[@inline] no_escape (c : char) = + match c with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '$' -> true | _ -> false let is_uident name = @@ -136,35 +124,31 @@ let is_uident name = let is_uppercase_exotic name = let len = String.length name in - len >= 3 - && name.[0] = '\\' - && name.[1] = '\"' - && name.[len - 1] = '\"' + len >= 3 && name.[0] = '\\' && name.[1] = '\"' && name.[len - 1] = '\"' let unwrap_uppercase_exotic name = if is_uppercase_exotic name then - let len = String.length name in - String.sub name 2 (len - 3) + let len = String.length name in + String.sub name 2 (len - 3) else name exception Not_normal_letter of int let name_mangle name = - let len = String.length name in + let len = String.length name in try - for i = 0 to len - 1 do + for i = 0 to len - 1 do if not (no_escape (String.unsafe_get name i)) then raise_notrace (Not_normal_letter i) done; name (* Normal letter *) - with - | Not_normal_letter i -> + with Not_normal_letter i -> let buffer = Ext_buffer.create len in - for j = 0 to len - 1 do + for j = 0 to len - 1 do let c = String.unsafe_get name j in - if no_escape c then Ext_buffer.add_char buffer c - else - Ext_buffer.add_string buffer (convert ~op:(i=0) c) - done; Ext_buffer.contents buffer + if no_escape c then Ext_buffer.add_char buffer c + else Ext_buffer.add_string buffer (convert ~op:(i = 0) c) + done; + Ext_buffer.contents buffer (** [convert name] if [name] is a js keyword or js global, add "$$" @@ -173,8 +157,8 @@ let name_mangle name = *) let convert (name : string) = let name = unwrap_uppercase_exotic name in - if Js_reserved_map.is_js_keyword name || Js_reserved_map.is_js_global name then - "$$" ^ name + if Js_reserved_map.is_js_keyword name || Js_reserved_map.is_js_global name + then "$$" ^ name else name_mangle name (** keyword could be used in property *) @@ -185,22 +169,15 @@ let convert (name : string) = *) let make_unused () = create "_" - - -let reset () = - Hash_string.clear js_module_table - +let reset () = Hash_string.clear js_module_table (* Has to be total order, [x < y] and [x > y] should be consistent flags are not relevant here *) -let compare (x : Ident.t ) ( y : Ident.t) = +let compare (x : Ident.t) (y : Ident.t) = let u = x.stamp - y.stamp in - if u = 0 then - Ext_string.compare x.name y.name - else u + if u = 0 then Ext_string.compare x.name y.name else u -let equal ( x : Ident.t) ( y : Ident.t) = - if x.stamp <> 0 then x.stamp = y.stamp - else y.stamp = 0 && x.name = y.name +let equal (x : Ident.t) (y : Ident.t) = + if x.stamp <> 0 then x.stamp = y.stamp else y.stamp = 0 && x.name = y.name diff --git a/compiler/ext/ext_ident.mli b/compiler/ext/ext_ident.mli index 27e7a05056..ff21fca3c5 100644 --- a/compiler/ext/ext_ident.mli +++ b/compiler/ext/ext_ident.mli @@ -22,31 +22,24 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - (** A wrapper around [Ident] module in compiler-libs*) -val is_js : Ident.t -> bool +val is_js : Ident.t -> bool val is_js_object : Ident.t -> bool -(** create identifiers for predefined [js] global variables *) val create_js : string -> Ident.t +(** create identifiers for predefined [js] global variables *) val create : string -> Ident.t -val make_js_object : Ident.t -> unit +val make_js_object : Ident.t -> unit val reset : unit -> unit -val create_tmp : ?name:string -> unit -> Ident.t +val create_tmp : ?name:string -> unit -> Ident.t -val make_unused : unit -> Ident.t +val make_unused : unit -> Ident.t val is_uident : string -> bool @@ -54,16 +47,12 @@ val is_uppercase_exotic : string -> bool val unwrap_uppercase_exotic : string -> string +val convert : string -> string (** Invariant: if name is not converted, the reference should be equal *) -val convert : string -> string - - val is_js_or_global : Ident.t -> bool - - val compare : Ident.t -> Ident.t -> int -val equal : Ident.t -> Ident.t -> bool +val equal : Ident.t -> Ident.t -> bool diff --git a/compiler/ext/ext_io.ml b/compiler/ext/ext_io.ml index ee3a96eb63..ffb84a49d9 100644 --- a/compiler/ext/ext_io.ml +++ b/compiler/ext/ext_io.ml @@ -35,8 +35,8 @@ let rev_lines_of_chann chan = match input_line chan with | line -> loop (line :: acc) chan | exception End_of_file -> - close_in chan; - acc + close_in chan; + acc in loop [] chan diff --git a/compiler/ext/ext_js_file_kind.ml b/compiler/ext/ext_js_file_kind.ml index 196ba32462..2efce680a8 100644 --- a/compiler/ext/ext_js_file_kind.ml +++ b/compiler/ext/ext_js_file_kind.ml @@ -23,4 +23,4 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type case = Upper | Little -type [@warning "-69"] t = { case : case; suffix : string } +type t = {case: case; suffix: string} [@@warning "-69"] diff --git a/compiler/ext/ext_js_regex.ml b/compiler/ext/ext_js_regex.ml index 83a881fcfd..dcb917959c 100644 --- a/compiler/ext/ext_js_regex.ml +++ b/compiler/ext/ext_js_regex.ml @@ -27,15 +27,15 @@ let check_from_end al = match l with | [] -> false | e :: r -> - if e < 0 || e > 255 then false - else - let c = Char.chr e in - if c = '/' then true - else if Ext_list.exists seen (fun x -> x = c) then false - (* flag should not be repeated *) - else if c = 'i' || c = 'g' || c = 'm' || c = 'y' || c = 'u' then - aux r (c :: seen) - else false + if e < 0 || e > 255 then false + else + let c = Char.chr e in + if c = '/' then true + else if Ext_list.exists seen (fun x -> x = c) then false + (* flag should not be repeated *) + else if c = 'i' || c = 'g' || c = 'm' || c = 'y' || c = 'u' then + aux r (c :: seen) + else false in aux al [] diff --git a/compiler/ext/ext_json.ml b/compiler/ext/ext_json.ml index 3dedb8d870..90915a2504 100644 --- a/compiler/ext/ext_json.ml +++ b/compiler/ext/ext_json.ml @@ -44,18 +44,20 @@ let test ?(fail = fun () -> ()) key (cb : callback) (m : Ext_json_types.t Map_string.t) = (match (Map_string.find_exn m key, cb) with | exception Not_found -> ( - match cb with `Not_found f -> f () | _ -> fail ()) + match cb with + | `Not_found f -> f () + | _ -> fail ()) | True _, `Bool cb -> cb true | False _, `Bool cb -> cb false - | Flo { flo = s }, `Flo cb -> cb s - | Flo { flo = s; loc }, `Flo_loc cb -> cb s loc - | Obj { map = b }, `Obj cb -> cb b - | Arr { content }, `Arr cb -> cb content - | Arr { content; loc_start; loc_end }, `Arr_loc cb -> - cb content loc_start loc_end + | Flo {flo = s}, `Flo cb -> cb s + | Flo {flo = s; loc}, `Flo_loc cb -> cb s loc + | Obj {map = b}, `Obj cb -> cb b + | Arr {content}, `Arr cb -> cb content + | Arr {content; loc_start; loc_end}, `Arr_loc cb -> + cb content loc_start loc_end | Null _, `Null cb -> cb () - | Str { str = s }, `Str cb -> cb s - | Str { str = s; loc }, `Str_loc cb -> cb s loc + | Str {str = s}, `Str cb -> cb s + | Str {str = s; loc}, `Str_loc cb -> cb s loc | any, `Id cb -> cb any | _, _ -> fail ()); m diff --git a/compiler/ext/ext_json_noloc.ml b/compiler/ext/ext_json_noloc.ml index 9ce2733c00..5f751f4fda 100644 --- a/compiler/ext/ext_json_noloc.ml +++ b/compiler/ext/ext_json_noloc.ml @@ -52,25 +52,25 @@ let naive_escaped (unmodified_input : string) : string = let open Bytes in (match String.unsafe_get unmodified_input i with | ('\"' | '\\') as c -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n c + unsafe_set result !n '\\'; + incr n; + unsafe_set result !n c | '\n' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 'n' + unsafe_set result !n '\\'; + incr n; + unsafe_set result !n 'n' | '\t' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 't' + unsafe_set result !n '\\'; + incr n; + unsafe_set result !n 't' | '\r' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 'r' + unsafe_set result !n '\\'; + incr n; + unsafe_set result !n 'r' | '\b' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 'b' + unsafe_set result !n '\\'; + incr n; + unsafe_set result !n 'b' | c -> unsafe_set result !n c); incr n done; @@ -100,37 +100,37 @@ let rec encode_buf (x : t) (buf : Buffer.t) : unit = | Null -> a "null" | Str s -> a (quot s) | Flo s -> - a s - (* + a s + (* since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *) | Arr content -> ( - match content with - | [||] -> a "[]" - | _ -> - a "[ "; - encode_buf (Array.unsafe_get content 0) buf; - for i = 1 to Array.length content - 1 do - a " , "; - encode_buf (Array.unsafe_get content i) buf - done; - a " ]") + match content with + | [||] -> a "[]" + | _ -> + a "[ "; + encode_buf (Array.unsafe_get content 0) buf; + for i = 1 to Array.length content - 1 do + a " , "; + encode_buf (Array.unsafe_get content i) buf + done; + a " ]") | True -> a "true" | False -> a "false" | Obj map -> - if Map_string.is_empty map then a "{}" - else ( - (*prerr_endline "WEIRD"; - prerr_endline (string_of_int @@ Map_string.cardinal map ); *) - a "{ "; - let (_ : int) = - Map_string.fold map 0 (fun k v i -> - if i <> 0 then a " , "; - a (quot k); - a " : "; - encode_buf v buf; - i + 1) - in - a " }") + if Map_string.is_empty map then a "{}" + else ( + (*prerr_endline "WEIRD"; + prerr_endline (string_of_int @@ Map_string.cardinal map ); *) + a "{ "; + let (_ : int) = + Map_string.fold map 0 (fun k v i -> + if i <> 0 then a " , "; + a (quot k); + a " : "; + encode_buf v buf; + i + 1) + in + a " }") let to_string x = let buf = Buffer.create 1024 in diff --git a/compiler/ext/ext_json_types.ml b/compiler/ext/ext_json_types.ml index 1eb6212dd6..3c33844680 100644 --- a/compiler/ext/ext_json_types.ml +++ b/compiler/ext/ext_json_types.ml @@ -24,13 +24,13 @@ type loc = Lexing.position -type json_str = { str : string; loc : loc } +type json_str = {str: string; loc: loc} -type json_flo = { flo : string; loc : loc } +type json_flo = {flo: string; loc: loc} -type json_array = { content : t array; loc_start : loc; loc_end : loc } +type json_array = {content: t array; loc_start: loc; loc_end: loc} -and json_map = { map : t Map_string.t; loc : loc } +and json_map = {map: t Map_string.t; loc: loc} and t = | True of loc diff --git a/compiler/ext/ext_list.ml b/compiler/ext/ext_list.ml index be7f30b8df..7066f301ba 100644 --- a/compiler/ext/ext_list.ml +++ b/compiler/ext/ext_list.ml @@ -27,38 +27,38 @@ external ( .!() ) : 'a array -> int -> 'a = "%array_unsafe_get" let rec map l f = match l with | [] -> [] - | [ x1 ] -> - let y1 = f x1 in - [ y1 ] - | [ x1; x2 ] -> - let y1 = f x1 in - let y2 = f x2 in - [ y1; y2 ] - | [ x1; x2; x3 ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - [ y1; y2; y3 ] - | [ x1; x2; x3; x4 ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - [ y1; y2; y3; y4 ] + | [x1] -> + let y1 = f x1 in + [y1] + | [x1; x2] -> + let y1 = f x1 in + let y2 = f x2 in + [y1; y2] + | [x1; x2; x3] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + [y1; y2; y3] + | [x1; x2; x3; x4] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + [y1; y2; y3; y4] | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - let y5 = f x5 in - y1 :: y2 :: y3 :: y4 :: y5 :: map tail f + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + let y5 = f x5 in + y1 :: y2 :: y3 :: y4 :: y5 :: map tail f let rec has_string l f = match l with | [] -> false - | [ x1 ] -> x1 = f - | [ x1; x2 ] -> x1 = f || x2 = f - | [ x1; x2; x3 ] -> x1 = f || x2 = f || x3 = f + | [x1] -> x1 = f + | [x1; x2] -> x1 = f || x2 = f + | [x1; x2; x3] -> x1 = f || x2 = f || x3 = f | x1 :: x2 :: x3 :: x4 -> x1 = f || x2 = f || x3 = f || has_string x4 f let rec map_combine l1 l2 f = @@ -73,7 +73,7 @@ let rec arr_list_combine_unsafe arr l i j acc f = match l with | [] -> invalid_arg "Ext_list.combine" | h :: tl -> - (f arr.!(i), h) :: arr_list_combine_unsafe arr tl (i + 1) j acc f + (f arr.!(i), h) :: arr_list_combine_unsafe arr tl (i + 1) j acc f let combine_array_append arr l acc f = let len = Array.length arr in @@ -89,9 +89,9 @@ let rec arr_list_filter_map_unasfe arr l i j acc f = match l with | [] -> invalid_arg "Ext_list.arr_list_filter_map_unsafe" | h :: tl -> ( - match f arr.!(i) h with - | None -> arr_list_filter_map_unasfe arr tl (i + 1) j acc f - | Some v -> v :: arr_list_filter_map_unasfe arr tl (i + 1) j acc f) + match f arr.!(i) h with + | None -> arr_list_filter_map_unasfe arr tl (i + 1) j acc f + | Some v -> v :: arr_list_filter_map_unasfe arr tl (i + 1) j acc f) let array_list_filter_map arr l f = let len = Array.length arr in @@ -102,75 +102,79 @@ let rec map_split_opt (xs : 'a list) (f : 'a -> 'b option * 'c option) : match xs with | [] -> ([], []) | x :: xs -> ( - let c, d = f x in - let cs, ds = map_split_opt xs f in - ( (match c with Some c -> c :: cs | None -> cs), - match d with Some d -> d :: ds | None -> ds )) + let c, d = f x in + let cs, ds = map_split_opt xs f in + ( (match c with + | Some c -> c :: cs + | None -> cs), + match d with + | Some d -> d :: ds + | None -> ds )) let rec map_snd l f = match l with | [] -> [] - | [ (v1, x1) ] -> - let y1 = f x1 in - [ (v1, y1) ] - | [ (v1, x1); (v2, x2) ] -> - let y1 = f x1 in - let y2 = f x2 in - [ (v1, y1); (v2, y2) ] - | [ (v1, x1); (v2, x2); (v3, x3) ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - [ (v1, y1); (v2, y2); (v3, y3) ] - | [ (v1, x1); (v2, x2); (v3, x3); (v4, x4) ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - [ (v1, y1); (v2, y2); (v3, y3); (v4, y4) ] + | [(v1, x1)] -> + let y1 = f x1 in + [(v1, y1)] + | [(v1, x1); (v2, x2)] -> + let y1 = f x1 in + let y2 = f x2 in + [(v1, y1); (v2, y2)] + | [(v1, x1); (v2, x2); (v3, x3)] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + [(v1, y1); (v2, y2); (v3, y3)] + | [(v1, x1); (v2, x2); (v3, x3); (v4, x4)] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + [(v1, y1); (v2, y2); (v3, y3); (v4, y4)] | (v1, x1) :: (v2, x2) :: (v3, x3) :: (v4, x4) :: (v5, x5) :: tail -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - let y5 = f x5 in - (v1, y1) :: (v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: map_snd tail f + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + let y5 = f x5 in + (v1, y1) :: (v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: map_snd tail f let rec map_last l f = match l with | [] -> [] - | [ x1 ] -> - let y1 = f true x1 in - [ y1 ] - | [ x1; x2 ] -> - let y1 = f false x1 in - let y2 = f true x2 in - [ y1; y2 ] - | [ x1; x2; x3 ] -> - let y1 = f false x1 in - let y2 = f false x2 in - let y3 = f true x3 in - [ y1; y2; y3 ] - | [ x1; x2; x3; x4 ] -> - let y1 = f false x1 in - let y2 = f false x2 in - let y3 = f false x3 in - let y4 = f true x4 in - [ y1; y2; y3; y4 ] + | [x1] -> + let y1 = f true x1 in + [y1] + | [x1; x2] -> + let y1 = f false x1 in + let y2 = f true x2 in + [y1; y2] + | [x1; x2; x3] -> + let y1 = f false x1 in + let y2 = f false x2 in + let y3 = f true x3 in + [y1; y2; y3] + | [x1; x2; x3; x4] -> + let y1 = f false x1 in + let y2 = f false x2 in + let y3 = f false x3 in + let y4 = f true x4 in + [y1; y2; y3; y4] | x1 :: x2 :: x3 :: x4 :: tail -> - (* make sure that tail is not empty *) - let y1 = f false x1 in - let y2 = f false x2 in - let y3 = f false x3 in - let y4 = f false x4 in - y1 :: y2 :: y3 :: y4 :: map_last tail f + (* make sure that tail is not empty *) + let y1 = f false x1 in + let y2 = f false x2 in + let y3 = f false x3 in + let y4 = f false x4 in + y1 :: y2 :: y3 :: y4 :: map_last tail f let rec mapi_aux lst i f tail = match lst with | [] -> tail | a :: l -> - let r = f i a in - r :: mapi_aux l (i + 1) f tail + let r = f i a in + r :: mapi_aux l (i + 1) f tail let mapi lst f = mapi_aux lst 0 f [] @@ -178,173 +182,176 @@ let mapi_append lst f tail = mapi_aux lst 0 f tail let rec last xs = match xs with - | [ x ] -> x + | [x] -> x | _ :: tl -> last tl | [] -> invalid_arg "Ext_list.last" let rec append_aux l1 l2 = match l1 with | [] -> l2 - | [ a0 ] -> a0 :: l2 - | [ a0; a1 ] -> a0 :: a1 :: l2 - | [ a0; a1; a2 ] -> a0 :: a1 :: a2 :: l2 - | [ a0; a1; a2; a3 ] -> a0 :: a1 :: a2 :: a3 :: l2 - | [ a0; a1; a2; a3; a4 ] -> a0 :: a1 :: a2 :: a3 :: a4 :: l2 + | [a0] -> a0 :: l2 + | [a0; a1] -> a0 :: a1 :: l2 + | [a0; a1; a2] -> a0 :: a1 :: a2 :: l2 + | [a0; a1; a2; a3] -> a0 :: a1 :: a2 :: a3 :: l2 + | [a0; a1; a2; a3; a4] -> a0 :: a1 :: a2 :: a3 :: a4 :: l2 | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - a0 :: a1 :: a2 :: a3 :: a4 :: append_aux rest l2 + a0 :: a1 :: a2 :: a3 :: a4 :: append_aux rest l2 -let append l1 l2 = match l2 with [] -> l1 | _ -> append_aux l1 l2 +let append l1 l2 = + match l2 with + | [] -> l1 + | _ -> append_aux l1 l2 -let append_one l1 x = append_aux l1 [ x ] +let append_one l1 x = append_aux l1 [x] let rec map_append l1 l2 f = match l1 with | [] -> l2 - | [ a0 ] -> f a0 :: l2 - | [ a0; a1 ] -> - let b0 = f a0 in - let b1 = f a1 in - b0 :: b1 :: l2 - | [ a0; a1; a2 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - b0 :: b1 :: b2 :: l2 - | [ a0; a1; a2; a3 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - b0 :: b1 :: b2 :: b3 :: l2 - | [ a0; a1; a2; a3; a4 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - b0 :: b1 :: b2 :: b3 :: b4 :: l2 + | [a0] -> f a0 :: l2 + | [a0; a1] -> + let b0 = f a0 in + let b1 = f a1 in + b0 :: b1 :: l2 + | [a0; a1; a2] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + b0 :: b1 :: b2 :: l2 + | [a0; a1; a2; a3] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + b0 :: b1 :: b2 :: b3 :: l2 + | [a0; a1; a2; a3; a4] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + b0 :: b1 :: b2 :: b3 :: b4 :: l2 | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - b0 :: b1 :: b2 :: b3 :: b4 :: map_append rest l2 f + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + b0 :: b1 :: b2 :: b3 :: b4 :: map_append rest l2 f let rec fold_right l acc f = match l with | [] -> acc - | [ a0 ] -> f a0 acc - | [ a0; a1 ] -> f a0 (f a1 acc) - | [ a0; a1; a2 ] -> f a0 (f a1 (f a2 acc)) - | [ a0; a1; a2; a3 ] -> f a0 (f a1 (f a2 (f a3 acc))) - | [ a0; a1; a2; a3; a4 ] -> f a0 (f a1 (f a2 (f a3 (f a4 acc)))) + | [a0] -> f a0 acc + | [a0; a1] -> f a0 (f a1 acc) + | [a0; a1; a2] -> f a0 (f a1 (f a2 acc)) + | [a0; a1; a2; a3] -> f a0 (f a1 (f a2 (f a3 acc))) + | [a0; a1; a2; a3; a4] -> f a0 (f a1 (f a2 (f a3 (f a4 acc)))) | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - f a0 (f a1 (f a2 (f a3 (f a4 (fold_right rest acc f))))) + f a0 (f a1 (f a2 (f a3 (f a4 (fold_right rest acc f))))) let rec fold_right2 l r acc f = match (l, r) with | [], [] -> acc - | [ a0 ], [ b0 ] -> f a0 b0 acc - | [ a0; a1 ], [ b0; b1 ] -> f a0 b0 (f a1 b1 acc) - | [ a0; a1; a2 ], [ b0; b1; b2 ] -> f a0 b0 (f a1 b1 (f a2 b2 acc)) - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ] -> - f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 acc))) - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ] -> - f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 acc)))) + | [a0], [b0] -> f a0 b0 acc + | [a0; a1], [b0; b1] -> f a0 b0 (f a1 b1 acc) + | [a0; a1; a2], [b0; b1; b2] -> f a0 b0 (f a1 b1 (f a2 b2 acc)) + | [a0; a1; a2; a3], [b0; b1; b2; b3] -> + f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 acc))) + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> + f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 acc)))) | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - f a0 b0 - (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 (fold_right2 arest brest acc f))))) + f a0 b0 + (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 (fold_right2 arest brest acc f))))) | _, _ -> invalid_arg "Ext_list.fold_right2" let rec fold_right3 l r last acc f = match (l, r, last) with | [], [], [] -> acc - | [ a0 ], [ b0 ], [ c0 ] -> f a0 b0 c0 acc - | [ a0; a1 ], [ b0; b1 ], [ c0; c1 ] -> f a0 b0 c0 (f a1 b1 c1 acc) - | [ a0; a1; a2 ], [ b0; b1; b2 ], [ c0; c1; c2 ] -> - f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 acc)) - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ], [ c0; c1; c2; c3 ] -> - f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 acc))) - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ], [ c0; c1; c2; c3; c4 ] -> - f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 (f a4 b4 c4 acc)))) + | [a0], [b0], [c0] -> f a0 b0 c0 acc + | [a0; a1], [b0; b1], [c0; c1] -> f a0 b0 c0 (f a1 b1 c1 acc) + | [a0; a1; a2], [b0; b1; b2], [c0; c1; c2] -> + f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 acc)) + | [a0; a1; a2; a3], [b0; b1; b2; b3], [c0; c1; c2; c3] -> + f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 acc))) + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4], [c0; c1; c2; c3; c4] -> + f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 (f a4 b4 c4 acc)))) | ( a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest, c0 :: c1 :: c2 :: c3 :: c4 :: crest ) -> - f a0 b0 c0 - (f a1 b1 c1 - (f a2 b2 c2 - (f a3 b3 c3 (f a4 b4 c4 (fold_right3 arest brest crest acc f))))) + f a0 b0 c0 + (f a1 b1 c1 + (f a2 b2 c2 + (f a3 b3 c3 (f a4 b4 c4 (fold_right3 arest brest crest acc f))))) | _, _, _ -> invalid_arg "Ext_list.fold_right2" let rec map2i l r f = match (l, r) with | [], [] -> [] - | [ a0 ], [ b0 ] -> [ f 0 a0 b0 ] - | [ a0; a1 ], [ b0; b1 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - [ c0; c1 ] - | [ a0; a1; a2 ], [ b0; b1; b2 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - [ c0; c1; c2 ] - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - [ c0; c1; c2; c3 ] - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - let c4 = f 4 a4 b4 in - [ c0; c1; c2; c3; c4 ] + | [a0], [b0] -> [f 0 a0 b0] + | [a0; a1], [b0; b1] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + [c0; c1] + | [a0; a1; a2], [b0; b1; b2] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + [c0; c1; c2] + | [a0; a1; a2; a3], [b0; b1; b2; b3] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + let c3 = f 3 a3 b3 in + [c0; c1; c2; c3] + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + let c3 = f 3 a3 b3 in + let c4 = f 4 a4 b4 in + [c0; c1; c2; c3; c4] | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - let c4 = f 4 a4 b4 in - c0 :: c1 :: c2 :: c3 :: c4 :: map2i arest brest f + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + let c3 = f 3 a3 b3 in + let c4 = f 4 a4 b4 in + c0 :: c1 :: c2 :: c3 :: c4 :: map2i arest brest f | _, _ -> invalid_arg "Ext_list.map2" let rec map2 l r f = match (l, r) with | [], [] -> [] - | [ a0 ], [ b0 ] -> [ f a0 b0 ] - | [ a0; a1 ], [ b0; b1 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - [ c0; c1 ] - | [ a0; a1; a2 ], [ b0; b1; b2 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - [ c0; c1; c2 ] - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - let c3 = f a3 b3 in - [ c0; c1; c2; c3 ] - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - let c3 = f a3 b3 in - let c4 = f a4 b4 in - [ c0; c1; c2; c3; c4 ] + | [a0], [b0] -> [f a0 b0] + | [a0; a1], [b0; b1] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + [c0; c1] + | [a0; a1; a2], [b0; b1; b2] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + [c0; c1; c2] + | [a0; a1; a2; a3], [b0; b1; b2; b3] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + let c3 = f a3 b3 in + [c0; c1; c2; c3] + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + let c3 = f a3 b3 in + let c4 = f a4 b4 in + [c0; c1; c2; c3; c4] | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - let c3 = f a3 b3 in - let c4 = f a4 b4 in - c0 :: c1 :: c2 :: c3 :: c4 :: map2 arest brest f + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + let c3 = f a3 b3 in + let c4 = f a4 b4 in + c0 :: c1 :: c2 :: c3 :: c4 :: map2 arest brest f | _, _ -> invalid_arg "Ext_list.map2" let rec fold_left_with_offset l accu i f = @@ -356,7 +363,9 @@ let rec filter_map xs (f : 'a -> 'b option) = match xs with | [] -> [] | y :: ys -> ( - match f y with None -> filter_map ys f | Some z -> z :: filter_map ys f) + match f y with + | None -> filter_map ys f + | Some z -> z :: filter_map ys f) let rec exclude (xs : 'a list) (p : 'a -> bool) : 'a list = match xs with @@ -367,16 +376,16 @@ let rec exclude_with_val l p = match l with | [] -> None | a0 :: xs -> ( - if p a0 then Some (exclude xs p) - else - match xs with - | [] -> None - | a1 :: rest -> ( - if p a1 then Some (a0 :: exclude rest p) - else - match exclude_with_val rest p with - | None -> None - | Some rest -> Some (a0 :: a1 :: rest))) + if p a0 then Some (exclude xs p) + else + match xs with + | [] -> None + | a1 :: rest -> ( + if p a1 then Some (a0 :: exclude rest p) + else + match exclude_with_val rest p with + | None -> None + | Some rest -> Some (a0 :: a1 :: rest))) let rec same_length xs ys = match (xs, ys) with @@ -388,37 +397,37 @@ let init n f = match n with | 0 -> [] | 1 -> - let a0 = f 0 in - [ a0 ] + let a0 = f 0 in + [a0] | 2 -> - let a0 = f 0 in - let a1 = f 1 in - [ a0; a1 ] + let a0 = f 0 in + let a1 = f 1 in + [a0; a1] | 3 -> - let a0 = f 0 in - let a1 = f 1 in - let a2 = f 2 in - [ a0; a1; a2 ] + let a0 = f 0 in + let a1 = f 1 in + let a2 = f 2 in + [a0; a1; a2] | 4 -> - let a0 = f 0 in - let a1 = f 1 in - let a2 = f 2 in - let a3 = f 3 in - [ a0; a1; a2; a3 ] + let a0 = f 0 in + let a1 = f 1 in + let a2 = f 2 in + let a3 = f 3 in + [a0; a1; a2; a3] | 5 -> - let a0 = f 0 in - let a1 = f 1 in - let a2 = f 2 in - let a3 = f 3 in - let a4 = f 4 in - [ a0; a1; a2; a3; a4 ] + let a0 = f 0 in + let a1 = f 1 in + let a2 = f 2 in + let a3 = f 3 in + let a4 = f 4 in + [a0; a1; a2; a3; a4] | _ -> Array.to_list (Array.init n f) let rec rev_append l1 l2 = match l1 with | [] -> l2 - | [ a0 ] -> a0 :: l2 (* single element is common *) - | [ a0; a1 ] -> a1 :: a0 :: l2 + | [a0] -> a0 :: l2 (* single element is common *) + | [a0; a1] -> a1 :: a0 :: l2 | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: l2) let rev l = rev_append l [] @@ -435,20 +444,20 @@ let split_at l n = small_split_at n [] l let rec split_at_last_aux acc x = match x with | [] -> invalid_arg "Ext_list.split_at_last" - | [ x ] -> (rev acc, x) + | [x] -> (rev acc, x) | y0 :: ys -> split_at_last_aux (y0 :: acc) ys let split_at_last (x : 'a list) = match x with | [] -> invalid_arg "Ext_list.split_at_last" - | [ a0 ] -> ([], a0) - | [ a0; a1 ] -> ([ a0 ], a1) - | [ a0; a1; a2 ] -> ([ a0; a1 ], a2) - | [ a0; a1; a2; a3 ] -> ([ a0; a1; a2 ], a3) - | [ a0; a1; a2; a3; a4 ] -> ([ a0; a1; a2; a3 ], a4) + | [a0] -> ([], a0) + | [a0; a1] -> ([a0], a1) + | [a0; a1; a2] -> ([a0; a1], a2) + | [a0; a1; a2; a3] -> ([a0; a1; a2], a3) + | [a0; a1; a2; a3; a4] -> ([a0; a1; a2; a3], a4) | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - let rev, last = split_at_last_aux [] rest in - (a0 :: a1 :: a2 :: a3 :: a4 :: rev, last) + let rev, last = split_at_last_aux [] rest in + (a0 :: a1 :: a2 :: a3 :: a4 :: rev, last) (** can not do loop unroll due to state combination @@ -458,9 +467,9 @@ let filter_mapi xs f = match xs with | [] -> [] | y :: ys -> ( - match f y i with - | None -> aux (i + 1) ys - | Some z -> z :: aux (i + 1) ys) + match f y i with + | None -> aux (i + 1) ys + | Some z -> z :: aux (i + 1) ys) in aux 0 xs @@ -468,13 +477,15 @@ let rec filter_map2 xs ys (f : 'a -> 'b -> 'c option) = match (xs, ys) with | [], [] -> [] | u :: us, v :: vs -> ( - match f u v with - | None -> filter_map2 us vs f (* idea: rec f us vs instead? *) - | Some z -> z :: filter_map2 us vs f) + match f u v with + | None -> filter_map2 us vs f (* idea: rec f us vs instead? *) + | Some z -> z :: filter_map2 us vs f) | _ -> invalid_arg "Ext_list.filter_map2" let rec rev_map_append l1 l2 f = - match l1 with [] -> l2 | a :: l -> rev_map_append l (f a :: l2) f + match l1 with + | [] -> l2 + | a :: l -> rev_map_append l (f a :: l2) f (** It is not worth loop unrolling, it is already tail-call, and we need to be careful @@ -484,14 +495,14 @@ let rec flat_map_aux f acc append lx = match lx with | [] -> rev_append acc append | a0 :: rest -> - let new_acc = - match f a0 with - | [] -> acc - | [ a0 ] -> a0 :: acc - | [ a0; a1 ] -> a1 :: a0 :: acc - | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: acc) - in - flat_map_aux f new_acc append rest + let new_acc = + match f a0 with + | [] -> acc + | [a0] -> a0 :: acc + | [a0; a1] -> a1 :: a0 :: acc + | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: acc) + in + flat_map_aux f new_acc append rest let flat_map lx f = flat_map_aux f [] [] lx @@ -505,7 +516,10 @@ let rec length_compare l n = | [] -> if n = 0 then `Eq else `Lt let rec length_ge l n = - if n > 0 then match l with _ :: tl -> length_ge tl (n - 1) | [] -> false + if n > 0 then + match l with + | _ :: tl -> length_ge tl (n - 1) + | [] -> false else true (** @@ -518,14 +532,16 @@ let rec length_larger_than_n xs ys n = | [], _ -> false let rec group (eq : 'a -> 'a -> bool) lst = - match lst with [] -> [] | x :: xs -> aux eq x (group eq xs) + match lst with + | [] -> [] + | x :: xs -> aux eq x (group eq xs) and aux eq (x : 'a) (xss : 'a list list) : 'a list list = match xss with - | [] -> [ [ x ] ] + | [] -> [[x]] | (y0 :: _ as y) :: ys -> - (* cannot be empty *) - if eq x y0 then (x :: y) :: ys else y :: aux eq x ys + (* cannot be empty *) + if eq x y0 then (x :: y) :: ys else y :: aux eq x ys | _ :: _ -> assert false let stable_group lst eq = group eq lst |> rev @@ -534,10 +550,14 @@ let rec drop h n = if n < 0 then invalid_arg "Ext_list.drop" else if n = 0 then h else - match h with [] -> invalid_arg "Ext_list.drop" | _ :: tl -> drop tl (n - 1) + match h with + | [] -> invalid_arg "Ext_list.drop" + | _ :: tl -> drop tl (n - 1) let rec find_first x p = - match x with [] -> None | x :: l -> if p x then Some x else find_first l p + match x with + | [] -> None + | x :: l -> if p x then Some x else find_first l p let rec find_first_not xs p = match xs with @@ -547,56 +567,60 @@ let rec find_first_not xs p = let rec rev_iter l f = match l with | [] -> () - | [ x1 ] -> f x1 - | [ x1; x2 ] -> - f x2; - f x1 - | [ x1; x2; x3 ] -> - f x3; - f x2; - f x1 - | [ x1; x2; x3; x4 ] -> - f x4; - f x3; - f x2; - f x1 + | [x1] -> f x1 + | [x1; x2] -> + f x2; + f x1 + | [x1; x2; x3] -> + f x3; + f x2; + f x1 + | [x1; x2; x3; x4] -> + f x4; + f x3; + f x2; + f x1 | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - rev_iter tail f; - f x5; - f x4; - f x3; - f x2; - f x1 + rev_iter tail f; + f x5; + f x4; + f x3; + f x2; + f x1 let rec iter l f = match l with | [] -> () - | [ x1 ] -> f x1 - | [ x1; x2 ] -> - f x1; - f x2 - | [ x1; x2; x3 ] -> - f x1; - f x2; - f x3 - | [ x1; x2; x3; x4 ] -> - f x1; - f x2; - f x3; - f x4 + | [x1] -> f x1 + | [x1; x2] -> + f x1; + f x2 + | [x1; x2; x3] -> + f x1; + f x2; + f x3 + | [x1; x2; x3; x4] -> + f x1; + f x2; + f x3; + f x4 | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - f x1; - f x2; - f x3; - f x4; - f x5; - iter tail f + f x1; + f x2; + f x3; + f x4; + f x5; + iter tail f let rec for_all lst p = - match lst with [] -> true | a :: l -> p a && for_all l p + match lst with + | [] -> true + | a :: l -> p a && for_all l p let rec for_all_snd lst p = - match lst with [] -> true | (_, a) :: l -> p a && for_all_snd l p + match lst with + | [] -> true + | (_, a) :: l -> p a && for_all_snd l p let rec for_all2_no_exn l1 l2 p = match (l1, l2) with @@ -607,42 +631,48 @@ let rec for_all2_no_exn l1 l2 p = let rec find_opt xs p = match xs with | [] -> None - | x :: l -> ( match p x with Some _ as v -> v | None -> find_opt l p) + | x :: l -> ( + match p x with + | Some _ as v -> v + | None -> find_opt l p) let rec find_def xs p def = match xs with | [] -> def - | x :: l -> ( match p x with Some v -> v | None -> find_def l p def) + | x :: l -> ( + match p x with + | Some v -> v + | None -> find_def l p def) let rec split_map l f = match l with | [] -> ([], []) - | [ x1 ] -> - let a0, b0 = f x1 in - ([ a0 ], [ b0 ]) - | [ x1; x2 ] -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - ([ a1; a2 ], [ b1; b2 ]) - | [ x1; x2; x3 ] -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - let a3, b3 = f x3 in - ([ a1; a2; a3 ], [ b1; b2; b3 ]) - | [ x1; x2; x3; x4 ] -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - let a3, b3 = f x3 in - let a4, b4 = f x4 in - ([ a1; a2; a3; a4 ], [ b1; b2; b3; b4 ]) + | [x1] -> + let a0, b0 = f x1 in + ([a0], [b0]) + | [x1; x2] -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + ([a1; a2], [b1; b2]) + | [x1; x2; x3] -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + let a3, b3 = f x3 in + ([a1; a2; a3], [b1; b2; b3]) + | [x1; x2; x3; x4] -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + let a3, b3 = f x3 in + let a4, b4 = f x4 in + ([a1; a2; a3; a4], [b1; b2; b3; b4]) | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - let a3, b3 = f x3 in - let a4, b4 = f x4 in - let a5, b5 = f x5 in - let ass, bss = split_map tail f in - (a1 :: a2 :: a3 :: a4 :: a5 :: ass, b1 :: b2 :: b3 :: b4 :: b5 :: bss) + let a1, b1 = f x1 in + let a2, b2 = f x2 in + let a3, b3 = f x3 in + let a4, b4 = f x4 in + let a5, b5 = f x5 in + let ass, bss = split_map tail f in + (a1 :: a2 :: a3 :: a4 :: a5 :: ass, b1 :: b2 :: b3 :: b4 :: b5 :: bss) let sort_via_array lst cmp = let arr = Array.of_list lst in @@ -656,12 +686,18 @@ let sort_via_arrayf lst cmp f = let rec assoc_by_string lst (k : string) def = match lst with - | [] -> ( match def with None -> assert false | Some x -> x) + | [] -> ( + match def with + | None -> assert false + | Some x -> x) | (k1, v1) :: rest -> if k1 = k then v1 else assoc_by_string rest k def let rec assoc_by_int lst (k : int) def = match lst with - | [] -> ( match def with None -> assert false | Some x -> x) + | [] -> ( + match def with + | None -> assert false + | Some x -> x) | (k1, v1) :: rest -> if k1 = k then v1 else assoc_by_int rest k def let rec nth_aux l n = @@ -675,29 +711,40 @@ let rec iter_snd lst f = match lst with | [] -> () | (_, x) :: xs -> - f x; - iter_snd xs f + f x; + iter_snd xs f let rec iter_fst lst f = match lst with | [] -> () | (x, _) :: xs -> - f x; - iter_fst xs f + f x; + iter_fst xs f -let rec exists l p = match l with [] -> false | x :: xs -> p x || exists xs p +let rec exists l p = + match l with + | [] -> false + | x :: xs -> p x || exists xs p let rec exists_fst l p = - match l with [] -> false | (a, _) :: l -> p a || exists_fst l p + match l with + | [] -> false + | (a, _) :: l -> p a || exists_fst l p let rec exists_snd l p = - match l with [] -> false | (_, a) :: l -> p a || exists_snd l p + match l with + | [] -> false + | (_, a) :: l -> p a || exists_snd l p let rec concat_append (xss : 'a list list) (xs : 'a list) : 'a list = - match xss with [] -> xs | l :: r -> append l (concat_append r xs) + match xss with + | [] -> xs + | l :: r -> append l (concat_append r xs) let rec fold_left l accu f = - match l with [] -> accu | a :: l -> fold_left l (f accu a) f + match l with + | [] -> accu + | a :: l -> fold_left l (f accu a) f let reduce_from_left lst fn = match lst with @@ -710,10 +757,15 @@ let rec fold_left2 l1 l2 accu f = | a1 :: l1, a2 :: l2 -> fold_left2 l1 l2 (f a1 a2 accu) f | _, _ -> invalid_arg "Ext_list.fold_left2" -let singleton_exn xs = match xs with [ x ] -> x | _ -> assert false +let singleton_exn xs = + match xs with + | [x] -> x + | _ -> assert false let rec mem_string (xs : string list) (x : string) = - match xs with [] -> false | a :: l -> a = x || mem_string l x + match xs with + | [] -> false + | a :: l -> a = x || mem_string l x let filter lst p = let rec find ~p accu lst = diff --git a/compiler/ext/ext_list.mli b/compiler/ext/ext_list.mli index 95a078bd37..61a07c7b38 100644 --- a/compiler/ext/ext_list.mli +++ b/compiler/ext/ext_list.mli @@ -108,7 +108,7 @@ val filter_mapi : 'a list -> ('a -> int -> 'b option) -> 'b list val filter_map2 : 'a list -> 'b list -> ('a -> 'b -> 'c option) -> 'c list -val length_compare : 'a list -> int -> [ `Gt | `Eq | `Lt ] +val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt] val length_ge : 'a list -> int -> bool diff --git a/compiler/ext/ext_module_system.ml b/compiler/ext/ext_module_system.ml index 9b06848f3f..c8a0734f5d 100644 --- a/compiler/ext/ext_module_system.ml +++ b/compiler/ext/ext_module_system.ml @@ -1 +1 @@ -type t = Commonjs | Esmodule | Es6_global +type t = Commonjs | Esmodule | Es6_global diff --git a/compiler/ext/ext_modulename.ml b/compiler/ext/ext_modulename.ml index ddc0292dec..d2d46930f0 100644 --- a/compiler/ext/ext_modulename.ml +++ b/compiler/ext/ext_modulename.ml @@ -25,7 +25,9 @@ let good_hint_name module_name offset = let len = String.length module_name in len > offset - && (function 'a' .. 'z' | 'A' .. 'Z' -> true | _ -> false) + && (function + | 'a' .. 'z' | 'A' .. 'Z' -> true + | _ -> false) (String.unsafe_get module_name offset) && Ext_string.for_all_from module_name (offset + 1) (function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true @@ -37,11 +39,11 @@ let rec collect_start buf s off len = let next = succ off in match String.unsafe_get s off with | 'a' .. 'z' as c -> - Ext_buffer.add_char buf (Char.uppercase_ascii c); - collect_next buf s next len + Ext_buffer.add_char buf (Char.uppercase_ascii c); + collect_next buf s next len | 'A' .. 'Z' as c -> - Ext_buffer.add_char buf c; - collect_next buf s next len + Ext_buffer.add_char buf c; + collect_next buf s next len | _ -> collect_start buf s next len and collect_next buf s off len = @@ -50,8 +52,8 @@ and collect_next buf s off len = let next = off + 1 in match String.unsafe_get s off with | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_') as c -> - Ext_buffer.add_char buf c; - collect_next buf s next len + Ext_buffer.add_char buf c; + collect_next buf s next len | '.' | '-' -> collect_start buf s next len | _ -> collect_next buf s next len diff --git a/compiler/ext/ext_namespace.ml b/compiler/ext/ext_namespace.ml index deccf1f961..faad6920fb 100644 --- a/compiler/ext/ext_namespace.ml +++ b/compiler/ext/ext_namespace.ml @@ -43,7 +43,9 @@ let try_split_module_name name = let js_name_of_modulename s (case : Ext_js_file_kind.case) suffix : string = let s = - match case with Little -> Ext_string.uncapitalize_ascii s | Upper -> s + match case with + | Little -> Ext_string.uncapitalize_ascii s + | Upper -> s in change_ext_ns_suffix s suffix @@ -61,10 +63,10 @@ let is_valid_npm_package_name (s : string) = && match String.unsafe_get s 0 with | 'a' .. 'z' | '@' -> - Ext_string.for_all_from s 1 (fun x -> - match x with - | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true - | _ -> false) + Ext_string.for_all_from s 1 (fun x -> + match x with + | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true + | _ -> false) | _ -> false let namespace_of_package_name (s : string) : string = @@ -79,8 +81,8 @@ let namespace_of_package_name (s : string) : string = let ch = String.unsafe_get s off in match ch with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> - add capital ch; - aux false (off + 1) len + add capital ch; + aux false (off + 1) len | '/' | '-' -> aux true (off + 1) len | _ -> aux capital (off + 1) len in diff --git a/compiler/ext/ext_namespace.mli b/compiler/ext/ext_namespace.mli index f562729d7b..fa6401694d 100644 --- a/compiler/ext/ext_namespace.mli +++ b/compiler/ext/ext_namespace.mli @@ -33,8 +33,7 @@ val try_split_module_name : string -> (string * string) option *) val change_ext_ns_suffix : string -> string -> string -val js_name_of_modulename : - string -> Ext_js_file_kind.case -> string -> string +val js_name_of_modulename : string -> Ext_js_file_kind.case -> string -> string (** [js_name_of_modulename ~little A-Ns] *) diff --git a/compiler/ext/ext_namespace_encode.ml b/compiler/ext/ext_namespace_encode.ml index 071a92c966..87ad276f73 100644 --- a/compiler/ext/ext_namespace_encode.ml +++ b/compiler/ext/ext_namespace_encode.ml @@ -23,4 +23,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let make ?ns cunit = - match ns with None -> cunit | Some ns -> cunit ^ Literals.ns_sep ^ ns + match ns with + | None -> cunit + | Some ns -> cunit ^ Literals.ns_sep ^ ns diff --git a/compiler/ext/ext_obj.ml b/compiler/ext/ext_obj.ml index f57d9f680e..01ec1d8f54 100644 --- a/compiler/ext/ext_obj.ml +++ b/compiler/ext/ext_obj.ml @@ -29,8 +29,8 @@ let rec dump r = let rec get_fields acc = function | 0 -> acc | n -> - let n = n - 1 in - get_fields (Obj.field r n :: acc) n + let n = n - 1 in + get_fields (Obj.field r n :: acc) n in let rec is_list r = if Obj.is_int r then r = Obj.repr 0 (* [] *) @@ -54,46 +54,48 @@ let rec dump r = (* From the tag, determine the type of block. *) match t with | _ when is_list r -> - let fields = get_list r in - "[" ^ String.concat "; " (Ext_list.map fields dump) ^ "]" + let fields = get_list r in + "[" ^ String.concat "; " (Ext_list.map fields dump) ^ "]" | 0 -> - let fields = get_fields [] s in - "(" ^ String.concat ", " (Ext_list.map fields dump) ^ ")" + let fields = get_fields [] s in + "(" ^ String.concat ", " (Ext_list.map fields dump) ^ ")" | x when x = Obj.lazy_tag -> - (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not - * clear if very large constructed values could have the same - * tag. XXX *) - opaque "lazy" + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + opaque "lazy" | x when x = Obj.closure_tag -> opaque "closure" | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let _clasz, id, slots = - match fields with h :: h' :: t -> (h, h', t) | _ -> assert false - in - (* No information on decoding the class (first field). So just print - * out the ID and the slots. *) - "Object #" ^ dump id ^ " (" - ^ String.concat ", " (Ext_list.map slots dump) - ^ ")" + let fields = get_fields [] s in + let _clasz, id, slots = + match fields with + | h :: h' :: t -> (h, h', t) + | _ -> assert false + in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. *) + "Object #" ^ dump id ^ " (" + ^ String.concat ", " (Ext_list.map slots dump) + ^ ")" | x when x = Obj.infix_tag -> opaque "infix" | x when x = Obj.forward_tag -> opaque "forward" | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s in - "Tag" ^ string_of_int t ^ " (" - ^ String.concat ", " (Ext_list.map fields dump) - ^ ")" + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ " (" + ^ String.concat ", " (Ext_list.map fields dump) + ^ ")" | x when x = Obj.string_tag -> - "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" + "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" | x when x = Obj.double_tag -> string_of_float (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> opaque "custom" | x when x = Obj.custom_tag -> opaque "final" | x when x = Obj.double_array_tag -> - "[|" - ^ String.concat ";" - (Array.to_list - (Array.map string_of_float (Obj.magic r : float array))) - ^ "|]" + "[|" + ^ String.concat ";" + (Array.to_list + (Array.map string_of_float (Obj.magic r : float array))) + ^ "|]" | _ -> opaque (Printf.sprintf "unknown: tag %d size %d" t s) let dump v = dump (Obj.repr v) @@ -109,16 +111,16 @@ let bt () = match raw_bt with | None -> () | Some raw_bt -> - let acc = ref [] in - for i = Array.length raw_bt - 1 downto 0 do - let slot = raw_bt.(i) in - match Printexc.Slot.location slot with - | None -> () - | Some bt -> ( - match !acc with - | [] -> acc := [ bt ] - | hd :: _ -> if hd <> bt then acc := bt :: !acc) - done; - Ext_list.iter !acc (fun bt -> - Printf.eprintf "File \"%s\", line %d, characters %d-%d\n" bt.filename - bt.line_number bt.start_char bt.end_char) + let acc = ref [] in + for i = Array.length raw_bt - 1 downto 0 do + let slot = raw_bt.(i) in + match Printexc.Slot.location slot with + | None -> () + | Some bt -> ( + match !acc with + | [] -> acc := [bt] + | hd :: _ -> if hd <> bt then acc := bt :: !acc) + done; + Ext_list.iter !acc (fun bt -> + Printf.eprintf "File \"%s\", line %d, characters %d-%d\n" bt.filename + bt.line_number bt.start_char bt.end_char) diff --git a/compiler/ext/ext_option.ml b/compiler/ext/ext_option.ml index 0e4f128abb..92a2439a97 100644 --- a/compiler/ext/ext_option.ml +++ b/compiler/ext/ext_option.ml @@ -22,8 +22,17 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let map v f = match v with None -> None | Some x -> Some (f x) +let map v f = + match v with + | None -> None + | Some x -> Some (f x) -let iter v f = match v with None -> () | Some x -> f x +let iter v f = + match v with + | None -> () + | Some x -> f x -let exists v f = match v with None -> false | Some x -> f x +let exists v f = + match v with + | None -> false + | Some x -> f x diff --git a/compiler/ext/ext_path.ml b/compiler/ext/ext_path.ml index c4c28aafcc..5e2f483f66 100644 --- a/compiler/ext/ext_path.ml +++ b/compiler/ext/ext_path.ml @@ -37,17 +37,22 @@ let split_by_sep_per_os : string -> string list = if Ext_sys.is_windows_or_cygwin then fun x -> (* on Windows, we can still accept -bs-package-output lib/js *) Ext_string.split_by - (fun x -> match x with '/' | '\\' -> true | _ -> false) + (fun x -> + match x with + | '/' | '\\' -> true + | _ -> false) x else fun x -> Ext_string.split x '/' let node_relative_path ~from:(file_or_dir_2 : t) (file_or_dir_1 : t) = let relevant_dir1 = - match file_or_dir_1 with Dir x -> x + match file_or_dir_1 with + | Dir x -> x (* | File file1 -> Filename.dirname file1 *) in let relevant_dir2 = - match file_or_dir_2 with Dir x -> x + match file_or_dir_2 with + | Dir x -> x (* | File file2 -> Filename.dirname file2 *) in let dir1 = split_by_sep_per_os relevant_dir1 in @@ -61,7 +66,7 @@ let node_relative_path ~from:(file_or_dir_2 : t) (file_or_dir_1 : t) = in match go dir1 dir2 with | x :: _ as ys when x = Literals.node_parent -> - String.concat Literals.node_sep ys + String.concat Literals.node_sep ys | ys -> String.concat Literals.node_sep @@ (Literals.node_current :: ys) let node_concat ~dir base = dir ^ Literals.node_sep ^ base @@ -70,7 +75,7 @@ let node_rebase_file ~from ~to_ file = node_concat ~dir: (if from = to_ then Literals.node_current - else node_relative_path ~from:(Dir from) (Dir to_)) + else node_relative_path ~from:(Dir from) (Dir to_)) file (*** @@ -144,20 +149,20 @@ let rel_normalized_absolute_path ~from to_ = let rec go xss yss = match (xss, yss) with | x :: xs, y :: ys -> - if Ext_string.equal x y then go xs ys - else if x = Filename.current_dir_name then go xs yss - else if y = Filename.current_dir_name then go xss ys - else - let start = - Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> - acc // Ext_string.parent_dir_lit) - in - Ext_list.fold_left yss start (fun acc v -> acc // v) + if Ext_string.equal x y then go xs ys + else if x = Filename.current_dir_name then go xs yss + else if y = Filename.current_dir_name then go xss ys + else + let start = + Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> + acc // Ext_string.parent_dir_lit) + in + Ext_list.fold_left yss start (fun acc v -> acc // v) | [], [] -> Ext_string.empty | [], y :: ys -> Ext_list.fold_left ys y (fun acc x -> acc // x) | _ :: xs, [] -> - Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> - acc // Ext_string.parent_dir_lit) + Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> + acc // Ext_string.parent_dir_lit) in let v = go paths1 paths2 in @@ -191,16 +196,20 @@ let rel_normalized_absolute_path ~from to_ = (** See tests in {!Ounit_path_tests} *) let normalize_absolute_path x = - let drop_if_exist xs = match xs with [] -> [] | _ :: xs -> xs in + let drop_if_exist xs = + match xs with + | [] -> [] + | _ :: xs -> xs + in let rec normalize_list acc paths = match paths with | [] -> acc | x :: xs -> - if Ext_string.equal x Ext_string.current_dir_lit then - normalize_list acc xs - else if Ext_string.equal x Ext_string.parent_dir_lit then - normalize_list (drop_if_exist acc) xs - else normalize_list (x :: acc) xs + if Ext_string.equal x Ext_string.current_dir_lit then + normalize_list acc xs + else if Ext_string.equal x Ext_string.parent_dir_lit then + normalize_list (drop_if_exist acc) xs + else normalize_list (x :: acc) xs in let root, paths = split_aux x in let rev_paths = normalize_list [] paths in @@ -209,7 +218,9 @@ let normalize_absolute_path x = | [] -> Filename.concat root acc | last :: rest -> go (Filename.concat last acc) rest in - match rev_paths with [] -> root | last :: rest -> go last rest + match rev_paths with + | [] -> root + | last :: rest -> go last rest let absolute_path cwd s = let process s = @@ -242,16 +253,20 @@ let check_suffix_case = Ext_string.ends_with (* Input must be absolute directory *) let rec find_root_filename ~cwd filenames = - let file_exists = Ext_list.exists filenames (fun filename -> - Sys.file_exists (Filename.concat cwd filename)) + let file_exists = + Ext_list.exists filenames (fun filename -> + Sys.file_exists (Filename.concat cwd filename)) in if file_exists then cwd else let cwd' = Filename.dirname cwd in if String.length cwd' < String.length cwd then find_root_filename ~cwd:cwd' filenames - else Ext_fmt.failwithf ~loc:__LOC__ "%s not found from %s" (List.hd filenames) cwd + else + Ext_fmt.failwithf ~loc:__LOC__ "%s not found from %s" (List.hd filenames) + cwd -let find_config_dir cwd = find_root_filename ~cwd [Literals.rescript_json; Literals.bsconfig_json] +let find_config_dir cwd = + find_root_filename ~cwd [Literals.rescript_json; Literals.bsconfig_json] let package_dir = lazy (find_config_dir (Lazy.force cwd)) diff --git a/compiler/ext/ext_pervasives.ml b/compiler/ext/ext_pervasives.ml index a8540f5a5e..cdc44d8130 100644 --- a/compiler/ext/ext_pervasives.ml +++ b/compiler/ext/ext_pervasives.ml @@ -27,11 +27,11 @@ external reraise : exn -> 'a = "%raise" let finally v ~clean:action f = match f v with | exception e -> - action v; - reraise e + action v; + reraise e | e -> - action v; - e + action v; + e (* let try_it f = try ignore (f ()) with _ -> () *) diff --git a/compiler/ext/ext_position.ml b/compiler/ext/ext_position.ml index 96e575bc66..a15409429d 100644 --- a/compiler/ext/ext_position.ml +++ b/compiler/ext/ext_position.ml @@ -23,10 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = Lexing.position = { - pos_fname : string; - pos_lnum : int; - pos_bol : int; - pos_cnum : int; + pos_fname: string; + pos_lnum: int; + pos_bol: int; + pos_cnum: int; } let offset (x : t) (y : t) = diff --git a/compiler/ext/ext_position.mli b/compiler/ext/ext_position.mli index 0d17a2cf29..7d0a0563ca 100644 --- a/compiler/ext/ext_position.mli +++ b/compiler/ext/ext_position.mli @@ -23,10 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = Lexing.position = { - pos_fname : string; - pos_lnum : int; - pos_bol : int; - pos_cnum : int; + pos_fname: string; + pos_lnum: int; + pos_bol: int; + pos_cnum: int; } val offset : t -> t -> t diff --git a/compiler/ext/ext_pp.ml b/compiler/ext/ext_pp.ml index 5b1e4a8b02..f9237c271a 100644 --- a/compiler/ext/ext_pp.ml +++ b/compiler/ext/ext_pp.ml @@ -31,11 +31,11 @@ end let indent_length = String.length L.indent_str type t = { - output_string : string -> unit; - output_char : char -> unit; - flush : unit -> unit; - mutable indent_level : int; - mutable last_new_line : bool; + output_string: string -> unit; + output_char: char -> unit; + flush: unit -> unit; + mutable indent_level: int; + mutable last_new_line: bool; (* only when we print newline, we print the indent *) } diff --git a/compiler/ext/ext_pp_scope.ml b/compiler/ext/ext_pp_scope.ml index 66df85da50..f074a411f0 100644 --- a/compiler/ext/ext_pp_scope.ml +++ b/compiler/ext/ext_pp_scope.ml @@ -42,11 +42,11 @@ let add_ident ~mangled:name (stamp : int) (cxt : t) : int * t = match Map_string.find_opt cxt name with | None -> (0, Map_string.add cxt name (Map_int.add Map_int.empty stamp 0)) | Some imap -> ( - match Map_int.find_opt imap stamp with - | None -> - let v = Map_int.cardinal imap in - (v, Map_string.add cxt name (Map_int.add imap stamp v)) - | Some i -> (i, cxt)) + match Map_int.find_opt imap stamp with + | None -> + let v = Map_int.cardinal imap in + (v, Map_string.add cxt name (Map_int.add imap stamp v)) + | Some i -> (i, cxt)) (** same as {!Js_dump.ident} except it generates a string instead of doing the printing @@ -104,10 +104,10 @@ let merge (cxt : t) (set : Set_ident.t) = update twice, once is enough *) let sub_scope (scope : t) (idents : Set_ident.t) : t = - Set_ident.fold idents empty (fun { name } acc -> + Set_ident.fold idents empty (fun {name} acc -> let mangled = Ext_ident.convert name in match Map_string.find_exn scope mangled with | exception Not_found -> assert false | imap -> - if Map_string.mem acc mangled then acc - else Map_string.add acc mangled imap) + if Map_string.mem acc mangled then acc + else Map_string.add acc mangled imap) diff --git a/compiler/ext/ext_topsort.ml b/compiler/ext/ext_topsort.ml index fc44e7176f..7cdef010c9 100644 --- a/compiler/ext/ext_topsort.ml +++ b/compiler/ext/ext_topsort.ml @@ -22,12 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type edges = { id : int; deps : Vec_int.t } +type edges = {id: int; deps: Vec_int.t} module Edge_vec = Vec.Make (struct type t = edges - let null = { id = 0; deps = Vec_int.empty () } + let null = {id = 0; deps = Vec_int.empty ()} end) type t = Edge_vec.t diff --git a/compiler/ext/ext_topsort.mli b/compiler/ext/ext_topsort.mli index 673f8d1256..11d634cb92 100644 --- a/compiler/ext/ext_topsort.mli +++ b/compiler/ext/ext_topsort.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type edges = { id : int; deps : Vec_int.t } +type edges = {id: int; deps: Vec_int.t} module Edge_vec : Vec_gen.S with type elt = edges diff --git a/compiler/ext/ext_utf8.ml b/compiler/ext/ext_utf8.ml index 0d02b2c573..18336b8040 100644 --- a/compiler/ext/ext_utf8.ml +++ b/compiler/ext/ext_utf8.ml @@ -74,13 +74,13 @@ let decode_utf8_string s = else match classify s.[i] with | Single c -> - add c; - decode_utf8_cont s (i + 1) s_len + add c; + decode_utf8_cont s (i + 1) s_len | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") | Leading (n, c) -> - let c', i' = follow s n c i in - add c'; - decode_utf8_cont s (i' + 1) s_len + let c', i' = follow s n c i in + add c'; + decode_utf8_cont s (i' + 1) s_len | Invalid -> raise (Invalid_utf8 "Invalid byte") in decode_utf8_cont s 0 (String.length s); @@ -128,4 +128,3 @@ let encode_codepoint c = Bytes.unsafe_set bytes 3 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); Bytes.unsafe_to_string bytes - diff --git a/compiler/ext/ext_util.ml b/compiler/ext/ext_util.ml index 1be75ff117..58b8ad2a17 100644 --- a/compiler/ext/ext_util.ml +++ b/compiler/ext/ext_util.ml @@ -34,7 +34,7 @@ let rec power_2_above x n = else power_2_above (x * 2) n let stats_to_string - ({ num_bindings; num_buckets; max_bucket_length; bucket_histogram } : + ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings num_buckets max_bucket_length @@ -53,9 +53,9 @@ let string_of_int_as_char (i : int) : string = | '\r' -> "\\r" | '\b' -> "\\b" | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s | _ -> Ext_utf8.encode_codepoint i in Printf.sprintf "\'%s\'" str diff --git a/compiler/ext/ext_util.mli b/compiler/ext/ext_util.mli index d31d11a90b..720e5b19b2 100644 --- a/compiler/ext/ext_util.mli +++ b/compiler/ext/ext_util.mli @@ -27,4 +27,3 @@ val power_2_above : int -> int -> int val stats_to_string : Hashtbl.statistics -> string val string_of_int_as_char : int -> string - diff --git a/compiler/ext/hash_gen.ml b/compiler/ext/hash_gen.ml index 01b6498fb4..589639aea9 100644 --- a/compiler/ext/hash_gen.ml +++ b/compiler/ext/hash_gen.ml @@ -18,23 +18,19 @@ type ('a, 'b) bucket = | Empty - | Cons of { - mutable key : 'a; - mutable data : 'b; - mutable next : ('a, 'b) bucket; - } + | Cons of {mutable key: 'a; mutable data: 'b; mutable next: ('a, 'b) bucket} type ('a, 'b) t = { - mutable size : int; + mutable size: int; (* number of entries *) - mutable data : ('a, 'b) bucket array; + mutable data: ('a, 'b) bucket array; (* the buckets *) - initial_size : int; (* initial array size *) + initial_size: int; (* initial array size *) } let create initial_size = let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } + {initial_size = s; size = 0; data = Array.make s Empty} let clear h = h.size <- 0; @@ -60,13 +56,13 @@ let resize indexfun h = (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () - | Cons { key; next } as cell -> - let nidx = indexfun h key in - (match Array.unsafe_get ndata_tail nidx with - | Empty -> Array.unsafe_set ndata nidx cell - | Cons tail -> tail.next <- cell); - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next + | Cons {key; next} as cell -> + let nidx = indexfun h key in + (match Array.unsafe_get ndata_tail nidx with + | Empty -> Array.unsafe_set ndata nidx cell + | Cons tail -> tail.next <- cell); + Array.unsafe_set ndata_tail nidx cell; + insert_bucket next in for i = 0 to osize - 1 do insert_bucket (Array.unsafe_get odata i) @@ -81,8 +77,8 @@ let iter h f = let rec do_bucket = function | Empty -> () | Cons l -> - f l.key l.data; - do_bucket l.next + f l.key l.data; + do_bucket l.next in let d = h.data in for i = 0 to Array.length d - 1 do @@ -108,89 +104,88 @@ let rec small_bucket_mem (lst : _ bucket) eq key = match lst with | Empty -> false | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> ( eq key lst.key || match lst.next with | Empty -> false - | Cons lst -> ( - eq key lst.key - || - match lst.next with - | Empty -> false - | Cons lst -> eq key lst.key || small_bucket_mem lst.next eq key)) + | Cons lst -> eq key lst.key || small_bucket_mem lst.next eq key)) let rec small_bucket_opt eq key (lst : _ bucket) : _ option = match lst with | Empty -> None | Cons lst -> ( - if eq key lst.key then Some lst.data - else - match lst.next with - | Empty -> None - | Cons lst -> ( + if eq key lst.key then Some lst.data + else + match lst.next with + | Empty -> None + | Cons lst -> ( + if eq key lst.key then Some lst.data + else + match lst.next with + | Empty -> None + | Cons lst -> if eq key lst.key then Some lst.data - else - match lst.next with - | Empty -> None - | Cons lst -> - if eq key lst.key then Some lst.data - else small_bucket_opt eq key lst.next)) + else small_bucket_opt eq key lst.next)) let rec small_bucket_key_opt eq key (lst : _ bucket) : _ option = match lst with | Empty -> None - | Cons { key = k; next } -> ( - if eq key k then Some k - else - match next with - | Empty -> None - | Cons { key = k; next } -> ( - if eq key k then Some k - else - match next with - | Empty -> None - | Cons { key = k; next } -> - if eq key k then Some k else small_bucket_key_opt eq key next) - ) + | Cons {key = k; next} -> ( + if eq key k then Some k + else + match next with + | Empty -> None + | Cons {key = k; next} -> ( + if eq key k then Some k + else + match next with + | Empty -> None + | Cons {key = k; next} -> + if eq key k then Some k else small_bucket_key_opt eq key next)) let rec small_bucket_default eq key default (lst : _ bucket) = match lst with | Empty -> default | Cons lst -> ( - if eq key lst.key then lst.data - else - match lst.next with - | Empty -> default - | Cons lst -> ( + if eq key lst.key then lst.data + else + match lst.next with + | Empty -> default + | Cons lst -> ( + if eq key lst.key then lst.data + else + match lst.next with + | Empty -> default + | Cons lst -> if eq key lst.key then lst.data - else - match lst.next with - | Empty -> default - | Cons lst -> - if eq key lst.key then lst.data - else small_bucket_default eq key default lst.next)) + else small_bucket_default eq key default lst.next)) let rec remove_bucket h (i : int) key ~(prec : _ bucket) (buck : _ bucket) eq_key = match buck with | Empty -> () - | Cons { key = k; next } -> - if eq_key k key then ( - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next) - else remove_bucket h i key ~prec:buck next eq_key + | Cons {key = k; next} -> + if eq_key k key then ( + h.size <- h.size - 1; + match prec with + | Empty -> Array.unsafe_set h.data i next + | Cons c -> c.next <- next) + else remove_bucket h i key ~prec:buck next eq_key let rec replace_bucket key data (buck : _ bucket) eq_key = match buck with | Empty -> true | Cons slot -> - if eq_key slot.key key then ( - slot.key <- key; - slot.data <- data; - false) - else replace_bucket key data slot.next eq_key + if eq_key slot.key key then ( + slot.key <- key; + slot.data <- data; + false) + else replace_bucket key data slot.next eq_key module type S = sig type key diff --git a/compiler/ext/hash_ident.mli b/compiler/ext/hash_ident.mli index 0a299ad283..43971863e8 100644 --- a/compiler/ext/hash_ident.mli +++ b/compiler/ext/hash_ident.mli @@ -1,5 +1 @@ - - -include Hash_gen.S with type key = Ident.t - - +include Hash_gen.S with type key = Ident.t diff --git a/compiler/ext/hash_set_gen.ml b/compiler/ext/hash_set_gen.ml index a1879036f8..db892caf46 100644 --- a/compiler/ext/hash_set_gen.ml +++ b/compiler/ext/hash_set_gen.ml @@ -25,21 +25,19 @@ (* We do dynamic hashing, and resize the table and rehash the elements when buckets become too long. *) -type 'a bucket = - | Empty - | Cons of { mutable key : 'a; mutable next : 'a bucket } +type 'a bucket = Empty | Cons of {mutable key: 'a; mutable next: 'a bucket} type 'a t = { - mutable size : int; + mutable size: int; (* number of entries *) - mutable data : 'a bucket array; + mutable data: 'a bucket array; (* the buckets *) - initial_size : int; (* initial array size *) + initial_size: int; (* initial array size *) } let create initial_size = let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } + {initial_size = s; size = 0; data = Array.make s Empty} let clear h = h.size <- 0; @@ -65,13 +63,13 @@ let resize indexfun h = (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () - | Cons { key; next } as cell -> - let nidx = indexfun h key in - (match Array.unsafe_get ndata_tail nidx with - | Empty -> Array.unsafe_set ndata nidx cell - | Cons tail -> tail.next <- cell); - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next + | Cons {key; next} as cell -> + let nidx = indexfun h key in + (match Array.unsafe_get ndata_tail nidx with + | Empty -> Array.unsafe_set ndata nidx cell + | Cons tail -> tail.next <- cell); + Array.unsafe_set ndata_tail nidx cell; + insert_bucket next in for i = 0 to osize - 1 do insert_bucket (Array.unsafe_get odata i) @@ -86,8 +84,8 @@ let iter h f = let rec do_bucket = function | Empty -> () | Cons l -> - f l.key; - do_bucket l.next + f l.key; + do_bucket l.next in let d = h.data in for i = 0 to Array.length d - 1 do @@ -96,7 +94,9 @@ let iter h f = let fold h init f = let rec do_bucket b accu = - match b with Empty -> accu | Cons l -> do_bucket l.next (f l.key accu) + match b with + | Empty -> accu + | Cons l -> do_bucket l.next (f l.key accu) in let d = h.data in let accu = ref init in @@ -111,28 +111,28 @@ let rec small_bucket_mem eq key lst = match lst with | Empty -> false | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> ( eq key lst.key || match lst.next with | Empty -> false - | Cons lst -> ( - eq key lst.key - || - match lst.next with - | Empty -> false - | Cons lst -> eq key lst.key || small_bucket_mem eq key lst.next)) + | Cons lst -> eq key lst.key || small_bucket_mem eq key lst.next)) let rec remove_bucket (h : _ t) (i : int) key ~(prec : _ bucket) (buck : _ bucket) eq_key = match buck with | Empty -> () - | Cons { key = k; next } -> - if eq_key k key then ( - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next) - else remove_bucket h i key ~prec:buck next eq_key + | Cons {key = k; next} -> + if eq_key k key then ( + h.size <- h.size - 1; + match prec with + | Empty -> Array.unsafe_set h.data i next + | Cons c -> c.next <- next) + else remove_bucket h i key ~prec:buck next eq_key module type S = sig type key diff --git a/compiler/ext/hash_set_ident.mli b/compiler/ext/hash_set_ident.mli index 5fed77b9b7..b32ba8aec4 100644 --- a/compiler/ext/hash_set_ident.mli +++ b/compiler/ext/hash_set_ident.mli @@ -22,5 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - include Hash_set_gen.S with type key = Ident.t diff --git a/compiler/ext/hash_set_ident_mask.ml b/compiler/ext/hash_set_ident_mask.ml index 8cdc76b772..67a78d836d 100644 --- a/compiler/ext/hash_set_ident_mask.ml +++ b/compiler/ext/hash_set_ident_mask.ml @@ -1,4 +1,3 @@ - (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -27,137 +26,118 @@ type ident = Ident.t -type bucket = - | Empty - | Cons of { - ident : ident; - mutable mask : bool; - rest : bucket - } +type bucket = Empty | Cons of {ident: ident; mutable mask: bool; rest: bucket} type t = { - mutable size : int ; - mutable data : bucket array; - mutable mask_size : int (* mark how many idents are marked *) + mutable size: int; + mutable data: bucket array; + mutable mask_size: int; (* mark how many idents are marked *) } +let key_index_by_ident (h : t) (key : Ident.t) = + Bs_hash_stubs.hash_string_int key.name key.stamp land (Array.length h.data - 1) - -let key_index_by_ident (h : t) (key : Ident.t) = - (Bs_hash_stubs.hash_string_int key.name key.stamp) land (Array.length h.data - 1) - - - - -let create initial_size = +let create initial_size = let s = Ext_util.power_2_above 8 initial_size in - { size = 0; data = Array.make s Empty ; mask_size = 0} + {size = 0; data = Array.make s Empty; mask_size = 0} let iter_and_unmask h f = - let rec iter_bucket buckets = - match buckets with - | Empty -> - () - | Cons k -> - let k_mask = k.mask in - f k.ident k_mask ; - if k_mask then - begin - k.mask <- false ; - (* we can set [h.mask_size] to zero, - however, it would result inconsistent state - once [f] throw - *) - h.mask_size <- h.mask_size - 1 - end; - iter_bucket k.rest + let rec iter_bucket buckets = + match buckets with + | Empty -> () + | Cons k -> + let k_mask = k.mask in + f k.ident k_mask; + if k_mask then ( + k.mask <- false; + (* we can set [h.mask_size] to zero, + however, it would result inconsistent state + once [f] throw + *) + h.mask_size <- h.mask_size - 1); + iter_bucket k.rest in let d = h.data in for i = 0 to Array.length d - 1 do iter_bucket (Array.unsafe_get d i) done - let rec small_bucket_mem key lst = - match lst with - | Empty -> false - | Cons rst -> - Ext_ident.equal key rst.ident || - match rst.rest with - | Empty -> false - | Cons rst -> - Ext_ident.equal key rst.ident || - match rst.rest with - | Empty -> false - | Cons rst -> - Ext_ident.equal key rst.ident || - small_bucket_mem key rst.rest + match lst with + | Empty -> false + | Cons rst -> ( + Ext_ident.equal key rst.ident + || + match rst.rest with + | Empty -> false + | Cons rst -> ( + Ext_ident.equal key rst.ident + || + match rst.rest with + | Empty -> false + | Cons rst -> + Ext_ident.equal key rst.ident || small_bucket_mem key rst.rest)) let resize indexfun h = let odata = h.data in let osize = Array.length odata in let nsize = osize * 2 in - if nsize < Sys.max_array_length then begin + if nsize < Sys.max_array_length then ( let ndata = Array.make nsize Empty in - h.data <- ndata; (* so that indexfun sees the new bucket count *) + h.data <- ndata; + (* so that indexfun sees the new bucket count *) let rec insert_bucket = function - Empty -> () - | Cons {ident = key; mask; rest} -> + | Empty -> () + | Cons {ident = key; mask; rest} -> let nidx = indexfun h key in - Array.unsafe_set - ndata (nidx) - (Cons {ident = key; mask; rest = Array.unsafe_get ndata (nidx)}); + Array.unsafe_set ndata nidx + (Cons {ident = key; mask; rest = Array.unsafe_get ndata nidx}); insert_bucket rest in for i = 0 to osize - 1 do insert_bucket (Array.unsafe_get odata i) - done - end + done) let add_unmask (h : t) (key : Ident.t) = - let i = key_index_by_ident h key in - let h_data = h.data in + let i = key_index_by_ident h key in + let h_data = h.data in let old_bucket = Array.unsafe_get h_data i in - if not (small_bucket_mem key old_bucket) then - begin - Array.unsafe_set h_data i - (Cons {ident = key; mask = false; rest = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then resize key_index_by_ident h - end - - - - -let rec small_bucket_mask key lst = - match lst with - | Empty -> false - | Cons rst -> - if Ext_ident.equal key rst.ident then - if rst.mask then false else (rst.mask <- true ; true) - else - match rst.rest with + if not (small_bucket_mem key old_bucket) then ( + Array.unsafe_set h_data i + (Cons {ident = key; mask = false; rest = old_bucket}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then resize key_index_by_ident h) + +let rec small_bucket_mask key lst = + match lst with + | Empty -> false + | Cons rst -> ( + if Ext_ident.equal key rst.ident then + if rst.mask then false + else ( + rst.mask <- true; + true) + else + match rst.rest with | Empty -> false - | Cons rst -> - if Ext_ident.equal key rst.ident then - if rst.mask then false else (rst.mask <- true ; true) - else - match rst.rest with + | Cons rst -> ( + if Ext_ident.equal key rst.ident then + if rst.mask then false + else ( + rst.mask <- true; + true) + else + match rst.rest with | Empty -> false - | Cons rst -> - if Ext_ident.equal key rst.ident then - if rst.mask then false else (rst.mask <- true ; true) - else - small_bucket_mask key rst.rest - -let mask_and_check_all_hit (h : t) (key : Ident.t) = - if - small_bucket_mask key - (Array.unsafe_get h.data (key_index_by_ident h key )) then - begin - h.mask_size <- h.mask_size + 1 - end; - h.size = h.mask_size - - - + | Cons rst -> + if Ext_ident.equal key rst.ident then + if rst.mask then false + else ( + rst.mask <- true; + true) + else small_bucket_mask key rst.rest)) + +let mask_and_check_all_hit (h : t) (key : Ident.t) = + if small_bucket_mask key (Array.unsafe_get h.data (key_index_by_ident h key)) + then h.mask_size <- h.mask_size + 1; + h.size = h.mask_size diff --git a/compiler/ext/hash_set_ident_mask.mli b/compiler/ext/hash_set_ident_mask.mli index 19c60a0282..1c5bb8f481 100644 --- a/compiler/ext/hash_set_ident_mask.mli +++ b/compiler/ext/hash_set_ident_mask.mli @@ -1,38 +1,23 @@ - - +type ident = Ident.t (** Based on [hash_set] specialized for mask operations *) -type ident = Ident.t - type t -val create: int -> t +val create : int -> t - -(* add one ident +(* add one ident ident is unmaksed by default *) -val add_unmask : t -> ident -> unit - +val add_unmask : t -> ident -> unit +val mask_and_check_all_hit : t -> ident -> bool (** [check_mask h key] if [key] exists mask it otherwise nothing return true if all keys are masked otherwise false *) -val mask_and_check_all_hit : - t -> - ident -> - bool +val iter_and_unmask : t -> (ident -> bool -> unit) -> unit (** [iter_and_unmask f h] iterating the collection and mask all idents, dont consul the collection in function [f] TODO: what happens if an exception raised in the callback, would the hashtbl still be in consistent state? *) -val iter_and_unmask: - t -> - (ident -> bool -> unit) -> - unit - - - - diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml index ca4697332e..a5ca80e840 100644 --- a/compiler/ext/ident.ml +++ b/compiler/ext/ident.ml @@ -15,9 +15,9 @@ open Format -type t = { stamp: int; name: string; mutable flags: int } +type t = {stamp: int; name: string; mutable flags: int} -let [@inlnie] max (x:int) y = if x >= y then x else y +let[@inlnie] max (x : int) y = if x >= y then x else y let global_flag = 1 let predef_exn_flag = 2 @@ -27,18 +27,17 @@ let currentstamp = ref 0 let create s = incr currentstamp; - { name = s; stamp = !currentstamp; flags = 0 } + {name = s; stamp = !currentstamp; flags = 0} let create_predef_exn s = incr currentstamp; - { name = s; stamp = !currentstamp; flags = predef_exn_flag } + {name = s; stamp = !currentstamp; flags = predef_exn_flag} -let create_persistent s = - { name = s; stamp = 0; flags = global_flag } +let create_persistent s = {name = s; stamp = 0; flags = global_flag} let rename i = incr currentstamp; - { i with stamp = !currentstamp } + {i with stamp = !currentstamp} let name i = i.name @@ -46,40 +45,31 @@ let unique_name i = i.name ^ "_" ^ string_of_int i.stamp let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp -let persistent i = (i.stamp = 0) +let persistent i = i.stamp = 0 let equal i1 i2 = i1.name = i2.name -let same ({stamp; name } : t) i2 = - if stamp <> 0 - then stamp = i2.stamp - else i2.stamp = 0 && name = i2.name - - +let same ({stamp; name} : t) i2 = + if stamp <> 0 then stamp = i2.stamp else i2.stamp = 0 && name = i2.name let binding_time i = i.stamp -let current_time() = !currentstamp +let current_time () = !currentstamp let set_current_time t = currentstamp := max !currentstamp t let reinit_level = ref (-1) let reinit () = - if !reinit_level < 0 - then reinit_level := !currentstamp + if !reinit_level < 0 then reinit_level := !currentstamp else currentstamp := !reinit_level -let hide i = - { i with stamp = -1 } +let hide i = {i with stamp = -1} -let make_global i = - i.flags <- i.flags lor global_flag +let make_global i = i.flags <- i.flags lor global_flag -let global i = - (i.flags land global_flag) <> 0 +let global i = i.flags land global_flag <> 0 -let is_predef_exn i = - (i.flags land predef_exn_flag) <> 0 +let is_predef_exn i = i.flags land predef_exn_flag <> 0 let print ppf i = match i.stamp with @@ -87,14 +77,9 @@ let print ppf i = | -1 -> fprintf ppf "%s#" i.name | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "") -type 'a tbl = - Empty - | Node of 'a tbl * 'a data * 'a tbl * int +type 'a tbl = Empty | Node of 'a tbl * 'a data * 'a tbl * int -and 'a data = - { ident: t; - data: 'a; - previous: 'a data option } +and 'a data = {ident: t; data: 'a; previous: 'a data option} let empty = Empty @@ -105,113 +90,119 @@ let empty = Empty *) let mknode l d r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h - and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1)) + let hl = + match l with + | Empty -> 0 + | Node (_, _, _, h) -> h + and hr = + match r with + | Empty -> 0 + | Node (_, _, _, h) -> h + in + Node (l, d, r, if hl >= hr then hl + 1 else hr + 1) let balance l d r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h - and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + let hl = + match l with + | Empty -> 0 + | Node (_, _, _, h) -> h + and hr = + match r with + | Empty -> 0 + | Node (_, _, _, h) -> h + in if hl > hr + 1 then match l with | Node (ll, ld, lr, _) - when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >= - (match lr with Empty -> 0 | Node(_,_,_,h) -> h) -> - mknode ll ld (mknode lr d r) - | Node (ll, ld, Node(lrl, lrd, lrr, _), _) -> - mknode (mknode ll ld lrl) lrd (mknode lrr d r) + when (match ll with + | Empty -> 0 + | Node (_, _, _, h) -> h) + >= + match lr with + | Empty -> 0 + | Node (_, _, _, h) -> h -> + mknode ll ld (mknode lr d r) + | Node (ll, ld, Node (lrl, lrd, lrr, _), _) -> + mknode (mknode ll ld lrl) lrd (mknode lrr d r) | _ -> assert false else if hr > hl + 1 then match r with | Node (rl, rd, rr, _) - when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >= - (match rl with Empty -> 0 | Node(_,_,_,h) -> h) -> - mknode (mknode l d rl) rd rr + when (match rr with + | Empty -> 0 + | Node (_, _, _, h) -> h) + >= + match rl with + | Empty -> 0 + | Node (_, _, _, h) -> h -> + mknode (mknode l d rl) rd rr | Node (Node (rll, rld, rlr, _), rd, rr, _) -> - mknode (mknode l d rll) rld (mknode rlr rd rr) + mknode (mknode l d rll) rld (mknode rlr rd rr) | _ -> assert false - else - mknode l d r + else mknode l d r let rec add id data = function - Empty -> - Node(Empty, {ident = id; data = data; previous = None}, Empty, 1) - | Node(l, k, r, h) -> - let c = compare id.name k.ident.name in - if c = 0 then - Node(l, {ident = id; data = data; previous = Some k}, r, h) - else if c < 0 then - balance (add id data l) k r - else - balance l k (add id data r) + | Empty -> Node (Empty, {ident = id; data; previous = None}, Empty, 1) + | Node (l, k, r, h) -> + let c = compare id.name k.ident.name in + if c = 0 then Node (l, {ident = id; data; previous = Some k}, r, h) + else if c < 0 then balance (add id data l) k r + else balance l k (add id data r) let rec find_stamp s = function - None -> - raise Not_found - | Some k -> - if k.ident.stamp = s then k.data else find_stamp s k.previous + | None -> raise Not_found + | Some k -> if k.ident.stamp = s then k.data else find_stamp s k.previous let rec find_same id = function - Empty -> - raise Not_found - | Node(l, k, r, _) -> - let c = compare id.name k.ident.name in - if c = 0 then - if id.stamp = k.ident.stamp - then k.data - else find_stamp id.stamp k.previous - else - find_same id (if c < 0 then l else r) + | Empty -> raise Not_found + | Node (l, k, r, _) -> + let c = compare id.name k.ident.name in + if c = 0 then + if id.stamp = k.ident.stamp then k.data + else find_stamp id.stamp k.previous + else find_same id (if c < 0 then l else r) let rec find_name name = function - Empty -> - raise Not_found - | Node(l, k, r, _) -> - let c = compare name k.ident.name in - if c = 0 then - k.ident, k.data - else - find_name name (if c < 0 then l else r) + | Empty -> raise Not_found + | Node (l, k, r, _) -> + let c = compare name k.ident.name in + if c = 0 then (k.ident, k.data) else find_name name (if c < 0 then l else r) let rec get_all = function | None -> [] | Some k -> (k.ident, k.data) :: get_all k.previous let rec find_all name = function - Empty -> - [] - | Node(l, k, r, _) -> - let c = compare name k.ident.name in - if c = 0 then - (k.ident, k.data) :: get_all k.previous - else - find_all name (if c < 0 then l else r) + | Empty -> [] + | Node (l, k, r, _) -> + let c = compare name k.ident.name in + if c = 0 then (k.ident, k.data) :: get_all k.previous + else find_all name (if c < 0 then l else r) let rec fold_aux f stack accu = function - Empty -> - begin match stack with - [] -> accu - | a :: l -> fold_aux f l accu a - end - | Node(l, k, r, _) -> - fold_aux f (l :: stack) (f k accu) r + | Empty -> ( + match stack with + | [] -> accu + | a :: l -> fold_aux f l accu a) + | Node (l, k, r, _) -> fold_aux f (l :: stack) (f k accu) r let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl let rec fold_data f d accu = match d with - None -> accu + | None -> accu | Some k -> f k.ident k.data (fold_data f k.previous accu) -let fold_all f tbl accu = - fold_aux (fun k -> fold_data f (Some k)) [] accu tbl +let fold_all f tbl accu = fold_aux (fun k -> fold_data f (Some k)) [] accu tbl (* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) let rec iter f = function - Empty -> () - | Node(l, k, r, _) -> - iter f l; f k.ident k.data; iter f r + | Empty -> () + | Node (l, k, r, _) -> + iter f l; + f k.ident k.data; + iter f r (* Idents for sharing keys *) @@ -222,20 +213,18 @@ let make_key_generator () = let c = ref 1 in fun id -> let stamp = !c in - decr c ; - { id with name = key_name; stamp = stamp; } + decr c; + {id with name = key_name; stamp} let compare x y = let c = x.stamp - y.stamp in if c <> 0 then c else let c = compare x.name y.name in - if c <> 0 then c - else - compare x.flags y.flags + if c <> 0 then c else compare x.flags y.flags let output oc id = output_string oc (unique_name id) -let hash i = (Char.code i.name.[0]) lxor i.stamp +let hash i = Char.code i.name.[0] lxor i.stamp let original_equal = equal include Identifiable.Make (struct diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli index c2983edbed..d73cff6f6e 100644 --- a/compiler/ext/ident.mli +++ b/compiler/ext/ident.mli @@ -15,7 +15,7 @@ (* Identifiers (unique names) *) -type t = { stamp: int; name: string; mutable flags: int } +type t = {stamp: int; name: string; mutable flags: int} include Identifiable.S with type t := t (* Notes: @@ -24,50 +24,49 @@ include Identifiable.S with type t := t - [compare] compares identifiers by binding location *) +val create : string -> t +val create_persistent : string -> t +val create_predef_exn : string -> t +val rename : t -> t +val name : t -> string +val unique_name : t -> string +val unique_toplevel_name : t -> string +val persistent : t -> bool +val same : t -> t -> bool +(* Compare identifiers by binding location. + Two identifiers are the same either if they are both + non-persistent and have been created by the same call to + [new], or if they are both persistent and have the same + name. *) -val create: string -> t -val create_persistent: string -> t -val create_predef_exn: string -> t -val rename: t -> t -val name: t -> string -val unique_name: t -> string -val unique_toplevel_name: t -> string -val persistent: t -> bool -val same: t -> t -> bool - (* Compare identifiers by binding location. - Two identifiers are the same either if they are both - non-persistent and have been created by the same call to - [new], or if they are both persistent and have the same - name. *) -val compare: t -> t -> int -val hide: t -> t - (* Return an identifier with same name as the given identifier, - but stamp different from any stamp returned by new. - When put in a 'a tbl, this identifier can only be looked - up by name. *) +val compare : t -> t -> int +val hide : t -> t +(* Return an identifier with same name as the given identifier, + but stamp different from any stamp returned by new. + When put in a 'a tbl, this identifier can only be looked + up by name. *) -val make_global: t -> unit -val global: t -> bool -val is_predef_exn: t -> bool +val make_global : t -> unit +val global : t -> bool +val is_predef_exn : t -> bool -val binding_time: t -> int -val current_time: unit -> int -val set_current_time: int -> unit -val reinit: unit -> unit +val binding_time : t -> int +val current_time : unit -> int +val set_current_time : int -> unit +val reinit : unit -> unit type 'a tbl - (* Association tables from identifiers to type 'a. *) - -val empty: 'a tbl -val add: t -> 'a -> 'a tbl -> 'a tbl -val find_same: t -> 'a tbl -> 'a -val find_name: string -> 'a tbl -> t * 'a -val find_all: string -> 'a tbl -> (t * 'a) list -val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b -val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b -val iter: (t -> 'a -> unit) -> 'a tbl -> unit +(* Association tables from identifiers to type 'a. *) +val empty : 'a tbl +val add : t -> 'a -> 'a tbl -> 'a tbl +val find_same : t -> 'a tbl -> 'a +val find_name : string -> 'a tbl -> t * 'a +val find_all : string -> 'a tbl -> (t * 'a) list +val fold_name : (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val fold_all : (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val iter : (t -> 'a -> unit) -> 'a tbl -> unit (* Idents for sharing keys *) -val make_key_generator : unit -> (t -> t) +val make_key_generator : unit -> t -> t diff --git a/compiler/ext/identifiable.ml b/compiler/ext/identifiable.ml index 6ee0519a9f..bd6133c87e 100644 --- a/compiler/ext/identifiable.ml +++ b/compiler/ext/identifiable.ml @@ -26,9 +26,7 @@ end module type Set = sig module T : Set.OrderedType - include Set.S - with type elt = T.t - and type t = Set.Make (T).t + include Set.S with type elt = T.t and type t = Set.Make(T).t val output : out_channel -> t -> unit val print : Format.formatter -> t -> unit @@ -39,14 +37,17 @@ end module type Map = sig module T : Map.OrderedType - include Map.S - with type key = T.t - and type 'a t = 'a Map.Make (T).t + include Map.S with type key = T.t and type 'a t = 'a Map.Make(T).t val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t val of_list : (key * 'a) list -> 'a t - val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t + val disjoint_union : + ?eq:('a -> 'a -> bool) -> + ?print:(Format.formatter -> 'a -> unit) -> + 'a t -> + 'a t -> + 'a t val union_right : 'a t -> 'a t -> 'a t @@ -70,9 +71,7 @@ module type Tbl = sig include Map.OrderedType with type t := t include Hashtbl.HashedType with type t := t end - include Hashtbl.S - with type key = T.t - and type 'a t = 'a Hashtbl.Make (T).t + include Hashtbl.S with type key = T.t and type 'a t = 'a Hashtbl.Make(T).t val to_list : 'a t -> (T.t * 'a) list val of_list : (T.t * 'a) list -> 'a t @@ -88,8 +87,7 @@ module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct let compare (a1, b1) (a2, b2) = let c = A.compare a1 a2 in - if c <> 0 then c - else B.compare b1 b2 + if c <> 0 then c else B.compare b1 b2 let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b) @@ -100,62 +98,62 @@ end module Make_map (T : Thing) = struct include Map.Make (T) - let filter_map f t = - fold (fun id v map -> + let filter_map f t = + fold + (fun id v map -> match f id v with | None -> map - | Some r -> add id r map) t empty + | Some r -> add id r map) + t empty - let of_list l = - List.fold_left (fun map (id, v) -> add id v map) empty l + let of_list l = List.fold_left (fun map (id, v) -> add id v map) empty l let disjoint_union ?eq ?print m1 m2 = - union (fun id v1 v2 -> - let ok = match eq with + union + (fun id v1 v2 -> + let ok = + match eq with | None -> false | Some eq -> eq v1 v2 in if not ok then let err = match print with - | None -> - Format.asprintf "Map.disjoint_union %a" T.print id + | None -> Format.asprintf "Map.disjoint_union %a" T.print id | Some print -> - Format.asprintf "Map.disjoint_union %a => %a <> %a" - T.print id print v1 print v2 + Format.asprintf "Map.disjoint_union %a => %a <> %a" T.print id + print v1 print v2 in Misc.fatal_error err else Some v1) m1 m2 let union_right m1 m2 = - merge (fun _id x y -> match x, y with + merge + (fun _id x y -> + match (x, y) with | None, None -> None - | None, Some v - | Some v, None - | Some _, Some v -> Some v) + | None, Some v | Some v, None | Some _, Some v -> Some v) m1 m2 let union_left m1 m2 = union_right m2 m1 let union_merge f m1 m2 = let aux _ m1 m2 = - match m1, m2 with + match (m1, m2) with | None, m | m, None -> m | Some m1, Some m2 -> Some (f m1 m2) in merge aux m1 m2 - let rename m v = - try find v m - with Not_found -> v + let rename m v = try find v m with Not_found -> v - let map_keys f m = - of_list (List.map (fun (k, v) -> f k, v) (bindings m)) + let map_keys f m = of_list (List.map (fun (k, v) -> (f k, v)) (bindings m)) let print f ppf s = - let elts ppf s = iter (fun id v -> - Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in + let elts ppf s = + iter (fun id v -> Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s + in Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s module T_set = Set.Make (T) @@ -168,13 +166,12 @@ module Make_map (T : Thing) = struct let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty let transpose_keys_and_data_set map = - fold (fun k v m -> + fold + (fun k v m -> let set = match find v m with - | exception Not_found -> - T_set.singleton k - | set -> - T_set.add k set + | exception Not_found -> T_set.singleton k + | set -> T_set.add k set in add v set m) map empty @@ -194,7 +191,8 @@ module Make_set (T : Thing) = struct let to_string s = Format.asprintf "%a" print s - let of_list l = match l with + let of_list l = + match l with | [] -> empty | [t] -> singleton t | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q @@ -207,8 +205,7 @@ module Make_tbl (T : Thing) = struct module T_map = Make_map (T) - let to_list t = - fold (fun key datum elts -> (key, datum)::elts) t [] + let to_list t = fold (fun key datum elts -> (key, datum) :: elts) t [] let of_list elts = let t = create 42 in @@ -222,15 +219,14 @@ module Make_tbl (T : Thing) = struct T_map.iter (fun k v -> add t k v) m; t - let memoize t f = fun key -> - try find t key with - | Not_found -> + let memoize t f key = + try find t key + with Not_found -> let r = f key in add t key r; r - let map t f = - of_map (T_map.map f (to_map t)) + let map t f = of_map (T_map.map f (to_map t)) end module type S = sig diff --git a/compiler/ext/identifiable.mli b/compiler/ext/identifiable.mli index 46e1454516..9dd8defd9e 100644 --- a/compiler/ext/identifiable.mli +++ b/compiler/ext/identifiable.mli @@ -30,9 +30,7 @@ module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t module type Set = sig module T : Set.OrderedType - include Set.S - with type elt = T.t - and type t = Set.Make (T).t + include Set.S with type elt = T.t and type t = Set.Make(T).t val output : out_channel -> t -> unit val print : Format.formatter -> t -> unit @@ -43,24 +41,27 @@ end module type Map = sig module T : Map.OrderedType - include Map.S - with type key = T.t - and type 'a t = 'a Map.Make (T).t + include Map.S with type key = T.t and type 'a t = 'a Map.Make(T).t val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t val of_list : (key * 'a) list -> 'a t + val disjoint_union : + ?eq:('a -> 'a -> bool) -> + ?print:(Format.formatter -> 'a -> unit) -> + 'a t -> + 'a t -> + 'a t (** [disjoint_union m1 m2] contains all bindings from [m1] and [m2]. If some binding is present in both and the associated value is not equal, a Fatal_error is raised *) - val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t + val union_right : 'a t -> 'a t -> 'a t (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If some binding is present in both, the one from [m2] is taken *) - val union_right : 'a t -> 'a t -> 'a t - (** [union_left m1 m2 = union_right m2 m1] *) val union_left : 'a t -> 'a t -> 'a t + (** [union_left m1 m2 = union_right m2 m1] *) val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val rename : key t -> key -> key @@ -80,9 +81,7 @@ module type Tbl = sig include Map.OrderedType with type t := t include Hashtbl.HashedType with type t := t end - include Hashtbl.S - with type key = T.t - and type 'a t = 'a Hashtbl.Make (T).t + include Hashtbl.S with type key = T.t and type 'a t = 'a Hashtbl.Make(T).t val to_list : 'a t -> (T.t * 'a) list val of_list : (T.t * 'a) list -> 'a t diff --git a/compiler/ext/js_reserved_map.mli b/compiler/ext/js_reserved_map.mli index cf4e1cb2bd..5ee19826fa 100644 --- a/compiler/ext/js_reserved_map.mli +++ b/compiler/ext/js_reserved_map.mli @@ -22,8 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val is_js_keyword: string -> bool +val is_js_keyword : string -> bool -val is_js_special_word: string -> bool +val is_js_special_word : string -> bool -val is_js_global: string -> bool +val is_js_global : string -> bool diff --git a/compiler/ext/map_gen.ml b/compiler/ext/map_gen.ml index ecd0aa3156..7c8af834dd 100644 --- a/compiler/ext/map_gen.ml +++ b/compiler/ext/map_gen.ml @@ -16,15 +16,15 @@ type ('key, 'a) t0 = | Empty - | Leaf of { k : 'key; v : 'a } - | Node of { l : ('key, 'a) t0; k : 'key; v : 'a; r : ('key, 'a) t0; h : int } + | Leaf of {k: 'key; v: 'a} + | Node of {l: ('key, 'a) t0; k: 'key; v: 'a; r: ('key, 'a) t0; h: int} type ('key, 'a) parital_node = { - l : ('key, 'a) t0; - k : 'key; - v : 'a; - r : ('key, 'a) t0; - h : int; + l: ('key, 'a) t0; + k: 'key; + v: 'a; + r: ('key, 'a) t0; + h: int; } external ( ~! ) : ('key, 'a) t0 -> ('key, 'a) parital_node = "%identity" @@ -34,103 +34,106 @@ let empty = Empty let rec map x f = match x with | Empty -> Empty - | Leaf { k; v } -> Leaf { k; v = f v } - | Node ({ l; v; r } as x) -> - let l' = map l f in - let d' = f v in - let r' = map r f in - Node { x with l = l'; v = d'; r = r' } + | Leaf {k; v} -> Leaf {k; v = f v} + | Node ({l; v; r} as x) -> + let l' = map l f in + let d' = f v in + let r' = map r f in + Node {x with l = l'; v = d'; r = r'} let rec mapi x f = match x with | Empty -> Empty - | Leaf { k; v } -> Leaf { k; v = f k v } - | Node ({ l; k; v; r } as x) -> - let l' = mapi l f in - let v' = f k v in - let r' = mapi r f in - Node { x with l = l'; v = v'; r = r' } + | Leaf {k; v} -> Leaf {k; v = f k v} + | Node ({l; k; v; r} as x) -> + let l' = mapi l f in + let v' = f k v in + let r' = mapi r f in + Node {x with l = l'; v = v'; r = r'} let[@inline] calc_height a b = (if a >= b then a else b) + 1 -let[@inline] singleton k v = Leaf { k; v } +let[@inline] singleton k v = Leaf {k; v} -let[@inline] height = function Empty -> 0 | Leaf _ -> 1 | Node { h } -> h +let[@inline] height = function + | Empty -> 0 + | Leaf _ -> 1 + | Node {h} -> h -let[@inline] unsafe_node k v l r h = Node { l; k; v; r; h } +let[@inline] unsafe_node k v l r h = Node {l; k; v; r; h} let[@inline] unsafe_two_elements k1 v1 k2 v2 = unsafe_node k2 v2 (singleton k1 v1) empty 2 let[@inline] unsafe_node_maybe_leaf k v l r h = - if h = 1 then Leaf { k; v } else Node { l; k; v; r; h } + if h = 1 then Leaf {k; v} else Node {l; k; v; r; h} type ('key, +'a) t = ('key, 'a) t0 = private | Empty - | Leaf of { k : 'key; v : 'a } - | Node of { l : ('key, 'a) t; k : 'key; v : 'a; r : ('key, 'a) t; h : int } + | Leaf of {k: 'key; v: 'a} + | Node of {l: ('key, 'a) t; k: 'key; v: 'a; r: ('key, 'a) t; h: int} let rec cardinal_aux acc = function | Empty -> acc | Leaf _ -> acc + 1 - | Node { l; r } -> cardinal_aux (cardinal_aux (acc + 1) r) l + | Node {l; r} -> cardinal_aux (cardinal_aux (acc + 1) r) l let cardinal s = cardinal_aux 0 s let rec bindings_aux accu = function | Empty -> accu - | Leaf { k; v } -> (k, v) :: accu - | Node { l; k; v; r } -> bindings_aux ((k, v) :: bindings_aux accu r) l + | Leaf {k; v} -> (k, v) :: accu + | Node {l; k; v; r} -> bindings_aux ((k, v) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let rec fill_array_with_f (s : _ t) i arr f : int = match s with | Empty -> i - | Leaf { k; v } -> - Array.unsafe_set arr i (f k v); - i + 1 - | Node { l; k; v; r } -> - let inext = fill_array_with_f l i arr f in - Array.unsafe_set arr inext (f k v); - fill_array_with_f r (inext + 1) arr f + | Leaf {k; v} -> + Array.unsafe_set arr i (f k v); + i + 1 + | Node {l; k; v; r} -> + let inext = fill_array_with_f l i arr f in + Array.unsafe_set arr inext (f k v); + fill_array_with_f r (inext + 1) arr f let rec fill_array_aux (s : _ t) i arr : int = match s with | Empty -> i - | Leaf { k; v } -> - Array.unsafe_set arr i (k, v); - i + 1 - | Node { l; k; v; r } -> - let inext = fill_array_aux l i arr in - Array.unsafe_set arr inext (k, v); - fill_array_aux r (inext + 1) arr + | Leaf {k; v} -> + Array.unsafe_set arr i (k, v); + i + 1 + | Node {l; k; v; r} -> + let inext = fill_array_aux l i arr in + Array.unsafe_set arr inext (k, v); + fill_array_aux r (inext + 1) arr let to_sorted_array (s : ('key, 'a) t) : ('key * 'a) array = match s with | Empty -> [||] - | Leaf { k; v } -> [| (k, v) |] - | Node { l; k; v; r } -> - let len = cardinal_aux (cardinal_aux 1 r) l in - let arr = Array.make len (k, v) in - ignore (fill_array_aux s 0 arr : int); - arr + | Leaf {k; v} -> [|(k, v)|] + | Node {l; k; v; r} -> + let len = cardinal_aux (cardinal_aux 1 r) l in + let arr = Array.make len (k, v) in + ignore (fill_array_aux s 0 arr : int); + arr let to_sorted_array_with_f (type key a b) (s : (key, a) t) (f : key -> a -> b) : b array = match s with | Empty -> [||] - | Leaf { k; v } -> [| f k v |] - | Node { l; k; v; r } -> - let len = cardinal_aux (cardinal_aux 1 r) l in - let arr = Array.make len (f k v) in - ignore (fill_array_with_f s 0 arr f : int); - arr + | Leaf {k; v} -> [|f k v|] + | Node {l; k; v; r} -> + let len = cardinal_aux (cardinal_aux 1 r) l in + let arr = Array.make len (f k v) in + ignore (fill_array_with_f s 0 arr f : int); + arr let rec keys_aux accu = function | Empty -> accu - | Leaf { k } -> k :: accu - | Node { l; k; r } -> keys_aux (k :: keys_aux accu r) l + | Leaf {k} -> k :: accu + | Node {l; k; r} -> keys_aux (k :: keys_aux accu r) l let keys s = keys_aux [] s @@ -138,7 +141,7 @@ let bal l x d r = let hl = height l in let hr = height r in if hl > hr + 2 then - let { l = ll; r = lr; v = lv; k = lk; h = _ } = ~!l in + let {l = ll; r = lr; v = lv; k = lk; h = _} = ~!l in let hll = height ll in let hlr = height lr in if hll >= hlr then @@ -147,7 +150,7 @@ let bal l x d r = (unsafe_node_maybe_leaf x d lr r hnode) (calc_height hll hnode) else - let { l = lrl; r = lrr; k = lrk; v = lrv } = ~!lr in + let {l = lrl; r = lrr; k = lrk; v = lrv} = ~!lr in let hlrl = height lrl in let hlrr = height lrr in let hlnode = calc_height hll hlrl in @@ -157,7 +160,7 @@ let bal l x d r = (unsafe_node_maybe_leaf x d lrr r hrnode) (calc_height hlnode hrnode) else if hr > hl + 2 then - let { l = rl; r = rr; k = rk; v = rv } = ~!r in + let {l = rl; r = rr; k = rk; v = rv} = ~!r in let hrr = height rr in let hrl = height rl in if hrr >= hrl then @@ -166,7 +169,7 @@ let bal l x d r = (unsafe_node_maybe_leaf x d l rl hnode) rr (calc_height hnode hrr) else - let { l = rll; r = rlr; k = rlk; v = rlv } = ~!rl in + let {l = rll; r = rlr; k = rlk; v = rlv} = ~!rl in let hrll = height rll in let hrlr = height rlr in let hlnode = calc_height hl hrll in @@ -177,54 +180,58 @@ let bal l x d r = (calc_height hlnode hrnode) else unsafe_node_maybe_leaf x d l r (calc_height hl hr) -let[@inline] is_empty = function Empty -> true | _ -> false +let[@inline] is_empty = function + | Empty -> true + | _ -> false let rec min_binding_exn = function | Empty -> raise Not_found - | Leaf { k; v } -> (k, v) - | Node { l; k; v } -> ( - match l with Empty -> (k, v) | Leaf _ | Node _ -> min_binding_exn l) + | Leaf {k; v} -> (k, v) + | Node {l; k; v} -> ( + match l with + | Empty -> (k, v) + | Leaf _ | Node _ -> min_binding_exn l) let rec remove_min_binding = function | Empty -> invalid_arg "Map.remove_min_elt" | Leaf _ -> empty - | Node { l = Empty; r } -> r - | Node { l; k; v; r } -> bal (remove_min_binding l) k v r + | Node {l = Empty; r} -> r + | Node {l; k; v; r} -> bal (remove_min_binding l) k v r let merge t1 t2 = match (t1, t2) with | Empty, t -> t | t, Empty -> t | _, _ -> - let x, d = min_binding_exn t2 in - bal t1 x d (remove_min_binding t2) + let x, d = min_binding_exn t2 in + bal t1 x d (remove_min_binding t2) let rec iter x f = match x with | Empty -> () - | Leaf { k; v } -> (f k v : unit) - | Node { l; k; v; r } -> - iter l f; - f k v; - iter r f + | Leaf {k; v} -> (f k v : unit) + | Node {l; k; v; r} -> + iter l f; + f k v; + iter r f let rec fold m accu f = match m with | Empty -> accu - | Leaf { k; v } -> f k v accu - | Node { l; k; v; r } -> fold r (f k v (fold l accu f)) f + | Leaf {k; v} -> f k v accu + | Node {l; k; v; r} -> fold r (f k v (fold l accu f)) f let rec for_all x p = match x with | Empty -> true - | Leaf { k; v } -> p k v - | Node { l; k; v; r } -> p k v && for_all l p && for_all r p + | Leaf {k; v} -> p k v + | Node {l; k; v; r} -> p k v && for_all l p && for_all r p let rec exists x p = match x with | Empty -> false - | Leaf { k; v } -> p k v - | Node { l; k; v; r } -> p k v || exists l p || exists r p + | Leaf {k; v} -> p k v + | Node {l; k; v; r} -> p k v || exists l p || exists r p (* Beware: those two functions assume that the added k is *strictly* smaller (or bigger) than all the present keys in the tree; it @@ -252,15 +259,15 @@ let rec join l v d r = | Empty -> add_min v d r | Leaf leaf -> add_min leaf.k leaf.v (add_min v d r) | Node xl -> ( - match r with - | Empty -> add_max v d l - | Leaf leaf -> add_max leaf.k leaf.v (add_max v d l) - | Node xr -> - let lh = xl.h in - let rh = xr.h in - if lh > rh + 2 then bal xl.l xl.k xl.v (join xl.r v d r) - else if rh > lh + 2 then bal (join l v d xr.l) xr.k xr.v xr.r - else unsafe_node v d l r (calc_height lh rh)) + match r with + | Empty -> add_max v d l + | Leaf leaf -> add_max leaf.k leaf.v (add_max v d l) + | Node xr -> + let lh = xl.h in + let rh = xr.h in + if lh > rh + 2 then bal xl.l xl.k xl.v (join xl.r v d r) + else if rh > lh + 2 then bal (join l v d xr.l) xr.k xr.v xr.r + else unsafe_node v d l r (calc_height lh rh)) (* Merge two trees l and r into one. All elements of l must precede the elements of r. @@ -271,11 +278,13 @@ let concat t1 t2 = | Empty, t -> t | t, Empty -> t | _, _ -> - let x, d = min_binding_exn t2 in - join t1 x d (remove_min_binding t2) + let x, d = min_binding_exn t2 in + join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = - match d with Some d -> join t1 v d t2 | None -> concat t1 t2 + match d with + | Some d -> join t1 v d t2 + | None -> concat t1 t2 module type S = sig type key diff --git a/compiler/ext/map_gen.mli b/compiler/ext/map_gen.mli index a1452460a4..c5038ffc42 100644 --- a/compiler/ext/map_gen.mli +++ b/compiler/ext/map_gen.mli @@ -1,7 +1,7 @@ type ('key, +'a) t = private | Empty - | Leaf of { k : 'key; v : 'a } - | Node of { l : ('key, 'a) t; k : 'key; v : 'a; r : ('key, 'a) t; h : int } + | Leaf of {k: 'key; v: 'a} + | Node of {l: ('key, 'a) t; k: 'key; v: 'a; r: ('key, 'a) t; h: int} val cardinal : ('a, 'b) t -> int diff --git a/compiler/ext/map_ident.mli b/compiler/ext/map_ident.mli index f4e717e4cd..56b3678c0b 100644 --- a/compiler/ext/map_ident.mli +++ b/compiler/ext/map_ident.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -include Map_gen.S with type key = Ident.t \ No newline at end of file +include Map_gen.S with type key = Ident.t diff --git a/compiler/ext/misc.ml b/compiler/ext/misc.ml index c1d5261b01..d63856aa07 100644 --- a/compiler/ext/misc.ml +++ b/compiler/ext/misc.ml @@ -17,20 +17,24 @@ exception Fatal_error - - let fatal_error msg = - prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error + prerr_string ">> Fatal error: "; + prerr_endline msg; + raise Fatal_error let fatal_errorf fmt = Format.kasprintf fatal_error fmt (* Exceptions *) let try_finally work cleanup = - let result = (try work () with e -> cleanup (); raise e) in + let result = + try work () + with e -> + cleanup (); + raise e + in cleanup (); result -;; type ref_and_value = R : 'a ref * 'a -> ref_and_value @@ -40,40 +44,45 @@ let protect_refs = let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in set_refs refs; match f () with - | x -> set_refs backup; x - | exception e -> set_refs backup; raise e + | x -> + set_refs backup; + x + | exception e -> + set_refs backup; + raise e (* List functions *) let rec map_end f l1 l2 = match l1 with - [] -> l2 - | hd::tl -> f hd :: map_end f tl l2 + | [] -> l2 + | hd :: tl -> f hd :: map_end f tl l2 let rec map_left_right f = function - [] -> [] - | hd::tl -> let res = f hd in res :: map_left_right f tl + | [] -> [] + | hd :: tl -> + let res = f hd in + res :: map_left_right f tl let rec for_all2 pred l1 l2 = match (l1, l2) with - ([], []) -> true - | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2 - | (_, _) -> false + | [], [] -> true + | hd1 :: tl1, hd2 :: tl2 -> pred hd1 hd2 && for_all2 pred tl1 tl2 + | _, _ -> false let rec replicate_list elem n = - if n <= 0 then [] else elem :: replicate_list elem (n-1) + if n <= 0 then [] else elem :: replicate_list elem (n - 1) let rec list_remove x = function - [] -> [] - | hd :: tl -> - if hd = x then tl else hd :: list_remove x tl + | [] -> [] + | hd :: tl -> if hd = x then tl else hd :: list_remove x tl let rec split_last = function - [] -> assert false + | [] -> assert false | [x] -> ([], x) | hd :: tl -> - let (lst, last) = split_last tl in - (hd :: lst, last) + let lst, last = split_last tl in + (hd :: lst, last) let may = Stdlib.Option.iter let may_map = Stdlib.Option.map @@ -83,14 +92,14 @@ let may_map = Stdlib.Option.map let find_in_path path name = if not (Filename.is_implicit name) then if Sys.file_exists name then name else raise Not_found - else begin + else let rec try_dir = function - [] -> raise Not_found - | dir::rem -> + | [] -> raise Not_found + | dir :: rem -> let fullname = Filename.concat dir name in if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path - end + in + try_dir path let find_in_path_rel path name = let rec simplify s = @@ -102,38 +111,36 @@ let find_in_path_rel path name = else concat (simplify dir) base in let rec try_dir = function - [] -> raise Not_found - | dir::rem -> + | [] -> raise Not_found + | dir :: rem -> let fullname = simplify (Filename.concat dir name) in if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path + in + try_dir path let find_in_path_uncap path name = let uname = String.uncapitalize_ascii name in let rec try_dir = function - [] -> raise Not_found - | dir::rem -> + | [] -> raise Not_found + | dir :: rem -> let fullname = Filename.concat dir name and ufullname = Filename.concat dir uname in if Sys.file_exists ufullname then ufullname else if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path + in + try_dir path let remove_file filename = - try - if Sys.file_exists filename - then Sys.remove filename - with Sys_error _msg -> - () + try if Sys.file_exists filename then Sys.remove filename + with Sys_error _msg -> () (* Expand a -I option: if it starts with +, make it relative to the standard library directory *) let expand_directory alt s = - if String.length s > 0 && s.[0] = '+' - then Filename.concat alt - (String.sub s 1 (String.length s - 1)) + if String.length s > 0 && s.[0] = '+' then + Filename.concat alt (String.sub s 1 (String.length s - 1)) else s (* Hashtable functions *) @@ -150,71 +157,89 @@ let copy_file ic oc = let buff = Bytes.create 0x1000 in let rec copy () = let n = input ic buff 0 0x1000 in - if n = 0 then () else (output oc buff 0 n; copy()) - in copy() + if n = 0 then () + else ( + output oc buff 0 n; + copy ()) + in + copy () let copy_file_chunk ic oc len = let buff = Bytes.create 0x1000 in let rec copy n = - if n <= 0 then () else begin + if n <= 0 then () + else let r = input ic buff 0 (min n 0x1000) in - if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r)) - end - in copy len + if r = 0 then raise End_of_file + else ( + output oc buff 0 r; + copy (n - r)) + in + copy len let string_of_file ic = let b = Buffer.create 0x10000 in let buff = Bytes.create 0x1000 in let rec copy () = let n = input ic buff 0 0x1000 in - if n = 0 then Buffer.contents b else - (Buffer.add_subbytes b buff 0 n; copy()) - in copy() - -let output_to_bin_file_directly filename fn = - let oc = open_out_bin filename in - match fn filename oc with - | v -> close_out oc ; v - | exception e -> close_out oc ; raise e + if n = 0 then Buffer.contents b + else ( + Buffer.add_subbytes b buff 0 n; + copy ()) + in + copy () + +let output_to_bin_file_directly filename fn = + let oc = open_out_bin filename in + match fn filename oc with + | v -> + close_out oc; + v + | exception e -> + close_out oc; + raise e let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = - let (temp_filename, oc) = - Filename.open_temp_file - ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename) - (Filename.basename filename) ".tmp" in - (* The 0o666 permissions will be modified by the umask. It's just - like what [open_out] and [open_out_bin] do. - With temp_dir = dirname filename, we ensure that the returned - temp file is in the same directory as filename itself, making - it safe to rename temp_filename to filename later. - With prefix = basename filename, we are almost certain that - the first generated name will be unique. A fixed prefix - would work too but might generate more collisions if many - files are being produced simultaneously in the same directory. *) + let temp_filename, oc = + Filename.open_temp_file ~mode ~perms:0o666 + ~temp_dir:(Filename.dirname filename) + (Filename.basename filename) + ".tmp" + in + (* The 0o666 permissions will be modified by the umask. It's just + like what [open_out] and [open_out_bin] do. + With temp_dir = dirname filename, we ensure that the returned + temp file is in the same directory as filename itself, making + it safe to rename temp_filename to filename later. + With prefix = basename filename, we are almost certain that + the first generated name will be unique. A fixed prefix + would work too but might generate more collisions if many + files are being produced simultaneously in the same directory. *) match fn temp_filename oc with - | res -> - close_out oc; - begin try - Sys.rename temp_filename filename; res - with exn -> - remove_file temp_filename; raise exn - end + | res -> ( + close_out oc; + try + Sys.rename temp_filename filename; + res + with exn -> + remove_file temp_filename; + raise exn) | exception exn -> - close_out oc; remove_file temp_filename; raise exn + close_out oc; + remove_file temp_filename; + raise exn (* Integer operations *) -let rec log2 n = - if n <= 1 then 0 else 1 + log2(n asr 1) +let rec log2 n = if n <= 1 then 0 else 1 + log2 (n asr 1) -let align n a = - if n >= 0 then (n + a - 1) land (-a) else n land (-a) +let align n a = if n >= 0 then (n + a - 1) land -a else n land -a -let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0 +let no_overflow_add a b = a lxor b lor (a lxor lnot (a + b)) < 0 -let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0 +let no_overflow_sub a b = a lxor lnot b lor (b lxor (a - b)) < 0 -let no_overflow_mul a b = b <> 0 && (a * b) / b = a +let no_overflow_mul a b = b <> 0 && a * b / b = a let no_overflow_lsl a k = 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k @@ -222,10 +247,9 @@ let no_overflow_lsl a k = module Int_literal_converter = struct (* To convert integer literals, allowing max_int + 1 (PR#4210) *) let cvt_int_aux str neg of_string = - if String.length str = 0 || str.[0]= '-' - then of_string str + if String.length str = 0 || str.[0] = '-' then of_string str else neg (of_string ("-" ^ str)) - let int s = cvt_int_aux s (~-) int_of_string + let int s = cvt_int_aux s ( ~- ) int_of_string let int32 s = cvt_int_aux s Int32.neg Int32.of_string let int64 s = cvt_int_aux s Int64.neg Int64.of_string end @@ -239,82 +263,87 @@ let chop_extensions file = let basename = String.sub basename 0 pos in if Filename.is_implicit file && dirname = Filename.current_dir_name then basename - else - Filename.concat dirname basename + else Filename.concat dirname basename with Not_found -> file let search_substring pat str start = let rec search i j = if j >= String.length pat then i else if i + j >= String.length str then raise Not_found - else if str.[i + j] = pat.[j] then search i (j+1) - else search (i+1) 0 - in search start 0 + else if str.[i + j] = pat.[j] then search i (j + 1) + else search (i + 1) 0 + in + search start 0 let replace_substring ~before ~after str = let rec search acc curr = match search_substring before str curr with - | next -> - let prefix = String.sub str curr (next - curr) in - search (prefix :: acc) (next + String.length before) - | exception Not_found -> - let suffix = String.sub str curr (String.length str - curr) in - List.rev (suffix :: acc) - in String.concat after (search [] 0) + | next -> + let prefix = String.sub str curr (next - curr) in + search (prefix :: acc) (next + String.length before) + | exception Not_found -> + let suffix = String.sub str curr (String.length str - curr) in + List.rev (suffix :: acc) + in + String.concat after (search [] 0) let rev_split_words s = let rec split1 res i = - if i >= String.length s then res else begin + if i >= String.length s then res + else match s.[i] with - ' ' | '\t' | '\r' | '\n' -> split1 res (i+1) - | _ -> split2 res i (i+1) - end + | ' ' | '\t' | '\r' | '\n' -> split1 res (i + 1) + | _ -> split2 res i (i + 1) and split2 res i j = - if j >= String.length s then String.sub s i (j-i) :: res else begin + if j >= String.length s then String.sub s i (j - i) :: res + else match s.[j] with - ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1) - | _ -> split2 res i (j+1) - end - in split1 [] 0 + | ' ' | '\t' | '\r' | '\n' -> + split1 (String.sub s i (j - i) :: res) (j + 1) + | _ -> split2 res i (j + 1) + in + split1 [] 0 let get_ref r = let v = !r in - r := []; v + r := []; + v let fst3 (x, _, _) = x -let snd3 (_,x,_) = x -let thd3 (_,_,x) = x +let snd3 (_, x, _) = x +let thd3 (_, _, x) = x let fst4 (x, _, _, _) = x -let snd4 (_,x,_, _) = x -let thd4 (_,_,x,_) = x -let for4 (_,_,_,x) = x +let snd4 (_, x, _, _) = x +let thd4 (_, _, x, _) = x +let for4 (_, _, _, x) = x let edit_distance a b cutoff = - let la, lb = String.length a, String.length b in + let la, lb = (String.length a, String.length b) in let cutoff = (* using max_int for cutoff would cause overflows in (i + cutoff + 1); we bring it back to the (max la lb) worstcase *) - min (max la lb) cutoff in + min (max la lb) cutoff + in if abs (la - lb) > cutoff then None - else begin + else (* initialize with 'cutoff + 1' so that not-yet-written-to cases have the worst possible cost; this is useful when computing the cost of a case just at the boundary of the cutoff diagonal. *) let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in m.(0).(0) <- 0; for i = 1 to la do - m.(i).(0) <- i; + m.(i).(0) <- i done; for j = 1 to lb do - m.(0).(j) <- j; + m.(0).(j) <- j done; for i = 1 to la do for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do - let cost = if a.[i-1] = b.[j-1] then 0 else 1 in + let cost = if a.[i - 1] = b.[j - 1] then 0 else 1 in let best = (* insert, delete or substitute *) - min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost) + min (1 + min m.(i - 1).(j) m.(i).(j - 1)) (m.(i - 1).(j - 1) + cost) in let best = (* swap two adjacent letters; we use "cost" again in case of @@ -322,35 +351,34 @@ let edit_distance a b cutoff = redundant as this is a double-substitution case, but it was done this way in most online implementations and imitation has its virtues *) - if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1]) + if + not + (i > 1 && j > 1 && a.[i - 1] = b.[j - 2] && a.[i - 2] = b.[j - 1]) then best - else min best (m.(i-2).(j-2) + cost) + else min best (m.(i - 2).(j - 2) + cost) in m.(i).(j) <- best - done; + done done; let result = m.(la).(lb) in - if result > cutoff - then None - else Some result - end + if result > cutoff then None else Some result let spellcheck env name = let cutoff = match String.length name with - | 1 | 2 -> 0 - | 3 | 4 -> 1 - | 5 | 6 -> 2 - | _ -> 3 + | 1 | 2 -> 0 + | 3 | 4 -> 1 + | 5 | 6 -> 2 + | _ -> 3 in let compare target acc head = match edit_distance target head cutoff with - | None -> acc - | Some dist -> - let (best_choice, best_dist) = acc in - if dist < best_dist then ([head], dist) - else if dist = best_dist then (head :: best_choice, dist) - else acc + | None -> acc + | Some dist -> + let best_choice, best_dist = acc in + if dist < best_dist then ([head], dist) + else if dist = best_dist then (head :: best_choice, dist) + else acc in fst (List.fold_left (compare name) ([], max_int) env) @@ -363,33 +391,29 @@ let did_you_mean ppf get_choices = match get_choices () with | [] -> () | choices -> - let rest, last = split_last choices in - Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?" - (String.concat ", " rest) - (if rest = [] then "" else " or ") - last + let rest, last = split_last choices in + Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?" + (String.concat ", " rest) + (if rest = [] then "" else " or ") + last let cut_at s c = let pos = String.index s c in - String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1) + (String.sub s 0 pos, String.sub s (pos + 1) (String.length s - pos - 1)) - -module StringSet = Set.Make(struct type t = string let compare = compare end) -module StringMap = Map.Make(struct type t = string let compare = compare end) +module StringSet = Set.Make (struct + type t = string + let compare = compare +end) +module StringMap = Map.Make (struct + type t = string + let compare = compare +end) (* Color handling *) module Color = struct (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) - type color = - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - ;; + type color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White type style = | FG of color (* foreground *) @@ -398,7 +422,6 @@ module Color = struct | Reset | Dim - let ansi_of_color = function | Black -> "0" | Red -> "1" @@ -416,26 +439,19 @@ module Color = struct | Reset -> "0" | Dim -> "2" - let ansi_of_style_l l = - let s = match l with + let s = + match l with | [] -> code_of_style Reset | [s] -> code_of_style s | _ -> String.concat ";" (List.map code_of_style l) in "\x1b[" ^ s ^ "m" - type styles = { - error: style list; - warning: style list; - loc: style list; - } + type styles = {error: style list; warning: style list; loc: style list} - let default_styles = { - warning = [Bold; FG Magenta]; - error = [Bold; FG Red]; - loc = [Bold]; - } + let default_styles = + {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} let cur_styles = ref default_styles let get_styles () = !cur_styles @@ -443,10 +459,11 @@ module Color = struct (* map a tag to a style, if the tag is known. @raise Not_found otherwise *) - let style_of_tag s = match s with - | Format.String_tag "error" -> (!cur_styles).error - | Format.String_tag "warning" -> (!cur_styles).warning - | Format.String_tag "loc" -> (!cur_styles).loc + let style_of_tag s = + match s with + | Format.String_tag "error" -> !cur_styles.error + | Format.String_tag "warning" -> !cur_styles.warning + | Format.String_tag "loc" -> !cur_styles.loc | Format.String_tag "info" -> [Bold; FG Yellow] | Format.String_tag "dim" -> [Dim] | Format.String_tag "filename" -> [FG Cyan] @@ -471,14 +488,18 @@ module Color = struct let set_color_tag_handling ppf = let open Format in let functions = pp_get_formatter_stag_functions ppf () in - let functions' = {functions with - mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); - mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); - } in - pp_set_mark_tags ppf true; (* enable tags *) + let functions' = + { + functions with + mark_open_stag = mark_open_tag ~or_else:functions.mark_open_stag; + mark_close_stag = mark_close_tag ~or_else:functions.mark_close_stag; + } + in + pp_set_mark_tags ppf true; + (* enable tags *) pp_set_formatter_stag_functions ppf functions'; (* also setup margins *) - pp_set_margin ppf (pp_get_margin std_formatter()); + pp_set_margin ppf (pp_get_margin std_formatter ()); () external isatty : out_channel -> bool = "caml_sys_isatty" @@ -486,14 +507,13 @@ module Color = struct (* reasonable heuristic on whether colors should be enabled *) let should_enable_color () = let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr + term <> "dumb" && term <> "" && isatty stderr type setting = Auto | Always | Never let setup = - let first = ref true in (* initialize only once *) + let first = ref true in + (* initialize only once *) let formatter_l = [Format.std_formatter; Format.err_formatter; Format.str_formatter] in @@ -502,42 +522,38 @@ module Color = struct first := false; Format.set_mark_tags true; List.iter set_color_tag_handling formatter_l; - color_enabled := (match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) - ); + color_enabled := + match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); () end let normalise_eol s = let b = Buffer.create 80 in - for i = 0 to String.length s - 1 do - if s.[i] <> '\r' then Buffer.add_char b s.[i] - done; - Buffer.contents b + for i = 0 to String.length s - 1 do + if s.[i] <> '\r' then Buffer.add_char b s.[i] + done; + Buffer.contents b let delete_eol_spaces src = let len_src = String.length src in let dst = Bytes.create len_src in let rec loop i_src i_dst = - if i_src = len_src then - i_dst + if i_src = len_src then i_dst else match src.[i_src] with - | ' ' | '\t' -> - loop_spaces 1 (i_src + 1) i_dst + | ' ' | '\t' -> loop_spaces 1 (i_src + 1) i_dst | c -> Bytes.set dst i_dst c; loop (i_src + 1) (i_dst + 1) and loop_spaces spaces i_src i_dst = - if i_src = len_src then - i_dst + if i_src = len_src then i_dst else match src.[i_src] with - | ' ' | '\t' -> - loop_spaces (spaces + 1) (i_src + 1) i_dst + | ' ' | '\t' -> loop_spaces (spaces + 1) (i_src + 1) i_dst | '\n' -> Bytes.set dst i_dst '\n'; loop (i_src + 1) (i_dst + 1) @@ -550,16 +566,10 @@ let delete_eol_spaces src = let stop = loop 0 0 in Bytes.sub_string dst 0 stop -type hook_info = { - sourcefile : string; -} +type hook_info = {sourcefile: string} -exception HookExnWrapper of - { - error: exn; - hook_name: string; - hook_info: hook_info; - } +exception + HookExnWrapper of {error: exn; hook_name: string; hook_info: hook_info} exception HookExn of exn diff --git a/compiler/ext/misc.mli b/compiler/ext/misc.mli index 5f9cbb05b8..8e4a1cb283 100644 --- a/compiler/ext/misc.mli +++ b/compiler/ext/misc.mli @@ -15,31 +15,36 @@ (* Miscellaneous useful types and functions *) - -val fatal_error: string -> 'a -val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a +val fatal_error : string -> 'a +val fatal_errorf : ('a, Format.formatter, unit, 'b) format4 -> 'a exception Fatal_error -val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;; - -val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list - (* [map_end f l t] is [map f l @ t], just more efficient. *) -val map_left_right: ('a -> 'b) -> 'a list -> 'b list - (* Like [List.map], with guaranteed left-to-right evaluation order *) -val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - (* Same as [List.for_all] but for a binary predicate. - In addition, this [for_all2] never fails: given two lists - with different lengths, it returns false. *) -val replicate_list: 'a -> int -> 'a list - (* [replicate_list elem n] is the list with [n] elements - all identical to [elem]. *) -val list_remove: 'a -> 'a list -> 'a list - (* [list_remove x l] returns a copy of [l] with the first - element equal to [x] removed. *) -val split_last: 'a list -> 'a list * 'a - (* Return the last element and the other elements of the given list. *) -val may: ('a -> unit) -> 'a option -> unit -val may_map: ('a -> 'b) -> 'a option -> 'b option +val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a + +val map_end : ('a -> 'b) -> 'a list -> 'b list -> 'b list +(* [map_end f l t] is [map f l @ t], just more efficient. *) + +val map_left_right : ('a -> 'b) -> 'a list -> 'b list +(* Like [List.map], with guaranteed left-to-right evaluation order *) + +val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(* Same as [List.for_all] but for a binary predicate. + In addition, this [for_all2] never fails: given two lists + with different lengths, it returns false. *) + +val replicate_list : 'a -> int -> 'a list +(* [replicate_list elem n] is the list with [n] elements + all identical to [elem]. *) + +val list_remove : 'a -> 'a list -> 'a list +(* [list_remove x l] returns a copy of [l] with the first + element equal to [x] removed. *) + +val split_last : 'a list -> 'a list * 'a +(* Return the last element and the other elements of the given list. *) + +val may : ('a -> unit) -> 'a option -> unit +val may_map : ('a -> 'b) -> 'a option -> 'b option type ref_and_value = R : 'a ref * 'a -> ref_and_value @@ -48,64 +53,75 @@ val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a while executing [f]. The previous contents of the references is restored even if [f] raises an exception. *) -val find_in_path: string list -> string -> string - (* Search a file in a list of directories. *) -val find_in_path_rel: string list -> string -> string - (* Search a relative file in a list of directories. *) -val find_in_path_uncap: string list -> string -> string - (* Same, but search also for uncapitalized name, i.e. - if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml - to match. *) -val remove_file: string -> unit - (* Delete the given file if it exists. Never raise an error. *) -val expand_directory: string -> string -> string - (* [expand_directory alt file] eventually expands a [+] at the - beginning of file into [alt] (an alternate root directory) *) - -val create_hashtable: ('a * 'b) array -> ('a, 'b) Hashtbl.t - (* Create a hashtable of the given size and fills it with the - given bindings. *) - -val copy_file: in_channel -> out_channel -> unit - (* [copy_file ic oc] reads the contents of file [ic] and copies - them to [oc]. It stops when encountering EOF on [ic]. *) -val copy_file_chunk: in_channel -> out_channel -> int -> unit - (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies - them to [oc]. It raises [End_of_file] when encountering - EOF on [ic]. *) -val string_of_file: in_channel -> string - (* [string_of_file ic] reads the contents of file [ic] and copies - them to a string. It stops when encountering EOF on [ic]. *) - -val output_to_bin_file_directly: string -> (string -> out_channel -> 'a) -> 'a - -val output_to_file_via_temporary: - ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a - (* Produce output in temporary file, then rename it - (as atomically as possible) to the desired output file name. - [output_to_file_via_temporary filename fn] opens a temporary file - which is passed to [fn] (name + output channel). When [fn] returns, - the channel is closed and the temporary file is renamed to - [filename]. *) - -val log2: int -> int - (* [log2 n] returns [s] such that [n = 1 lsl s] - if [n] is a power of 2*) -val align: int -> int -> int - (* [align n a] rounds [n] upwards to a multiple of [a] - (a power of 2). *) -val no_overflow_add: int -> int -> bool - (* [no_overflow_add n1 n2] returns [true] if the computation of - [n1 + n2] does not overflow. *) -val no_overflow_sub: int -> int -> bool - (* [no_overflow_sub n1 n2] returns [true] if the computation of - [n1 - n2] does not overflow. *) -val no_overflow_mul: int -> int -> bool - (* [no_overflow_mul n1 n2] returns [true] if the computation of - [n1 * n2] does not overflow. *) -val no_overflow_lsl: int -> int -> bool - (* [no_overflow_lsl n k] returns [true] if the computation of - [n lsl k] does not overflow. *) +val find_in_path : string list -> string -> string +(* Search a file in a list of directories. *) + +val find_in_path_rel : string list -> string -> string +(* Search a relative file in a list of directories. *) + +val find_in_path_uncap : string list -> string -> string +(* Same, but search also for uncapitalized name, i.e. + if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml + to match. *) + +val remove_file : string -> unit +(* Delete the given file if it exists. Never raise an error. *) + +val expand_directory : string -> string -> string +(* [expand_directory alt file] eventually expands a [+] at the + beginning of file into [alt] (an alternate root directory) *) + +val create_hashtable : ('a * 'b) array -> ('a, 'b) Hashtbl.t +(* Create a hashtable of the given size and fills it with the + given bindings. *) + +val copy_file : in_channel -> out_channel -> unit +(* [copy_file ic oc] reads the contents of file [ic] and copies + them to [oc]. It stops when encountering EOF on [ic]. *) + +val copy_file_chunk : in_channel -> out_channel -> int -> unit +(* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies + them to [oc]. It raises [End_of_file] when encountering + EOF on [ic]. *) + +val string_of_file : in_channel -> string +(* [string_of_file ic] reads the contents of file [ic] and copies + them to a string. It stops when encountering EOF on [ic]. *) + +val output_to_bin_file_directly : string -> (string -> out_channel -> 'a) -> 'a + +val output_to_file_via_temporary : + ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a +(* Produce output in temporary file, then rename it + (as atomically as possible) to the desired output file name. + [output_to_file_via_temporary filename fn] opens a temporary file + which is passed to [fn] (name + output channel). When [fn] returns, + the channel is closed and the temporary file is renamed to + [filename]. *) + +val log2 : int -> int +(* [log2 n] returns [s] such that [n = 1 lsl s] + if [n] is a power of 2*) + +val align : int -> int -> int +(* [align n a] rounds [n] upwards to a multiple of [a] + (a power of 2). *) + +val no_overflow_add : int -> int -> bool +(* [no_overflow_add n1 n2] returns [true] if the computation of + [n1 + n2] does not overflow. *) + +val no_overflow_sub : int -> int -> bool +(* [no_overflow_sub n1 n2] returns [true] if the computation of + [n1 - n2] does not overflow. *) + +val no_overflow_mul : int -> int -> bool +(* [no_overflow_mul n1 n2] returns [true] if the computation of + [n1 * n2] does not overflow. *) + +val no_overflow_lsl : int -> int -> bool +(* [no_overflow_lsl n k] returns [true] if the computation of + [n lsl k] does not overflow. *) module Int_literal_converter : sig val int : string -> int @@ -113,41 +129,40 @@ module Int_literal_converter : sig val int64 : string -> int64 end -val chop_extensions: string -> string - (* Return the given file name without its extensions. The extensions - is the longest suffix starting with a period and not including - a directory separator, [.xyz.uvw] for instance. +val chop_extensions : string -> string +(* Return the given file name without its extensions. The extensions + is the longest suffix starting with a period and not including + a directory separator, [.xyz.uvw] for instance. - Return the given name if it does not contain an extension. *) + Return the given name if it does not contain an extension. *) -val search_substring: string -> string -> int -> int - (* [search_substring pat str start] returns the position of the first - occurrence of string [pat] in string [str]. Search starts - at offset [start] in [str]. Raise [Not_found] if [pat] - does not occur. *) +val search_substring : string -> string -> int -> int +(* [search_substring pat str start] returns the position of the first + occurrence of string [pat] in string [str]. Search starts + at offset [start] in [str]. Raise [Not_found] if [pat] + does not occur. *) -val replace_substring: before:string -> after:string -> string -> string - (* [replace_substring ~before ~after str] replaces all - occurrences of [before] with [after] in [str] and returns - the resulting string. *) +val replace_substring : before:string -> after:string -> string -> string +(* [replace_substring ~before ~after str] replaces all + occurrences of [before] with [after] in [str] and returns + the resulting string. *) -val rev_split_words: string -> string list - (* [rev_split_words s] splits [s] in blank-separated words, and returns - the list of words in reverse order. *) +val rev_split_words : string -> string list +(* [rev_split_words s] splits [s] in blank-separated words, and returns + the list of words in reverse order. *) -val get_ref: 'a list ref -> 'a list - (* [get_ref lr] returns the content of the list reference [lr] and reset - its content to the empty list. *) +val get_ref : 'a list ref -> 'a list +(* [get_ref lr] returns the content of the list reference [lr] and reset + its content to the empty list. *) +val fst3 : 'a * 'b * 'c -> 'a +val snd3 : 'a * 'b * 'c -> 'b +val thd3 : 'a * 'b * 'c -> 'c -val fst3: 'a * 'b * 'c -> 'a -val snd3: 'a * 'b * 'c -> 'b -val thd3: 'a * 'b * 'c -> 'c - -val fst4: 'a * 'b * 'c * 'd -> 'a -val snd4: 'a * 'b * 'c * 'd -> 'b -val thd4: 'a * 'b * 'c * 'd -> 'c -val for4: 'a * 'b * 'c * 'd -> 'd +val fst4 : 'a * 'b * 'c * 'd -> 'a +val snd4 : 'a * 'b * 'c * 'd -> 'b +val thd4 : 'a * 'b * 'c * 'd -> 'c +val for4 : 'a * 'b * 'c * 'd -> 'd val edit_distance : string -> string -> int -> int option (** [edit_distance a b cutoff] computes the edit distance between @@ -191,24 +206,14 @@ val cut_at : string -> char -> string * string @since 4.01 *) - -module StringSet: Set.S with type elt = string -module StringMap: Map.S with type key = string +module StringSet : Set.S with type elt = string +module StringMap : Map.S with type key = string (* TODO: replace all custom instantiations of StringSet/StringMap in various compiler modules with this one. *) (* Color handling *) module Color : sig - type color = - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - ;; + type color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White type style = | FG of color (* foreground *) @@ -217,19 +222,14 @@ module Color : sig | Reset | Dim - val ansi_of_style_l : style list -> string (* ANSI escape sequence for the given style *) - type styles = { - error: style list; - warning: style list; - loc: style list; - } + type styles = {error: style list; warning: style list; loc: style list} - val default_styles: styles - val get_styles: unit -> styles - val set_styles: styles -> unit + val default_styles : styles + val get_styles : unit -> styles + val set_styles : styles -> unit type setting = Auto | Always | Never @@ -252,8 +252,6 @@ val delete_eol_spaces : string -> string line spaces removed. Intended to normalize the output of the toplevel for tests. *) - - (** {1 Hook machinery} Hooks machinery: @@ -262,22 +260,15 @@ val delete_eol_spaces : string -> string lexicographical order of their names. *) -type hook_info = { - sourcefile : string; -} - -exception HookExnWrapper of - { - error: exn; - hook_name: string; - hook_info: hook_info; - } - (** An exception raised by a hook will be wrapped into a - [HookExnWrapper] constructor by the hook machinery. *) +type hook_info = {sourcefile: string} +exception + HookExnWrapper of {error: exn; hook_name: string; hook_info: hook_info} +(** An exception raised by a hook will be wrapped into a + [HookExnWrapper] constructor by the hook machinery. *) -val raise_direct_hook_exn: exn -> 'a - (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will +val raise_direct_hook_exn : exn -> 'a +(** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will not be wrapped into a {!HookExnWrapper}. *) module type HookSig = sig diff --git a/compiler/ext/ordered_hash_map_gen.ml b/compiler/ext/ordered_hash_map_gen.ml index 31ad7e6d18..b85ce6e96b 100644 --- a/compiler/ext/ordered_hash_map_gen.ml +++ b/compiler/ext/ordered_hash_map_gen.ml @@ -62,19 +62,19 @@ end when buckets become too long. *) type ('a, 'b) bucket = | Empty - | Cons of { key : 'a; ord : int; data : 'b; next : ('a, 'b) bucket } + | Cons of {key: 'a; ord: int; data: 'b; next: ('a, 'b) bucket} type ('a, 'b) t = { - mutable size : int; + mutable size: int; (* number of entries *) - mutable data : ('a, 'b) bucket array; + mutable data: ('a, 'b) bucket array; (* the buckets *) - initial_size : int; (* initial array size *) + initial_size: int; (* initial array size *) } let create initial_size = let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } + {initial_size = s; size = 0; data = Array.make s Empty} let clear h = h.size <- 0; @@ -99,11 +99,11 @@ let resize indexfun h = (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () - | Cons { key; ord; data; next } -> - let nidx = indexfun h key in - Array.unsafe_set ndata nidx - (Cons { key; ord; data; next = Array.unsafe_get ndata nidx }); - insert_bucket next + | Cons {key; ord; data; next} -> + let nidx = indexfun h key in + Array.unsafe_set ndata nidx + (Cons {key; ord; data; next = Array.unsafe_get ndata nidx}); + insert_bucket next in for i = 0 to osize - 1 do insert_bucket (Array.unsafe_get odata i) @@ -112,9 +112,9 @@ let resize indexfun h = let iter h f = let rec do_bucket = function | Empty -> () - | Cons { key; ord; data; next } -> - f key data ord; - do_bucket next + | Cons {key; ord; data; next} -> + f key data ord; + do_bucket next in let d = h.data in for i = 0 to Array.length d - 1 do @@ -127,7 +127,7 @@ let choose h = else match Array.unsafe_get arr offset with | Empty -> aux arr (offset + 1) len - | Cons { key = k; _ } -> k + | Cons {key = k; _} -> k in aux h.data 0 (Array.length h.data) @@ -143,7 +143,7 @@ let fold h init f = let rec do_bucket b accu = match b with | Empty -> accu - | Cons { key; ord; data; next } -> do_bucket next (f key data ord accu) + | Cons {key; ord; data; next} -> do_bucket next (f key data ord accu) in let d = h.data in let accu = ref init in @@ -155,4 +155,6 @@ let fold h init f = let elements set = fold set [] (fun k _ _ acc -> k :: acc) let rec bucket_length acc (x : _ bucket) = - match x with Empty -> 0 | Cons rhs -> bucket_length (acc + 1) rhs.next + match x with + | Empty -> 0 + | Cons rhs -> bucket_length (acc + 1) rhs.next diff --git a/compiler/ext/ordered_hash_map_local_ident.mli b/compiler/ext/ordered_hash_map_local_ident.mli index c22d6784ae..66af1d078c 100644 --- a/compiler/ext/ordered_hash_map_local_ident.mli +++ b/compiler/ext/ordered_hash_map_local_ident.mli @@ -22,9 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - +include Ordered_hash_map_gen.S with type key = Ident.t (** Hash algorithm only hash stamp, this makes sense when all identifiers are local (no global) *) -include Ordered_hash_map_gen.S with type key = Ident.t diff --git a/compiler/ext/set_gen.ml b/compiler/ext/set_gen.ml index 34eb1e09bf..0fd5e66f41 100644 --- a/compiler/ext/set_gen.ml +++ b/compiler/ext/set_gen.ml @@ -14,18 +14,18 @@ (* balanced tree based on stdlib distribution *) -type 'a t0 = - | Empty - | Leaf of 'a - | Node of { l : 'a t0; v : 'a; r : 'a t0; h : int } +type 'a t0 = Empty | Leaf of 'a | Node of {l: 'a t0; v: 'a; r: 'a t0; h: int} -type 'a partial_node = { l : 'a t0; v : 'a; r : 'a t0; h : int } +type 'a partial_node = {l: 'a t0; v: 'a; r: 'a t0; h: int} external ( ~! ) : 'a t0 -> 'a partial_node = "%identity" let empty = Empty -let[@inline] height = function Empty -> 0 | Leaf _ -> 1 | Node { h } -> h +let[@inline] height = function + | Empty -> 0 + | Leaf _ -> 1 + | Node {h} -> h let[@inline] calc_height a b = (if a >= b then a else b) + 1 @@ -35,10 +35,10 @@ let[@inline] calc_height a b = (if a >= b then a else b) + 1 2. l and r balanced 3. [height l] - [height r] <= 2 *) -let[@inline] unsafe_node v l r h = Node { l; v; r; h } +let[@inline] unsafe_node v l r h = Node {l; v; r; h} let[@inline] unsafe_node_maybe_leaf v l r h = - if h = 1 then Leaf v else Node { l; v; r; h } + if h = 1 then Leaf v else Node {l; v; r; h} let[@inline] singleton x = Leaf x @@ -47,28 +47,33 @@ let[@inline] unsafe_two_elements x v = unsafe_node v (singleton x) empty 2 type 'a t = 'a t0 = private | Empty | Leaf of 'a - | Node of { l : 'a t0; v : 'a; r : 'a t0; h : int } + | Node of {l: 'a t0; v: 'a; r: 'a t0; h: int} (* Smallest and greatest element of a set *) let rec min_exn = function | Empty -> raise Not_found | Leaf v -> v - | Node { l; v } -> ( match l with Empty -> v | Leaf _ | Node _ -> min_exn l) + | Node {l; v} -> ( + match l with + | Empty -> v + | Leaf _ | Node _ -> min_exn l) -let[@inline] is_empty = function Empty -> true | _ -> false +let[@inline] is_empty = function + | Empty -> true + | _ -> false let rec cardinal_aux acc = function | Empty -> acc | Leaf _ -> acc + 1 - | Node { l; r } -> cardinal_aux (cardinal_aux (acc + 1) r) l + | Node {l; r} -> cardinal_aux (cardinal_aux (acc + 1) r) l let cardinal s = cardinal_aux 0 s let rec elements_aux accu = function | Empty -> accu | Leaf v -> v :: accu - | Node { l; v; r } -> elements_aux (v :: elements_aux accu r) l + | Node {l; v; r} -> elements_aux (v :: elements_aux accu r) l let elements s = elements_aux [] s @@ -78,28 +83,28 @@ let rec iter x f = match x with | Empty -> () | Leaf v -> f v - | Node { l; v; r } -> - iter l f; - f v; - iter r f + | Node {l; v; r} -> + iter l f; + f v; + iter r f let rec fold s accu f = match s with | Empty -> accu | Leaf v -> f v accu - | Node { l; v; r } -> fold r (f v (fold l accu f)) f + | Node {l; v; r} -> fold r (f v (fold l accu f)) f let rec for_all x p = match x with | Empty -> true | Leaf v -> p v - | Node { l; v; r } -> p v && for_all l p && for_all r p + | Node {l; v; r} -> p v && for_all l p && for_all r p let rec exists x p = match x with | Empty -> false | Leaf v -> p v - | Node { l; v; r } -> p v || exists l p || exists r p + | Node {l; v; r} -> p v || exists l p || exists r p exception Height_invariant_broken @@ -108,13 +113,13 @@ exception Height_diff_borken let rec check_height_and_diff = function | Empty -> 0 | Leaf _ -> 1 - | Node { l; r; h } -> - let hl = check_height_and_diff l in - let hr = check_height_and_diff r in - if h <> calc_height hl hr then raise Height_invariant_broken - else - let diff = abs (hl - hr) in - if diff > 2 then raise Height_diff_borken else h + | Node {l; r; h} -> + let hl = check_height_and_diff l in + let hr = check_height_and_diff r in + if h <> calc_height hl hr then raise Height_invariant_broken + else + let diff = abs (hl - hr) in + if diff > 2 then raise Height_diff_borken else h let check tree = ignore (check_height_and_diff tree) @@ -132,7 +137,7 @@ let bal l v r : _ t = let hl = height l in let hr = height r in if hl > hr + 2 then - let { l = ll; r = lr; v = lv; h = _ } = ~!l in + let {l = ll; r = lr; v = lv; h = _} = ~!l in let hll = height ll in let hlr = height lr in if hll >= hlr then @@ -141,7 +146,7 @@ let bal l v r : _ t = (unsafe_node_maybe_leaf v lr r hnode) (calc_height hll hnode) else - let { l = lrl; r = lrr; v = lrv } = ~!lr in + let {l = lrl; r = lrr; v = lrv} = ~!lr in let hlrl = height lrl in let hlrr = height lrr in let hlnode = calc_height hll hlrl in @@ -151,7 +156,7 @@ let bal l v r : _ t = (unsafe_node_maybe_leaf v lrr r hrnode) (calc_height hlnode hrnode) else if hr > hl + 2 then - let { l = rl; r = rr; v = rv } = ~!r in + let {l = rl; r = rr; v = rv} = ~!r in let hrr = height rr in let hrl = height rl in if hrr >= hrl then @@ -160,7 +165,7 @@ let bal l v r : _ t = (unsafe_node_maybe_leaf v l rl hnode) rr (calc_height hnode hrr) else - let { l = rll; r = rlr; v = rlv } = ~!rl in + let {l = rll; r = rlr; v = rlv} = ~!rl in let hrll = height rll in let hrlr = height rlr in let hlnode = calc_height hl hrll in @@ -174,8 +179,8 @@ let bal l v r : _ t = let rec remove_min_elt = function | Empty -> invalid_arg "Set.remove_min_elt" | Leaf _ -> empty - | Node { l = Empty; r } -> r - | Node { l; v; r } -> bal (remove_min_elt l) v r + | Node {l = Empty; r} -> r + | Node {l; v; r} -> bal (remove_min_elt l) v r (* All elements of l must precede the elements of r. @@ -219,21 +224,21 @@ let rec internal_join l v r = match (l, r) with | Empty, _ -> add_min v r | _, Empty -> add_max v l - | Leaf lv, Node { h = rh } -> - if rh > 3 then add_min lv (add_min v r) (* FIXME: could inlined *) - else unsafe_node v l r (rh + 1) + | Leaf lv, Node {h = rh} -> + if rh > 3 then add_min lv (add_min v r) (* FIXME: could inlined *) + else unsafe_node v l r (rh + 1) | Leaf _, Leaf _ -> unsafe_node v l r 2 - | Node { h = lh }, Leaf rv -> - if lh > 3 then add_max rv (add_max v l) else unsafe_node v l r (lh + 1) - | ( Node { l = ll; v = lv; r = lr; h = lh }, - Node { l = rl; v = rv; r = rr; h = rh } ) -> - if lh > rh + 2 then - (* proof by induction: - now [height of ll] is [lh - 1] - *) - bal ll lv (internal_join lr v r) - else if rh > lh + 2 then bal (internal_join l v rl) rv rr - else unsafe_node v l r (calc_height lh rh) + | Node {h = lh}, Leaf rv -> + if lh > 3 then add_max rv (add_max v l) else unsafe_node v l r (lh + 1) + | Node {l = ll; v = lv; r = lr; h = lh}, Node {l = rl; v = rv; r = rr; h = rh} + -> + if lh > rh + 2 then + (* proof by induction: + now [height of ll] is [lh - 1] + *) + bal ll lv (internal_join lr v r) + else if rh > lh + 2 then bal (internal_join l v rl) rv rr + else unsafe_node v l r (calc_height lh rh) (* Required Invariants: @@ -249,15 +254,15 @@ let rec partition x p = match x with | Empty -> (empty, empty) | Leaf v -> - let pv = p v in - if pv then (x, empty) else (empty, x) - | Node { l; v; r } -> - (* call [p] in the expected left-to-right order *) - let lt, lf = partition l p in - let pv = p v in - let rt, rf = partition r p in - if pv then (internal_join lt v rt, internal_concat lf rf) - else (internal_concat lt rt, internal_join lf v rf) + let pv = p v in + if pv then (x, empty) else (empty, x) + | Node {l; v; r} -> + (* call [p] in the expected left-to-right order *) + let lt, lf = partition l p in + let pv = p v in + let rt, rf = partition r p in + if pv then (internal_join lt v rt, internal_concat lf rf) + else (internal_concat lt rt, internal_join lf v rf) let of_sorted_array l = let rec sub start n l = @@ -289,20 +294,20 @@ let is_ordered ~cmp tree = match tree with | Empty -> `Empty | Leaf v -> `V (v, v) - | Node { l; v; r } -> ( - match is_ordered_min_max l with + | Node {l; v; r} -> ( + match is_ordered_min_max l with + | `No -> `No + | `Empty -> ( + match is_ordered_min_max r with + | `No -> `No + | `Empty -> `V (v, v) + | `V (l, r) -> if cmp v l < 0 then `V (v, r) else `No) + | `V (min_v, max_v) -> ( + match is_ordered_min_max r with | `No -> `No - | `Empty -> ( - match is_ordered_min_max r with - | `No -> `No - | `Empty -> `V (v, v) - | `V (l, r) -> if cmp v l < 0 then `V (v, r) else `No) - | `V (min_v, max_v) -> ( - match is_ordered_min_max r with - | `No -> `No - | `Empty -> if cmp max_v v < 0 then `V (min_v, v) else `No - | `V (min_v_r, max_v_r) -> - if cmp max_v min_v_r < 0 then `V (min_v, max_v_r) else `No)) + | `Empty -> if cmp max_v v < 0 then `V (min_v, v) else `No + | `V (min_v_r, max_v_r) -> + if cmp max_v min_v_r < 0 then `V (min_v, max_v_r) else `No)) in is_ordered_min_max tree <> `No diff --git a/compiler/ext/set_gen.mli b/compiler/ext/set_gen.mli index 0dac4f5955..f3f39f0191 100644 --- a/compiler/ext/set_gen.mli +++ b/compiler/ext/set_gen.mli @@ -1,7 +1,7 @@ type 'a t = private | Empty | Leaf of 'a - | Node of { l : 'a t; v : 'a; r : 'a t; h : int } + | Node of {l: 'a t; v: 'a; r: 'a t; h: int} val empty : 'a t diff --git a/compiler/ext/set_ident.mli b/compiler/ext/set_ident.mli index 2209243e5c..49638c9f46 100644 --- a/compiler/ext/set_ident.mli +++ b/compiler/ext/set_ident.mli @@ -22,9 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - include Set_gen.S with type elt = Ident.t - - - - diff --git a/compiler/ext/union_find.ml b/compiler/ext/union_find.ml index a06b49c31d..bba7846207 100644 --- a/compiler/ext/union_find.ml +++ b/compiler/ext/union_find.ml @@ -22,14 +22,14 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t = { id : int array; sz : int array; mutable components : int } +type t = {id: int array; sz: int array; mutable components: int} let init n = let id = Array.make n 0 in for i = 0 to n - 1 do Array.unsafe_set id i i done; - { id; sz = Array.make n 1; components = n } + {id; sz = Array.make n 1; components = n} let rec find_aux id_store p = let parent = Array.unsafe_get id_store p in diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml index 709ec651af..3b0c18a389 100644 --- a/compiler/ext/warnings.ml +++ b/compiler/ext/warnings.ml @@ -21,9 +21,9 @@ *) type loc = { - loc_start : Lexing.position; - loc_end : Lexing.position; - loc_ghost : bool; + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; } type top_level_unit_help = FunctionCall | Other @@ -85,7 +85,8 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) - | Bs_toplevel_expression_unit of (string * top_level_unit_help) option (* 109 *) + | Bs_toplevel_expression_unit of + (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -165,33 +166,33 @@ let letter_all = let letter = function | 'a' -> letter_all | 'b' -> [] - | 'c' -> [ 1; 2 ] - | 'd' -> [ 3 ] - | 'e' -> [ 4 ] - | 'f' -> [ 5 ] + | 'c' -> [1; 2] + | 'd' -> [3] + | 'e' -> [4] + | 'f' -> [5] | 'g' -> [] | 'h' -> [] | 'i' -> [] | 'j' -> [] - | 'k' -> [ 32; 33; 34; 35; 36; 37; 38; 39 ] - | 'l' -> [ 6 ] - | 'm' -> [ 7 ] + | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] + | 'l' -> [6] + | 'm' -> [7] | 'n' -> [] | 'o' -> [] - | 'p' -> [ 8 ] + | 'p' -> [8] | 'q' -> [] - | 'r' -> [ 9 ] - | 's' -> [ 10 ] + | 'r' -> [9] + | 's' -> [10] | 't' -> [] - | 'u' -> [ 11; 12 ] - | 'v' -> [ 13 ] + | 'u' -> [11; 12] + | 'v' -> [13] | 'w' -> [] - | 'x' -> [ 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30 ] - | 'y' -> [ 26 ] - | 'z' -> [ 27 ] + | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30] + | 'y' -> [26] + | 'z' -> [27] | _ -> assert false -type state = { active : bool array; error : bool array } +type state = {active: bool array; error: bool array} let current = ref @@ -202,7 +203,7 @@ let current = let disabled = ref false -let without_warnings f = Misc.protect_refs [ Misc.R (disabled, true) ] f +let without_warnings f = Misc.protect_refs [Misc.R (disabled, true)] f let backup () = !current @@ -238,7 +239,7 @@ let parse_opt error active flags s = else match s.[i] with | '0' .. '9' -> - get_num ((10 * n) + Char.code s.[i] - Char.code '0') (i + 1) + get_num ((10 * n) + Char.code s.[i] - Char.code '0') (i + 1) | _ -> (i, n) in let get_range i = @@ -254,11 +255,11 @@ let parse_opt error active flags s = else match s.[i] with | 'A' .. 'Z' -> - List.iter set (letter (Char.lowercase_ascii s.[i])); - loop (i + 1) + List.iter set (letter (Char.lowercase_ascii s.[i])); + loop (i + 1) | 'a' .. 'z' -> - List.iter clear (letter s.[i]); - loop (i + 1) + List.iter clear (letter s.[i]); + loop (i + 1) | '+' -> loop_letter_num set (i + 1) | '-' -> loop_letter_num clear (i + 1) | '@' -> loop_letter_num set_all (i + 1) @@ -268,17 +269,17 @@ let parse_opt error active flags s = else match s.[i] with | '0' .. '9' -> - let i, n1, n2 = get_range i in - for n = n1 to Ext_pervasives.min_int n2 last_warning_number do - myset n - done; - loop i + let i, n1, n2 = get_range i in + for n = n1 to Ext_pervasives.min_int n2 last_warning_number do + myset n + done; + loop i | 'A' .. 'Z' -> - List.iter myset (letter (Char.lowercase_ascii s.[i])); - loop (i + 1) + List.iter myset (letter (Char.lowercase_ascii s.[i])); + loop (i + 1) | 'a' .. 'z' -> - List.iter myset (letter s.[i]); - loop (i + 1) + List.iter myset (letter s.[i]); + loop (i + 1) | _ -> error () in loop 0 @@ -287,7 +288,7 @@ let parse_options errflag s = let error = Array.copy !current.error in let active = Array.copy !current.active in parse_opt error active (if errflag then error else active) s; - current := { error; active } + current := {error; active} let reset () = parse_options false Bsc_warnings.defaults_w; @@ -299,223 +300,239 @@ let message = function | Comment_start -> "this is the start of a comment." | Comment_not_end -> "this is not the end of a comment." | Deprecated (s, _, _) -> - (* Reduce \r\n to \n: - - Prevents any \r characters being printed on Unix when processing - Windows sources - - Prevents \r\r\n being generated on Windows, which affects the - testsuite - *) - "deprecated: " ^ Misc.normalise_eol s + (* Reduce \r\n to \n: + - Prevents any \r characters being printed on Unix when processing + Windows sources + - Prevents \r\r\n being generated on Windows, which affects the + testsuite + *) + "deprecated: " ^ Misc.normalise_eol s | Fragile_match "" -> "this pattern-matching is fragile." | Fragile_match s -> - "this pattern-matching is fragile.\n\ - It will remain exhaustive when constructors are added to type " ^ s ^ "." + "this pattern-matching is fragile.\n\ + It will remain exhaustive when constructors are added to type " ^ s ^ "." | Partial_application -> - "this function application is partial,\nmaybe some arguments are missing." - | Method_override [ lab ] -> "the method " ^ lab ^ " is overridden." + "this function application is partial,\nmaybe some arguments are missing." + | Method_override [lab] -> "the method " ^ lab ^ " is overridden." | Method_override (cname :: slist) -> - String.concat " " - ("the following methods are overridden by the class" :: cname :: ":\n " - :: slist) + String.concat " " + ("the following methods are overridden by the class" :: cname :: ":\n " + :: slist) | Method_override [] -> assert false | Partial_match "" -> - "You forgot to handle a possible case here, though we don't have more \ - information on the value." + "You forgot to handle a possible case here, though we don't have more \ + information on the value." | Partial_match s -> - "You forgot to handle a possible case here, for example: \n " ^ s + "You forgot to handle a possible case here, for example: \n " ^ s | Non_closed_record_pattern s -> - "the following labels are not bound in this record pattern: " ^ s - ^ "\nEither bind these labels explicitly or add ', _' to the pattern." + "the following labels are not bound in this record pattern: " ^ s + ^ "\nEither bind these labels explicitly or add ', _' to the pattern." | Statement_type -> - "This expression returns a value, but you're not doing anything with it. \ - If this is on purpose, wrap it with `ignore`." + "This expression returns a value, but you're not doing anything with it. \ + If this is on purpose, wrap it with `ignore`." | Unused_match -> "this match case is unused." | Unused_pat -> "this sub-pattern is unused." - | Instance_variable_override [ lab ] -> - "the instance variable " ^ lab ^ " is overridden.\n" - ^ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + | Instance_variable_override [lab] -> + "the instance variable " ^ lab ^ " is overridden.\n" + ^ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" | Instance_variable_override (cname :: slist) -> - String.concat " " - ("the following instance variables are overridden by the class" :: cname - :: ":\n " :: slist) - ^ "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + String.concat " " + ("the following instance variables are overridden by the class" :: cname + :: ":\n " :: slist) + ^ "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" | Instance_variable_override [] -> assert false | Illegal_backslash -> "illegal backslash escape in string." | Implicit_public_methods l -> - "the following private methods were made public implicitly:\n " - ^ String.concat " " l ^ "." + "the following private methods were made public implicitly:\n " + ^ String.concat " " l ^ "." | Unerasable_optional_argument -> - String.concat "" - [ - "This optional parameter in final position will, in practice, not be \ - optional.\n"; - " Reorder the parameters so that at least one non-optional one is \ - in final position or, if all parameters are optional, insert a \ - final ().\n\n"; - " Explanation: If the final parameter is optional, it'd be unclear \ - whether a function application that omits it should be considered \ - fully applied, or partially applied. Imagine writing `let title = \ - display(\"hello!\")`, only to realize `title` isn't your desired \ - result, but a curried call that takes a final optional argument, \ - e.g. `~showDate`.\n\n"; - " Formal rule: an optional argument is considered intentionally \ - omitted when the 1st positional (i.e. neither labeled nor optional) \ - argument defined after it is passed in."; - ] + String.concat "" + [ + "This optional parameter in final position will, in practice, not be \ + optional.\n"; + " Reorder the parameters so that at least one non-optional one is in \ + final position or, if all parameters are optional, insert a final \ + ().\n\n"; + " Explanation: If the final parameter is optional, it'd be unclear \ + whether a function application that omits it should be considered \ + fully applied, or partially applied. Imagine writing `let title = \ + display(\"hello!\")`, only to realize `title` isn't your desired \ + result, but a curried call that takes a final optional argument, e.g. \ + `~showDate`.\n\n"; + " Formal rule: an optional argument is considered intentionally \ + omitted when the 1st positional (i.e. neither labeled nor optional) \ + argument defined after it is passed in."; + ] | Unused_argument -> "this argument will not be used by the function." | Nonreturning_statement -> - "this statement never returns (or has an unsound type.)" + "this statement never returns (or has an unsound type.)" | Preprocessor s -> s - | Useless_record_with -> ( - "All the fields are already explicitly listed in this record. You \ - can remove the `...` spread.") + | Useless_record_with -> + "All the fields are already explicitly listed in this record. You can \ + remove the `...` spread." | Bad_module_name modname -> - "This file's name is potentially invalid. The build systems \ - conventionally turn a file name into a module name by upper-casing the \ - first letter. " ^ modname ^ " isn't a valid module name.\n" - ^ "Note: some build systems might e.g. turn kebab-case into CamelCase \ - module, which is why this isn't a hard error." + "This file's name is potentially invalid. The build systems conventionally \ + turn a file name into a module name by upper-casing the first letter. " + ^ modname ^ " isn't a valid module name.\n" + ^ "Note: some build systems might e.g. turn kebab-case into CamelCase \ + module, which is why this isn't a hard error." | All_clauses_guarded -> - "this pattern-matching is not exhaustive.\n\ - All clauses in this pattern-matching are guarded." - | Unused_var v | Unused_var_strict v -> - Format.sprintf "unused variable %s.\n\nFix this by:\n- Deleting the variable if it's not used anymore.\n- Prepending the variable name with `_` (like `_%s`) to ignore that the variable is unused.\n- Using the variable somewhere." v v + "this pattern-matching is not exhaustive.\n\ + All clauses in this pattern-matching are guarded." + | Unused_var v | Unused_var_strict v -> + Format.sprintf + "unused variable %s.\n\n\ + Fix this by:\n\ + - Deleting the variable if it's not used anymore.\n\ + - Prepending the variable name with `_` (like `_%s`) to ignore that the \ + variable is unused.\n\ + - Using the variable somewhere." v v | Wildcard_arg_to_constant_constr -> - "wildcard pattern given as argument to a constant constructor" + "wildcard pattern given as argument to a constant constructor" | Eol_in_string -> - "unescaped end-of-line in a string constant (non-portable code)" + "unescaped end-of-line in a string constant (non-portable code)" | Duplicate_definitions (kind, cname, tc1, tc2) -> - Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname - tc1 tc2 + Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname + tc1 tc2 | Unused_value_declaration v -> "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." | Unused_type_declaration s -> "unused type " ^ s ^ "." | Unused_for_index s -> "unused for-loop index " ^ s ^ "." | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." | Unused_constructor (s, true, _) -> - "constructor " ^ s + "constructor " ^ s + ^ " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | Unused_constructor (s, false, true) -> + "constructor " ^ s + ^ " is never used to build values.\nIts type is exported as a private type." + | Unused_extension (s, is_exception, cu_pattern, cu_privatize) -> ( + let kind = if is_exception then "exception" else "extension constructor" in + let name = kind ^ " " ^ s in + match (cu_pattern, cu_privatize) with + | false, false -> "unused " ^ name + | true, _ -> + name ^ " is never used to build values.\n\ (However, this constructor appears in patterns.)" - | Unused_constructor (s, false, true) -> - "constructor " ^ s + | false, true -> + name ^ " is never used to build values.\n\ - Its type is exported as a private type." - | Unused_extension (s, is_exception, cu_pattern, cu_privatize) -> ( - let kind = - if is_exception then "exception" else "extension constructor" - in - let name = kind ^ " " ^ s in - match (cu_pattern, cu_privatize) with - | false, false -> "unused " ^ name - | true, _ -> - name - ^ " is never used to build values.\n\ - (However, this constructor appears in patterns.)" - | false, true -> - name - ^ " is never used to build values.\n\ - It is exported or rebound as a private extension.") + It is exported or rebound as a private extension.") | Unused_rec_flag -> "unused rec flag." - | Ambiguous_name ([ s ], tl, false) -> - s ^ " belongs to several types: " ^ String.concat " " tl - ^ "\nThe first one was selected. Please disambiguate if this is wrong." + | Ambiguous_name ([s], tl, false) -> + s ^ " belongs to several types: " ^ String.concat " " tl + ^ "\nThe first one was selected. Please disambiguate if this is wrong." | Ambiguous_name (_, _, false) -> assert false | Ambiguous_name (_slist, tl, true) -> - "these field labels belong to several types: " ^ String.concat " " tl - ^ "\nThe first one was selected. Please disambiguate if this is wrong." + "these field labels belong to several types: " ^ String.concat " " tl + ^ "\nThe first one was selected. Please disambiguate if this is wrong." | Nonoptional_label s -> "the label " ^ s ^ " is not optional." | Open_shadow_identifier (kind, s) -> - Printf.sprintf - "this open statement shadows the %s identifier %s (which is later used)" - kind s + Printf.sprintf + "this open statement shadows the %s identifier %s (which is later used)" + kind s | Open_shadow_label_constructor (kind, s) -> - Printf.sprintf - "this open statement shadows the %s %s (which is later used)" kind s + Printf.sprintf "this open statement shadows the %s %s (which is later used)" + kind s | Attribute_payload (a, s) -> - Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s + Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s | Eliminated_optional_arguments sl -> - Printf.sprintf "implicit elimination of optional argument%s %s" - (if List.length sl = 1 then "" else "s") - (String.concat ", " sl) + Printf.sprintf "implicit elimination of optional argument%s %s" + (if List.length sl = 1 then "" else "s") + (String.concat ", " sl) | No_cmi_file (name, None) -> - "no cmi file was found in path for module " ^ name + "no cmi file was found in path for module " ^ name | No_cmi_file (name, Some msg) -> - Printf.sprintf "no valid cmi file was found in path for module %s. %s" - name msg + Printf.sprintf "no valid cmi file was found in path for module %s. %s" name + msg | Bad_docstring unattached -> - if unattached then "unattached documentation comment (ignored)" - else "ambiguous documentation comment" + if unattached then "unattached documentation comment (ignored)" + else "ambiguous documentation comment" | Fragile_literal_pattern -> - Printf.sprintf - "Code should not depend on the actual values of\n\ - this constructor's arguments. They are only for information\n\ - and may change in future versions. (See manual section 8.5)" + Printf.sprintf + "Code should not depend on the actual values of\n\ + this constructor's arguments. They are only for information\n\ + and may change in future versions. (See manual section 8.5)" | Unreachable_case -> - "this match case is unreachable.\n\ - Consider replacing it with a refutation case ' -> .'" + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" | Misplaced_attribute attr_name -> - Printf.sprintf "the %S attribute cannot appear in this context" attr_name + Printf.sprintf "the %S attribute cannot appear in this context" attr_name | Duplicated_attribute attr_name -> - Printf.sprintf - "the %S attribute is used more than once on this expression" attr_name + Printf.sprintf "the %S attribute is used more than once on this expression" + attr_name | Ambiguous_pattern vars -> - let msg = - let vars = List.sort String.compare vars in - match vars with - | [] -> assert false - | [ x ] -> "variable " ^ x - | _ :: _ -> "variables " ^ String.concat "," vars - in - Printf.sprintf - "Ambiguous or-pattern variables under guard;\n\ - %s may match different arguments. (See manual section 8.5)" msg + let msg = + let vars = List.sort String.compare vars in + match vars with + | [] -> assert false + | [x] -> "variable " ^ x + | _ :: _ -> "variables " ^ String.concat "," vars + in + Printf.sprintf + "Ambiguous or-pattern variables under guard;\n\ + %s may match different arguments. (See manual section 8.5)" msg | Unused_module s -> "unused module " ^ s ^ "." | Constraint_on_gadt -> - "Type constraints do not apply to GADT cases of variant types." + "Type constraints do not apply to GADT cases of variant types." | Bs_unused_attribute s -> - "Unused attribute: @" ^ s - ^ "\n\ - This attribute has no effect here.\n\ - For example, some attributes are only meaningful in externals.\n" + "Unused attribute: @" ^ s + ^ "\n\ + This attribute has no effect here.\n\ + For example, some attributes are only meaningful in externals.\n" | Bs_polymorphic_comparison -> - "Polymorphic comparison introduced (maybe unsafe)" + "Polymorphic comparison introduced (maybe unsafe)" | Bs_ffi_warning s -> "FFI warning: " ^ s | Bs_derive_warning s -> "@deriving warning: " ^ s | Bs_fragile_external s -> - s - ^ " : using an empty string as a shorthand to infer the external's name \ - from the value's name is dangerous when refactoring, and therefore \ - deprecated" + s + ^ " : using an empty string as a shorthand to infer the external's name \ + from the value's name is dangerous when refactoring, and therefore \ + deprecated" | Bs_unimplemented_primitive s -> "Unimplemented primitive used: " ^ s | Bs_integer_literal_overflow -> - "Integer literal exceeds the range of representable integers of type int" + "Integer literal exceeds the range of representable integers of type int" | Bs_uninterpreted_delimiters s -> "Uninterpreted delimiters " ^ s | Bs_toplevel_expression_unit help -> - Printf.sprintf "This%sis at the top level and is expected to return `unit`. But it's returning %s.\n\n In ReScript, anything at the top level must evaluate to `unit`. You can fix this by assigning the expression to a value, or piping it into the `ignore` function.%s" - (match help with - | Some (_, FunctionCall) -> " function call " - | _ -> " ") - - (match help with - | Some (return_type, _) -> Printf.sprintf "`%s`" return_type - | None -> "something that is not `unit`") - - (match help with - | Some (_, help_typ) -> - let help_text = (match help_typ with - | FunctionCall -> "yourFunctionCall()" - | Other -> "yourExpression") in - Printf.sprintf "\n\n Possible solutions:\n - Assigning to a value that is then ignored: `let _ = %s`\n - Piping into the built-in ignore function to ignore the result: `%s->ignore`" help_text help_text - | _ -> "") - | Bs_todo maybe_text -> ( - match maybe_text with - | None -> "Todo found." - | Some todo -> "Todo found: " ^ todo - ) ^ "\n\n This code is not implemented yet and will crash at runtime. Make sure you implement this before running the code." + Printf.sprintf + "This%sis at the top level and is expected to return `unit`. But it's \ + returning %s.\n\n\ + \ In ReScript, anything at the top level must evaluate to `unit`. You \ + can fix this by assigning the expression to a value, or piping it into \ + the `ignore` function.%s" + (match help with + | Some (_, FunctionCall) -> " function call " + | _ -> " ") + (match help with + | Some (return_type, _) -> Printf.sprintf "`%s`" return_type + | None -> "something that is not `unit`") + (match help with + | Some (_, help_typ) -> + let help_text = + match help_typ with + | FunctionCall -> "yourFunctionCall()" + | Other -> "yourExpression" + in + Printf.sprintf + "\n\n\ + \ Possible solutions:\n\ + \ - Assigning to a value that is then ignored: `let _ = %s`\n\ + \ - Piping into the built-in ignore function to ignore the result: \ + `%s->ignore`" + help_text help_text + | _ -> "") + | Bs_todo maybe_text -> + (match maybe_text with + | None -> "Todo found." + | Some todo -> "Todo found: " ^ todo) + ^ "\n\n\ + \ This code is not implemented yet and will crash at runtime. Make sure \ + you implement this before running the code." let sub_locs = function | Deprecated (_, def, use) -> - [ (def, "Definition"); (use, "Expected signature") ] + [(def, "Definition"); (use, "Expected signature")] | _ -> [] let has_warnings = ref false @@ -523,25 +540,25 @@ let has_warnings = ref false let nerrors = ref 0 type reporting_information = { - number : int; - message : string; - is_error : bool; - sub_locs : (loc * string) list; + number: int; + message: string; + is_error: bool; + sub_locs: (loc * string) list; } let report w = match is_active w with | false -> `Inactive | true -> - has_warnings := true; - if is_error w then incr nerrors; - `Active - { - number = number w; - message = message w; - is_error = is_error w; - sub_locs = sub_locs w; - } + has_warnings := true; + if is_error w then incr nerrors; + `Active + { + number = number w; + message = message w; + is_error = is_error w; + sub_locs = sub_locs w; + } exception Errors @@ -653,10 +670,10 @@ let help_warnings () = let c = Char.chr i in match letter c with | [] -> () - | [ n ] -> - Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n + | [n] -> + Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n | l -> - Printf.printf " %c warnings %s.\n" (Char.uppercase_ascii c) - (String.concat ", " (List.map string_of_int l)) + Printf.printf " %c warnings %s.\n" (Char.uppercase_ascii c) + (String.concat ", " (List.map string_of_int l)) done; exit 0 diff --git a/compiler/ext/warnings.mli b/compiler/ext/warnings.mli index e72f4f980c..4b96f0f427 100644 --- a/compiler/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -14,9 +14,9 @@ (**************************************************************************) type loc = { - loc_start : Lexing.position; - loc_end : Lexing.position; - loc_ghost : bool; + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; } type top_level_unit_help = FunctionCall | Other @@ -78,7 +78,8 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) - | Bs_toplevel_expression_unit of (string * top_level_unit_help) option (* 109 *) + | Bs_toplevel_expression_unit of + (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) val parse_options : bool -> string -> unit @@ -90,13 +91,13 @@ val is_active : t -> bool val is_error : t -> bool type reporting_information = { - number : int; - message : string; - is_error : bool; - sub_locs : (loc * string) list; + number: int; + message: string; + is_error: bool; + sub_locs: (loc * string) list; } -val report : t -> [ `Active of reporting_information | `Inactive ] +val report : t -> [`Active of reporting_information | `Inactive] exception Errors diff --git a/compiler/js_parser/.ocamlformat b/compiler/js_parser/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/js_parser/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/jsoo/.ocamlformat b/compiler/jsoo/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/jsoo/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index ea972a0b29..dd7ffd1f00 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -22,7 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - (* * The API version is giving information about the feature set * of the resulting ReScript JS bundle API. @@ -55,18 +54,18 @@ let api_version = "5" module Js = Js_of_ocaml.Js -let export (field : string) v = - Js.Unsafe.set (Js.Unsafe.global) field v -;; +let export (field : string) v = Js.Unsafe.set Js.Unsafe.global field v module Lang = struct type t = Res - let from_string t = match t with + let from_string t = + match t with | "res" -> Some Res | _ -> None - let to_string t = match t with + let to_string t = + match t with | Res -> "res" end @@ -78,20 +77,21 @@ module BundleConfig = struct mutable open_modules: string list; } - let make () = { - module_system=Ext_module_system.Commonjs; - filename=None; - warn_flags=Bsc_warnings.defaults_w; - open_modules=[]; - } - + let make () = + { + module_system = Ext_module_system.Commonjs; + filename = None; + warn_flags = Bsc_warnings.defaults_w; + open_modules = []; + } - let default_filename (lang: Lang.t) = "playground." ^ (Lang.to_string lang) + let default_filename (lang : Lang.t) = "playground." ^ Lang.to_string lang - let string_of_module_system m = (match m with + let string_of_module_system m = + match m with | Ext_module_system.Commonjs -> "nodejs" | Esmodule -> "es6" - | Es6_global -> "es6_global") + | Es6_global -> "es6_global" end type loc_err_info = { @@ -110,86 +110,98 @@ module LocWarnInfo = struct } end - exception RescriptParsingErrors of loc_err_info list module ErrorRet = struct - let loc_error_attributes ~(type_: string) ~(full_msg: string) ~(short_msg: string) (loc: Location.t) = - let (_file,line,startchar) = Location.get_pos_info loc.Location.loc_start in - let (_file,endline,endchar) = Location.get_pos_info loc.Location.loc_end in - Js.Unsafe.([| - "fullMsg", inject @@ Js.string full_msg; - "row" , inject line; - "column" , inject startchar; - "endRow" , inject endline; - "endColumn" , inject endchar; - "shortMsg" , inject @@ Js.string short_msg; - "type" , inject @@ Js.string type_; - |]) - - let make_warning (e: LocWarnInfo.t) = - let loc_attrs = loc_error_attributes - ~type_:"warning" - ~full_msg: e.full_msg - ~short_msg: e.short_msg - e.loc in - let warn_attrs = Js.Unsafe.([| - "warnNumber", inject @@ (e.warn_number |> float_of_int |> Js.number_of_float); - "isError", inject @@ Js.bool e.is_error; - |]) in + let loc_error_attributes ~(type_ : string) ~(full_msg : string) + ~(short_msg : string) (loc : Location.t) = + let _file, line, startchar = Location.get_pos_info loc.Location.loc_start in + let _file, endline, endchar = Location.get_pos_info loc.Location.loc_end in + Js.Unsafe. + [| + ("fullMsg", inject @@ Js.string full_msg); + ("row", inject line); + ("column", inject startchar); + ("endRow", inject endline); + ("endColumn", inject endchar); + ("shortMsg", inject @@ Js.string short_msg); + ("type", inject @@ Js.string type_); + |] + + let make_warning (e : LocWarnInfo.t) = + let loc_attrs = + loc_error_attributes ~type_:"warning" ~full_msg:e.full_msg + ~short_msg:e.short_msg e.loc + in + let warn_attrs = + Js.Unsafe. + [| + ( "warnNumber", + inject @@ (e.warn_number |> float_of_int |> Js.number_of_float) ); + ("isError", inject @@ Js.bool e.is_error); + |] + in let attrs = Array.append loc_attrs warn_attrs in Js.Unsafe.obj attrs - let from_loc_errors ?(warnings: LocWarnInfo.t array option) ~(type_: string) (errors: loc_err_info array) = - let js_errors = Array.map - (fun (e: loc_err_info) -> - Js.Unsafe.(obj - (loc_error_attributes - ~type_ - ~full_msg: e.full_msg - ~short_msg: e.short_msg - e.loc))) errors + let from_loc_errors ?(warnings : LocWarnInfo.t array option) ~(type_ : string) + (errors : loc_err_info array) = + let js_errors = + Array.map + (fun (e : loc_err_info) -> + Js.Unsafe.( + obj + (loc_error_attributes ~type_ ~full_msg:e.full_msg + ~short_msg:e.short_msg e.loc))) + errors in - let loc_err_attrs = Js.Unsafe.([| - "errors" , inject @@ Js.array js_errors; - "type" , inject @@ Js.string type_ - |]) + let loc_err_attrs = + Js.Unsafe. + [| + ("errors", inject @@ Js.array js_errors); + ("type", inject @@ Js.string type_); + |] in - let warning_attr = match warnings with - | Some warnings -> Js.Unsafe.([| - "warnings", - inject @@ Js.array (Array.map make_warning warnings) - |]) + let warning_attr = + match warnings with + | Some warnings -> + Js.Unsafe. + [|("warnings", inject @@ Js.array (Array.map make_warning warnings))|] | None -> [||] in let attrs = Array.append loc_err_attrs warning_attr in Js.Unsafe.(obj attrs) - let from_syntax_errors (errors: loc_err_info array) = + let from_syntax_errors (errors : loc_err_info array) = from_loc_errors ~type_:"syntax_error" errors (* for raised errors caused by malformed warning / warning_error flags *) - let make_warning_flag_error ~(warn_flags: string) (msg: string) = - Js.Unsafe.(obj [| - "msg" , inject @@ Js.string msg; - "warn_flags", inject @@ Js.string warn_flags; - "type" , inject @@ Js.string "warning_flag_error" - |]) - - let make_warning_error (errors: LocWarnInfo.t array) = + let make_warning_flag_error ~(warn_flags : string) (msg : string) = + Js.Unsafe.( + obj + [| + ("msg", inject @@ Js.string msg); + ("warn_flags", inject @@ Js.string warn_flags); + ("type", inject @@ Js.string "warning_flag_error"); + |]) + + let make_warning_error (errors : LocWarnInfo.t array) = let type_ = "warning_error" in let js_errors = Array.map make_warning errors in - Js.Unsafe.(obj [| - "errors" , inject @@ Js.array js_errors; - "type" , inject @@ Js.string type_ - |]) + Js.Unsafe.( + obj + [| + ("errors", inject @@ Js.array js_errors); + ("type", inject @@ Js.string type_); + |]) let make_unexpected_error msg = - Js.Unsafe.(obj [| - "msg" , inject @@ Js.string msg; - "type" , inject @@ Js.string "unexpected_error" - |]) - + Js.Unsafe.( + obj + [| + ("msg", inject @@ Js.string msg); + ("type", inject @@ Js.string "unexpected_error"); + |]) end (* One time setup for all relevant modules *) @@ -200,13 +212,12 @@ let () = Lazy.force Res_outcome_printer.setup let error_of_exn e = - (match Location.error_of_exn e with + match Location.error_of_exn e with | Some (`Ok e) -> Some e - | Some `Already_displayed - | None -> None) + | Some `Already_displayed | None -> None (* Returns a default filename in case given value opt is not set *) -let get_filename ~(lang: Lang.t) opt = +let get_filename ~(lang : Lang.t) opt = match opt with | Some fname -> fname | None -> BundleConfig.default_filename lang @@ -217,23 +228,21 @@ module ResDriver = struct (* adds ~src parameter *) let setup ~src ~filename ~for_printer () = - let mode = if for_printer - then Res_parser.Default - else ParseForTypeChecker + let mode = + if for_printer then Res_parser.Default else ParseForTypeChecker in Res_parser.make ~mode src filename (* get full super error message *) - let diagnostic_to_string ~(src: string) (d: Res_diagnostics.t) = - let start_pos = Res_diagnostics.get_start_pos(d) in - let end_pos = Res_diagnostics.get_end_pos(d) in - let msg = Res_diagnostics.explain(d) in - let loc = {loc_start = start_pos; Location.loc_end=end_pos; loc_ghost=false} in - let err = { Location.loc; msg; sub=[]; if_highlight=""} in - Location.default_error_reporter - ~src:(Some src) - Format.str_formatter - err; + let diagnostic_to_string ~(src : string) (d : Res_diagnostics.t) = + let start_pos = Res_diagnostics.get_start_pos d in + let end_pos = Res_diagnostics.get_end_pos d in + let msg = Res_diagnostics.explain d in + let loc = + {loc_start = start_pos; Location.loc_end = end_pos; loc_ghost = false} + in + let err = {Location.loc; msg; sub = []; if_highlight = ""} in + Location.default_error_reporter ~src:(Some src) Format.str_formatter err; Format.flush_str_formatter () let parse_implementation ~sourcefile ~for_printer ~src = @@ -241,10 +250,12 @@ module ResDriver = struct let parse_result = let engine = setup ~filename:sourcefile ~for_printer ~src () in let structure = Res_core.parse_implementation engine in - let (invalid, diagnostics) = match engine.diagnostics with + let invalid, diagnostics = + match engine.diagnostics with | [] as diagnostics -> (false, diagnostics) | _ as diagnostics -> (true, diagnostics) - in { + in + { filename = engine.scanner.filename; source = engine.scanner.src; parsetree = structure; @@ -253,23 +264,24 @@ module ResDriver = struct comments = List.rev engine.comments; } in - let () = if parse_result.invalid then - let errors = parse_result.diagnostics - |> List.map (fun d -> - let full_msg = diagnostic_to_string ~src:parse_result.source d in - let short_msg = Res_diagnostics.explain d in - let loc = { - Location.loc_start = Res_diagnostics.get_start_pos d; - Location.loc_end = Res_diagnostics.get_end_pos d; - loc_ghost = false - } in - { - full_msg; - short_msg; - loc; - } - ) - |> List.rev + let () = + if parse_result.invalid then + let errors = + parse_result.diagnostics + |> List.map (fun d -> + let full_msg = + diagnostic_to_string ~src:parse_result.source d + in + let short_msg = Res_diagnostics.explain d in + let loc = + { + Location.loc_start = Res_diagnostics.get_start_pos d; + Location.loc_end = Res_diagnostics.get_end_pos d; + loc_ghost = false; + } + in + {full_msg; short_msg; loc}) + |> List.rev in raise (RescriptParsingErrors errors) in @@ -277,24 +289,24 @@ module ResDriver = struct end let rescript_parse ~filename src = - let (structure, _ ) = ResDriver.parse_implementation ~for_printer:false ~sourcefile:filename ~src + let structure, _ = + ResDriver.parse_implementation ~for_printer:false ~sourcefile:filename ~src in structure - module Printer = struct let print_expr typ = - Printtyp.reset_names(); + Printtyp.reset_names (); Printtyp.reset_and_mark_loops typ; - Res_doc.to_string - ~width:60 (Res_outcome_printer.print_out_type_doc (Printtyp.tree_of_typexp false typ)) - + Res_doc.to_string ~width:60 + (Res_outcome_printer.print_out_type_doc + (Printtyp.tree_of_typexp false typ)) let print_decl ~rec_status name decl = - Printtyp.reset_names(); - Res_doc.to_string - ~width:60 - (Res_outcome_printer.print_out_sig_item_doc (Printtyp.tree_of_type_declaration (Ident.create name) decl rec_status)) + Printtyp.reset_names (); + Res_doc.to_string ~width:60 + (Res_outcome_printer.print_out_sig_item_doc + (Printtyp.tree_of_type_declaration (Ident.create name) decl rec_status)) end module Compile = struct @@ -302,7 +314,7 @@ module Compile = struct * Location.error_of_exn properly, so we need to do some extra * overloading action * *) - let warning_infos: LocWarnInfo.t array ref = ref [||] + let warning_infos : LocWarnInfo.t array ref = ref [||] let warning_buffer = Buffer.create 512 let warning_ppf = Format.formatter_of_buffer warning_buffer @@ -316,62 +328,54 @@ module Compile = struct as an array *) let playground_warning_printer loc ppf w = match Warnings.report w with - | `Inactive -> () - | `Active { Warnings. number; is_error; } -> - Location.default_warning_printer loc ppf w; - let open LocWarnInfo in - let full_msg = flush_warning_buffer () in - let short_msg = Warnings.message w in - let info = { - full_msg; - short_msg; - warn_number=number; - is_error=is_error; - loc; - } in - warning_infos := Array.append !warning_infos [|info|] + | `Inactive -> () + | `Active {Warnings.number; is_error} -> + Location.default_warning_printer loc ppf w; + let open LocWarnInfo in + let full_msg = flush_warning_buffer () in + let short_msg = Warnings.message w in + let info = {full_msg; short_msg; warn_number = number; is_error; loc} in + warning_infos := Array.append !warning_infos [|info|] let () = Location.formatter_for_warnings := warning_ppf; Location.warning_printer := playground_warning_printer let handle_err e = - (match error_of_exn e with - | Some error -> - (* This branch handles all - * errors handled by the Location error reporting - * system. - * - * Here we can differentiate between the different kinds - * of error types just by looking at the raised exn names *) - let type_ = match e with - | Typetexp.Error _ - | Typecore.Error _ - | Typemod.Error _ -> "type_error" - | _ -> "other_error" - in - let full_msg = - Location.report_error Format.str_formatter error; - Format.flush_str_formatter () - in - let err = { full_msg; short_msg=error.msg; loc=error.loc; } in - ErrorRet.from_loc_errors ~type_ [|err|] - | None -> - match e with - | RescriptParsingErrors errors -> - ErrorRet.from_syntax_errors(Array.of_list errors) - | _ -> - let msg = Printexc.to_string e in - match e with - | Warnings.Errors -> - ErrorRet.make_warning_error !warning_infos - | _ -> ErrorRet.make_unexpected_error msg) + match error_of_exn e with + | Some error -> + (* This branch handles all + * errors handled by the Location error reporting + * system. + * + * Here we can differentiate between the different kinds + * of error types just by looking at the raised exn names *) + let type_ = + match e with + | Typetexp.Error _ | Typecore.Error _ | Typemod.Error _ -> "type_error" + | _ -> "other_error" + in + let full_msg = + Location.report_error Format.str_formatter error; + Format.flush_str_formatter () + in + let err = {full_msg; short_msg = error.msg; loc = error.loc} in + ErrorRet.from_loc_errors ~type_ [|err|] + | None -> ( + match e with + | RescriptParsingErrors errors -> + ErrorRet.from_syntax_errors (Array.of_list errors) + | _ -> ( + let msg = Printexc.to_string e in + match e with + | Warnings.Errors -> ErrorRet.make_warning_error !warning_infos + | _ -> ErrorRet.make_unexpected_error msg)) (* Responsible for resetting all compiler state as if it were a new instance *) let reset_compiler () = warning_infos := [||]; flush_warning_buffer () |> ignore; - Location.reset(); + Location.reset (); Warnings.reset_fatal (); Env.reset_cache_toplevel () @@ -384,68 +388,88 @@ module Compile = struct let open Typedtree in let create_type_hint_obj loc kind hint = let open Location in - let (_ , startline, startcol) = Location.get_pos_info loc.loc_start in - let (_ , endline, endcol) = Location.get_pos_info loc.loc_end in - Js.Unsafe.(obj [| - "start", inject @@ (obj [| - "line", inject @@ (startline |> float_of_int |> Js.number_of_float); - "col", inject @@ (startcol|> float_of_int |> Js.number_of_float); - |]); - "end", inject @@ (obj [| - "line", inject @@ (endline |> float_of_int |> Js.number_of_float); - "col", inject @@ (endcol |> float_of_int |> Js.number_of_float); - |]); - "kind", inject @@ Js.string kind; - "hint", inject @@ Js.string hint; - |]) + let _, startline, startcol = Location.get_pos_info loc.loc_start in + let _, endline, endcol = Location.get_pos_info loc.loc_end in + Js.Unsafe.( + obj + [| + ( "start", + inject + @@ obj + [| + ( "line", + inject + @@ (startline |> float_of_int |> Js.number_of_float) ); + ( "col", + inject @@ (startcol |> float_of_int |> Js.number_of_float) + ); + |] ); + ( "end", + inject + @@ obj + [| + ( "line", + inject @@ (endline |> float_of_int |> Js.number_of_float) + ); + ( "col", + inject @@ (endcol |> float_of_int |> Js.number_of_float) + ); + |] ); + ("kind", inject @@ Js.string kind); + ("hint", inject @@ Js.string hint); + |]) in - let (structure, _) = typed_tree in + let structure, _ = typed_tree in let acc = ref [] in let module Iter = TypedtreeIter.MakeIterator (struct - include TypedtreeIter.DefaultIteratorArgument + include TypedtreeIter.DefaultIteratorArgument - let cur_rec_status = ref None + let cur_rec_status = ref None - let enter_expression expr = - let hint = Printer.print_expr expr.exp_type in - let obj = create_type_hint_obj expr.exp_loc "expression" hint in - acc := obj :: !acc + let enter_expression expr = + let hint = Printer.print_expr expr.exp_type in + let obj = create_type_hint_obj expr.exp_loc "expression" hint in + acc := obj :: !acc - let enter_binding binding = - let hint = Printer.print_expr binding.vb_expr.exp_type in - let obj = create_type_hint_obj binding.vb_loc "binding" hint in - acc := obj :: !acc + let enter_binding binding = + let hint = Printer.print_expr binding.vb_expr.exp_type in + let obj = create_type_hint_obj binding.vb_loc "binding" hint in + acc := obj :: !acc - let enter_core_type ct = - let hint = Printer.print_expr ct.ctyp_type in - let obj = create_type_hint_obj ct.ctyp_loc "core_type" hint in - acc := obj :: !acc + let enter_core_type ct = + let hint = Printer.print_expr ct.ctyp_type in + let obj = create_type_hint_obj ct.ctyp_loc "core_type" hint in + acc := obj :: !acc - let enter_type_declarations rec_flag = - let status = match rec_flag with + let enter_type_declarations rec_flag = + let status = + match rec_flag with | Asttypes.Nonrecursive -> Types.Trec_not | Recursive -> Trec_first + in + cur_rec_status := Some status + + let enter_type_declaration tdecl = + let open Types in + match !cur_rec_status with + | Some rec_status -> ( + let hint = + Printer.print_decl ~rec_status tdecl.typ_name.Asttypes.txt + tdecl.typ_type in - cur_rec_status := Some status - - let enter_type_declaration tdecl = - let open Types in - match !cur_rec_status with - | Some rec_status -> - let hint = Printer.print_decl ~rec_status tdecl.typ_name.Asttypes.txt tdecl.typ_type in - let obj = create_type_hint_obj tdecl.typ_loc "type_declaration" hint in - acc := obj :: !acc; - (match rec_status with - | Trec_not - | Trec_first -> cur_rec_status := Some Trec_next - | _ -> ()) - | None -> () - end) - in + let obj = + create_type_hint_obj tdecl.typ_loc "type_declaration" hint + in + acc := obj :: !acc; + match rec_status with + | Trec_not | Trec_first -> cur_rec_status := Some Trec_next + | _ -> ()) + | None -> () + end) in List.iter Iter.iter_structure_item structure.str_items; Js.array (!acc |> Array.of_list) - let implementation ~(config: BundleConfig.t) ~lang str = + let implementation ~(config : BundleConfig.t) ~lang str = let {BundleConfig.module_system; warn_flags; open_modules} = config in try reset_compiler (); @@ -458,101 +482,107 @@ module Compile = struct (* Res_compmisc.init_path (); *) (* let modulename = module_of_filename ppf sourcefile outputprefix in *) (* Env.set_unit_name modulename; *) - Lam_compile_env.reset () ; - let env = Res_compmisc.initial_env () in (* Question ?? *) + Lam_compile_env.reset (); + let env = Res_compmisc.initial_env () in + (* Question ?? *) (* let finalenv = ref Env.empty in *) let types_signature = ref [] in - Js_config.jsx_version := Some Js_config.Jsx_v4; (* default *) - Js_config.jsx_mode := Js_config.Automatic; (* default *) - let ast = impl (str) in + Js_config.jsx_version := Some Js_config.Jsx_v4; + (* default *) + Js_config.jsx_mode := Js_config.Automatic; + (* default *) + let ast = impl str in let ast = Ppx_entry.rewrite_implementation ast in let typed_tree = - let (a,b,_,signature) = Typemod.type_implementation_more modulename modulename modulename env ast in + let a, b, _, signature = + Typemod.type_implementation_more modulename modulename modulename env + ast + in (* finalenv := c ; *) types_signature := signature; - (a,b) in - typed_tree - |> Translmod.transl_implementation modulename - |> (* Printlambda.lambda ppf *) (fun (lam, exports) -> - let buffer = Buffer.create 1000 in - let () = Js_dump_program.pp_deps_program - ~output_prefix:"" (* does not matter here *) - module_system - (Lam_compile_main.compile "" exports lam) - (Ext_pp.from_buffer buffer) in - let v = Buffer.contents buffer in - let type_hints = collect_type_hints typed_tree in - Js.Unsafe.(obj [| - "js_code", inject @@ Js.string v; - "warnings", - inject @@ ( - !warning_infos - |> Array.map ErrorRet.make_warning - |> Js.array - |> inject - ); - "type_hints", inject @@ type_hints; - "type" , inject @@ Js.string "success" - |])) - with - | e -> + (a, b) + in + typed_tree |> Translmod.transl_implementation modulename + |> (* Printlambda.lambda ppf *) fun (lam, exports) -> + let buffer = Buffer.create 1000 in + let () = + Js_dump_program.pp_deps_program ~output_prefix:"" + (* does not matter here *) module_system + (Lam_compile_main.compile "" exports lam) + (Ext_pp.from_buffer buffer) + in + let v = Buffer.contents buffer in + let type_hints = collect_type_hints typed_tree in + Js.Unsafe.( + obj + [| + ("js_code", inject @@ Js.string v); + ( "warnings", + inject + @@ (!warning_infos + |> Array.map ErrorRet.make_warning + |> Js.array |> inject) ); + ("type_hints", inject @@ type_hints); + ("type", inject @@ Js.string "success"); + |]) + with e -> ( match e with - | Arg.Bad msg -> - ErrorRet.make_warning_flag_error ~warn_flags msg - | _ -> handle_err e;; + | Arg.Bad msg -> ErrorRet.make_warning_flag_error ~warn_flags msg + | _ -> handle_err e) - let syntax_format ?(filename: string option) ~(from:Lang.t) ~(to_:Lang.t) (src: string) = + let syntax_format ?(filename : string option) ~(from : Lang.t) ~(to_ : Lang.t) + (src : string) = let filename = get_filename ~lang:from filename in try - let code = match (from, to_) with - | (Res, Res) -> + let code = + match (from, to_) with + | Res, Res -> (* Essentially pretty printing. * IMPORTANT: we need forPrinter:true when parsing code here, * otherwise we will loose some information for the ReScript printer *) - let (structure, comments) = - ResDriver.parse_implementation ~for_printer:true ~sourcefile:filename ~src + let structure, comments = + ResDriver.parse_implementation ~for_printer:true + ~sourcefile:filename ~src in Res_printer.print_implementation ~width:80 structure ~comments in - Js.Unsafe.(obj [| - "code", inject @@ Js.string code; - "fromLang", inject @@ Js.string (Lang.to_string from); - "toLang", inject @@ Js.string (Lang.to_string to_); - "type" , inject @@ Js.string "success" - |]) - with - | e -> handle_err e + Js.Unsafe.( + obj + [| + ("code", inject @@ Js.string code); + ("fromLang", inject @@ Js.string (Lang.to_string from)); + ("toLang", inject @@ Js.string (Lang.to_string to_)); + ("type", inject @@ Js.string "success"); + |]) + with e -> handle_err e end - (* To add a directory to the load path *) -let dir_directory d = - Config.load_path := d :: !Config.load_path -let () = - dir_directory "/static" +let dir_directory d = Config.load_path := d :: !Config.load_path +let () = dir_directory "/static" module Export = struct let make_compiler ~config ~lang = let open Js.Unsafe in let base_attrs = - [|"compile", - inject @@ - Js.wrap_meth_callback - (fun _ code -> - (Compile.implementation ~config ~lang (Js.to_string code))); - "version", - inject @@ - Js.string Bs_version.version; - |] in - let attrs = - Array.append base_attrs [| - ("format", - inject @@ - Js.wrap_meth_callback - (fun _ code -> - (Compile.syntax_format ?filename:config.filename ~from:lang ~to_:lang (Js.to_string code)))) + [| + ( "compile", + inject + @@ Js.wrap_meth_callback (fun _ code -> + Compile.implementation ~config ~lang (Js.to_string code)) ); + ("version", inject @@ Js.string Bs_version.version); |] in + let attrs = + Array.append base_attrs + [| + ( "format", + inject + @@ Js.wrap_meth_callback (fun _ code -> + Compile.syntax_format ?filename:config.filename ~from:lang + ~to_:lang (Js.to_string code)) ); + |] + in obj attrs (* Creates a "compiler instance" binding the configuration context to the specific compile / formatter functions *) @@ -562,98 +592,98 @@ module Export = struct let set_module_system value = match value with | "esmodule" | "es6" -> - config.module_system <- Ext_module_system.Esmodule; true + config.module_system <- Ext_module_system.Esmodule; + true | "commonjs" | "nodejs" -> - config.module_system <- Commonjs; true - | _ -> false in + config.module_system <- Commonjs; + true + | _ -> false + in let set_filename value = - config.filename <- Some value; true + config.filename <- Some value; + true in let set_warn_flags value = - config.warn_flags <- value; true + config.warn_flags <- value; + true in let set_open_modules value = - config.open_modules <- value; true + config.open_modules <- value; + true in - let convert_syntax ~(from_lang: string) ~(to_lang: string) (src: string) = + let convert_syntax ~(from_lang : string) ~(to_lang : string) (src : string) + = let open Lang in match (from_string from_lang, from_string to_lang) with - | (Some from, Some to_) -> + | Some from, Some to_ -> Compile.syntax_format ?filename:config.filename ~from ~to_ src | other -> - let msg = match other with - | (None, None) -> "Unknown from / to language: " ^ from_lang ^ ", " ^ to_lang - | (None, Some _) -> "Unknown from language: " ^ from_lang - | (Some _, None) -> "Unknown to language: " ^ to_lang - | (Some _, Some _) -> "Can't convert from " ^ from_lang ^ " to " ^ to_lang + let msg = + match other with + | None, None -> + "Unknown from / to language: " ^ from_lang ^ ", " ^ to_lang + | None, Some _ -> "Unknown from language: " ^ from_lang + | Some _, None -> "Unknown to language: " ^ to_lang + | Some _, Some _ -> + "Can't convert from " ^ from_lang ^ " to " ^ to_lang in - ErrorRet.make_unexpected_error(msg) + ErrorRet.make_unexpected_error msg in - Js.Unsafe.(obj [| - "version", - inject @@ Js.string Bs_version.version; - "rescript", - inject @@ make_compiler ~config ~lang:Res; - "convertSyntax", - inject @@ - Js.wrap_meth_callback - (fun _ from_lang to_lang src -> - (convert_syntax ~from_lang:(Js.to_string from_lang) ~to_lang:(Js.to_string to_lang) (Js.to_string src)) - ); - "setModuleSystem", - inject @@ - Js.wrap_meth_callback - (fun _ value -> - (Js.bool (set_module_system (Js.to_string value))) - ); - "setFilename", - inject @@ - Js.wrap_meth_callback - (fun _ value -> - (Js.bool (set_filename (Js.to_string value))) - ); - "setWarnFlags", - inject @@ - Js.wrap_meth_callback - (fun _ value -> - (Js.bool (set_warn_flags (Js.to_string value))) - ); - "setOpenModules", - inject @@ - Js.wrap_meth_callback - (fun _ (value) -> - (Js.bool (set_open_modules (value |> Js.to_array |> Array.map Js.to_string |> Array.to_list))) - ); - "getConfig", - inject @@ - Js.wrap_meth_callback - (fun _ -> - (Js.Unsafe.(obj - [| - "module_system", - inject @@ ( - config.module_system - |> BundleConfig.string_of_module_system - |> Js.string - ); - "warn_flags", - inject @@ (Js.string config.warn_flags); - "open_modules", inject @@ (config.open_modules |> Array.of_list |> Js.array); - |])) - ); - |]) - + Js.Unsafe.( + obj + [| + ("version", inject @@ Js.string Bs_version.version); + ("rescript", inject @@ make_compiler ~config ~lang:Res); + ( "convertSyntax", + inject + @@ Js.wrap_meth_callback (fun _ from_lang to_lang src -> + convert_syntax ~from_lang:(Js.to_string from_lang) + ~to_lang:(Js.to_string to_lang) (Js.to_string src)) ); + ( "setModuleSystem", + inject + @@ Js.wrap_meth_callback (fun _ value -> + Js.bool (set_module_system (Js.to_string value))) ); + ( "setFilename", + inject + @@ Js.wrap_meth_callback (fun _ value -> + Js.bool (set_filename (Js.to_string value))) ); + ( "setWarnFlags", + inject + @@ Js.wrap_meth_callback (fun _ value -> + Js.bool (set_warn_flags (Js.to_string value))) ); + ( "setOpenModules", + inject + @@ Js.wrap_meth_callback (fun _ value -> + Js.bool + (set_open_modules + (value |> Js.to_array |> Array.map Js.to_string + |> Array.to_list))) ); + ( "getConfig", + inject + @@ Js.wrap_meth_callback (fun _ -> + Js.Unsafe.( + obj + [| + ( "module_system", + inject + @@ (config.module_system + |> BundleConfig.string_of_module_system + |> Js.string) ); + ("warn_flags", inject @@ Js.string config.warn_flags); + ( "open_modules", + inject + @@ (config.open_modules |> Array.of_list |> Js.array) + ); + |])) ); + |]) end let () = export "rescript_compiler" - (Js.Unsafe.(obj - [| - "api_version", - inject @@ Js.string api_version; - "version", - inject @@ Js.string Bs_version.version; - "make", - inject @@ Export.make - |])) - + Js.Unsafe.( + obj + [| + ("api_version", inject @@ Js.string api_version); + ("version", inject @@ Js.string Bs_version.version); + ("make", inject @@ Export.make); + |]) diff --git a/compiler/jsoo/jsoo_playground_main.mli b/compiler/jsoo/jsoo_playground_main.mli index f4f9d8937e..3999ce7f69 100644 --- a/compiler/jsoo/jsoo_playground_main.mli +++ b/compiler/jsoo/jsoo_playground_main.mli @@ -21,5 +21,3 @@ * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - diff --git a/compiler/ml/.ocamlformat b/compiler/ml/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/ml/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/ml/annot.ml b/compiler/ml/annot.ml index 3cae8f2735..13a586592e 100644 --- a/compiler/ml/annot.ml +++ b/compiler/ml/annot.ml @@ -15,10 +15,9 @@ (* Data types for annotations (Stypes.ml) *) -type call = Tail | Stack | Inline;; +type call = Tail | Stack | Inline type ident = | Iref_internal of Location.t (* defining occurrence *) | Iref_external - | Idef of Location.t (* scope *) -;; + | Idef of Location.t (* scope *) diff --git a/compiler/ml/ast_async.ml b/compiler/ml/ast_async.ml index a758ae29ba..e8ed63a736 100644 --- a/compiler/ml/ast_async.ml +++ b/compiler/ml/ast_async.ml @@ -1,5 +1,5 @@ let is_async : Parsetree.attribute -> bool = - fun ({txt}, _) -> txt = "async" || txt = "res.async" + fun ({txt}, _) -> txt = "async" || txt = "res.async" let add_promise_type ?(loc = Location.none) ~async (result : Parsetree.expression) = @@ -13,18 +13,29 @@ let add_promise_type ?(loc = Location.none) ~async let add_async_attribute ~async (body : Parsetree.expression) = if async then - ( - match body.pexp_desc with - | Pexp_construct (x, Some e) when Ast_uncurried.expr_is_uncurried_fun body -> - {body with pexp_desc = Pexp_construct (x, Some {e with pexp_attributes = - ({txt = "res.async"; loc = Location.none}, PStr []) :: e.pexp_attributes} )} - | _ -> - { - body with - pexp_attributes = - ({txt = "res.async"; loc = Location.none}, PStr []) - :: body.pexp_attributes; - }) + match body.pexp_desc with + | Pexp_construct (x, Some e) when Ast_uncurried.expr_is_uncurried_fun body + -> + { + body with + pexp_desc = + Pexp_construct + ( x, + Some + { + e with + pexp_attributes = + ({txt = "res.async"; loc = Location.none}, PStr []) + :: e.pexp_attributes; + } ); + } + | _ -> + { + body with + pexp_attributes = + ({txt = "res.async"; loc = Location.none}, PStr []) + :: body.pexp_attributes; + } else body let rec add_promise_to_result ~loc (e : Parsetree.expression) = diff --git a/compiler/ml/ast_await.ml b/compiler/ml/ast_await.ml index 4cf7461979..9fd1b9081b 100644 --- a/compiler/ml/ast_await.ml +++ b/compiler/ml/ast_await.ml @@ -1,5 +1,5 @@ let is_await : Parsetree.attribute -> bool = - fun ({txt}, _) -> txt = "await" || txt = "res.await" + fun ({txt}, _) -> txt = "await" || txt = "res.await" let create_await_expression (e : Parsetree.expression) = let loc = {e.pexp_loc with loc_ghost = true} in @@ -24,7 +24,8 @@ let create_await_module_expression ~module_type_lid (e : Parsetree.module_expr) (Exp.apply ~loc:e.pmod_loc (Exp.ident ~loc:e.pmod_loc { - txt = Longident.Ldot (Lident Primitive_modules.module_, "import"); + txt = + Longident.Ldot (Lident Primitive_modules.module_, "import"); loc = e.pmod_loc; }) [ diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 7ed32f69bf..37f1542baf 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -28,15 +28,20 @@ let default_loc = ref Location.none let with_default_loc l f = let old = !default_loc in default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn + try + let r = f () in + default_loc := old; + r + with exn -> + default_loc := old; + raise exn module Const = struct let integer ?suffix i = Pconst_integer (i, suffix) let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) + let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) + let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) + let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) let float ?suffix f = Pconst_float (f, suffix) let char c = Pconst_char (Char.code c) let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) @@ -66,58 +71,51 @@ module Typ = struct let varify_constructors var_names t = let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in + if List.mem v vl then raise Syntaxerr.(Error (Variable_in_scope (loc, v))) + in let var_names = List.map (fun v -> v.txt) var_names in let rec loop t = let desc = match t.ptyp_desc with | Ptyp_any -> Ptyp_any | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow (label, core_type, core_type') -> + Ptyp_arrow (label, loop core_type, loop core_type') | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names + -> + Ptyp_var s + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, List.map loop lst) + | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o) | Ptyp_class () -> assert false - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) + | Ptyp_alias (core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly (string_lst, core_type) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) in {t with ptyp_desc = desc} - and loop_row_field = - function - | Rtag(label,attrs,flag,lst) -> - Rtag(label,attrs,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - and loop_object_field = - function - | Otag(label, attrs, t) -> - Otag(label, attrs, loop t) - | Oinherit t -> - Oinherit (loop t) + and loop_row_field = function + | Rtag (label, attrs, flag, lst) -> + Rtag (label, attrs, flag, List.map loop lst) + | Rinherit t -> Rinherit (loop t) + and loop_object_field = function + | Otag (label, attrs, t) -> Otag (label, attrs, loop t) + | Oinherit t -> Oinherit (loop t) in loop t - end module Pat = struct @@ -175,7 +173,7 @@ module Exp = struct let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) @@ -186,12 +184,7 @@ module Exp = struct let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } + let case lhs ?guard rhs = {pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs} end module Mty = struct @@ -209,8 +202,8 @@ module Mty = struct end module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) @@ -259,160 +252,118 @@ module Str = struct end module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(prim = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = { - pval_name = name; - pval_type = typ; - pval_attributes = attrs; - pval_loc = loc; - pval_prim = prim; + pval_name = name; + pval_type = typ; + pval_attributes = attrs; + pval_loc = loc; + pval_prim = prim; } end module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = attrs; - pmd_loc = loc; - } + let mk ?(loc = !default_loc) ?(attrs = []) name typ = + {pmd_name = name; pmd_type = typ; pmd_attributes = attrs; pmd_loc = loc} end module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = attrs; - pmtd_loc = loc; - } + let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + {pmtd_name = name; pmtd_type = typ; pmtd_attributes = attrs; pmtd_loc = loc} end module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = attrs; - pmb_loc = loc; - } + let mk ?(loc = !default_loc) ?(attrs = []) name expr = + {pmb_name = name; pmb_expr = expr; pmb_attributes = attrs; pmb_loc = loc} end module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(override = Fresh) lid = + let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = attrs; + popen_lid = lid; + popen_override = override; + popen_loc = loc; + popen_attributes = attrs; } end module Incl = struct let mk ?(loc = !default_loc) ?(attrs = []) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = attrs; - } - + {pincl_mod = mexpr; pincl_loc = loc; pincl_attributes = attrs} end module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = attrs; - pvb_loc = loc; - } + let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + {pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc} end module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = + let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = []) + ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name = { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = attrs; - ptype_loc = loc; + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = attrs; + ptype_loc = loc; } - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(args = Pcstr_tuple []) ?res name = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) + ?res name = { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = attrs; + pcd_name = name; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = attrs; } - let field ?(loc = !default_loc) ?(attrs = []) - ?(mut = Immutable) name typ = + let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ = { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = attrs; + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = attrs; } - end (** Type extensions *) module Te = struct - let mk ?(attrs = []) - ?(params = []) ?(priv = Public) path constructors = + let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = attrs; + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_attributes = attrs; } - let constructor ?(loc = !default_loc) ?(attrs = []) - name kind = + let constructor ?(loc = !default_loc) ?(attrs = []) name kind = { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = attrs; + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = attrs; } - let decl ?(loc = !default_loc) ?(attrs = []) - ?(args = Pcstr_tuple []) ?res name = + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res + name = { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = attrs; + pext_name = name; + pext_kind = Pext_decl (args, res); + pext_loc = loc; + pext_attributes = attrs; } - let rebind ?(loc = !default_loc) ?(attrs = []) - name lid = + let rebind ?(loc = !default_loc) ?(attrs = []) name lid = { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = attrs; + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = attrs; } - end diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 3aac4ed6e8..05fc814486 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -25,11 +25,11 @@ type attrs = attribute list (** {1 Default locations} *) -val default_loc: loc ref - (** Default value for all optional location arguments. *) +val default_loc : loc ref +(** Default value for all optional location arguments. *) -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution +val with_default_loc : loc -> (unit -> 'a) -> 'a +(** Set the [default_loc] within the scope of the execution of the provided function. *) (** {1 Constants} *) @@ -48,283 +48,353 @@ end (** {1 Core language} *) (** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which +module Typ : sig + val mk : ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type + val attr : core_type -> attribute -> core_type + + val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type + val var : ?loc:loc -> ?attrs:attrs -> string -> core_type + val arrow : + ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type + val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val object_ : + ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type + val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type + val variant : + ?loc:loc -> + ?attrs:attrs -> + row_field list -> + closed_flag -> + label list option -> + core_type + val poly : ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + val package : + ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type + val extension : ?loc:loc -> ?attrs:attrs -> extension -> core_type + + val force_poly : core_type -> core_type + + val varify_constructors : str list -> core_type -> core_type + (** [varify_constructors newtypes te] is type expression [te], of which any of nullary type constructor [tc] is replaced by type variable of the same name, if [tc]'s name appears in [newtypes]. Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] appears in [newtypes]. @since 4.05 *) - end +end (** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end +module Pat : sig + val mk : ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern + val attr : pattern -> attribute -> pattern + + val any : ?loc:loc -> ?attrs:attrs -> unit -> pattern + val var : ?loc:loc -> ?attrs:attrs -> str -> pattern + val alias : ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern + val constant : ?loc:loc -> ?attrs:attrs -> constant -> pattern + val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern + val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern + val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern + val record : + ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern + val array : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val or_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + val constraint_ : ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern + val type_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern + val lazy_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val unpack : ?loc:loc -> ?attrs:attrs -> str -> pattern + val open_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern + val exception_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val extension : ?loc:loc -> ?attrs:attrs -> extension -> pattern +end (** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end +module Exp : sig + val mk : ?loc:loc -> ?attrs:attrs -> expression_desc -> expression + val attr : expression -> attribute -> expression + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> expression + val constant : ?loc:loc -> ?attrs:attrs -> constant -> expression + val let_ : + ?loc:loc -> + ?attrs:attrs -> + rec_flag -> + value_binding list -> + expression -> + expression + val fun_ : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + expression option -> + pattern -> + expression -> + expression + val function_ : ?loc:loc -> ?attrs:attrs -> case list -> expression + val apply : + ?loc:loc -> + ?attrs:attrs -> + expression -> + (arg_label * expression) list -> + expression + val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression + val construct : + ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression + val variant : + ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression + val record : + ?loc:loc -> + ?attrs:attrs -> + (lid * expression) list -> + expression option -> + expression + val field : ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + val setfield : + ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression -> expression + val array : ?loc:loc -> ?attrs:attrs -> expression list -> expression + val ifthenelse : + ?loc:loc -> + ?attrs:attrs -> + expression -> + expression -> + expression option -> + expression + val sequence : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + val while_ : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + val for_ : + ?loc:loc -> + ?attrs:attrs -> + pattern -> + expression -> + expression -> + direction_flag -> + expression -> + expression + val coerce : ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + val constraint_ : + ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + val new_ : ?loc:loc -> ?attrs:attrs -> lid -> expression + val setinstvar : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val override : + ?loc:loc -> ?attrs:attrs -> (str * expression) list -> expression + val letmodule : + ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression -> expression + val letexception : + ?loc:loc -> + ?attrs:attrs -> + extension_constructor -> + expression -> + expression + val assert_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + val lazy_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + val poly : + ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> expression + val newtype : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val pack : ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val open_ : + ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression -> expression + val extension : ?loc:loc -> ?attrs:attrs -> extension -> expression + val unreachable : ?loc:loc -> ?attrs:attrs -> unit -> expression + + val case : pattern -> ?guard:expression -> expression -> case +end (** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - ?prim:string list -> str -> core_type -> value_description - end +module Val : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?prim:string list -> + str -> + core_type -> + value_description +end (** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end +module Type : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?params:(core_type * variance) list -> + ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> + ?priv:private_flag -> + ?manifest:core_type -> + str -> + type_declaration + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + constructor_declaration + val field : + ?loc:loc -> + ?attrs:attrs -> + ?mut:mutable_flag -> + str -> + core_type -> + label_declaration +end (** Type extensions *) -module Te: - sig - val mk: ?attrs:attrs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> - str -> lid -> extension_constructor - end +module Te : sig + val mk : + ?attrs:attrs -> + ?params:(core_type * variance) list -> + ?priv:private_flag -> + lid -> + extension_constructor list -> + type_extension + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + str -> + extension_constructor_kind -> + extension_constructor + + val decl : + ?loc:loc -> + ?attrs:attrs -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + extension_constructor + val rebind : ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor +end (** {1 Module language} *) (** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end +module Mty : sig + val mk : ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type + val attr : module_type -> attribute -> module_type + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_type + val alias : ?loc:loc -> ?attrs:attrs -> lid -> module_type + val signature : ?loc:loc -> ?attrs:attrs -> signature -> module_type + val functor_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + module_type option -> + module_type -> + module_type + val with_ : + ?loc:loc -> + ?attrs:attrs -> + module_type -> + with_constraint list -> + module_type + val typeof_ : ?loc:loc -> ?attrs:attrs -> module_expr -> module_type + val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_type +end (** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end +module Mod : sig + val mk : ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr + val attr : module_expr -> attribute -> module_expr + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_expr + val structure : ?loc:loc -> ?attrs:attrs -> structure -> module_expr + val functor_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + module_type option -> + module_expr -> + module_expr + val apply : + ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr + val constraint_ : + ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr + val unpack : ?loc:loc -> ?attrs:attrs -> expression -> module_expr + val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_expr +end (** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - end +module Sig : sig + val mk : ?loc:loc -> signature_item_desc -> signature_item + + val value : ?loc:loc -> value_description -> signature_item + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> signature_item + val type_extension : ?loc:loc -> type_extension -> signature_item + val exception_ : ?loc:loc -> extension_constructor -> signature_item + val module_ : ?loc:loc -> module_declaration -> signature_item + val rec_module : ?loc:loc -> module_declaration list -> signature_item + val modtype : ?loc:loc -> module_type_declaration -> signature_item + val open_ : ?loc:loc -> open_description -> signature_item + val include_ : ?loc:loc -> include_description -> signature_item + val extension : ?loc:loc -> ?attrs:attrs -> extension -> signature_item + val attribute : ?loc:loc -> attribute -> signature_item +end (** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - end +module Str : sig + val mk : ?loc:loc -> structure_item_desc -> structure_item + + val eval : ?loc:loc -> ?attrs:attributes -> expression -> structure_item + val value : ?loc:loc -> rec_flag -> value_binding list -> structure_item + val primitive : ?loc:loc -> value_description -> structure_item + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> structure_item + val type_extension : ?loc:loc -> type_extension -> structure_item + val exception_ : ?loc:loc -> extension_constructor -> structure_item + val module_ : ?loc:loc -> module_binding -> structure_item + val rec_module : ?loc:loc -> module_binding list -> structure_item + val modtype : ?loc:loc -> module_type_declaration -> structure_item + val open_ : ?loc:loc -> open_description -> structure_item + val include_ : ?loc:loc -> include_declaration -> structure_item + val extension : ?loc:loc -> ?attrs:attrs -> extension -> structure_item + val attribute : ?loc:loc -> attribute -> structure_item +end (** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - str -> module_type -> module_declaration - end +module Md : sig + val mk : ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_declaration +end (** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - ?typ:module_type -> str -> module_type_declaration - end +module Mtd : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?typ:module_type -> + str -> + module_type_declaration +end (** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - str -> module_expr -> module_binding - end +module Mb : sig + val mk : ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding +end (** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> - ?override:override_flag -> lid -> open_description - end +module Opn : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?override:override_flag -> + lid -> + open_description +end (** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos - end +module Incl : sig + val mk : ?loc:loc -> ?attrs:attrs -> 'a -> 'a include_infos +end (** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> - pattern -> expression -> value_binding - end +module Vb : sig + val mk : ?loc:loc -> ?attrs:attrs -> pattern -> expression -> value_binding +end diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml old mode 100755 new mode 100644 index c5826d5493..d0dc295fd2 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -20,7 +20,6 @@ (* Ensure that record patterns don't miss any field. *) *) - open Parsetree open Location @@ -64,9 +63,16 @@ type iterator = { let iter_fst f (x, _) = f x let iter_snd f (_, y) = f y -let iter_tuple f1 f2 (x, y) = f1 x; f2 y -let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z -let iter_opt f = function None -> () | Some x -> f x +let iter_tuple f1 f2 (x, y) = + f1 x; + f2 y +let iter_tuple3 f1 f2 f3 (x, y, z) = + f1 x; + f2 y; + f3 z +let iter_opt f = function + | None -> () + | Some x -> f x let iter_loc sub {loc; txt = _} = sub.location sub loc @@ -75,44 +81,49 @@ module T = struct let row_field sub = function | Rtag (_, attrs, _, tl) -> - sub.attributes sub attrs; List.iter (sub.typ sub) tl + sub.attributes sub attrs; + List.iter (sub.typ sub) tl | Rinherit t -> sub.typ sub t let object_field sub = function | Otag (_, attrs, t) -> - sub.attributes sub attrs; sub.typ sub t + sub.attributes sub attrs; + sub.typ sub t | Oinherit t -> sub.typ sub t let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; match desc with - | Ptyp_any - | Ptyp_var _ -> () + | Ptyp_any | Ptyp_var _ -> () | Ptyp_arrow (_lab, t1, t2) -> - sub.typ sub t1; sub.typ sub t2 + sub.typ sub t1; + sub.typ sub t2 | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl | Ptyp_constr (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_object (ol, _o) -> - List.iter (object_field sub) ol + iter_loc sub lid; + List.iter (sub.typ sub) tl + | Ptyp_object (ol, _o) -> List.iter (object_field sub) ol | Ptyp_class () -> () | Ptyp_alias (t, _) -> sub.typ sub t - | Ptyp_variant (rl, _b, _ll) -> - List.iter (row_field sub) rl + | Ptyp_variant (rl, _b, _ll) -> List.iter (row_field sub) rl | Ptyp_poly (_, t) -> sub.typ sub t | Ptyp_package (lid, l) -> - iter_loc sub lid; - List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + iter_loc sub lid; + List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l | Ptyp_extension x -> sub.extension sub x let iter_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private = _; - ptype_manifest; - ptype_attributes; - ptype_loc} = + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private = _; + ptype_manifest; + ptype_attributes; + ptype_loc; + } = iter_loc sub ptype_name; List.iter (iter_fst (sub.typ sub)) ptype_params; List.iter @@ -125,45 +136,41 @@ module T = struct let iter_type_kind sub = function | Ptype_abstract -> () - | Ptype_variant l -> - List.iter (sub.constructor_declaration sub) l + | Ptype_variant l -> List.iter (sub.constructor_declaration sub) l | Ptype_record l -> List.iter (sub.label_declaration sub) l | Ptype_open -> () let iter_constructor_arguments sub = function | Pcstr_tuple l -> List.iter (sub.typ sub) l - | Pcstr_record l -> - List.iter (sub.label_declaration sub) l + | Pcstr_record l -> List.iter (sub.label_declaration sub) l let iter_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private = _; - ptyext_attributes} = + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private = _; + ptyext_attributes; + } = iter_loc sub ptyext_path; List.iter (sub.extension_constructor sub) ptyext_constructors; List.iter (iter_fst (sub.typ sub)) ptyext_params; sub.attributes sub ptyext_attributes let iter_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto - | Pext_rebind li -> - iter_loc sub li + | Pext_decl (ctl, cto) -> + iter_constructor_arguments sub ctl; + iter_opt (sub.typ sub) cto + | Pext_rebind li -> iter_loc sub li let iter_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = + {pext_name; pext_kind; pext_loc; pext_attributes} = iter_loc sub pext_name; iter_extension_constructor_kind sub pext_kind; sub.location sub pext_loc; sub.attributes sub pext_attributes - end - module MT = struct (* Type expressions for the module language *) @@ -175,24 +182,28 @@ module MT = struct | Pmty_alias s -> iter_loc sub s | Pmty_signature sg -> sub.signature sub sg | Pmty_functor (s, mt1, mt2) -> - iter_loc sub s; - iter_opt (sub.module_type sub) mt1; - sub.module_type sub mt2 + iter_loc sub s; + iter_opt (sub.module_type sub) mt1; + sub.module_type sub mt2 | Pmty_with (mt, l) -> - sub.module_type sub mt; - List.iter (sub.with_constraint sub) l + sub.module_type sub mt; + List.iter (sub.with_constraint sub) l | Pmty_typeof me -> sub.module_expr sub me | Pmty_extension x -> sub.extension sub x let iter_with_constraint sub = function | Pwith_type (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d + iter_loc sub lid; + sub.type_declaration sub d | Pwith_module (lid, lid2) -> - iter_loc sub lid; iter_loc sub lid2 + iter_loc sub lid; + iter_loc sub lid2 | Pwith_typesubst (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d + iter_loc sub lid; + sub.type_declaration sub d | Pwith_modsubst (s, lid) -> - iter_loc sub s; iter_loc sub lid + iter_loc sub s; + iter_loc sub lid let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = sub.location sub loc; @@ -202,19 +213,18 @@ module MT = struct | Psig_typext te -> sub.type_extension sub te | Psig_exception ed -> sub.extension_constructor sub ed | Psig_module x -> sub.module_declaration sub x - | Psig_recmodule l -> - List.iter (sub.module_declaration sub) l + | Psig_recmodule l -> List.iter (sub.module_declaration sub) l | Psig_modtype x -> sub.module_type_declaration sub x | Psig_open x -> sub.open_description sub x | Psig_include x -> sub.include_description sub x | Psig_class () -> () | Psig_class_type () -> () | Psig_extension (x, attrs) -> - sub.extension sub x; sub.attributes sub attrs + sub.extension sub x; + sub.attributes sub attrs | Psig_attribute x -> sub.attribute sub x end - module M = struct (* Value expressions for the module language *) @@ -225,13 +235,15 @@ module M = struct | Pmod_ident x -> iter_loc sub x | Pmod_structure str -> sub.structure sub str | Pmod_functor (arg, arg_ty, body) -> - iter_loc sub arg; - iter_opt (sub.module_type sub) arg_ty; - sub.module_expr sub body + iter_loc sub arg; + iter_opt (sub.module_type sub) arg_ty; + sub.module_expr sub body | Pmod_apply (m1, m2) -> - sub.module_expr sub m1; sub.module_expr sub m2 + sub.module_expr sub m1; + sub.module_expr sub m2 | Pmod_constraint (m, mty) -> - sub.module_expr sub m; sub.module_type sub mty + sub.module_expr sub m; + sub.module_type sub mty | Pmod_unpack e -> sub.expr sub e | Pmod_extension x -> sub.extension sub x @@ -239,7 +251,8 @@ module M = struct sub.location sub loc; match desc with | Pstr_eval (x, attrs) -> - sub.expr sub x; sub.attributes sub attrs + sub.expr sub x; + sub.attributes sub attrs | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs | Pstr_primitive vd -> sub.value_description sub vd | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l @@ -253,7 +266,8 @@ module M = struct | Pstr_class_type () -> () | Pstr_include x -> sub.include_declaration sub x | Pstr_extension (x, attrs) -> - sub.extension sub x; sub.attributes sub attrs + sub.extension sub x; + sub.attributes sub attrs | Pstr_attribute x -> sub.attribute sub x end @@ -267,68 +281,84 @@ module E = struct | Pexp_ident x -> iter_loc sub x | Pexp_constant _ -> () | Pexp_let (_r, vbs, e) -> - List.iter (sub.value_binding sub) vbs; - sub.expr sub e + List.iter (sub.value_binding sub) vbs; + sub.expr sub e | Pexp_fun (_lab, def, p, e) -> - iter_opt (sub.expr sub) def; - sub.pat sub p; - sub.expr sub e + iter_opt (sub.expr sub) def; + sub.pat sub p; + sub.expr sub e | Pexp_function pel -> sub.cases sub pel | Pexp_apply (e, l) -> - sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l + sub.expr sub e; + List.iter (iter_snd (sub.expr sub)) l | Pexp_match (e, pel) -> - sub.expr sub e; sub.cases sub pel - | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel + sub.expr sub e; + sub.cases sub pel + | Pexp_try (e, pel) -> + sub.expr sub e; + sub.cases sub pel | Pexp_tuple el -> List.iter (sub.expr sub) el | Pexp_construct (lid, arg) -> - iter_loc sub lid; iter_opt (sub.expr sub) arg - | Pexp_variant (_lab, eo) -> - iter_opt (sub.expr sub) eo + iter_loc sub lid; + iter_opt (sub.expr sub) arg + | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo | Pexp_record (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; - iter_opt (sub.expr sub) eo + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + iter_opt (sub.expr sub) eo | Pexp_field (e, lid) -> - sub.expr sub e; iter_loc sub lid + sub.expr sub e; + iter_loc sub lid | Pexp_setfield (e1, lid, e2) -> - sub.expr sub e1; iter_loc sub lid; - sub.expr sub e2 + sub.expr sub e1; + iter_loc sub lid; + sub.expr sub e2 | Pexp_array el -> List.iter (sub.expr sub) el | Pexp_ifthenelse (e1, e2, e3) -> - sub.expr sub e1; sub.expr sub e2; - iter_opt (sub.expr sub) e3 + sub.expr sub e1; + sub.expr sub e2; + iter_opt (sub.expr sub) e3 | Pexp_sequence (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 + sub.expr sub e1; + sub.expr sub e2 | Pexp_while (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 + sub.expr sub e1; + sub.expr sub e2 | Pexp_for (p, e1, e2, _d, e3) -> - sub.pat sub p; sub.expr sub e1; sub.expr sub e2; - sub.expr sub e3 + sub.pat sub p; + sub.expr sub e1; + sub.expr sub e2; + sub.expr sub e3 | Pexp_coerce (e, (), t2) -> - sub.expr sub e; - sub.typ sub t2 + sub.expr sub e; + sub.typ sub t2 | Pexp_constraint (e, t) -> - sub.expr sub e; sub.typ sub t + sub.expr sub e; + sub.typ sub t | Pexp_send (e, _s) -> sub.expr sub e | Pexp_new lid -> iter_loc sub lid | Pexp_setinstvar (s, e) -> - iter_loc sub s; sub.expr sub e + iter_loc sub s; + sub.expr sub e | Pexp_override sel -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel | Pexp_letmodule (s, me, e) -> - iter_loc sub s; sub.module_expr sub me; - sub.expr sub e + iter_loc sub s; + sub.module_expr sub me; + sub.expr sub e | Pexp_letexception (cd, e) -> - sub.extension_constructor sub cd; - sub.expr sub e + sub.extension_constructor sub cd; + sub.expr sub e | Pexp_assert e -> sub.expr sub e | Pexp_lazy e -> sub.expr sub e | Pexp_poly (e, t) -> - sub.expr sub e; iter_opt (sub.typ sub) t + sub.expr sub e; + iter_opt (sub.typ sub) t | Pexp_object () -> () | Pexp_newtype (_s, e) -> sub.expr sub e | Pexp_pack me -> sub.module_expr sub me | Pexp_open (_ovf, lid, e) -> - iter_loc sub lid; sub.expr sub e + iter_loc sub lid; + sub.expr sub e | Pexp_extension x -> sub.extension sub x | Pexp_unreachable -> () end @@ -342,30 +372,35 @@ module P = struct match desc with | Ppat_any -> () | Ppat_var s -> iter_loc sub s - | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s + | Ppat_alias (p, s) -> + sub.pat sub p; + iter_loc sub s | Ppat_constant _ -> () | Ppat_interval _ -> () | Ppat_tuple pl -> List.iter (sub.pat sub) pl | Ppat_construct (l, p) -> - iter_loc sub l; iter_opt (sub.pat sub) p + iter_loc sub l; + iter_opt (sub.pat sub) p | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p | Ppat_record (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl | Ppat_array pl -> List.iter (sub.pat sub) pl - | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 + | Ppat_or (p1, p2) -> + sub.pat sub p1; + sub.pat sub p2 | Ppat_constraint (p, t) -> - sub.pat sub p; sub.typ sub t + sub.pat sub p; + sub.typ sub t | Ppat_type s -> iter_loc sub s | Ppat_lazy p -> sub.pat sub p | Ppat_unpack s -> iter_loc sub s | Ppat_exception p -> sub.pat sub p | Ppat_extension x -> sub.extension sub x | Ppat_open (lid, p) -> - iter_loc sub lid; sub.pat sub p - + iter_loc sub lid; + sub.pat sub p end - (* Now, a generic AST mapper, to be extended to cover all kinds and cases of the OCaml grammar. The default behavior of the mapper is the identity. *) @@ -385,108 +420,87 @@ let default_iterator = type_extension = T.iter_type_extension; extension_constructor = T.iter_extension_constructor; value_description = - (fun this {pval_name; pval_type; pval_prim = _; pval_loc; - pval_attributes} -> + (fun this {pval_name; pval_type; pval_prim = _; pval_loc; pval_attributes} -> iter_loc this pval_name; this.typ this pval_type; this.attributes this pval_attributes; - this.location this pval_loc - ); - + this.location this pval_loc); pat = P.iter; expr = E.iter; - module_declaration = (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - iter_loc this pmd_name; - this.module_type this pmd_type; - this.attributes this pmd_attributes; - this.location this pmd_loc - ); - + iter_loc this pmd_name; + this.module_type this pmd_type; + this.attributes this pmd_attributes; + this.location this pmd_loc); module_type_declaration = (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - iter_loc this pmtd_name; - iter_opt (this.module_type this) pmtd_type; - this.attributes this pmtd_attributes; - this.location this pmtd_loc - ); - + iter_loc this pmtd_name; + iter_opt (this.module_type this) pmtd_type; + this.attributes this pmtd_attributes; + this.location this pmtd_loc); module_binding = (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - iter_loc this pmb_name; this.module_expr this pmb_expr; - this.attributes this pmb_attributes; - this.location this pmb_loc - ); - - + iter_loc this pmb_name; + this.module_expr this pmb_expr; + this.attributes this pmb_attributes; + this.location this pmb_loc); open_description = (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_lid; - this.location this popen_loc; - this.attributes this popen_attributes - ); - - + iter_loc this popen_lid; + this.location this popen_loc; + this.attributes this popen_attributes); include_description = (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_type this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - + this.module_type this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes); include_declaration = (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_expr this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - + this.module_expr this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes); value_binding = (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - this.pat this pvb_pat; - this.expr this pvb_expr; - this.location this pvb_loc; - this.attributes this pvb_attributes - ); - - + this.pat this pvb_pat; + this.expr this pvb_expr; + this.location this pvb_loc; + this.attributes this pvb_attributes); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - iter_loc this pcd_name; - T.iter_constructor_arguments this pcd_args; - iter_opt (this.typ this) pcd_res; - this.location this pcd_loc; - this.attributes this pcd_attributes - ); - + iter_loc this pcd_name; + T.iter_constructor_arguments this pcd_args; + iter_opt (this.typ this) pcd_res; + this.location this pcd_loc; + this.attributes this pcd_attributes); label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}-> - iter_loc this pld_name; - this.typ this pld_type; - this.location this pld_loc; - this.attributes this pld_attributes - ); - + (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes} -> + iter_loc this pld_name; + this.typ this pld_type; + this.location this pld_loc; + this.attributes this pld_attributes); cases = (fun this l -> List.iter (this.case this) l); case = (fun this {pc_lhs; pc_guard; pc_rhs} -> - this.pat this pc_lhs; - iter_opt (this.expr this) pc_guard; - this.expr this pc_rhs - ); - + this.pat this pc_lhs; + iter_opt (this.expr this) pc_guard; + this.expr this pc_rhs); location = (fun _this _l -> ()); - - extension = (fun this (s, e) -> iter_loc this s; this.payload this e); - attribute = (fun this (s, e) -> iter_loc this s; this.payload this e); + extension = + (fun this (s, e) -> + iter_loc this s; + this.payload this e); + attribute = + (fun this (s, e) -> + iter_loc this s; + this.payload this e); attributes = (fun this l -> List.iter (this.attribute this) l); payload = (fun this -> function - | PStr x -> this.structure this x - | PSig x -> this.signature this x - | PTyp x -> this.typ this x - | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g - ); + | PStr x -> this.structure this x + | PSig x -> this.signature this x + | PTyp x -> this.typ this x + | PPat (x, g) -> + this.pat this x; + iter_opt (this.expr this) g); } diff --git a/compiler/ml/ast_iterator.mli b/compiler/ml/ast_iterator.mli old mode 100755 new mode 100644 index cf533fb164..8c7b7a5e9f --- a/compiler/ml/ast_iterator.mli +++ b/compiler/ml/ast_iterator.mli @@ -59,5 +59,5 @@ type iterator = { argument the iterator to be applied to children in the syntax tree. *) -val default_iterator: iterator +val default_iterator : iterator (** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 0475aa6ad4..6e9f022d28 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -20,7 +20,6 @@ (* Ensure that record patterns don't miss any field. *) *) - open Parsetree open Ast_helper open Location @@ -30,12 +29,12 @@ type mapper = { attributes: mapper -> attribute list -> attribute list; case: mapper -> case -> case; cases: mapper -> case list -> case list; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; + constructor_declaration: + mapper -> constructor_declaration -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; label_declaration: mapper -> label_declaration -> label_declaration; @@ -44,8 +43,8 @@ type mapper = { module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; @@ -66,7 +65,9 @@ let map_fst f (x, y) = (f x, y) let map_snd f (x, y) = (x, f y) let map_tuple f1 f2 (x, y) = (f1 x, f2 y) let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let map_opt f = function None -> None | Some x -> Some (f x) +let map_opt f = function + | None -> None + | Some x -> Some (f x) let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} @@ -75,13 +76,13 @@ module T = struct let row_field sub = function | Rtag (l, attrs, b, tl) -> - Rtag (map_loc sub l, sub.attributes sub attrs, - b, List.map (sub.typ sub) tl) + Rtag + (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) | Rinherit t -> Rinherit (sub.typ sub t) let object_field sub = function | Otag (l, attrs, t) -> - Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) | Oinherit t -> Oinherit (sub.typ sub t) let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = @@ -92,36 +93,41 @@ module T = struct | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o + object_ ~loc ~attrs (List.map (object_field sub) l) o | Ptyp_class () -> assert false | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) + variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> + poly ~loc ~attrs (List.map (map_loc sub) sl) (sub.typ sub t) | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } = Type.mk (map_loc sub ptype_name) ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) + ~cstrs: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) ~kind:(sub.type_kind sub ptype_kind) ?manifest:(map_opt (sub.typ sub) ptype_manifest) ~loc:(sub.location sub ptype_loc) @@ -130,44 +136,39 @@ module T = struct let map_type_kind sub = function | Ptype_abstract -> Ptype_abstract | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) + Ptype_variant (List.map (sub.constructor_declaration sub) l) | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) | Ptype_open -> Ptype_open let map_constructor_arguments sub = function | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) + | Pcstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes; + } = + Te.mk (map_loc sub ptyext_path) (List.map (sub.extension_constructor sub) ptyext_constructors) ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) ~priv:ptyext_private ~attrs:(sub.attributes sub ptyext_attributes) let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) + | Pext_decl (ctl, cto) -> + Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) + | Pext_rebind li -> Pext_rebind (map_loc sub li) let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) + {pext_name; pext_kind; pext_loc; pext_attributes} = + Te.constructor (map_loc sub pext_name) (map_extension_constructor_kind sub pext_kind) ~loc:(sub.location sub pext_loc) ~attrs:(sub.attributes sub pext_attributes) - end module MT = struct @@ -182,24 +183,23 @@ module MT = struct | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Misc.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) + (sub.module_type sub mt2) | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_with_constraint sub = function | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) + Pwith_type (map_loc sub lid, sub.type_declaration sub d) | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) + Pwith_module (map_loc sub lid, map_loc sub lid2) | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let open Sig in @@ -211,18 +211,17 @@ module MT = struct | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) | Psig_module x -> module_ ~loc (sub.module_declaration sub x) | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) + rec_module ~loc (List.map (sub.module_declaration sub) l) | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) | Psig_open x -> open_ ~loc (sub.open_description sub x) | Psig_include x -> include_ ~loc (sub.include_description sub x) | Psig_class _ -> assert false | Psig_class_type _ -> assert false | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Psig_attribute x -> attribute ~loc (sub.attribute sub x) end - module M = struct (* Value expressions for the module language *) @@ -234,14 +233,13 @@ module M = struct | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Misc.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) + (sub.module_expr sub body) | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) @@ -250,7 +248,7 @@ module M = struct let loc = sub.location sub loc in match desc with | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) @@ -260,11 +258,11 @@ module M = struct | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class () -> {pstr_loc = loc ; pstr_desc = Pstr_class ()} - | Pstr_class_type () -> {pstr_loc = loc ; pstr_desc = Pstr_class_type ()} + | Pstr_class () -> {pstr_loc = loc; pstr_desc = Pstr_class ()} + | Pstr_class_type () -> {pstr_loc = loc; pstr_desc = Pstr_class_type ()} | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) end @@ -279,71 +277,69 @@ module E = struct | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) | Pexp_constant x -> constant ~loc ~attrs x | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) def) + (sub.pat sub p) (sub.expr sub e) | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) + apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) | Pexp_coerce (e, (), t2) -> - coerce ~loc ~attrs (sub.expr sub e) - (sub.typ sub t2) + coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) + setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) + override ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) + poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) | Pexp_object () -> assert false | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pexp_unreachable -> unreachable ~loc ~attrs () end @@ -363,24 +359,24 @@ module P = struct | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) end - (* Now, a generic AST mapper, to be extended to cover all kinds and cases of the OCaml grammar. The default behavior of the mapper is the identity. *) @@ -400,266 +396,230 @@ let default_mapper = type_extension = T.map_type_extension; extension_constructor = T.map_extension_constructor; value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) + (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> + Val.mk (map_loc this pval_name) (this.typ this pval_type) ~attrs:(this.attributes this pval_attributes) ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - + ~prim:pval_prim); pat = P.map; expr = E.map; - module_declaration = (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - + Md.mk (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc)); module_type_declaration = (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - + Mtd.mk (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc)); module_binding = (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - + Mb.mk (map_loc this pmb_name) + (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc)); open_description = (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - + Opn.mk (map_loc this popen_lid) ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes)); include_description = (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - + Incl.mk + (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); include_declaration = (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - + Incl.mk + (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); value_binding = (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) + Type.constructor (map_loc this pcd_name) ~args:(T.map_constructor_arguments this pcd_args) ?res:(map_opt (this.typ this) pcd_res) ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - + ~attrs:(this.attributes this pcd_attributes)); label_declaration = (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - + Type.field (map_loc this pld_name) (this.typ this pld_type) + ~mut:pld_mutable + ~loc:(this.location this pld_loc) + ~attrs:(this.attributes this pld_attributes)); cases = (fun this l -> List.map (this.case this) l); case = (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - + { + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + }); location = (fun _this l -> l); - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); attributes = (fun this l -> List.map (this.attribute this) l); payload = (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); } let rec extension_of_error {loc; msg; if_highlight; sub} = - { loc; txt = "ocaml.error" }, - PStr ([Str.eval (Exp.constant (Pconst_string (msg, None))); - Str.eval (Exp.constant (Pconst_string (if_highlight, None)))] @ - (List.map (fun ext -> Str.extension (extension_of_error ext)) sub)) + ( {loc; txt = "ocaml.error"}, + PStr + ([ + Str.eval (Exp.constant (Pconst_string (msg, None))); + Str.eval (Exp.constant (Pconst_string (if_highlight, None))); + ] + @ List.map (fun ext -> Str.extension (extension_of_error ext)) sub) ) let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) + ( {loc; txt = "ocaml.ppwarning"}, + PStr [Str.eval ~loc (Exp.constant (Pconst_string (s, None)))] ) -module StringMap = Map.Make(struct - type t = string - let compare = compare +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 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 set_cookie k v = cookies := StringMap.add k v !cookies let tool_name_ref = ref "_none_" let tool_name () = !tool_name_ref - module PpxContext = struct open Longident open Asttypes open Ast_helper - let lid name = { txt = Lident name; loc = Location.none } + let lid name = {txt = Lident name; loc = Location.none} let make_string x = Exp.constant (Pconst_string (x, None)) let make_bool x = - if x - then Exp.construct (lid "true") None + 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] + | [] -> Exp.construct (lid "[]") None + let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (StringMap.bindings !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)] + ( {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 "debug", make_bool !Clflags.debug; - get_cookies () + (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 "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" + | PStr + [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (fields, None)}, [])}] + -> + fields + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" let restore fields = let field name payload = let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name + | {pexp_desc = Pexp_constant (Pconst_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 + | {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 + | { + 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 + | {pexp_desc = Pexp_tuple [e1; e2]} -> (f1 e1, f2 e2) + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair 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 - | "debug" -> - Clflags.debug := get_bool payload + | "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 + | "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 - | _ -> - () + 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 + | _ -> () in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields + List.iter + (function + | {txt = Lident name}, x -> field name x + | _ -> ()) + fields let update_cookies fields = let fields = - Ext_list.filter fields - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) + Ext_list.filter fields (function + | {txt = Lident "cookies"}, _ -> false + | _ -> true) in fields @ [get_cookies ()] end @@ -669,17 +629,17 @@ let ppx_context = PpxContext.make let extension_of_exn exn = match error_of_exn exn with | Some (`Ok error) -> extension_of_error error - | Some `Already_displayed -> { loc = Location.none; txt = "ocaml.error" }, PStr [] + | Some `Already_displayed -> + ({loc = Location.none; txt = "ocaml.error"}, PStr []) | None -> raise exn - let apply_lazy ~source ~target mapper = let implem ast = let fields, ast = match ast with | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast + (PpxContext.get_fields x, l) + | _ -> ([], ast) in PpxContext.restore fields; let ast = @@ -687,8 +647,12 @@ let apply_lazy ~source ~target mapper = let mapper = mapper () in mapper.structure mapper ast with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] + [ + { + pstr_desc = Pstr_extension (extension_of_exn exn, []); + pstr_loc = Location.none; + }; + ] in let fields = PpxContext.update_cookies fields in Str.attribute (PpxContext.mk fields) :: ast @@ -697,8 +661,8 @@ let apply_lazy ~source ~target mapper = let fields, ast = match ast with | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast + (PpxContext.get_fields x, l) + | _ -> ([], ast) in PpxContext.restore fields; let ast = @@ -706,8 +670,12 @@ let apply_lazy ~source ~target mapper = let mapper = mapper () in mapper.signature mapper ast with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] + [ + { + psig_desc = Psig_extension (extension_of_exn exn, []); + psig_loc = Location.none; + }; + ] in let fields = PpxContext.update_cookies fields in Sig.attribute (PpxContext.mk fields) :: ast @@ -730,7 +698,7 @@ let apply_lazy ~source ~target mapper = close_out oc and fail () = close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; + failwith "Ast_mapper: OCaml version mismatch or malformed input" in if magic = Config.ast_impl_magic_number then @@ -740,19 +708,17 @@ let apply_lazy ~source ~target mapper = else fail () let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)} + | {pstr_desc = Pstr_attribute ({Location.txt = "ocaml.ppx.context"}, a)} :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields 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)} + | {psig_desc = Psig_attribute ({Location.txt = "ocaml.ppx.context"}, a)} :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items + if restore then PpxContext.restore (PpxContext.get_fields a); + items | items -> items let add_ppx_context_str ~tool_name ast = @@ -761,9 +727,7 @@ let add_ppx_context_str ~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 apply ~source ~target mapper = apply_lazy ~source ~target (fun () -> mapper) let run_main mapper = try @@ -778,11 +742,10 @@ let run_main mapper = {default_mapper with structure = f; signature = f} in apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin + else ( Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end + Sys.executable_name; + exit 2) with exn -> prerr_endline (Printexc.to_string exn); exit 2 diff --git a/compiler/ml/ast_mapper.mli b/compiler/ml/ast_mapper.mli index 51a105d8e7..745fdb8d20 100644 --- a/compiler/ml/ast_mapper.mli +++ b/compiler/ml/ast_mapper.mli @@ -57,12 +57,12 @@ type mapper = { attributes: mapper -> attribute list -> attribute list; case: mapper -> case -> case; cases: mapper -> case list -> case list; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; + constructor_declaration: + mapper -> constructor_declaration -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; label_declaration: mapper -> label_declaration -> label_declaration; @@ -71,8 +71,8 @@ type mapper = { module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; @@ -93,12 +93,12 @@ type mapper = { argument the mapper to be applied to children in the syntax tree. *) -val default_mapper: mapper +val default_mapper : mapper (** A default mapper, which implements a "deep identity" mapping. *) (** {1 Apply mappers to compilation units} *) -val tool_name: unit -> string +val tool_name : unit -> string (** Can be used within a ppx preprocessor to know which tool is calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], ["ocaml"], ... Some global variables that reflect command-line @@ -107,14 +107,13 @@ val tool_name: unit -> string {!Config.load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, {!Clflags.debug}. *) - -val apply: source:string -> target:string -> mapper -> unit +val apply : source:string -> target:string -> mapper -> unit (** Apply a mapper (parametrized by the unit name) to a dumped parsetree found in the [source] file and put the result in the [target] file. The [structure] or [signature] field of the mapper is applied to the implementation or interface. *) -val run_main: (string list -> mapper) -> unit +val run_main : (string list -> mapper) -> unit (** Entry point to call to implement a standalone -ppx rewriter from a mapper, parametrized by the command line arguments. The current unit name can be obtained from {!Location.input_name}. This @@ -123,9 +122,9 @@ val run_main: (string list -> mapper) -> unit (** {1 Registration API} *) -val register_function: (string -> (string list -> mapper) -> unit) ref +val register_function : (string -> (string list -> mapper) -> unit) ref -val register: string -> (string list -> mapper) -> unit +val register : string -> (string list -> mapper) -> unit (** Apply the [register_function]. The default behavior is to run the mapper immediately, taking arguments from the process command line. This is to support a scenario where a mapper is linked as a @@ -142,42 +141,41 @@ val register: string -> (string list -> mapper) -> unit The first argument to [register] is a symbolic name to be used by the ppx driver. *) - (** {1 Convenience functions to write mappers} *) -val map_opt: ('a -> 'b) -> 'a option -> 'b option +val map_opt : ('a -> 'b) -> 'a option -> 'b option -val extension_of_error: Location.error -> extension +val extension_of_error : Location.error -> extension (** Encode an error into an 'ocaml.error' extension node which can be inserted in a generated Parsetree. The compiler will be responsible for reporting the error. *) -val attribute_of_warning: Location.t -> string -> attribute +val attribute_of_warning : Location.t -> string -> attribute (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be inserted in a generated Parsetree. The compiler will be responsible for reporting the warning. *) (** {1 Helper functions to call external mappers} *) -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure +val add_ppx_context_str : + tool_name:string -> Parsetree.structure -> Parsetree.structure (** Extract information from the current environment and encode it 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 +val add_ppx_context_sig : + tool_name:string -> Parsetree.signature -> Parsetree.signature (** Same as [add_ppx_context_str], but for signatures. *) -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure +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 +val drop_ppx_context_sig : + restore:bool -> Parsetree.signature -> Parsetree.signature (** Same as [drop_ppx_context_str], but for signatures. *) (** {1 Cookies} *) @@ -186,5 +184,5 @@ val drop_ppx_context_sig: 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 +val set_cookie : string -> Parsetree.expression -> unit +val get_cookie : string -> Parsetree.expression option diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 0fe198d432..8a9d37854d 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -64,7 +64,10 @@ let is_single_int (x : t) : int option = ({pexp_desc = Pexp_constant (Pconst_integer (name, char)); _}, _); _; }; - ] when (match char with Some n when n = 'n' -> false | _ -> true) -> + ] + when match char with + | Some n when n = 'n' -> false + | _ -> true -> Some (int_of_string name) | _ -> None @@ -89,7 +92,8 @@ let is_single_bigint (x : t) : string option = { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_integer (name, Some 'n')); _}, _); + ( {pexp_desc = Pexp_constant (Pconst_integer (name, Some 'n')); _}, + _ ); _; }; ] -> @@ -146,17 +150,17 @@ let raw_as_string_exp_exn ~(kind : Js_raw_info.raw_kind) ?is_function (x : t) : Parser_flow.parse_expression (Parser_env.init_env None str) false in (if kind = Raw_re then - match e with - | Literal {value = RegExp _} -> () - | _ -> - Location.raise_errorf ~loc - "Syntax error: a valid JS regex literal expected"); + match e with + | Literal {value = RegExp _} -> () + | _ -> + Location.raise_errorf ~loc + "Syntax error: a valid JS regex literal expected"); (match is_function with - | Some is_function -> ( - match Classify_function.classify_exp prog with - | Js_function {arity; _} -> is_function := Some arity - | _ -> ()) - | None -> ()); + | Some is_function -> ( + match Classify_function.classify_exp prog with + | Js_function {arity; _} -> is_function := Some arity + | _ -> ()) + | None -> ()); errors | Raw_program -> snd (Parser_flow.parse_program false None str)); Some {e with pexp_desc = Pexp_constant (Pconst_string (str, None))} diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml index ef7ad20c5b..3d36fcc656 100644 --- a/compiler/ml/ast_uncurried.ml +++ b/compiler/ml/ast_uncurried.ml @@ -1,12 +1,13 @@ (* Uncurried AST *) - let encode_arity_string arity = "Has_arity" ^ string_of_int arity -let decode_arity_string arity_s = int_of_string ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) +let decode_arity_string arity_s = + int_of_string + ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) let arity_type ~loc arity = Ast_helper.Typ.variant ~loc - [ Rtag ({ txt = encode_arity_string arity; loc }, [], true, []) ] + [Rtag ({txt = encode_arity_string arity; loc}, [], true, [])] Closed None let arity_from_type (typ : Parsetree.core_type) = @@ -15,10 +16,8 @@ let arity_from_type (typ : Parsetree.core_type) = | _ -> assert false let uncurried_type ~loc ~arity t_arg = - let t_arity = arity_type ~loc arity in - Ast_helper.Typ.constr ~loc - { txt = Lident "function$"; loc } - [ t_arg; t_arity ] + let t_arity = arity_type ~loc arity in + Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity] let arity_to_attributes arity = [ @@ -33,34 +32,34 @@ let arity_to_attributes arity = let rec attributes_to_arity (attrs : Parsetree.attributes) = match attrs with - | ( { txt = "res.arity" }, + | ( {txt = "res.arity"}, PStr [ { pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_constant (Pconst_integer (arity, _)) }, _); + ({pexp_desc = Pexp_constant (Pconst_integer (arity, _))}, _); }; ] ) :: _ -> - int_of_string arity + int_of_string arity | _ :: rest -> attributes_to_arity rest | _ -> assert false let uncurried_fun ~loc ~arity fun_expr = - Ast_helper.Exp.construct ~loc - ~attrs:(arity_to_attributes arity) - (Location.mknoloc (Longident.Lident "Function$")) - (Some fun_expr) + Ast_helper.Exp.construct ~loc + ~attrs:(arity_to_attributes arity) + (Location.mknoloc (Longident.Lident "Function$")) + (Some fun_expr) let expr_is_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with - | Pexp_construct ({ txt = Lident "Function$" }, Some _) -> true + | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true | _ -> false let expr_extract_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with - | Pexp_construct ({ txt = Lident "Function$" }, Some e) -> e + | Pexp_construct ({txt = Lident "Function$"}, Some e) -> e | _ -> assert false let core_type_is_uncurried_fun (typ : Parsetree.core_type) = @@ -77,10 +76,9 @@ let core_type_extract_uncurried_fun (typ : Parsetree.core_type) = let type_is_uncurried_fun = Ast_uncurried_utils.type_is_uncurried_fun -let type_extract_uncurried_fun (typ : Types.type_expr) = +let type_extract_uncurried_fun (typ : Types.type_expr) = match typ.desc with - | Tconstr (Pident {name = "function$"}, [t_arg; _], _) -> - t_arg + | Tconstr (Pident {name = "function$"}, [t_arg; _], _) -> t_arg | _ -> assert false (* Typed AST *) @@ -90,7 +88,7 @@ let arity_to_type arity = Ctype.newty (Tvariant { - row_fields = [ (arity_s, Rpresent None) ]; + row_fields = [(arity_s, Rpresent None)]; row_more = Ctype.newty Tnil; row_bound = (); row_closed = true; @@ -100,26 +98,23 @@ let arity_to_type arity = let type_to_arity (t_arity : Types.type_expr) = match (Ctype.repr t_arity).desc with - | Tvariant { row_fields = [ (label, _) ] } -> decode_arity_string label + | Tvariant {row_fields = [(label, _)]} -> decode_arity_string label | _ -> assert false let make_uncurried_type ~env ~arity t = let typ_arity = arity_to_type arity in let lid : Longident.t = Lident "function$" in let path = Env.lookup_type lid env in - Ctype.newconstr path [ t; typ_arity ] + Ctype.newconstr path [t; typ_arity] let uncurried_type_get_arity ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident { name = "function$" }, [ _t; t_arity ], _) -> - type_to_arity t_arity + | Tconstr (Pident {name = "function$"}, [_t; t_arity], _) -> + type_to_arity t_arity | _ -> assert false let uncurried_type_get_arity_opt ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident { name = "function$" }, [ _t; t_arity ], _) -> - Some (type_to_arity t_arity) + | Tconstr (Pident {name = "function$"}, [_t; t_arity], _) -> + Some (type_to_arity t_arity) | _ -> None - - - diff --git a/compiler/ml/ast_uncurried_utils.ml b/compiler/ml/ast_uncurried_utils.ml index d884593903..fd0ea89839 100644 --- a/compiler/ml/ast_uncurried_utils.ml +++ b/compiler/ml/ast_uncurried_utils.ml @@ -1,5 +1,4 @@ let type_is_uncurried_fun (typ : Types.type_expr) = match typ.desc with - | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> - true - | _ -> false \ No newline at end of file + | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> true + | _ -> false diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 0ac0d54d1c..ab53f3961e 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -1,17 +1,11 @@ module Instance = struct - type t = - | Array - | Blob - | Date - | File - | Promise - | RegExp + type t = Array | Blob | Date | File | Promise | RegExp let to_string = function - Array -> "Array" + | Array -> "Array" | Blob -> "Blob" | Date -> "Date" | File -> "File" - | Promise -> "Promise" + | Promise -> "Promise" | RegExp -> "RegExp" end @@ -46,19 +40,24 @@ let report_error ppf = | InvalidUntaggedVariantDefinition untagged_variant -> fprintf ppf "This untagged variant definition is invalid: %s" (match untagged_variant with - | OnlyOneUnknown name -> "Case " ^ name ^ " has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads." + | OnlyOneUnknown name -> + "Case " ^ name + ^ " has a payload that is not of one of the recognized shapes (object, \ + array, etc). Then it must be the only case with payloads." | AtMostOneObject -> "At most one case can be an object type." - | AtMostOneInstance Array -> "At most one case can be an array or tuple type." - | AtMostOneInstance i -> "At most one case can be a " ^ (Instance.to_string i) ^ " type." + | AtMostOneInstance Array -> + "At most one case can be an array or tuple type." + | AtMostOneInstance i -> + "At most one case can be a " ^ Instance.to_string i ^ " type." | AtMostOneFunction -> "At most one case can be a function type." | AtMostOneString -> "At most one case can be a string type." | AtMostOneBoolean -> "At most one case can be a boolean type." | AtMostOneNumber -> "At most one case can be a number type (int or float)." - | AtMostOneBigint -> - "At most one case can be a bigint type." + | AtMostOneBigint -> "At most one case can be a bigint type." | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." - | ConstructorMoreThanOneArg (name) -> "Constructor " ^ name ^ " has more than one argument.") + | ConstructorMoreThanOneArg name -> + "Constructor " ^ name ^ " has more than one argument.") (* Type of the runtime representation of an untagged block (case with payoad) *) type block_type = @@ -103,11 +102,12 @@ let process_untagged (attrs : Parsetree.attributes) = | _ -> ()); !st -let extract_concrete_typedecl: (Env.t -> - Types.type_expr -> - Path.t * Path.t * Types.type_declaration) ref = ref (Obj.magic ()) +let extract_concrete_typedecl : + (Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration) ref = + ref (Obj.magic ()) -let expand_head: (Env.t -> Types.type_expr -> Types.type_expr) ref = ref (Obj.magic ()) +let expand_head : (Env.t -> Types.type_expr -> Types.type_expr) ref = + ref (Obj.magic ()) let process_tag_type (attrs : Parsetree.attributes) = let st : tag_type option ref = ref None in @@ -147,7 +147,9 @@ let () = | _ -> None) let report_constructor_more_than_one_arg ~loc ~name = - raise (Error (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) + raise + (Error + (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) let type_is_builtin_object (t : Types.type_expr) = match t.desc with @@ -161,18 +163,17 @@ let type_to_instanceof_backed_obj (t : Types.type_expr) = match t.desc with | Tconstr (path, _, _) when Path.same path Predef.path_promise -> Some Instance.Promise - | Tconstr (path, _, _) when Path.same path Predef.path_array -> - Some Array + | Tconstr (path, _, _) when Path.same path Predef.path_array -> Some Array | Tconstr (path, _, _) -> ( match Path.name path with - | "Js_date.t" -> Some(Date) - | "Js_re.t" -> Some(RegExp) - | "Js_file.t" -> Some(File) - | "Js_blob.t" -> Some(Blob) + | "Js_date.t" -> Some Date + | "Js_re.t" -> Some RegExp + | "Js_file.t" -> Some File + | "Js_blob.t" -> Some Blob | _ -> None) | _ -> None -let get_block_type_from_typ ~env (t: Types.type_expr) : block_type option = +let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = let t = !expand_head env t in match t with | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> @@ -184,17 +185,17 @@ let get_block_type_from_typ ~env (t: Types.type_expr) : block_type option = | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint -> Some BigintType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> - Some BooleanType - | ({desc = Tconstr _} as t) when Ast_uncurried_utils.type_is_uncurried_fun t -> + Some BooleanType + | {desc = Tconstr _} as t when Ast_uncurried_utils.type_is_uncurried_fun t -> Some FunctionType | {desc = Tarrow _} -> Some FunctionType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> Some StringType - | ({desc = Tconstr _} as t) when type_is_builtin_object t -> - Some ObjectType - | ({desc = Tconstr _} as t) when type_to_instanceof_backed_obj t |> Option.is_some -> - (match type_to_instanceof_backed_obj t with - | None -> None + | {desc = Tconstr _} as t when type_is_builtin_object t -> Some ObjectType + | {desc = Tconstr _} as t + when type_to_instanceof_backed_obj t |> Option.is_some -> ( + match type_to_instanceof_backed_obj t with + | None -> None | Some instance_type -> Some (InstanceType instance_type)) | {desc = Ttuple _} -> Some (InstanceType Array) | _ -> None @@ -203,7 +204,9 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : block_type option = match (process_untagged cstr.cd_attributes, cstr.cd_args) with | false, _ -> None - | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some -> get_block_type_from_typ ~env t + | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some + -> + get_block_type_from_typ ~env t | true, Cstr_tuple [ty] -> ( let default = Some UnknownType in match !extract_concrete_typedecl env ty with @@ -266,12 +269,15 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) in let invariant loc name = if !unknown_types <> 0 && List.length blocks <> 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); + raise + (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); if !object_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); - Hashtbl.iter (fun i count -> + Hashtbl.iter + (fun i count -> if count > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) + raise + (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) instance_types; if !function_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); @@ -283,8 +289,11 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); if !boolean_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - if !boolean_types > 0 && (StringSet.mem "true" !nonstring_literals || StringSet.mem "false" !nonstring_literals) then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); + if + !boolean_types > 0 + && (StringSet.mem "true" !nonstring_literals + || StringSet.mem "false" !nonstring_literals) + then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); () in Ext_list.rev_iter consts (fun (loc, literal) -> @@ -295,28 +304,29 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) | Some (BigInt i) -> add_nonstring_literal ~loc i | Some Null -> add_nonstring_literal ~loc "null" | Some Undefined -> add_nonstring_literal ~loc "undefined" - | Some (Bool b) -> add_nonstring_literal ~loc (if b then "true" else "false") + | Some (Bool b) -> + add_nonstring_literal ~loc (if b then "true" else "false") | Some (Untagged _) -> () | None -> add_string_literal ~loc literal.name); if is_untagged_def then Ext_list.rev_iter blocks (fun (loc, block) -> - match block.block_type with - | Some block_type -> - (match block_type with - | UnknownType -> incr unknown_types; - | ObjectType -> incr object_types; - | (InstanceType i) -> - let count = Hashtbl.find_opt instance_types i |> Option.value ~default:0 in - Hashtbl.replace instance_types i (count + 1); - | FunctionType -> incr function_types; - | (IntType | FloatType) -> incr number_types; - | BigintType -> incr bigint_types; - | BooleanType -> incr boolean_types; - | StringType -> incr string_types; - ); - invariant loc block.tag.name - | None -> () - ) + match block.block_type with + | Some block_type -> + (match block_type with + | UnknownType -> incr unknown_types + | ObjectType -> incr object_types + | InstanceType i -> + let count = + Hashtbl.find_opt instance_types i |> Option.value ~default:0 + in + Hashtbl.replace instance_types i (count + 1) + | FunctionType -> incr function_types + | IntType | FloatType -> incr number_types + | BigintType -> incr bigint_types + | BooleanType -> incr boolean_types + | StringType -> incr string_types); + invariant loc block.tag.name + | None -> ()) let names_from_type_variant ?(is_untagged_def = false) ~env (cstrs : Types.constructor_declaration list) = @@ -474,17 +484,25 @@ module DynamicChecks = struct typeof e != object_ let add_runtime_type_check ~tag_type ~(block_cases : block_type list) x y = - let instances = Ext_list.filter_map block_cases (function InstanceType i -> Some i | _ -> None) in + let instances = + Ext_list.filter_map block_cases (function + | InstanceType i -> Some i + | _ -> None) + in match tag_type with - | Untagged (IntType | StringType | FloatType | BigintType | BooleanType | FunctionType) -> + | Untagged + ( IntType | StringType | FloatType | BigintType | BooleanType + | FunctionType ) -> typeof y == x | Untagged ObjectType -> if instances <> [] then - let not_one_of_the_instances = - Ext_list.fold_right instances (typeof y == x) (fun i x -> x &&& not (is_instance i y)) in - not_one_of_the_instances - else - typeof y == x + let not_one_of_the_instances = + Ext_list.fold_right instances + (typeof y == x) + (fun i x -> x &&& not (is_instance i y)) + in + not_one_of_the_instances + else typeof y == x | Untagged (InstanceType i) -> is_instance i y | Untagged UnknownType -> (* This should not happen because unknown must be the only non-literal case *) diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml index 5abbdaa0a6..174d3aa793 100644 --- a/compiler/ml/asttypes.ml +++ b/compiler/ml/asttypes.ml @@ -16,7 +16,7 @@ (** Auxiliary AST types used by parsetree and typedtree. *) type constant = - Const_int of int + | Const_int of int | Const_char of int | Const_string of string * string option | Const_float of string @@ -42,32 +42,22 @@ type closed_flag = Closed | Open type label = string type arg_label = - Nolabel + | Nolabel | Labelled of string (* label:T -> ... *) | Optional of string (* ?label:T -> ... *) -type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; -} +type 'a loc = 'a Location.loc = {txt: 'a; loc: Location.t} +type variance = Covariant | Contravariant | Invariant -type variance = - | Covariant - | Contravariant - | Invariant - - -let same_arg_label (x : arg_label) y = - match x with +let same_arg_label (x : arg_label) y = + match x with | Nolabel -> y = Nolabel - | Labelled s -> - begin match y with - | Labelled s0 -> s = s0 - | _ -> false - end - | Optional s -> - begin match y with - | Optional s0 -> s = s0 - | _ -> false - end + | Labelled s -> ( + match y with + | Labelled s0 -> s = s0 + | _ -> false) + | Optional s -> ( + match y with + | Optional s0 -> s = s0 + | _ -> false) diff --git a/compiler/ml/bigint_utils.ml b/compiler/ml/bigint_utils.ml index e0f3fe9ac1..2454e0d158 100644 --- a/compiler/ml/bigint_utils.ml +++ b/compiler/ml/bigint_utils.ml @@ -6,25 +6,25 @@ let to_string sign s = (if sign then "" else "-") ^ s let remove_leading_sign str : bool * string = let len = String.length str in if len = 0 then (false, str) - else - if is_neg str || is_pos str then (not (is_neg str), String.sub str 1 (len -1)) - else (true, str) + else if is_neg str || is_pos str then + (not (is_neg str), String.sub str 1 (len - 1)) + else (true, str) + +(* + Removes leading zeros from the string only if the first non-zero character + encountered is a digit. Unlike int and float, bigint cannot be of_string, so + This function removes only leading 0s. Instead, values like 00x1 are not converted + and are intended to be syntax errors. -(* - Removes leading zeros from the string only if the first non-zero character - encountered is a digit. Unlike int and float, bigint cannot be of_string, so - This function removes only leading 0s. Instead, values like 00x1 are not converted - and are intended to be syntax errors. + 000n -> 0n + 001n -> 1n + 01_000_000n -> 1000000n + -00100n -> -100n - 000n -> 0n - 001n -> 1n - 01_000_000n -> 1000000n - -00100n -> -100n - - The following values are syntax errors + The following values are syntax errors - 00o1n -> 00o1n - 00x1_000_000n -> 00x1000000n + 00o1n -> 00o1n + 00x1_000_000n -> 00x1000000n *) let remove_leading_zeros str = let aux str = @@ -36,15 +36,20 @@ let remove_leading_zeros str = while !idx < len && str.[!idx] = '0' do incr idx done; - if !idx >= len then "0" (* If the string contains only '0's, return '0'. *) - else if (is_digit str.[!idx]) then String.sub str !idx (len - !idx) (* Remove leading zeros and return the rest of the string. *) + if !idx >= len then "0" + (* If the string contains only '0's, return '0'. *) + else if is_digit str.[!idx] then String.sub str !idx (len - !idx) + (* Remove leading zeros and return the rest of the string. *) else str in (* Replace the delimiters '_' inside number *) let str = String.concat "" (String.split_on_char '_' str) in (* Check if negative *) let starts_with_minus = str <> "" && str.[0] = '-' in - let str = if is_neg str || is_pos str then String.sub str 1 (String.length str - 1) else str in + let str = + if is_neg str || is_pos str then String.sub str 1 (String.length str - 1) + else str + in let processed_str = aux str in if starts_with_minus then "-" ^ processed_str else processed_str @@ -58,27 +63,32 @@ let is_valid s = else let is_digit c = (c >= '0' && c <= '9') || c = '_' in let first_char = s.[0] in - if first_char <> '-' && first_char <> '+' && not (is_digit first_char) then false + if first_char <> '-' && first_char <> '+' && not (is_digit first_char) then + false else let rec check idx = if idx >= len then true else let c = s.[idx] in - if is_digit c then check (idx + 1) - else false + if is_digit c then check (idx + 1) else false in check 1 let compare (p0, s0) (p1, s1) = match (p0, p1) with - | (false, true) -> -1 (* If only s1 is positive, s0 is smaller. *) - | (true, false) -> 1 (* If only s0 is positive, s0 is larger. *) + | false, true -> -1 (* If only s1 is positive, s0 is smaller. *) + | true, false -> 1 (* If only s0 is positive, s0 is larger. *) | _ -> (* If both numbers are either negative or positive, compare their lengths. *) let len0, len1 = (String.length s0, String.length s1) in if len0 = len1 then - if p0 then String.compare s0 s1 else String.compare s1 s0 (* If lengths are equal, compare the strings directly. *) - else if len0 > len1 then - if p0 then 1 else -1 (* A longer s0 means it's larger unless it's negative. *) - else (* len0 < len1 *) - if p0 then -1 else 1 (* A longer s1 means s0 is smaller unless s1 is negative. *) + if p0 then String.compare s0 s1 + else + String.compare s1 + s0 (* If lengths are equal, compare the strings directly. *) + else if len0 > len1 then + if p0 then 1 + else -1 (* A longer s0 means it's larger unless it's negative. *) + else if (* len0 < len1 *) + p0 then -1 + else 1 (* A longer s1 means s0 is smaller unless s1 is negative. *) diff --git a/compiler/ml/bigint_utils.mli b/compiler/ml/bigint_utils.mli index 34f9dfb628..14b09a9efc 100644 --- a/compiler/ml/bigint_utils.mli +++ b/compiler/ml/bigint_utils.mli @@ -1,8 +1,8 @@ -val is_neg: string -> bool -val is_pos: string -> bool -val to_string: bool -> string -> string +val is_neg : string -> bool +val is_pos : string -> bool +val to_string : bool -> string -> string val remove_leading_sign : string -> bool * string val remove_leading_zeros : string -> string -val parse_bigint: string -> bool * string +val parse_bigint : string -> bool * string val is_valid : string -> bool val compare : bool * string -> bool * string -> int diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index df9f8a4700..461f1dbf05 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -21,9 +21,9 @@ open Types (**** Sets, maps and hashtables of types ****) -module TypeSet = Set.Make(TypeOps) +module TypeSet = Set.Make (TypeOps) module TypeMap = Map.Make (TypeOps) -module TypeHash = Hashtbl.Make(TypeOps) +module TypeHash = Hashtbl.Make (TypeOps) (**** Forward declarations ****) @@ -36,16 +36,17 @@ let generic_level = 100000000 (* Used to mark a type during a traversal. *) let lowest_level = 0 -let pivot_level = 2 * lowest_level - 1 - (* pivot_level - lowest_level < lowest_level *) +let pivot_level = (2 * lowest_level) - 1 +(* pivot_level - lowest_level < lowest_level *) (**** Some type creators ****) let new_id = ref (-1) -let newty2 level desc = - incr new_id; { desc; level; id = !new_id } -let newgenty desc = newty2 generic_level desc +let newty2 level desc = + incr new_id; + {desc; level; id = !new_id} +let newgenty desc = newty2 generic_level desc let newgenvar ?name () = newgenty (Tvar name) (* let newmarkedvar level = @@ -57,19 +58,25 @@ let newmarkedgenvar () = (**** Check some types ****) -let is_Tvar = function {desc=Tvar _} -> true | _ -> false -let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false -let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false +let is_Tvar = function + | {desc = Tvar _} -> true + | _ -> false +let is_Tunivar = function + | {desc = Tunivar _} -> true + | _ -> false +let is_Tconstr = function + | {desc = Tconstr _} -> true + | _ -> false let dummy_method = "*dummy method*" let default_mty = function - Some mty -> mty + | Some mty -> mty | None -> Mty_signature [] (**** Definitions for backtracking ****) type change = - Ctype of type_expr * type_desc + | Ctype of type_expr * type_desc | Ccompress of type_expr * type_desc * type_desc | Clevel of type_expr * int | Cname of @@ -80,218 +87,225 @@ type change = | Cuniv of type_expr option ref * type_expr option | Ctypeset of TypeSet.t ref * TypeSet.t -type changes = - Change of change * changes ref - | Unchanged - | Invalid +type changes = Change of change * changes ref | Unchanged | Invalid let trail = Weak.create 1 let log_change ch = - match Weak.get trail 0 with None -> () + match Weak.get trail 0 with + | None -> () | Some r -> - let r' = ref Unchanged in - r := Change (ch, r'); - Weak.set trail 0 (Some r') + let r' = ref Unchanged in + r := Change (ch, r'); + Weak.set trail 0 (Some r') (**** Representative of a type ****) -let rec field_kind_repr = - function - Fvar {contents = Some kind} -> field_kind_repr kind - | kind -> kind - -let rec repr_link compress t d = - function - {desc = Tlink t' as d'} -> - repr_link true t d' t' - | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> - repr_link true t d' t' - | t' -> - if compress then begin - log_change (Ccompress (t, t.desc, d)); t.desc <- d - end; - t' +let rec field_kind_repr = function + | Fvar {contents = Some kind} -> field_kind_repr kind + | kind -> kind + +let rec repr_link compress t d = function + | {desc = Tlink t' as d'} -> repr_link true t d' t' + | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> + repr_link true t d' t' + | t' -> + if compress then ( + log_change (Ccompress (t, t.desc, d)); + t.desc <- d); + t' let repr t = match t.desc with - Tlink t' as d -> - repr_link false t d t' - | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> - repr_link false t d t' - | _ -> t + | Tlink t' as d -> repr_link false t d t' + | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> + repr_link false t d t' + | _ -> t let rec commu_repr = function - Clink r when !r <> Cunknown -> commu_repr !r + | Clink r when !r <> Cunknown -> commu_repr !r | c -> c let rec row_field_repr_aux tl = function - Reither(_, tl', _, {contents = Some fi}) -> - row_field_repr_aux (tl@tl') fi - | Reither(c, tl', m, r) -> - Reither(c, tl@tl', m, r) - | Rpresent (Some _) when tl <> [] -> - Rpresent (Some (List.hd tl)) + | Reither (_, tl', _, {contents = Some fi}) -> + row_field_repr_aux (tl @ tl') fi + | Reither (c, tl', m, r) -> Reither (c, tl @ tl', m, r) + | Rpresent (Some _) when tl <> [] -> Rpresent (Some (List.hd tl)) | fi -> fi let row_field_repr fi = row_field_repr_aux [] fi let rec rev_concat l ll = match ll with - [] -> l - | l'::ll -> rev_concat (l'@l) ll + | [] -> l + | l' :: ll -> rev_concat (l' @ l) ll let rec row_repr_aux ll row = match (repr row.row_more).desc with | Tvariant row' -> - let f = row.row_fields in - row_repr_aux (if f = [] then ll else f::ll) row' + let f = row.row_fields in + row_repr_aux (if f = [] then ll else f :: ll) row' | _ -> - if ll = [] then row else - {row with row_fields = rev_concat row.row_fields ll} + if ll = [] then row + else {row with row_fields = rev_concat row.row_fields ll} let row_repr row = row_repr_aux [] row let rec row_field tag row = let rec find = function - | (tag',f) :: fields -> - if tag = tag' then row_field_repr f else find fields - | [] -> - match repr row.row_more with - | {desc=Tvariant row'} -> row_field tag row' - | _ -> Rabsent - in find row.row_fields + | (tag', f) :: fields -> + if tag = tag' then row_field_repr f else find fields + | [] -> ( + match repr row.row_more with + | {desc = Tvariant row'} -> row_field tag row' + | _ -> Rabsent) + in + find row.row_fields let rec row_more row = match repr row.row_more with - | {desc=Tvariant row'} -> row_more row' + | {desc = Tvariant row'} -> row_more row' | ty -> ty let row_fixed row = let row = row_repr row in - row.row_fixed || + row.row_fixed + || match (repr row.row_more).desc with - Tvar _ | Tnil -> false + | Tvar _ | Tnil -> false | Tunivar _ | Tconstr _ -> true | _ -> assert false let static_row row = let row = row_repr row in - row.row_closed && - List.for_all - (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) - row.row_fields + row.row_closed + && List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither _ -> false + | _ -> true) + row.row_fields let hash_variant s = let accu = ref 0 in for i = 0 to String.length s - 1 do - accu := 223 * !accu + Char.code s.[i] + accu := (223 * !accu) + Char.code s.[i] done; (* reduce to 31 bits *) - accu := !accu land (1 lsl 31 - 1); + accu := !accu land ((1 lsl 31) - 1); (* make it signed for 64 bits architectures *) if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu let proxy ty = let ty0 = repr ty in match ty0.desc with - | Tvariant row when not (static_row row) -> - row_more row + | Tvariant row when not (static_row row) -> row_more row | Tobject (ty, _) -> - let rec proxy_obj ty = - match ty.desc with - Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty - | Tvar _ | Tunivar _ | Tconstr _ -> ty - | Tnil -> ty0 - | _ -> assert false - in proxy_obj ty + let rec proxy_obj ty = + match ty.desc with + | Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty0 + | _ -> assert false + in + proxy_obj ty | _ -> ty0 (**** Utilities for fixed row private types ****) -let row_of_type t = +let row_of_type t = match (repr t).desc with - Tobject(t,_) -> - let rec get_row t = - let t = repr t in - match t.desc with - Tfield(_,_,_,t) -> get_row t - | _ -> t - in get_row t - | Tvariant row -> - row_more row - | _ -> - t - -let has_constr_row t = - not (is_Tconstr t) && is_Tconstr (row_of_type t) + | Tobject (t, _) -> + let rec get_row t = + let t = repr t in + match t.desc with + | Tfield (_, _, _, t) -> get_row t + | _ -> t + in + get_row t + | Tvariant row -> row_more row + | _ -> t + +let has_constr_row t = (not (is_Tconstr t)) && is_Tconstr (row_of_type t) let is_row_name s = let l = String.length s in - if l < 4 then false else String.sub s (l-4) 4 = "#row" + if l < 4 then false else String.sub s (l - 4) 4 = "#row" let is_constr_row ~allow_ident t = match t.desc with - Tconstr (Path.Pident id, _, _) when allow_ident -> - is_row_name (Ident.name id) + | Tconstr (Path.Pident id, _, _) when allow_ident -> + is_row_name (Ident.name id) | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s | _ -> false - - (**********************************) - (* Utilities for type traversal *) - (**********************************) +(**********************************) +(* Utilities for type traversal *) +(**********************************) let rec iter_row f row = List.iter (fun (_, fi) -> match row_field_repr fi with - | Rpresent(Some ty) -> f ty - | Reither(_, tl, _, _) -> List.iter f tl + | Rpresent (Some ty) -> f ty + | Reither (_, tl, _, _) -> List.iter f tl | _ -> ()) row.row_fields; match (repr row.row_more).desc with - Tvariant row -> iter_row f row + | Tvariant row -> iter_row f row | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> - Misc.may (fun (_,l) -> List.iter f l) row.row_name + Misc.may (fun (_, l) -> List.iter f l) row.row_name | _ -> assert false let iter_type_expr f ty = match ty.desc with - Tvar _ -> () - | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2 - | Ttuple l -> List.iter f l - | Tconstr (_, l, _) -> List.iter f l - | Tobject(ty, {contents = Some (_, p)}) - -> f ty; List.iter f p - | Tobject (ty, _) -> f ty - | Tvariant row -> iter_row f row; f (row_more row) - | Tfield (_, _, ty1, ty2) -> f ty1; f ty2 - | Tnil -> () - | Tlink ty -> f ty - | Tsubst ty -> f ty - | Tunivar _ -> () - | Tpoly (ty, tyl) -> f ty; List.iter f tyl - | Tpackage (_, _, l) -> List.iter f l + | Tvar _ -> () + | Tarrow (_, ty1, ty2, _) -> + f ty1; + f ty2 + | Ttuple l -> List.iter f l + | Tconstr (_, l, _) -> List.iter f l + | Tobject (ty, {contents = Some (_, p)}) -> + f ty; + List.iter f p + | Tobject (ty, _) -> f ty + | Tvariant row -> + iter_row f row; + f (row_more row) + | Tfield (_, _, ty1, ty2) -> + f ty1; + f ty2 + | Tnil -> () + | Tlink ty -> f ty + | Tsubst ty -> f ty + | Tunivar _ -> () + | Tpoly (ty, tyl) -> + f ty; + List.iter f tyl + | Tpackage (_, _, l) -> List.iter f l let rec iter_abbrev f = function - Mnil -> () - | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem - | Mlink rem -> iter_abbrev f !rem - -type type_iterators = - { it_signature: type_iterators -> signature -> unit; - it_signature_item: type_iterators -> signature_item -> unit; - it_value_description: type_iterators -> value_description -> unit; - it_type_declaration: type_iterators -> type_declaration -> unit; - it_extension_constructor: type_iterators -> extension_constructor -> unit; - it_module_declaration: type_iterators -> module_declaration -> unit; - it_modtype_declaration: type_iterators -> modtype_declaration -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_type_kind: type_iterators -> type_kind -> unit; - it_do_type_expr: type_iterators -> type_expr -> unit; - it_type_expr: type_iterators -> type_expr -> unit; - it_path: Path.t -> unit; } + | Mnil -> () + | Mcons (_, _, ty, ty', rem) -> + f ty; + f ty'; + iter_abbrev f rem + | Mlink rem -> iter_abbrev f !rem + +type type_iterators = { + it_signature: type_iterators -> signature -> unit; + it_signature_item: type_iterators -> signature_item -> unit; + it_value_description: type_iterators -> value_description -> unit; + it_type_declaration: type_iterators -> type_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; + it_module_declaration: type_iterators -> module_declaration -> unit; + it_modtype_declaration: type_iterators -> modtype_declaration -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_type_kind: type_iterators -> type_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; + it_type_expr: type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; +} let iter_type_expr_cstr_args f = function | Cstr_tuple tl -> List.iter f tl @@ -300,36 +314,30 @@ let iter_type_expr_cstr_args f = function let map_type_expr_cstr_args f = function | Cstr_tuple tl -> Cstr_tuple (List.map f tl) | Cstr_record lbls -> - Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) + Cstr_record (List.map (fun d -> {d with ld_type = f d.ld_type}) lbls) let iter_type_expr_kind f = function | Type_abstract -> () | Type_variant cstrs -> - List.iter - (fun cd -> - iter_type_expr_cstr_args f cd.cd_args; - Misc.may f cd.cd_res - ) - cstrs - | Type_record(lbls, _) -> - List.iter (fun d -> f d.ld_type) lbls - | Type_open -> - () - + List.iter + (fun cd -> + iter_type_expr_cstr_args f cd.cd_args; + Misc.may f cd.cd_res) + cstrs + | Type_record (lbls, _) -> List.iter (fun d -> f d.ld_type) lbls + | Type_open -> () let type_iterators = - let it_signature it = - List.iter (it.it_signature_item it) + let it_signature it = List.iter (it.it_signature_item it) and it_signature_item it = function - Sig_value (_, vd) -> it.it_value_description it vd - | Sig_type (_, td, _) -> it.it_type_declaration it td + | Sig_value (_, vd) -> it.it_value_description it vd + | Sig_type (_, td, _) -> it.it_type_declaration it td | Sig_typext (_, td, _) -> it.it_extension_constructor it td | Sig_module (_, md, _) -> it.it_module_declaration it md - | Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd - | Sig_class () -> assert false + | Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd + | Sig_class () -> assert false | Sig_class_type () -> assert false - and it_value_description it vd = - it.it_type_expr it vd.val_type + and it_value_description it vd = it.it_type_expr it vd.val_type and it_type_declaration it td = List.iter (it.it_type_expr it) td.type_params; may (it.it_type_expr it) td.type_manifest; @@ -339,154 +347,162 @@ let type_iterators = List.iter (it.it_type_expr it) td.ext_type_params; iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; may (it.it_type_expr it) td.ext_ret_type - and it_module_declaration it md = - it.it_module_type it md.md_type - and it_modtype_declaration it mtd = - may (it.it_module_type it) mtd.mtd_type + and it_module_declaration it md = it.it_module_type it md.md_type + and it_modtype_declaration it mtd = may (it.it_module_type it) mtd.mtd_type and it_module_type it = function - Mty_ident p - | Mty_alias(_, p) -> it.it_path p + | Mty_ident p | Mty_alias (_, p) -> it.it_path p | Mty_signature sg -> it.it_signature it sg | Mty_functor (_, mto, mt) -> - may (it.it_module_type it) mto; - it.it_module_type it mt - and it_type_kind it kind = - iter_type_expr_kind (it.it_type_expr it) kind + may (it.it_module_type it) mto; + it.it_module_type it mt + and it_type_kind it kind = iter_type_expr_kind (it.it_type_expr it) kind and it_do_type_expr it ty = iter_type_expr (it.it_type_expr it) ty; match ty.desc with - Tconstr (p, _, _) - | Tobject (_, {contents=Some (p, _)}) + | Tconstr (p, _, _) + | Tobject (_, {contents = Some (p, _)}) | Tpackage (p, _, _) -> - it.it_path p - | Tvariant row -> - may (fun (p,_) -> it.it_path p) (row_repr row).row_name + it.it_path p + | Tvariant row -> may (fun (p, _) -> it.it_path p) (row_repr row).row_name | _ -> () - and it_path _p = () - in - { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; - it_type_kind; it_module_type; + and it_path _p = () in + { + it_path; + it_type_expr = it_do_type_expr; + it_do_type_expr; + it_type_kind; + it_module_type; it_signature; - it_modtype_declaration; it_module_declaration; it_extension_constructor; - it_type_declaration; it_value_description; it_signature_item; } + it_modtype_declaration; + it_module_declaration; + it_extension_constructor; + it_type_declaration; + it_value_description; + it_signature_item; + } let copy_row f fixed row keep more = - let fields = List.map - (fun (l, fi) -> l, - match row_field_repr fi with - | Rpresent(Some ty) -> Rpresent(Some(f ty)) - | Reither(c, tl, m, e) -> + let fields = + List.map + (fun (l, fi) -> + ( l, + match row_field_repr fi with + | Rpresent (Some ty) -> Rpresent (Some (f ty)) + | Reither (c, tl, m, e) -> let e = if keep then e else ref None in let m = if row.row_fixed then fixed else m in let tl = List.map f tl in - Reither(c, tl, m, e) - | _ -> fi) - row.row_fields in + Reither (c, tl, m, e) + | _ -> fi )) + row.row_fields + in let name = - match row.row_name with None -> None - | Some (path, tl) -> Some (path, List.map f tl) in - { row_fields = fields; row_more = more; - row_bound = (); row_fixed = row.row_fixed && fixed; - row_closed = row.row_closed; row_name = name; } + match row.row_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) + in + { + row_fields = fields; + row_more = more; + row_bound = (); + row_fixed = row.row_fixed && fixed; + row_closed = row.row_closed; + row_name = name; + } let rec copy_kind = function - Fvar{contents = Some k} -> copy_kind k - | Fvar _ -> Fvar (ref None) + | Fvar {contents = Some k} -> copy_kind k + | Fvar _ -> Fvar (ref None) | Fpresent -> Fpresent - | Fabsent -> assert false + | Fabsent -> assert false -let copy_commu c = - if commu_repr c = Cok then Cok else Clink (ref Cunknown) +let copy_commu c = if commu_repr c = Cok then Cok else Clink (ref Cunknown) (* Since univars may be used as row variables, we need to do some encoding during substitution *) let rec norm_univar ty = match ty.desc with - Tunivar _ | Tsubst _ -> ty - | Tlink ty -> norm_univar ty - | Ttuple (ty :: _) -> norm_univar ty - | _ -> assert false - -let rec copy_type_desc ?(keep_names=false) f = function - Tvar _ as ty -> if keep_names then ty else Tvar None - | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) - | Ttuple l -> Ttuple (List.map f l) - | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) - | Tobject(ty, {contents = Some (p, tl)}) - -> Tobject (f ty, ref (Some(p, List.map f tl))) - | Tobject (ty, _) -> Tobject (f ty, ref None) - | Tvariant _ -> assert false (* too ambiguous *) - | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) - Tfield (p, field_kind_repr k, f ty1, f ty2) - | Tnil -> Tnil - | Tlink ty -> copy_type_desc f ty.desc - | Tsubst _ -> assert false - | Tunivar _ as ty -> ty (* always keep the name *) - | Tpoly (ty, tyl) -> - let tyl = List.map (fun x -> norm_univar (f x)) tyl in - Tpoly (f ty, tyl) - | Tpackage (p, n, l) -> Tpackage (p, n, List.map f l) + | Tunivar _ | Tsubst _ -> ty + | Tlink ty -> norm_univar ty + | Ttuple (ty :: _) -> norm_univar ty + | _ -> assert false + +let rec copy_type_desc ?(keep_names = false) f = function + | Tvar _ as ty -> if keep_names then ty else Tvar None + | Tarrow (p, ty1, ty2, c) -> Tarrow (p, f ty1, f ty2, copy_commu c) + | Ttuple l -> Ttuple (List.map f l) + | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) + | Tobject (ty, {contents = Some (p, tl)}) -> + Tobject (f ty, ref (Some (p, List.map f tl))) + | Tobject (ty, _) -> Tobject (f ty, ref None) + | Tvariant _ -> assert false (* too ambiguous *) + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared *) + Tfield (p, field_kind_repr k, f ty1, f ty2) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f ty.desc + | Tsubst _ -> assert false + | Tunivar _ as ty -> ty (* always keep the name *) + | Tpoly (ty, tyl) -> + let tyl = List.map (fun x -> norm_univar (f x)) tyl in + Tpoly (f ty, tyl) + | Tpackage (p, n, l) -> Tpackage (p, n, List.map f l) (* Utilities for copying *) let saved_desc = ref [] - (* Saved association of generic nodes with their description. *) +(* Saved association of generic nodes with their description. *) -let save_desc ty desc = - saved_desc := (ty, desc)::!saved_desc +let save_desc ty desc = saved_desc := (ty, desc) :: !saved_desc let saved_kinds = ref [] (* duplicated kind variables *) -let new_kinds = ref [] (* new kind variables *) +let new_kinds = ref [] (* new kind variables *) let dup_kind r = - (match !r with None -> () | Some _ -> assert false); - if not (List.memq r !new_kinds) then begin + (match !r with + | None -> () + | Some _ -> assert false); + if not (List.memq r !new_kinds) then ( saved_kinds := r :: !saved_kinds; let r' = ref None in new_kinds := r' :: !new_kinds; - r := Some (Fvar r') - end + r := Some (Fvar r')) (* Restored type descriptions. *) let cleanup_types () = List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc; List.iter (fun r -> r := None) !saved_kinds; - saved_desc := []; saved_kinds := []; new_kinds := [] + saved_desc := []; + saved_kinds := []; + new_kinds := [] (* Mark a type. *) let rec mark_type ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; - iter_type_expr mark_type ty - end + iter_type_expr mark_type ty) let mark_type_node ty = let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - end + if ty.level >= lowest_level then ty.level <- pivot_level - ty.level -let mark_type_params ty = - iter_type_expr mark_type ty +let mark_type_params ty = iter_type_expr mark_type ty let type_iterators = let it_type_expr it ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( mark_type_node ty; - it.it_do_type_expr it ty; - end + it.it_do_type_expr it ty) in {type_iterators with it_type_expr} - (* Remove marks from a type. *) let rec unmark_type ty = let ty = repr ty in - if ty.level < lowest_level then begin + if ty.level < lowest_level then ( ty.level <- pivot_level - ty.level; - iter_type_expr unmark_type ty - end + iter_type_expr unmark_type ty) let unmark_iterators = let it_type_expr _it ty = unmark_type ty in @@ -500,126 +516,125 @@ let unmark_extension_constructor ext = iter_type_expr_cstr_args unmark_type ext.ext_args; Misc.may unmark_type ext.ext_ret_type - - - (*******************************************) - (* Memorization of abbreviation expansion *) - (*******************************************) +(*******************************************) +(* Memorization of abbreviation expansion *) +(*******************************************) (* Search whether the expansion has been memorized. *) -let lte_public p1 p2 = (* Private <= Public *) - match p1, p2 with +let lte_public p1 p2 = + (* Private <= Public *) + match (p1, p2) with | Private, _ | _, Public -> true | Public, Private -> false let rec find_expans priv p1 = function - Mnil -> None - | Mcons (priv', p2, _ty0, ty, _) - when lte_public priv priv' && Path.same p1 p2 -> Some ty - | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem + | Mnil -> None + | Mcons (priv', p2, _ty0, ty, _) when lte_public priv priv' && Path.same p1 p2 + -> + Some ty + | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem | Mlink {contents = rem} -> find_expans priv p1 rem (* debug: check for cycles in abbreviation. only works with -principal -let rec check_expans visited ty = - let ty = repr ty in - assert (not (List.memq ty visited)); - match ty.desc with - Tconstr (path, args, abbrev) -> - begin match find_expans path !abbrev with - Some ty' -> check_expans (ty :: visited) ty' - | None -> () - end - | _ -> () + let rec check_expans visited ty = + let ty = repr ty in + assert (not (List.memq ty visited)); + match ty.desc with + Tconstr (path, args, abbrev) -> + begin match find_expans path !abbrev with + Some ty' -> check_expans (ty :: visited) ty' + | None -> () + end + | _ -> () *) let memo = ref [] - (* Contains the list of saved abbreviation expansions. *) +(* Contains the list of saved abbreviation expansions. *) let cleanup_abbrev () = - (* Remove all memorized abbreviation expansions. *) + (* Remove all memorized abbreviation expansions. *) List.iter (fun abbr -> abbr := Mnil) !memo; memo := [] let memorize_abbrev mem priv path v v' = - (* Memorize the expansion of an abbreviation. *) + (* Memorize the expansion of an abbreviation. *) mem := Mcons (priv, path, v, v', !mem); (* check_expans [] v; *) memo := mem :: !memo let rec forget_abbrev_rec mem path = match mem with - Mnil -> - assert false - | Mcons (_, path', _, _, rem) when Path.same path path' -> - rem + | Mnil -> assert false + | Mcons (_, path', _, _, rem) when Path.same path path' -> rem | Mcons (priv, path', v, v', rem) -> - Mcons (priv, path', v, v', forget_abbrev_rec rem path) + Mcons (priv, path', v, v', forget_abbrev_rec rem path) | Mlink mem' -> - mem' := forget_abbrev_rec !mem' path; - raise Exit + mem' := forget_abbrev_rec !mem' path; + raise Exit let forget_abbrev mem path = try mem := forget_abbrev_rec !mem path with Exit -> () (* debug: check for invalid abbreviations -let rec check_abbrev_rec = function - Mnil -> true - | Mcons (_, ty1, ty2, rem) -> - repr ty1 != repr ty2 - | Mlink mem' -> - check_abbrev_rec !mem' - -let check_memorized_abbrevs () = - List.for_all (fun mem -> check_abbrev_rec !mem) !memo + let rec check_abbrev_rec = function + Mnil -> true + | Mcons (_, ty1, ty2, rem) -> + repr ty1 != repr ty2 + | Mlink mem' -> + check_abbrev_rec !mem' + + let check_memorized_abbrevs () = + List.for_all (fun mem -> check_abbrev_rec !mem) !memo *) - (**********************************) - (* Utilities for labels *) - (**********************************) +(**********************************) +(* Utilities for labels *) +(**********************************) -let is_optional = function Optional _ -> true | _ -> false +let is_optional = function + | Optional _ -> true + | _ -> false let label_name = function - Nolabel -> "" - | Labelled s - | Optional s -> s + | Nolabel -> "" + | Labelled s | Optional s -> s let prefixed_label_name = function - Nolabel -> "" + | Nolabel -> "" | Labelled s -> "~" ^ s | Optional s -> "?" ^ s - type sargs = (Asttypes.arg_label * Parsetree.expression) list - -let rec extract_label_aux hd l = function - [] -> None - | (l',t as p) :: ls -> - if label_name l' = l then Some (l', t, List.rev_append hd ls) - else extract_label_aux (p::hd) l ls -let extract_label l (ls : sargs) : (arg_label * Parsetree.expression * sargs) option = extract_label_aux [] l ls +let rec extract_label_aux hd l = function + | [] -> None + | ((l', t) as p) :: ls -> + if label_name l' = l then Some (l', t, List.rev_append hd ls) + else extract_label_aux (p :: hd) l ls +let extract_label l (ls : sargs) : + (arg_label * Parsetree.expression * sargs) option = + extract_label_aux [] l ls -let rec label_assoc x (args : sargs) = - match args with +let rec label_assoc x (args : sargs) = + match args with | [] -> false - | (a, _) :: l -> Asttypes.same_arg_label a x || label_assoc x l + | (a, _) :: l -> Asttypes.same_arg_label a x || label_assoc x l - (**********************************) - (* Utilities for backtracking *) - (**********************************) +(**********************************) +(* Utilities for backtracking *) +(**********************************) let undo_change = function - Ctype (ty, desc) -> ty.desc <- desc - | Ccompress (ty, desc, _) -> ty.desc <- desc + | Ctype (ty, desc) -> ty.desc <- desc + | Ccompress (ty, desc, _) -> ty.desc <- desc | Clevel (ty, level) -> ty.level <- level - | Cname (r, v) -> r := v - | Crow (r, v) -> r := v - | Ckind (r, v) -> r := v + | Cname (r, v) -> r := v + | Crow (r, v) -> r := v + | Ckind (r, v) -> r := v | Ccommu (r, v) -> r := v - | Cuniv (r, v) -> r := v + | Cuniv (r, v) -> r := v | Ctypeset (r, v) -> r := v type snapshot = changes ref * int @@ -633,81 +648,90 @@ let link_type ty ty' = ty.desc <- Tlink ty'; (* Name is a user-supplied name for this unification variable (obtained * through a type annotation for instance). *) - match desc, ty'.desc with - Tvar name, Tvar name' -> - begin match name, name' with - | Some _, None -> log_type ty'; ty'.desc <- Tvar name - | None, Some _ -> () - | Some _, Some _ -> - if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name) - | None, None -> () - end + match (desc, ty'.desc) with + | Tvar name, Tvar name' -> ( + match (name, name') with + | Some _, None -> + log_type ty'; + ty'.desc <- Tvar name + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then ( + log_type ty'; + ty'.desc <- Tvar name) + | None, None -> ()) | _ -> () - (* ; assert (check_memorized_abbrevs ()) *) - (* ; check_expans [] ty' *) + +(* ; assert (check_memorized_abbrevs ()) *) +(* ; check_expans [] ty' *) let set_level ty level = if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); ty.level <- level let set_univar rty ty = - log_change (Cuniv (rty, !rty)); rty := Some ty + log_change (Cuniv (rty, !rty)); + rty := Some ty let set_name nm v = - log_change (Cname (nm, !nm)); nm := v + log_change (Cname (nm, !nm)); + nm := v let set_row_field e v = - log_change (Crow (e, !e)); e := Some v + log_change (Crow (e, !e)); + e := Some v let set_kind rk k = - log_change (Ckind (rk, !rk)); rk := Some k + log_change (Ckind (rk, !rk)); + rk := Some k let set_commu rc c = - log_change (Ccommu (rc, !rc)); rc := c + log_change (Ccommu (rc, !rc)); + rc := c let set_typeset rs s = - log_change (Ctypeset (rs, !rs)); rs := s + log_change (Ctypeset (rs, !rs)); + rs := s let snapshot () = let old = !last_snapshot in last_snapshot := !new_id; - match Weak.get trail 0 with Some r -> (r, old) + match Weak.get trail 0 with + | Some r -> (r, old) | None -> - let r = ref Unchanged in - Weak.set trail 0 (Some r); - (r, old) + let r = ref Unchanged in + Weak.set trail 0 (Some r); + (r, old) let rec rev_log accu = function - Unchanged -> accu + | Unchanged -> accu | Invalid -> assert false | Change (ch, next) -> - let d = !next in - next := Invalid; - rev_log (ch::accu) d + let d = !next in + next := Invalid; + rev_log (ch :: accu) d let backtrack (changes, old) = match !changes with - Unchanged -> last_snapshot := old + | Unchanged -> last_snapshot := old | Invalid -> failwith "Btype.backtrack" | Change _ as change -> - cleanup_abbrev (); - let backlog = rev_log [] change in - List.iter undo_change backlog; - changes := Unchanged; - last_snapshot := old; - Weak.set trail 0 (Some changes) + cleanup_abbrev (); + let backlog = rev_log [] change in + List.iter undo_change backlog; + changes := Unchanged; + last_snapshot := old; + Weak.set trail 0 (Some changes) let rec rev_compress_log log r = match !r with - Unchanged | Invalid -> - log - | Change (Ccompress _, next) -> - rev_compress_log (r::log) next - | Change (_, next) -> - rev_compress_log log next + | Unchanged | Invalid -> log + | Change (Ccompress _, next) -> rev_compress_log (r :: log) next + | Change (_, next) -> rev_compress_log log next let undo_compress (changes, _old) = match !changes with - Unchanged - | Invalid -> () + | Unchanged | Invalid -> () | Change _ -> - let log = rev_compress_log [] changes in - List.iter - (fun r -> match !r with - Change (Ccompress (ty, desc, d), next) when ty.desc == d -> - ty.desc <- desc; r := !next + let log = rev_compress_log [] changes in + List.iter + (fun r -> + match !r with + | Change (Ccompress (ty, desc, d), next) when ty.desc == d -> + ty.desc <- desc; + r := !next | _ -> ()) - log + log diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index 479ee63256..ef099af22b 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -20,144 +20,163 @@ open Types (**** Sets, maps and hashtables of types ****) -module TypeSet : Set.S with type elt = type_expr -module TypeMap : Map.S with type key = type_expr +module TypeSet : Set.S with type elt = type_expr +module TypeMap : Map.S with type key = type_expr module TypeHash : Hashtbl.S with type key = type_expr (**** Levels ****) -val generic_level: int +val generic_level : int -val newty2: int -> type_desc -> type_expr - (* Create a type *) -val newgenty: type_desc -> type_expr - (* Create a generic type *) -val newgenvar: ?name:string -> unit -> type_expr - (* Return a fresh generic variable *) +val newty2 : int -> type_desc -> type_expr +(* Create a type *) + +val newgenty : type_desc -> type_expr +(* Create a generic type *) + +val newgenvar : ?name:string -> unit -> type_expr +(* Return a fresh generic variable *) (* Use Tsubst instead -val newmarkedvar: int -> type_expr - (* Return a fresh marked variable *) -val newmarkedgenvar: unit -> type_expr - (* Return a fresh marked generic variable *) + val newmarkedvar: int -> type_expr + (* Return a fresh marked variable *) + val newmarkedgenvar: unit -> type_expr + (* Return a fresh marked generic variable *) *) (**** Types ****) -val is_Tvar: type_expr -> bool -val is_Tunivar: type_expr -> bool -val is_Tconstr: type_expr -> bool -val dummy_method: label -val default_mty: module_type option -> module_type +val is_Tvar : type_expr -> bool +val is_Tunivar : type_expr -> bool +val is_Tconstr : type_expr -> bool +val dummy_method : label +val default_mty : module_type option -> module_type -val repr: type_expr -> type_expr - (* Return the canonical representative of a type. *) +val repr : type_expr -> type_expr +(* Return the canonical representative of a type. *) -val field_kind_repr: field_kind -> field_kind - (* Return the canonical representative of an object field - kind. *) +val field_kind_repr : field_kind -> field_kind +(* Return the canonical representative of an object field + kind. *) -val commu_repr: commutable -> commutable - (* Return the canonical representative of a commutation lock *) +val commu_repr : commutable -> commutable +(* Return the canonical representative of a commutation lock *) (**** polymorphic variants ****) -val row_repr: row_desc -> row_desc - (* Return the canonical representative of a row description *) -val row_field_repr: row_field -> row_field -val row_field: label -> row_desc -> row_field - (* Return the canonical representative of a row field *) -val row_more: row_desc -> type_expr - (* Return the extension variable of the row *) -val row_fixed: row_desc -> bool - (* Return whether the row should be treated as fixed or not *) -val static_row: row_desc -> bool - (* Return whether the row is static or not *) -val hash_variant: label -> int - (* Hash function for variant tags *) - -val proxy: type_expr -> type_expr - (* Return the proxy representative of the type: either itself - or a row variable *) +val row_repr : row_desc -> row_desc +(* Return the canonical representative of a row description *) + +val row_field_repr : row_field -> row_field +val row_field : label -> row_desc -> row_field +(* Return the canonical representative of a row field *) + +val row_more : row_desc -> type_expr +(* Return the extension variable of the row *) + +val row_fixed : row_desc -> bool +(* Return whether the row should be treated as fixed or not *) + +val static_row : row_desc -> bool +(* Return whether the row is static or not *) + +val hash_variant : label -> int +(* Hash function for variant tags *) + +val proxy : type_expr -> type_expr +(* Return the proxy representative of the type: either itself + or a row variable *) (**** Utilities for private abbreviations with fixed rows ****) -val row_of_type: type_expr -> type_expr -val has_constr_row: type_expr -> bool -val is_row_name: string -> bool -val is_constr_row: allow_ident:bool -> type_expr -> bool +val row_of_type : type_expr -> type_expr +val has_constr_row : type_expr -> bool +val is_row_name : string -> bool +val is_constr_row : allow_ident:bool -> type_expr -> bool (**** Utilities for type traversal ****) -val iter_type_expr: (type_expr -> unit) -> type_expr -> unit - (* Iteration on types *) -val iter_row: (type_expr -> unit) -> row_desc -> unit - (* Iteration on types in a row *) -val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit - (* Iteration on types in an abbreviation list *) - -type type_iterators = - { it_signature: type_iterators -> signature -> unit; - it_signature_item: type_iterators -> signature_item -> unit; - it_value_description: type_iterators -> value_description -> unit; - it_type_declaration: type_iterators -> type_declaration -> unit; - it_extension_constructor: type_iterators -> extension_constructor -> unit; - it_module_declaration: type_iterators -> module_declaration -> unit; - it_modtype_declaration: type_iterators -> modtype_declaration -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_type_kind: type_iterators -> type_kind -> unit; - it_do_type_expr: type_iterators -> type_expr -> unit; - it_type_expr: type_iterators -> type_expr -> unit; - it_path: Path.t -> unit; } -val type_iterators: type_iterators - (* Iteration on arbitrary type information. - [it_type_expr] calls [mark_type_node] to avoid loops. *) -val unmark_iterators: type_iterators - (* Unmark any structure containing types. See [unmark_type] below. *) - -val copy_type_desc: - ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc - (* Copy on types *) -val copy_row: - (type_expr -> type_expr) -> - bool -> row_desc -> bool -> type_expr -> row_desc -val copy_kind: field_kind -> field_kind - -val save_desc: type_expr -> type_desc -> unit - (* Save a type description *) -val dup_kind: field_kind option ref -> unit - (* Save a None field_kind, and make it point to a fresh Fvar *) -val cleanup_types: unit -> unit - (* Restore type descriptions *) - -val lowest_level: int - (* Marked type: ty.level < lowest_level *) -val pivot_level: int - (* Type marking: ty.level <- pivot_level - ty.level *) -val mark_type: type_expr -> unit - (* Mark a type *) -val mark_type_node: type_expr -> unit - (* Mark a type node (but not its sons) *) -val mark_type_params: type_expr -> unit - (* Mark the sons of a type node *) -val unmark_type: type_expr -> unit -val unmark_type_decl: type_declaration -> unit -val unmark_extension_constructor: extension_constructor -> unit +val iter_type_expr : (type_expr -> unit) -> type_expr -> unit +(* Iteration on types *) + +val iter_row : (type_expr -> unit) -> row_desc -> unit +(* Iteration on types in a row *) + +val iter_abbrev : (type_expr -> unit) -> abbrev_memo -> unit +(* Iteration on types in an abbreviation list *) + +type type_iterators = { + it_signature: type_iterators -> signature -> unit; + it_signature_item: type_iterators -> signature_item -> unit; + it_value_description: type_iterators -> value_description -> unit; + it_type_declaration: type_iterators -> type_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; + it_module_declaration: type_iterators -> module_declaration -> unit; + it_modtype_declaration: type_iterators -> modtype_declaration -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_type_kind: type_iterators -> type_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; + it_type_expr: type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; +} +val type_iterators : type_iterators +(* Iteration on arbitrary type information. + [it_type_expr] calls [mark_type_node] to avoid loops. *) + +val unmark_iterators : type_iterators +(* Unmark any structure containing types. See [unmark_type] below. *) + +val copy_type_desc : + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc +(* Copy on types *) + +val copy_row : + (type_expr -> type_expr) -> bool -> row_desc -> bool -> type_expr -> row_desc +val copy_kind : field_kind -> field_kind + +val save_desc : type_expr -> type_desc -> unit +(* Save a type description *) + +val dup_kind : field_kind option ref -> unit +(* Save a None field_kind, and make it point to a fresh Fvar *) + +val cleanup_types : unit -> unit +(* Restore type descriptions *) + +val lowest_level : int +(* Marked type: ty.level < lowest_level *) + +val pivot_level : int +(* Type marking: ty.level <- pivot_level - ty.level *) + +val mark_type : type_expr -> unit +(* Mark a type *) + +val mark_type_node : type_expr -> unit +(* Mark a type node (but not its sons) *) + +val mark_type_params : type_expr -> unit +(* Mark the sons of a type node *) + +val unmark_type : type_expr -> unit +val unmark_type_decl : type_declaration -> unit +val unmark_extension_constructor : extension_constructor -> unit (**** Memorization of abbreviation expansion ****) -val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option - (* Look up a memorized abbreviation *) -val cleanup_abbrev: unit -> unit - (* Flush the cache of abbreviation expansions. - When some types are saved (using [output_value]), this - function MUST be called just before. *) -val memorize_abbrev: - abbrev_memo ref -> - private_flag -> Path.t -> type_expr -> type_expr -> unit - (* Add an expansion in the cache *) -val forget_abbrev: - abbrev_memo ref -> Path.t -> unit - (* Remove an abbreviation from the cache *) +val find_expans : private_flag -> Path.t -> abbrev_memo -> type_expr option +(* Look up a memorized abbreviation *) + +val cleanup_abbrev : unit -> unit +(* Flush the cache of abbreviation expansions. + When some types are saved (using [output_value]), this + function MUST be called just before. *) + +val memorize_abbrev : + abbrev_memo ref -> private_flag -> Path.t -> type_expr -> type_expr -> unit +(* Add an expansion in the cache *) + +val forget_abbrev : abbrev_memo ref -> Path.t -> unit +(* Remove an abbreviation from the cache *) (**** Utilities for labels ****) @@ -170,49 +189,54 @@ val prefixed_label_name : arg_label -> label type sargs = (arg_label * Parsetree.expression) list val extract_label : - label -> sargs -> - (arg_label * Parsetree.expression * sargs) option - (* actual label, value, new list with the same order *) + label -> sargs -> (arg_label * Parsetree.expression * sargs) option +(* actual label, value, new list with the same order *) val label_assoc : arg_label -> sargs -> bool (**** Utilities for backtracking ****) type snapshot - (* A snapshot for backtracking *) -val snapshot: unit -> snapshot - (* Make a snapshot for later backtracking. Costs nothing *) -val backtrack: snapshot -> unit - (* Backtrack to a given snapshot. Only possible if you have - not already backtracked to a previous snapshot. - Calls [cleanup_abbrev] internally *) -val undo_compress: snapshot -> unit - (* Backtrack only path compression. Only meaningful if you have - not already backtracked to a previous snapshot. - Does not call [cleanup_abbrev] *) +(* A snapshot for backtracking *) + +val snapshot : unit -> snapshot +(* Make a snapshot for later backtracking. Costs nothing *) + +val backtrack : snapshot -> unit +(* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) + +val undo_compress : snapshot -> unit +(* Backtrack only path compression. Only meaningful if you have + not already backtracked to a previous snapshot. + Does not call [cleanup_abbrev] *) (* Functions to use when modifying a type (only Ctype?) *) -val link_type: type_expr -> type_expr -> unit - (* Set the desc field of [t1] to [Tlink t2], logging the old - value if there is an active snapshot *) -val set_level: type_expr -> int -> unit -val set_name: - (Path.t * type_expr list) option ref -> - (Path.t * type_expr list) option -> unit -val set_row_field: row_field option ref -> row_field -> unit -val set_univar: type_expr option ref -> type_expr -> unit -val set_kind: field_kind option ref -> field_kind -> unit -val set_commu: commutable ref -> commutable -> unit -val set_typeset: TypeSet.t ref -> TypeSet.t -> unit - (* Set references, logging the old value *) -val log_type: type_expr -> unit - (* Log the old value of a type, before modifying it by hand *) +val link_type : type_expr -> type_expr -> unit +(* Set the desc field of [t1] to [Tlink t2], logging the old + value if there is an active snapshot *) + +val set_level : type_expr -> int -> unit +val set_name : + (Path.t * type_expr list) option ref -> + (Path.t * type_expr list) option -> + unit +val set_row_field : row_field option ref -> row_field -> unit +val set_univar : type_expr option ref -> type_expr -> unit +val set_kind : field_kind option ref -> field_kind -> unit +val set_commu : commutable ref -> commutable -> unit +val set_typeset : TypeSet.t ref -> TypeSet.t -> unit +(* Set references, logging the old value *) + +val log_type : type_expr -> unit +(* Log the old value of a type, before modifying it by hand *) (**** Forward declarations ****) -val print_raw: (Format.formatter -> type_expr -> unit) ref +val print_raw : (Format.formatter -> type_expr -> unit) ref -val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) +val iter_type_expr_kind : (type_expr -> unit) -> type_kind -> unit -val iter_type_expr_cstr_args: (type_expr -> unit) -> - (constructor_arguments -> unit) -val map_type_expr_cstr_args: (type_expr -> type_expr) -> - (constructor_arguments -> constructor_arguments) +val iter_type_expr_cstr_args : + (type_expr -> unit) -> constructor_arguments -> unit +val map_type_expr_cstr_args : + (type_expr -> type_expr) -> constructor_arguments -> constructor_arguments diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml old mode 100755 new mode 100644 index f53edbf906..5d110eda75 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -17,12 +17,12 @@ open Asttypes open Parsetree let string_of_cst = function - | Pconst_string(s, _) -> Some s + | Pconst_string (s, _) -> Some s | _ -> None let string_of_payload = function - | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> - string_of_cst c + | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant c}, _)}] -> + string_of_cst c | _ -> None let string_of_opt_payload p = @@ -32,42 +32,51 @@ let string_of_opt_payload p = let rec error_of_extension ext = match ext with - | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> + | {txt = ("ocaml.error" | "error") as txt; loc}, p -> ( let rec sub_from inner = match inner with - | {pstr_desc=Pstr_extension (ext, _)} :: rest -> - error_of_extension ext :: sub_from rest + | {pstr_desc = Pstr_extension (ext, _)} :: rest -> + error_of_extension ext :: sub_from rest | _ :: rest -> - (Location.errorf ~loc - "Invalid syntax for sub-error of extension '%s'." txt) :: - sub_from rest + Location.errorf ~loc "Invalid syntax for sub-error of extension '%s'." + txt + :: sub_from rest | [] -> [] in - begin match p with + match p with | PStr [] -> raise Location.Already_displayed_error - | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}:: - {pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(if_highlight,_))}, _)}:: - inner) -> - Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg - | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::inner) -> - Location.error ~loc ~sub:(sub_from inner) msg - | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt - end - | ({txt; loc}, _) -> - Location.errorf ~loc "Uninterpreted extension '%s'." txt + | PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (msg, _))}, _); + } + :: { + pstr_desc = + Pstr_eval + ( {pexp_desc = Pexp_constant (Pconst_string (if_highlight, _))}, + _ ); + } + :: inner) -> + Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg + | PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (msg, _))}, _); + } + :: inner) -> + Location.error ~loc ~sub:(sub_from inner) msg + | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt) + | {txt; loc}, _ -> Location.errorf ~loc "Uninterpreted extension '%s'." txt let cat s1 s2 = - if s2 = "" then s1 else - (* 2 spaces indentation for the next line *) - s1 ^ "\n " ^ s2 + if s2 = "" then s1 + else (* 2 spaces indentation for the next line *) + s1 ^ "\n " ^ s2 let rec deprecated_of_attrs = function | [] -> None - | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ -> - Some (string_of_opt_payload p) + | ({txt = "ocaml.deprecated" | "deprecated"; _}, p) :: _ -> + Some (string_of_opt_payload p) | _ :: tl -> deprecated_of_attrs tl let check_deprecated loc attrs s = @@ -76,85 +85,78 @@ let check_deprecated loc attrs s = | Some txt -> Location.deprecated loc (cat s txt) let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s = - match deprecated_of_attrs attrs1, deprecated_of_attrs attrs2 with + match (deprecated_of_attrs attrs1, deprecated_of_attrs attrs2) with | None, _ | Some _, Some _ -> () | Some txt, None -> Location.deprecated ~def ~use loc (cat s txt) let rec deprecated_mutable_of_attrs = function | [] -> None - | ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ -> - Some (string_of_opt_payload p) + | ({txt = "ocaml.deprecated_mutable" | "deprecated_mutable"; _}, p) :: _ -> + Some (string_of_opt_payload p) | _ :: tl -> deprecated_mutable_of_attrs tl let check_deprecated_mutable loc attrs s = match deprecated_mutable_of_attrs attrs with | None -> () | Some txt -> - Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) + Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = - match deprecated_mutable_of_attrs attrs1, - deprecated_mutable_of_attrs attrs2 + match + (deprecated_mutable_of_attrs attrs1, deprecated_mutable_of_attrs attrs2) with | None, _ | Some _, Some _ -> () | Some txt, None -> - Location.deprecated ~def ~use loc - (Printf.sprintf "mutating field %s" (cat s txt)) + Location.deprecated ~def ~use loc + (Printf.sprintf "mutating field %s" (cat s txt)) -let check_bs_attributes_inclusion = - ref (fun _attrs1 _attrs2 _s -> - None - ) +let check_bs_attributes_inclusion = ref (fun _attrs1 _attrs2 _s -> None) -let check_duplicated_labels : (_ -> _ option ) ref = ref (fun _lbls -> - None -) +let check_duplicated_labels : (_ -> _ option) ref = ref (fun _lbls -> None) let rec deprecated_of_sig = function - | {psig_desc = Psig_attribute a} :: tl -> - begin match deprecated_of_attrs [a] with - | None -> deprecated_of_sig tl - | Some _ as r -> r - end + | {psig_desc = Psig_attribute a} :: tl -> ( + match deprecated_of_attrs [a] with + | None -> deprecated_of_sig tl + | Some _ as r -> r) | _ -> None - let rec deprecated_of_str = function - | {pstr_desc = Pstr_attribute a} :: tl -> - begin match deprecated_of_attrs [a] with - | None -> deprecated_of_str tl - | Some _ as r -> r - end + | {pstr_desc = Pstr_attribute a} :: tl -> ( + match deprecated_of_attrs [a] with + | None -> deprecated_of_str tl + | Some _ as r -> r) | _ -> None - let warning_attribute ?(ppwarning = true) = let process loc txt errflag payload = match string_of_payload payload with - | Some s -> - begin try Warnings.parse_options errflag s - with Arg.Bad _ -> - Location.prerr_warning loc - (Warnings.Attribute_payload - (txt, "Ill-formed list of warnings")) - end - | None -> + | Some s -> ( + try Warnings.parse_options errflag s + with Arg.Bad _ -> Location.prerr_warning loc - (Warnings.Attribute_payload - (txt, "A single string literal is expected")) + (Warnings.Attribute_payload (txt, "Ill-formed list of warnings"))) + | None -> + Location.prerr_warning loc + (Warnings.Attribute_payload (txt, "A single string literal is expected")) in function - | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) -> - process loc txt false payload - | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) -> - process loc txt true payload - | {txt="ocaml.ppwarning"|"ppwarning"}, - PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant - (Pconst_string (s, _))},_); - pstr_loc}] when ppwarning -> - Location.prerr_warning pstr_loc (Warnings.Preprocessor s) - | _ -> - () + | {txt = ("ocaml.warning" | "warning") as txt; loc}, payload -> + process loc txt false payload + | {txt = ("ocaml.warnerror" | "warnerror") as txt; loc}, payload -> + process loc txt true payload + | ( {txt = "ocaml.ppwarning" | "ppwarning"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _); + pstr_loc; + }; + ] ) + when ppwarning -> + Location.prerr_warning pstr_loc (Warnings.Preprocessor s) + | _ -> () let warning_scope ?ppwarning attrs f = let prev = Warnings.backup () in @@ -167,28 +169,22 @@ let warning_scope ?ppwarning attrs f = Warnings.restore prev; raise exn - let warn_on_literal_pattern = - List.exists - (function - | ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _) - -> true - | _ -> false - ) + List.exists (function + | {txt = "ocaml.warn_on_literal_pattern" | "warn_on_literal_pattern"; _}, _ + -> + true + | _ -> false) let explicit_arity = - List.exists - (function - | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true - | _ -> false - ) + List.exists (function + | {txt = "ocaml.explicit_arity" | "explicit_arity"; _}, _ -> true + | _ -> false) let immediate = - List.exists - (function - | ({txt="ocaml.immediate"|"immediate"; _}, _) -> true - | _ -> false - ) + List.exists (function + | {txt = "ocaml.immediate" | "immediate"; _}, _ -> true + | _ -> false) (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" attributes cannot be input by the user, they are added by the @@ -199,9 +195,6 @@ let immediate = let check l (x, _) = List.mem x.txt l -let has_unboxed attr = - List.exists (check ["ocaml.unboxed"; "unboxed"]) - attr +let has_unboxed attr = List.exists (check ["ocaml.unboxed"; "unboxed"]) attr -let has_boxed attr = - List.exists (check ["ocaml.boxed"; "boxed"]) attr +let has_boxed attr = List.exists (check ["ocaml.boxed"; "boxed"]) attr diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli old mode 100755 new mode 100644 index 7282dbbe2e..fd898388c7 --- a/compiler/ml/builtin_attributes.mli +++ b/compiler/ml/builtin_attributes.mli @@ -27,33 +27,43 @@ ocaml.boxed / ocaml.unboxed *) +val check_deprecated : Location.t -> Parsetree.attributes -> string -> unit +val check_deprecated_inclusion : + def:Location.t -> + use:Location.t -> + Location.t -> + Parsetree.attributes -> + Parsetree.attributes -> + string -> + unit +val deprecated_of_attrs : Parsetree.attributes -> string option +val deprecated_of_sig : Parsetree.signature -> string option +val deprecated_of_str : Parsetree.structure -> string option -val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit -val check_deprecated_inclusion: - def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> - Parsetree.attributes -> string -> unit -val deprecated_of_attrs: Parsetree.attributes -> string option -val deprecated_of_sig: Parsetree.signature -> string option -val deprecated_of_str: Parsetree.structure -> string option +val check_deprecated_mutable : + Location.t -> Parsetree.attributes -> string -> unit +val check_deprecated_mutable_inclusion : + def:Location.t -> + use:Location.t -> + Location.t -> + Parsetree.attributes -> + Parsetree.attributes -> + string -> + unit -val check_deprecated_mutable: - Location.t -> Parsetree.attributes -> string -> unit -val check_deprecated_mutable_inclusion: - def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> - Parsetree.attributes -> string -> unit - -val check_bs_attributes_inclusion: +val check_bs_attributes_inclusion : (Parsetree.attributes -> - Parsetree.attributes -> string -> (string*string) option ) ref + Parsetree.attributes -> + string -> + (string * string) option) + ref -val check_duplicated_labels: - (Parsetree.label_declaration list -> - string Asttypes.loc option - ) ref -val error_of_extension: Parsetree.extension -> Location.error +val check_duplicated_labels : + (Parsetree.label_declaration list -> string Asttypes.loc option) ref +val error_of_extension : Parsetree.extension -> Location.error -val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit - (** Apply warning settings from the specified attribute. +val warning_attribute : ?ppwarning:bool -> Parsetree.attribute -> unit +(** Apply warning settings from the specified attribute. "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) are processed and other attributes are ignored. @@ -61,10 +71,9 @@ val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit passed). *) -val warning_scope: - ?ppwarning:bool -> - Parsetree.attributes -> (unit -> 'a) -> 'a - (** Execute a function in a new scope for warning settings. This +val warning_scope : + ?ppwarning:bool -> Parsetree.attributes -> (unit -> 'a) -> 'a +(** Execute a function in a new scope for warning settings. This means that the effect of any call to [warning_attribute] during the execution of this function will be discarded after execution. @@ -74,11 +83,10 @@ val warning_scope: is executed. *) -val warn_on_literal_pattern: Parsetree.attributes -> bool -val explicit_arity: Parsetree.attributes -> bool - +val warn_on_literal_pattern : Parsetree.attributes -> bool +val explicit_arity : Parsetree.attributes -> bool -val immediate: Parsetree.attributes -> bool +val immediate : Parsetree.attributes -> bool -val has_unboxed: Parsetree.attributes -> bool -val has_boxed: Parsetree.attributes -> bool +val has_unboxed : Parsetree.attributes -> bool +val has_boxed : Parsetree.attributes -> bool diff --git a/compiler/ml/ccomp.ml b/compiler/ml/ccomp.ml index ae2fb79fd9..d6fb5f1e53 100644 --- a/compiler/ml/ccomp.ml +++ b/compiler/ml/ccomp.ml @@ -1,9 +1,6 @@ - let command cmdline = - if !Clflags.verbose then begin + if !Clflags.verbose then ( prerr_string "+ "; prerr_string cmdline; - prerr_newline() - end; + prerr_newline ()); Sys.command cmdline - diff --git a/compiler/ml/ccomp.mli b/compiler/ml/ccomp.mli index 7ba8b4bfa5..87678cc146 100644 --- a/compiler/ml/ccomp.mli +++ b/compiler/ml/ccomp.mli @@ -1,2 +1 @@ - -val command: string -> int +val command : string -> int diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml index afabf747e0..2b663ba24e 100644 --- a/compiler/ml/clflags.ml +++ b/compiler/ml/clflags.ml @@ -1,64 +1,69 @@ +let output_name = ref (None : string option) (* -o *) +and include_dirs = ref ([] : string list) (* -I *) +and debug = ref false (* -g *) +and fast = ref false (* -unsafe *) -let output_name = ref (None : string option) (* -o *) -and include_dirs = ref ([] : string list)(* -I *) -and debug = ref false (* -g *) -and fast = ref false (* -unsafe *) +and nopervasives = ref false (* -nopervasives *) -and nopervasives = ref false (* -nopervasives *) -and preprocessor = ref(None : string option) (* -pp *) -and all_ppx = ref ([] : string list) (* -ppx *) -let annotations = ref false (* -annot *) -let binary_annotations = ref false (* -annot *) -and noassert = ref false (* -noassert *) -and verbose = ref false (* -verbose *) -and open_modules = ref [] (* -open *) +and preprocessor = ref (None : string option) (* -pp *) -and real_paths = ref true (* -short-paths *) -and applicative_functors = ref true (* -no-app-funct *) -and error_size = ref 500 (* -error-size *) -and transparent_modules = ref false (* -trans-mod *) -let dump_source = ref false (* -dsource *) -let dump_parsetree = ref false (* -dparsetree *) -and dump_typedtree = ref false (* -dtypedtree *) -and dump_rawlambda = ref false (* -drawlambda *) -and dump_lambda = ref false (* -dlambda *) -and only_parse = ref false (* -only-parse *) -and ignore_parse_errors = ref false (* -ignore-parse-errors *) +and all_ppx = ref ([] : string list) -let dont_write_files = ref false (* set to true under ocamldoc *) +(* -ppx *) +let annotations = ref false (* -annot *) +let binary_annotations = ref false (* -annot *) +and noassert = ref false (* -noassert *) -let reset_dump_state () = begin - dump_source := false; - dump_parsetree := false; - dump_typedtree := false; - dump_rawlambda := false -end +and verbose = ref false (* -verbose *) + +and open_modules = ref [] (* -open *) + +and real_paths = ref true (* -short-paths *) + +and applicative_functors = ref true (* -no-app-funct *) + +and error_size = ref 500 (* -error-size *) + +and transparent_modules = ref false (* -trans-mod *) +let dump_source = ref false (* -dsource *) +let dump_parsetree = ref false (* -dparsetree *) +and dump_typedtree = ref false (* -dtypedtree *) +and dump_rawlambda = ref false (* -drawlambda *) +and dump_lambda = ref false (* -dlambda *) -let keep_locs = ref true (* -keep-locs *) +and only_parse = ref false (* -only-parse *) +and ignore_parse_errors = ref false (* -ignore-parse-errors *) +let dont_write_files = ref false (* set to true under ocamldoc *) +let reset_dump_state () = + dump_source := false; + dump_parsetree := false; + dump_typedtree := false; + dump_rawlambda := false + +let keep_locs = ref true (* -keep-locs *) let parse_color_setting = function | "auto" -> Some Misc.Color.Auto | "always" -> Some Misc.Color.Always | "never" -> Some Misc.Color.Never | _ -> None -let color = ref None ;; (* -color *) - -let unboxed_types = ref false - +let color = ref None +(* -color *) +let unboxed_types = ref false -type mli_status = Mli_exists | Mli_non_exists +type mli_status = Mli_exists | Mli_non_exists let assume_no_mli = ref Mli_non_exists let dont_record_crc_unit : string option ref = ref None let bs_gentype = ref false diff --git a/compiler/ml/clflags.mli b/compiler/ml/clflags.mli index 0ab90ad398..c861614928 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -24,21 +24,18 @@ val dump_lambda : bool ref val dont_write_files : bool ref val keep_locs : bool ref val only_parse : bool ref -val ignore_parse_errors: bool ref - +val ignore_parse_errors : bool ref val parse_color_setting : string -> Misc.Color.setting option val color : Misc.Color.setting option ref val unboxed_types : bool ref -val reset_dump_state: unit -> unit - +val reset_dump_state : unit -> unit -type mli_status = Mli_exists | Mli_non_exists +type mli_status = Mli_exists | Mli_non_exists val assume_no_mli : mli_status ref val dont_record_crc_unit : string option ref val bs_gentype : bool ref val no_assert_false : bool ref val dump_location : bool ref - diff --git a/compiler/ml/cmi_format.ml b/compiler/ml/cmi_format.ml index ee95e8254f..1a708b96d9 100644 --- a/compiler/ml/cmi_format.ml +++ b/compiler/ml/cmi_format.ml @@ -13,35 +13,27 @@ (* *) (**************************************************************************) -type pers_flags = - | Deprecated of string - - +type pers_flags = Deprecated of string type error = - Not_an_interface of string + | Not_an_interface of string | Wrong_version_interface of string * string | Corrupted_interface of string exception Error of error type cmi_infos = { - cmi_name : string; - cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t option) list; - cmi_flags : pers_flags list; + cmi_name: string; + cmi_sign: Types.signature_item list; + cmi_crcs: (string * Digest.t option) list; + cmi_flags: pers_flags list; } let input_cmi ic = - let (name, sign) = input_value ic in + let name, sign = input_value ic in let crcs = input_value ic in let flags = input_value ic in - { - cmi_name = name; - cmi_sign = sign; - cmi_crcs = crcs; - cmi_flags = flags; - } + {cmi_name = name; cmi_sign = sign; cmi_crcs = crcs; cmi_flags = flags} let read_cmi filename = let ic = open_in_bin filename in @@ -49,31 +41,31 @@ let read_cmi filename = let buffer = really_input_string ic (String.length Config.cmi_magic_number) in - if buffer <> Config.cmi_magic_number then begin + if buffer <> Config.cmi_magic_number then ( close_in ic; let pre_len = String.length Config.cmi_magic_number - 3 in - if String.sub buffer 0 pre_len - = String.sub Config.cmi_magic_number 0 pre_len then - begin + if + String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len + then let msg = - if buffer < Config.cmi_magic_number then "an older" else "a newer" in + if buffer < Config.cmi_magic_number then "an older" else "a newer" + in raise (Error (Wrong_version_interface (filename, msg))) - end else begin - raise(Error(Not_an_interface filename)) - end - end; + else raise (Error (Not_an_interface filename))); let cmi = input_cmi ic in close_in ic; cmi - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_interface(filename))) - | Error e -> - close_in ic; - raise (Error e) + with + | End_of_file | Failure _ -> + close_in ic; + raise (Error (Corrupted_interface filename)) + | Error e -> + close_in ic; + raise (Error e) let output_cmi filename oc cmi = -(* beware: the provided signature must have been substituted for saving *) + (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; output_value oc (cmi.cmi_name, cmi.cmi_sign); flush oc; @@ -83,62 +75,60 @@ let output_cmi filename oc cmi = output_value oc cmi.cmi_flags; crc - -(* This function is also called by [save_cmt] as cmi_format is subset of +(* This function is also called by [save_cmt] as cmi_format is subset of cmt_format, so dont close the channel yet *) let create_cmi ?check_exists filename (cmi : cmi_infos) = (* beware: the provided signature must have been substituted for saving *) - let content = - Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) [] + let content = + Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) [] (* checkout [output_value] in {!Pervasives} module *) - in - let crc = Digest.string content in - let cmi_infos = - if check_exists <> None && Sys.file_exists filename then + in + let crc = Digest.string content in + let cmi_infos = + if check_exists <> None && Sys.file_exists filename then Some (read_cmi filename) - else None in - match cmi_infos with - | Some {cmi_name = _; cmi_sign = _; cmi_crcs = (old_name, Some old_crc)::rest ; cmi_flags} - (* TODO: design the cmi format so that we don't need read the whole cmi *) - when - cmi.cmi_name = old_name && - crc = old_crc && - cmi.cmi_crcs = rest && - cmi_flags = cmi.cmi_flags -> - crc - | _ -> - let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - let oc = open_out_bin filename in - output_string oc content; - output_value oc crcs; - output_value oc cmi.cmi_flags; - close_out oc; - crc - - + else None + in + match cmi_infos with + | Some + { + cmi_name = _; + cmi_sign = _; + cmi_crcs = (old_name, Some old_crc) :: rest; + cmi_flags; + } + (* TODO: design the cmi format so that we don't need read the whole cmi *) + when cmi.cmi_name = old_name && crc = old_crc && cmi.cmi_crcs = rest + && cmi_flags = cmi.cmi_flags -> + crc + | _ -> + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + let oc = open_out_bin filename in + output_string oc content; + output_value oc crcs; + output_value oc cmi.cmi_flags; + close_out oc; + crc - (* Error report *) open Format let report_error ppf = function | Not_an_interface filename -> - fprintf ppf "%a@ is not a compiled interface" - Location.print_filename filename + fprintf ppf "%a@ is not a compiled interface" Location.print_filename + filename | Wrong_version_interface (filename, older_newer) -> - fprintf ppf - "%a@ is not a compiled interface for this version of OCaml.@.\ - It seems to be for %s version of OCaml." - Location.print_filename filename older_newer + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.It seems to \ + be for %s version of OCaml." + Location.print_filename filename older_newer | Corrupted_interface filename -> - fprintf ppf "Corrupted compiled interface@ %a" - Location.print_filename filename + fprintf ppf "Corrupted compiled interface@ %a" Location.print_filename + filename let () = - Location.register_error_of_exn - (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) + Location.register_error_of_exn (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None) diff --git a/compiler/ml/cmi_format.mli b/compiler/ml/cmi_format.mli index 7aa7f8d8d7..ca608d3ab8 100644 --- a/compiler/ml/cmi_format.mli +++ b/compiler/ml/cmi_format.mli @@ -13,16 +13,13 @@ (* *) (**************************************************************************) -type pers_flags = - | Deprecated of string - - +type pers_flags = Deprecated of string type cmi_infos = { - cmi_name : string; - cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t option) list; - cmi_flags : pers_flags list; + cmi_name: string; + cmi_sign: Types.signature_item list; + cmi_crcs: (string * Digest.t option) list; + cmi_flags: pers_flags list; } (* write the magic + the cmi information *) @@ -39,7 +36,7 @@ val read_cmi : string -> cmi_infos (* Error report *) type error = - Not_an_interface of string + | Not_an_interface of string | Wrong_version_interface of string * string | Corrupted_interface of string @@ -47,4 +44,4 @@ exception Error of error open Format -val report_error: formatter -> error -> unit +val report_error : formatter -> error -> unit diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli index 6daf64339f..1a84aa68d0 100644 --- a/compiler/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -49,27 +49,27 @@ and binary_part = | Partial_module_type of module_type type cmt_infos = { - cmt_modname : string; - cmt_annots : binary_annots; - cmt_value_dependencies : + cmt_modname: string; + cmt_annots: binary_annots; + cmt_value_dependencies: (Types.value_description * Types.value_description) list; - cmt_comments : (string * Location.t) list; - cmt_args : string array; - cmt_sourcefile : string option; - cmt_builddir : string; - cmt_loadpath : string list; - cmt_source_digest : string option; - cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t option) list; - cmt_interface_digest : Digest.t option; - cmt_use_summaries : bool; + cmt_comments: (string * Location.t) list; + cmt_args: string array; + cmt_sourcefile: string option; + cmt_builddir: string; + cmt_loadpath: string list; + cmt_source_digest: string option; + cmt_initial_env: Env.t; + cmt_imports: (string * Digest.t option) list; + cmt_interface_digest: Digest.t option; + cmt_use_summaries: bool; } -type error = - Not_a_typedtree of string +type error = Not_a_typedtree of string exception Error of error +val read : string -> Cmi_format.cmi_infos option * cmt_infos option (** [read filename] opens filename, and extract both the cmi_infos, if it exists, and the cmt_infos, if it exists. Thus, it can be used with .cmi, .cmt and .cmti files. @@ -78,36 +78,39 @@ exception Error of error only contain a cmi_infos at the beginning if there is no associated .cmti file. *) -val read : string -> Cmi_format.cmi_infos option * cmt_infos option val read_cmt : string -> cmt_infos val read_cmi : string -> Cmi_format.cmi_infos -(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] - writes a cmt(i) file. *) val save_cmt : - string -> (* filename.cmt to generate *) - string -> (* module name *) + string -> + (* filename.cmt to generate *) + string -> + (* module name *) binary_annots -> - string option -> (* source file *) - Env.t -> (* initial env *) - Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + string option -> + (* source file *) + Env.t -> + (* initial env *) + Cmi_format.cmi_infos option -> + (* if a .cmi was generated *) unit +(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] + writes a cmt(i) file. *) (* Miscellaneous functions *) val read_magic_number : in_channel -> string -val clear: unit -> unit +val clear : unit -> unit val add_saved_type : binary_part -> unit val get_saved_types : unit -> binary_part list val set_saved_types : binary_part list -> unit -val record_value_dependency: +val record_value_dependency : Types.value_description -> Types.value_description -> unit - (* val is_magic_number : string -> bool diff --git a/compiler/ml/code_frame.ml b/compiler/ml/code_frame.ml index f0fdad1201..25c00d9512 100644 --- a/compiler/ml/code_frame.ml +++ b/compiler/ml/code_frame.ml @@ -7,8 +7,7 @@ let digits_count n = let seek_2_lines_before src (pos : Lexing.position) = let original_line = pos.pos_lnum in let rec loop current_line current_char = - if current_line + 2 >= original_line then - (current_char, current_line) + if current_line + 2 >= original_line then (current_char, current_line) else loop (if src.[current_char] = '\n' then current_line + 1 else current_line) @@ -19,8 +18,7 @@ let seek_2_lines_before src (pos : Lexing.position) = let seek_2_lines_after src (pos : Lexing.position) = let original_line = pos.pos_lnum in let rec loop current_line current_char = - if current_char = String.length src then - (current_char, current_line) + if current_char = String.length src then (current_char, current_line) else match src.[current_char] with | '\n' when current_line = original_line + 2 -> @@ -44,7 +42,7 @@ let break_long_line max_width line = else let chunk_length = min max_width (String.length line - pos) in let chunk = String.sub line pos chunk_length in - loop (pos + chunk_length) (chunk::accum) + loop (pos + chunk_length) (chunk :: accum) in loop 0 [] |> List.rev @@ -52,18 +50,18 @@ let filter_mapi f l = let rec loop f l i accum = match l with | [] -> accum - | head::rest -> + | head :: rest -> let accum = match f i head with | None -> accum - | Some result -> result::accum + | Some result -> result :: accum in loop f rest (i + 1) accum in loop f l 0 [] |> List.rev (* Spiritual equivalent of - https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 + https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 *) module Color = struct type color = @@ -74,32 +72,33 @@ module Color = struct | NoColor let dim = "\x1b[2m" + (* let filename = "\x1b[46m" *) let err = "\x1b[1;31m" let warn = "\x1b[1;33m" let reset = "\x1b[0m" external isatty : out_channel -> bool = "caml_sys_isatty" + (* reasonable heuristic on whether colors should be enabled *) let should_enable_color () = let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr + term <> "dumb" && term <> "" && isatty stderr let color_enabled = ref true let setup = - let first = ref true in (* initialize only once *) + let first = ref true in + (* initialize only once *) fun o -> if !first then ( first := false; - color_enabled := (match o with - | Some Misc.Color.Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) - ); + color_enabled := + match o with + | Some Misc.Color.Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); () end @@ -107,10 +106,8 @@ let setup = Color.setup type gutter = Number of int | Elided type highlighted_string = {s: string; start: int; end_: int} -type line = { - gutter: gutter; - content: highlighted_string list; -} +type line = {gutter: gutter; content: highlighted_string list} + (* Features: - display a line gutter @@ -119,12 +116,17 @@ type line = { - center snippet when it's heavily indented - ellide intermediate lines when the reported range is huge *) -let print ~is_warning ~src ~(start_pos : Lexing.position) ~(end_pos:Lexing.position) = +let print ~is_warning ~src ~(start_pos : Lexing.position) + ~(end_pos : Lexing.position) = let indent = 2 in let highlight_line_start_line = start_pos.pos_lnum in let highlight_line_end_line = end_pos.pos_lnum in - let (start_line_line_offset, first_shown_line) = seek_2_lines_before src start_pos in - let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src end_pos in + let start_line_line_offset, first_shown_line = + seek_2_lines_before src start_pos + in + let end_line_line_end_offset, last_shown_line = + seek_2_lines_after src end_pos + in let more_than_5_highlighted_lines = highlight_line_end_line - highlight_line_start_line + 1 > 5 @@ -134,125 +136,144 @@ let print ~is_warning ~src ~(start_pos : Lexing.position) ~(end_pos:Lexing.posit (* 3 for separator + the 2 spaces around it *) let line_width = 78 - max_line_digits_count - indent - 3 in let lines = - String.sub src start_line_line_offset (end_line_line_end_offset - start_line_line_offset) + String.sub src start_line_line_offset + (end_line_line_end_offset - start_line_line_offset) |> String.split_on_char '\n' |> filter_mapi (fun i line -> - let line_number = i + first_shown_line in - if more_than_5_highlighted_lines then - if line_number = highlight_line_start_line + 2 then - Some (Elided, line) - else if line_number > highlight_line_start_line + 2 && line_number < highlight_line_end_line - 1 then None - else Some (Number line_number, line) - else Some (Number line_number, line) - ) + let line_number = i + first_shown_line in + if more_than_5_highlighted_lines then + if line_number = highlight_line_start_line + 2 then + Some (Elided, line) + else if + line_number > highlight_line_start_line + 2 + && line_number < highlight_line_end_line - 1 + then None + else Some (Number line_number, line) + else Some (Number line_number, line)) in - let leading_space_to_cut = lines |> List.fold_left (fun current_max (_, line) -> - let leading_spaces = leading_space_count line in - if String.length line = leading_spaces then - (* the line's nothing but spaces. Doesn't count *) - current_max - else - min leading_spaces current_max - ) 99999 + let leading_space_to_cut = + lines + |> List.fold_left + (fun current_max (_, line) -> + let leading_spaces = leading_space_count line in + if String.length line = leading_spaces then + (* the line's nothing but spaces. Doesn't count *) + current_max + else min leading_spaces current_max) + 99999 in let separator = if leading_space_to_cut = 0 then "│" else "┆" in - let stripped_lines = lines |> List.map (fun (gutter, line) -> - let new_content = - if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] - else - String.sub line leading_space_to_cut (String.length line - leading_space_to_cut) - |> break_long_line line_width - |> List.mapi (fun i line -> - match gutter with - | Elided -> {s = line; start = 0; end_ = 0} - | Number line_number -> - let highlight_line_start_offset = start_pos.pos_cnum - start_pos.pos_bol in - let highlight_line_end_offset = end_pos.pos_cnum - end_pos.pos_bol in - let start = - if i = 0 && line_number = highlight_line_start_line then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if line_number = highlight_line_start_line && line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if line_number > highlight_line_start_line && line_number < highlight_line_end_line then - String.length line - else if line_number = highlight_line_end_line then highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_} - ) - in - {gutter; content = new_content} - ) + let stripped_lines = + lines + |> List.map (fun (gutter, line) -> + let new_content = + if String.length line <= leading_space_to_cut then + [{s = ""; start = 0; end_ = 0}] + else + String.sub line leading_space_to_cut + (String.length line - leading_space_to_cut) + |> break_long_line line_width + |> List.mapi (fun i line -> + match gutter with + | Elided -> {s = line; start = 0; end_ = 0} + | Number line_number -> + let highlight_line_start_offset = + start_pos.pos_cnum - start_pos.pos_bol + in + let highlight_line_end_offset = + end_pos.pos_cnum - end_pos.pos_bol + in + let start = + if i = 0 && line_number = highlight_line_start_line + then + highlight_line_start_offset - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if + line_number = highlight_line_start_line + && line_number = highlight_line_end_line + then highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line then + String.length line + else if + line_number > highlight_line_start_line + && line_number < highlight_line_end_line + then String.length line + else if line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else 0 + in + {s = line; start; end_}) + in + {gutter; content = new_content}) in let buf = Buffer.create 100 in let open Color in let add_ch = let last_color = ref NoColor in fun color ch -> - if not !Color.color_enabled || !last_color = color then + if (not !Color.color_enabled) || !last_color = color then Buffer.add_char buf ch - else begin - let ansi = match !last_color, color with - | NoColor, Dim -> dim - (* | NoColor, Filename -> filename *) - | NoColor, Err -> err - | NoColor, Warn -> warn - | _, NoColor -> reset - | _, Dim -> reset ^ dim - (* | _, Filename -> reset ^ filename *) - | _, Err -> reset ^ err - | _, Warn -> reset ^ warn + else + let ansi = + match (!last_color, color) with + | NoColor, Dim -> dim + (* | NoColor, Filename -> filename *) + | NoColor, Err -> err + | NoColor, Warn -> warn + | _, NoColor -> reset + | _, Dim -> reset ^ dim + (* | _, Filename -> reset ^ filename *) + | _, Err -> reset ^ err + | _, Warn -> reset ^ warn in Buffer.add_string buf ansi; Buffer.add_char buf ch; - last_color := color; - end + last_color := color in let draw_gutter color s = - for _i = 1 to (max_line_digits_count + indent - String.length s) do + for _i = 1 to max_line_digits_count + indent - String.length s do add_ch NoColor ' ' done; s |> String.iter (add_ch color); add_ch NoColor ' '; separator |> String.iter (add_ch Dim); - add_ch NoColor ' '; + add_ch NoColor ' ' in - stripped_lines |> List.iter (fun {gutter; content} -> - match gutter with - | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n'; - | Number line_number -> begin - content |> List.iteri (fun i line -> - let gutter_content = if i = 0 then string_of_int line_number else "" in - let gutter_color = - if i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line then - if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; + stripped_lines + |> List.iter (fun {gutter; content} -> + match gutter with + | Elided -> + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n' + | Number line_number -> + content + |> List.iteri (fun i line -> + let gutter_content = + if i = 0 then string_of_int line_number else "" + in + let gutter_color = + if + i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line + then if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; - line.s |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor in - add_ch c ch; - ); - add_ch NoColor '\n'; - ); - end - ); + line.s + |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor + in + add_ch c ch); + add_ch NoColor '\n')); Buffer.contents buf diff --git a/compiler/ml/consistbl.ml b/compiler/ml/consistbl.ml index dbba5d1f5a..37047a2628 100644 --- a/compiler/ml/consistbl.ml +++ b/compiler/ml/consistbl.ml @@ -27,17 +27,15 @@ exception Not_available of string let check tbl name crc source = try - let (old_crc, old_source) = Hashtbl.find tbl name in - if crc <> old_crc then raise(Inconsistency(name, source, old_source)) - with Not_found -> - Hashtbl.add tbl name (crc, source) + let old_crc, old_source = Hashtbl.find tbl name in + if crc <> old_crc then raise (Inconsistency (name, source, old_source)) + with Not_found -> Hashtbl.add tbl name (crc, source) let check_noadd tbl name crc source = try - let (old_crc, old_source) = Hashtbl.find tbl name in - if crc <> old_crc then raise(Inconsistency(name, source, old_source)) - with Not_found -> - raise (Not_available name) + let old_crc, old_source = Hashtbl.find tbl name in + if crc <> old_crc then raise (Inconsistency (name, source, old_source)) + with Not_found -> raise (Not_available name) let set tbl name crc source = Hashtbl.add tbl name (crc, source) @@ -47,20 +45,20 @@ let extract l tbl = let l = List.sort_uniq String.compare l in List.fold_left (fun assc name -> - try - let (crc, _) = Hashtbl.find tbl name in - (name, Some crc) :: assc - with Not_found -> - (name, None) :: assc) + try + let crc, _ = Hashtbl.find tbl name in + (name, Some crc) :: assc + with Not_found -> (name, None) :: assc) [] l let filter p tbl = let to_remove = ref [] in Hashtbl.iter - (fun name _ -> - if not (p name) then to_remove := name :: !to_remove) + (fun name _ -> if not (p name) then to_remove := name :: !to_remove) tbl; List.iter (fun name -> - while Hashtbl.mem tbl name do Hashtbl.remove tbl name done) + while Hashtbl.mem tbl name do + Hashtbl.remove tbl name + done) !to_remove diff --git a/compiler/ml/consistbl.mli b/compiler/ml/consistbl.mli index c532bddfe8..cfee26f5d2 100644 --- a/compiler/ml/consistbl.mli +++ b/compiler/ml/consistbl.mli @@ -17,46 +17,46 @@ type t -val create: unit -> t +val create : unit -> t -val clear: t -> unit +val clear : t -> unit -val check: t -> string -> Digest.t -> string -> unit - (* [check tbl name crc source] - checks consistency of ([name], [crc]) with infos previously - stored in [tbl]. If no CRC was previously associated with - [name], record ([name], [crc]) in [tbl]. - [source] is the name of the file from which the information - comes from. This is used for error reporting. *) +val check : t -> string -> Digest.t -> string -> unit +(* [check tbl name crc source] + checks consistency of ([name], [crc]) with infos previously + stored in [tbl]. If no CRC was previously associated with + [name], record ([name], [crc]) in [tbl]. + [source] is the name of the file from which the information + comes from. This is used for error reporting. *) -val check_noadd: t -> string -> Digest.t -> string -> unit - (* Same as [check], but raise [Not_available] if no CRC was previously - associated with [name]. *) +val check_noadd : t -> string -> Digest.t -> string -> unit +(* Same as [check], but raise [Not_available] if no CRC was previously + associated with [name]. *) -val set: t -> string -> Digest.t -> string -> unit - (* [set tbl name crc source] forcefully associates [name] with - [crc] in [tbl], even if [name] already had a different CRC - associated with [name] in [tbl]. *) +val set : t -> string -> Digest.t -> string -> unit +(* [set tbl name crc source] forcefully associates [name] with + [crc] in [tbl], even if [name] already had a different CRC + associated with [name] in [tbl]. *) -val source: t -> string -> string - (* [source tbl name] returns the file name associated with [name] - if the latter has an associated CRC in [tbl]. - Raise [Not_found] otherwise. *) +val source : t -> string -> string +(* [source tbl name] returns the file name associated with [name] + if the latter has an associated CRC in [tbl]. + Raise [Not_found] otherwise. *) -val extract: string list -> t -> (string * Digest.t option) list - (* [extract tbl names] returns an associative list mapping each string - in [names] to the CRC associated with it in [tbl]. If no CRC is - associated with a name then it is mapped to [None]. *) +val extract : string list -> t -> (string * Digest.t option) list +(* [extract tbl names] returns an associative list mapping each string + in [names] to the CRC associated with it in [tbl]. If no CRC is + associated with a name then it is mapped to [None]. *) -val filter: (string -> bool) -> t -> unit - (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs - such that [pred name] is [false]. *) +val filter : (string -> bool) -> t -> unit +(* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs + such that [pred name] is [false]. *) exception Inconsistency of string * string * string - (* Raised by [check] when a CRC mismatch is detected. - First string is the name of the compilation unit. - Second string is the source that caused the inconsistency. - Third string is the source that set the CRC. *) +(* Raised by [check] when a CRC mismatch is detected. + First string is the name of the compilation unit. + Second string is the source that caused the inconsistency. + Third string is the source that set the CRC. *) exception Not_available of string - (* Raised by [check_noadd] when a name doesn't have an associated CRC. *) +(* Raised by [check_noadd] when a name doesn't have an associated CRC. *) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 0337f008c4..ec3d3f96e0 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -59,20 +59,17 @@ exception Unify of (type_expr * type_expr) list exception Tags of label * label let () = - Location.register_error_of_exn - (function - | Tags (l, l') -> - Some - Location. - (errorf ~loc:(in_file !input_name) - "In this program,@ variant constructors@ #%s and #%s@ \ - have the same hash value.@ Change one of them." l l' - ) - | _ -> None - ) - -exception Subtype of - (type_expr * type_expr) list * (type_expr * type_expr) list + Location.register_error_of_exn (function + | Tags (l, l') -> + Some + Location.( + errorf ~loc:(in_file !input_name) + "In this program,@ variant constructors@ #%s and #%s@ have the \ + same hash value.@ Change one of them." + l l') + | _ -> None) + +exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list exception Cannot_expand @@ -90,14 +87,19 @@ let nongen_level = ref 0 let global_level = ref 1 let saved_level = ref [] -type levels = - { current_level: int; nongen_level: int; global_level: int; - saved_level: (int * int) list; } +type levels = { + current_level: int; + nongen_level: int; + global_level: int; + saved_level: (int * int) list; +} let save_levels () = - { current_level = !current_level; + { + current_level = !current_level; nongen_level = !nongen_level; global_level = !global_level; - saved_level = !saved_level } + saved_level = !saved_level; + } let set_levels l = current_level := l.current_level; nongen_level := l.nongen_level; @@ -105,10 +107,13 @@ let set_levels l = saved_level := l.saved_level let get_current_level () = !current_level -let init_def level = current_level := level; nongen_level := level +let init_def level = + current_level := level; + nongen_level := level let begin_def () = saved_level := (!current_level, !nongen_level) :: !saved_level; - incr current_level; nongen_level := !current_level + incr current_level; + nongen_level := !current_level let begin_class_def () = saved_level := (!current_level, !nongen_level) :: !saved_level; incr current_level @@ -116,36 +121,40 @@ let raise_nongen_level () = saved_level := (!current_level, !nongen_level) :: !saved_level; nongen_level := !current_level let end_def () = - let (cl, nl) = List.hd !saved_level in + let cl, nl = List.hd !saved_level in saved_level := List.tl !saved_level; - current_level := cl; nongen_level := nl + current_level := cl; + nongen_level := nl -let reset_global_level () = - global_level := !current_level + 1 +let reset_global_level () = global_level := !current_level + 1 let increase_global_level () = let gl = !global_level in global_level := !current_level; gl -let restore_global_level gl = - global_level := gl +let restore_global_level gl = global_level := gl (**** Whether a path points to an object type (with hidden row variable) ****) let is_object_type path = let name = - match path with Path.Pident id -> Ident.name id - | Path.Pdot(_, s,_) -> s + match path with + | Path.Pident id -> Ident.name id + | Path.Pdot (_, s, _) -> s | Path.Papply _ -> assert false - in name.[0] = '#' + in + name.[0] = '#' (**** Control tracing of GADT instances *) let trace_gadt_instances = ref false let check_trace_gadt_instances env = - not !trace_gadt_instances && Env.has_local_constraints env && - (trace_gadt_instances := true; cleanup_abbrev (); true) + (not !trace_gadt_instances) + && Env.has_local_constraints env + && + (trace_gadt_instances := true; + cleanup_abbrev (); + true) -let reset_trace_gadt_instances b = - if b then trace_gadt_instances := false +let reset_trace_gadt_instances b = if b then trace_gadt_instances := false let wrap_trace_gadt_instances env f x = let b = check_trace_gadt_instances env in @@ -159,27 +168,25 @@ let wrap_trace_gadt_instances env f x = let simple_abbrevs = ref Mnil let proper_abbrevs path tl abbrev = - if tl <> [] || !trace_gadt_instances || - is_object_type path - then abbrev + if tl <> [] || !trace_gadt_instances || is_object_type path then abbrev else simple_abbrevs (**** Some type creators ****) (* Re-export generic type creators *) -let newty2 = Btype.newty2 -let newty desc = newty2 !current_level desc +let newty2 = Btype.newty2 +let newty desc = newty2 !current_level desc -let newvar ?name () = newty2 !current_level (Tvar name) -let newvar2 ?name level = newty2 level (Tvar name) +let newvar ?name () = newty2 !current_level (Tvar name) +let newvar2 ?name level = newty2 level (Tvar name) let new_global_var ?name () = newty2 !global_level (Tvar name) -let newobj fields = newty (Tobject (fields, ref None)) +let newobj fields = newty (Tobject (fields, ref None)) let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) -let none = newty (Ttuple []) (* Clearly ill-formed type *) +let none = newty (Ttuple []) (* Clearly ill-formed type *) (**** Representative of a type ****) @@ -188,13 +195,11 @@ let repr = repr (**** Type maps ****) -module TypePairs = - Hashtbl.Make (struct - type t = type_expr * type_expr - let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') - let hash (t, t') = t.id + 93 * t'.id - end) - +module TypePairs = Hashtbl.Make (struct + type t = type_expr * type_expr + let equal (t1, t1') (t2, t2') = t1 == t2 && t1' == t2' + let hash (t, t') = t.id + (93 * t'.id) +end) (**** unification mode ****) @@ -232,65 +237,60 @@ let in_current_module = function | Path.Pdot _ | Path.Papply _ -> false let in_pervasives p = - in_current_module p && - try ignore (Env.find_type p Env.initial_safe_string); true + in_current_module p + && + try + ignore (Env.find_type p Env.initial_safe_string); + true with Not_found -> false -let is_datatype decl= +let is_datatype decl = match decl.type_kind with - Type_record _ | Type_variant _ | Type_open -> true + | Type_record _ | Type_variant _ | Type_open -> true | Type_abstract -> false - - (**********************************************) - (* Miscellaneous operations on object types *) - (**********************************************) +(**********************************************) +(* Miscellaneous operations on object types *) +(**********************************************) (* Note: We need to maintain some invariants: * cty_self must be a Tobject * ... *) -type fields = (string * Types.field_kind * Types.type_expr) list +type fields = (string * Types.field_kind * Types.type_expr) list (**** Object field manipulation. ****) let object_fields ty = match (repr ty).desc with - Tobject (fields, _) -> fields - | _ -> assert false + | Tobject (fields, _) -> fields + | _ -> assert false let flatten_fields (ty : Types.type_expr) : fields * _ = let rec flatten (l : fields) ty = let ty = repr ty in match ty.desc with - Tfield(s, k, ty1, ty2) -> - flatten ((s, k, ty1)::l) ty2 - | _ -> - (l, ty) + | Tfield (s, k, ty1, ty2) -> flatten ((s, k, ty1) :: l) ty2 + | _ -> (l, ty) in - let (l, r) = flatten [] ty in - (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) + let l, r = flatten [] ty in + (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) let build_fields level = - List.fold_right - (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2))) - - -let associate_fields - (fields1 : fields ) - (fields2 : fields ) : _ * fields * fields = - let rec associate p s s' : fields * fields -> _ = - function - (l, []) -> - (List.rev p, (List.rev s) @ l, List.rev s') - | ([], l') -> - (List.rev p, List.rev s, (List.rev s') @ l') - | ((n, k, t)::r, (n', k', t')::r') when n = n' -> - associate ((n, k, t, k', t')::p) s s' (r, r') - | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' -> - associate p ((n, k, t)::s) s' (r, l') - | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) -> - associate p s ((n', k', t')::s') (l, r') + List.fold_right (fun (s, k, ty1) ty2 -> + newty2 level (Tfield (s, k, ty1, ty2))) + +let associate_fields (fields1 : fields) (fields2 : fields) : _ * fields * fields + = + let rec associate p s s' : fields * fields -> _ = function + | l, [] -> (List.rev p, List.rev s @ l, List.rev s') + | [], l' -> (List.rev p, List.rev s, List.rev s' @ l') + | (n, k, t) :: r, (n', k', t') :: r' when n = n' -> + associate ((n, k, t, k', t') :: p) s s' (r, r') + | (n, k, t) :: r, ((n', _k', _t') :: _ as l') when n < n' -> + associate p ((n, k, t) :: s) s' (r, l') + | ((_n, _k, _t) :: _ as l), (n', k', t') :: r' (* when n > n' *) -> + associate p s ((n', k', t') :: s') (l, r') in associate [] [] [] (fields1, fields2) @@ -300,19 +300,19 @@ let associate_fields let rec object_row ty = let ty = repr ty in match ty.desc with - Tobject (t, _) -> object_row t - | Tfield(_, _, _, t) -> object_row t + | Tobject (t, _) -> object_row t + | Tfield (_, _, _, t) -> object_row t | _ -> ty let opened_object ty = match (object_row ty).desc with - | Tvar _ | Tunivar _ | Tconstr _ -> true - | _ -> false + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false let concrete_object ty = match (object_row ty).desc with - | Tvar _ -> false - | _ -> true + | Tvar _ -> false + | _ -> true (**** Close an object ****) @@ -320,14 +320,13 @@ let close_object ty = let rec close ty = let ty = repr ty in match ty.desc with - Tvar _ -> - link_type ty (newty2 ty.level Tnil) - | Tfield(_, _, _, ty') -> close ty' - | _ -> assert false + | Tvar _ -> link_type ty (newty2 ty.level Tnil) + | Tfield (_, _, _, ty') -> close ty' + | _ -> assert false in match (repr ty).desc with - Tobject (ty, _) -> close ty - | _ -> assert false + | Tobject (ty, _) -> close ty + | _ -> assert false (**** Row variable of an object type ****) @@ -335,89 +334,88 @@ let row_variable ty = let rec find ty = let ty = repr ty in match ty.desc with - Tfield (_, _, _, ty) -> find ty - | Tvar _ -> ty - | _ -> assert false + | Tfield (_, _, _, ty) -> find ty + | Tvar _ -> ty + | _ -> assert false in match (repr ty).desc with - Tobject (fi, _) -> find fi - | _ -> assert false + | Tobject (fi, _) -> find fi + | _ -> assert false (**** Object name manipulation ****) (* +++ Bientot obsolete *) let set_object_name id rv params ty = match (repr ty).desc with - Tobject (_fi, nm) -> - set_name nm (Some (Path.Pident id, rv::params)) - | _ -> - assert false + | Tobject (_fi, nm) -> set_name nm (Some (Path.Pident id, rv :: params)) + | _ -> assert false let remove_object_name ty = match (repr ty).desc with - Tobject (_, nm) -> set_name nm None + | Tobject (_, nm) -> set_name nm None | Tconstr (_, _, _) -> () - | _ -> fatal_error "Ctype.remove_object_name" + | _ -> fatal_error "Ctype.remove_object_name" (**** Hiding of private methods ****) let hide_private_methods ty = match (repr ty).desc with - Tobject (fi, nm) -> - nm := None; - let (fl, _) = flatten_fields fi in - List.iter - (function (_, k, _) -> + | Tobject (fi, nm) -> + nm := None; + let fl, _ = flatten_fields fi in + List.iter + (function + | _, k, _ -> ( match field_kind_repr k with - Fvar r -> set_kind r Fabsent - | _ -> ()) - fl - | _ -> - assert false - - - (*******************************) - (* Operations on class types *) - (*******************************) - - - - (*******************************************) - (* Miscellaneous operations on row types *) - (*******************************************) + | Fvar r -> set_kind r Fabsent + | _ -> ())) + fl + | _ -> assert false + +(*******************************) +(* Operations on class types *) +(*******************************) + +(*******************************************) +(* Miscellaneous operations on row types *) +(*******************************************) type row_fields = (Asttypes.label * Types.row_field) list type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list -let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q) - -let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) = - match fi1, fi2 with - (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> - if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else - if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else - merge_rf r1 (p2::r2) pairs fi1 fi2' +let sort_row_fields : row_fields -> row_fields = + List.sort (fun (p, _) (q, _) -> compare (p : string) q) + +let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) + (fi1 : row_fields) (fi2 : row_fields) = + match (fi1, fi2) with + | ((l1, f1) as p1) :: fi1', ((l2, f2) as p2) :: fi2' -> + if l1 = l2 then merge_rf r1 r2 ((l1, f1, f2) :: pairs) fi1' fi2' + else if l1 < l2 then merge_rf (p1 :: r1) r2 pairs fi1' fi2 + else merge_rf r1 (p2 :: r2) pairs fi1 fi2' | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) -let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs = - match fi1, fi2 with - [], _ | _, [] -> (fi1, fi2, []) +let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : + row_fields * row_fields * row_pairs = + match (fi1, fi2) with + | [], _ | _, [] -> (fi1, fi2, []) | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) let rec filter_row_fields erase = function - [] -> [] - | (_l,f as p)::fi -> - let fi = filter_row_fields erase fi in - match row_field_repr f with - Rabsent -> fi - | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi - | _ -> p :: fi - - (**************************************) - (* Check genericity of type schemes *) - (**************************************) + | [] -> [] + | ((_l, f) as p) :: fi -> ( + let fi = filter_row_fields erase fi in + match row_field_repr f with + | Rabsent -> fi + | Reither (_, _, false, e) when erase -> + set_row_field e Rabsent; + fi + | _ -> p :: fi) +(**************************************) +(* Check genericity of type schemes *) +(**************************************) exception Non_closed of type_expr * bool @@ -426,35 +424,30 @@ let really_closed = ref None let rec free_vars_rec real ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; - begin match ty.desc, !really_closed with - Tvar _, _ -> - free_variables := (ty, real) :: !free_variables + match (ty.desc, !really_closed) with + | Tvar _, _ -> free_variables := (ty, real) :: !free_variables | Tconstr (path, tl, _), Some env -> - begin try - let (_, body, _) = Env.find_type_expansion path env in - if (repr body).level <> generic_level then - free_variables := (ty, real) :: !free_variables - with Not_found -> () - end; - List.iter (free_vars_rec true) tl -(* Do not count "virtual" free variables - | Tobject(ty, {contents = Some (_, p)}) -> - free_vars_rec false ty; List.iter (free_vars_rec true) p -*) - | Tobject (ty, _), _ -> - free_vars_rec false ty + (try + let _, body, _ = Env.find_type_expansion path env in + if (repr body).level <> generic_level then + free_variables := (ty, real) :: !free_variables + with Not_found -> ()); + List.iter (free_vars_rec true) tl + (* Do not count "virtual" free variables + | Tobject(ty, {contents = Some (_, p)}) -> + free_vars_rec false ty; List.iter (free_vars_rec true) p + *) + | Tobject (ty, _), _ -> free_vars_rec false ty | Tfield (_, _, ty1, ty2), _ -> - free_vars_rec true ty1; free_vars_rec false ty2 + free_vars_rec true ty1; + free_vars_rec false ty2 | Tvariant row, _ -> - let row = row_repr row in - iter_row (free_vars_rec true) row; - if not (static_row row) then free_vars_rec false row.row_more - | _ -> - iter_type_expr (free_vars_rec true) ty - end; - end + let row = row_repr row in + iter_row (free_vars_rec true) row; + if not (static_row row) then free_vars_rec false row.row_more + | _ -> iter_type_expr (free_vars_rec true) ty) let free_vars ?env ty = free_variables := []; @@ -472,13 +465,17 @@ let free_variables ?env ty = let closed_type ty = match free_vars ty with - [] -> () + | [] -> () | (v, real) :: _ -> raise (Non_closed (v, real)) let closed_parameterized_type params ty = List.iter mark_type params; let ok = - try closed_type ty; true with Non_closed _ -> false in + try + closed_type ty; + true + with Non_closed _ -> false + in List.iter unmark_type params; unmark_type ty; ok @@ -486,28 +483,23 @@ let closed_parameterized_type params ty = let closed_type_decl decl = try List.iter mark_type decl.type_params; - begin match decl.type_kind with - Type_abstract -> - () + (match decl.type_kind with + | Type_abstract -> () | Type_variant v -> - List.iter - (fun {cd_args; cd_res; _} -> - match cd_res with - | Some _ -> () - | None -> - match cd_args with - | Cstr_tuple l -> List.iter closed_type l - | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l - ) - v - | Type_record(r, _rep) -> - List.iter (fun l -> closed_type l.ld_type) r - | Type_open -> () - end; - begin match decl.type_manifest with - None -> () - | Some ty -> closed_type ty - end; + List.iter + (fun {cd_args; cd_res; _} -> + match cd_res with + | Some _ -> () + | None -> ( + match cd_args with + | Cstr_tuple l -> List.iter closed_type l + | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l)) + v + | Type_record (r, _rep) -> List.iter (fun l -> closed_type l.ld_type) r + | Type_open -> ()); + (match decl.type_manifest with + | None -> () + | Some ty -> closed_type ty); unmark_type_decl decl; None with Non_closed (ty, _) -> @@ -517,10 +509,9 @@ let closed_type_decl decl = let closed_extension_constructor ext = try List.iter mark_type ext.ext_type_params; - begin match ext.ext_ret_type with + (match ext.ext_ret_type with | Some _ -> () - | None -> iter_type_expr_cstr_args closed_type ext.ext_args - end; + | None -> iter_type_expr_cstr_args closed_type ext.ext_args); unmark_extension_constructor ext; None with Non_closed (ty, _) -> @@ -528,25 +519,21 @@ let closed_extension_constructor ext = Some ty type closed_class_failure = - CC_Method of type_expr * bool * string * type_expr + | CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr - - (**********************) - (* Type duplication *) - (**********************) - +(**********************) +(* Type duplication *) +(**********************) (* Duplicate a type, preserving only type variables *) -let duplicate_type ty = - Subst.type_expr Subst.identity ty +let duplicate_type ty = Subst.type_expr Subst.identity ty (* Same, for class types *) - - (*****************************) - (* Type level manipulation *) - (*****************************) +(*****************************) +(* Type level manipulation *) +(*****************************) (* It would be a bit more efficient to remove abbreviation expansions @@ -557,15 +544,12 @@ let duplicate_type ty = *) let rec generalize ty = let ty = repr ty in - if (ty.level > !current_level) && (ty.level <> generic_level) then begin + if ty.level > !current_level && ty.level <> generic_level then ( set_level ty generic_level; - begin match ty.desc with - Tconstr (_, _, abbrev) -> - iter_abbrev generalize !abbrev - | _ -> () - end; - iter_type_expr generalize ty - end + (match ty.desc with + | Tconstr (_, _, abbrev) -> iter_abbrev generalize !abbrev + | _ -> ()); + iter_type_expr generalize ty) let generalize ty = simple_abbrevs := Mnil; @@ -575,27 +559,28 @@ let generalize ty = let rec generalize_structure var_level ty = let ty = repr ty in - if ty.level <> generic_level then begin - if is_Tvar ty && ty.level > var_level then - set_level ty var_level + if ty.level <> generic_level then + if is_Tvar ty && ty.level > var_level then set_level ty var_level else if - ty.level > !current_level && + ty.level > !current_level + && match ty.desc with - Tconstr (p, _, abbrev) -> - not (is_object_type p) && (abbrev := Mnil; true) + | Tconstr (p, _, abbrev) -> + (not (is_object_type p)) + && + (abbrev := Mnil; + true) | _ -> true - then begin + then ( set_level ty generic_level; - iter_type_expr (generalize_structure var_level) ty - end - end + iter_type_expr (generalize_structure var_level) ty) let generalize_structure var_level ty = simple_abbrevs := Mnil; generalize_structure var_level ty - -let forward_try_expand_once = (* Forward declaration *) +let forward_try_expand_once = + (* Forward declaration *) ref (fun _env _ty -> raise Cannot_expand) (* @@ -613,139 +598,122 @@ let forward_try_expand_once = (* Forward declaration *) let get_level env p = try match (Env.find_type p env).type_newtype_level with - | None -> Path.binding_time p - | Some (x, _) -> x - with - | Not_found -> - (* no newtypes in predef *) - Path.binding_time p + | None -> Path.binding_time p + | Some (x, _) -> x + with Not_found -> (* no newtypes in predef *) + Path.binding_time p let rec normalize_package_path env p = - let t = - try (Env.find_modtype p env).mtd_type - with Not_found -> None - in + let t = try (Env.find_modtype p env).mtd_type with Not_found -> None in match t with | Some (Mty_ident p) -> normalize_package_path env p - | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> - match p with - Path.Pdot (p1, s, n) -> - (* For module aliases *) - let p1' = Env.normalize_path None env p1 in - if Path.same p1 p1' then p else - normalize_package_path env (Path.Pdot (p1', s, n)) - | _ -> p + | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> ( + match p with + | Path.Pdot (p1, s, n) -> + (* For module aliases *) + let p1' = Env.normalize_path None env p1 in + if Path.same p1 p1' then p + else normalize_package_path env (Path.Pdot (p1', s, n)) + | _ -> p) let rec update_level env level expand ty = let ty = repr ty in - if ty.level > level then begin - begin match Env.gadt_instance_level env ty with - Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) - | None -> () - end; + if ty.level > level then ( + (match Env.gadt_instance_level env ty with + | Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) + | None -> ()); match ty.desc with - Tconstr(p, _tl, _abbrev) when level < get_level env p -> - (* Try first to replace an abbreviation by its expansion. *) - begin try - (* if is_newtype env p then raise Cannot_expand; *) - link_type ty (!forward_try_expand_once env ty); - update_level env level expand ty - with Cannot_expand -> - (* +++ Levels should be restored... *) - (* Format.printf "update_level: %i < %i@." level (get_level env p); *) - if level < get_level env p then raise (Unify [(ty, newvar2 level)]); - iter_type_expr (update_level env level expand) ty - end - | Tconstr(_, _ :: _, _) when expand -> - begin try - link_type ty (!forward_try_expand_once env ty); - update_level env level expand ty - with Cannot_expand -> - set_level ty level; - iter_type_expr (update_level env level expand) ty - end - | 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); + | Tconstr (p, _tl, _abbrev) when level < get_level env p -> ( + (* Try first to replace an abbreviation by its expansion. *) + try + (* if is_newtype env p then raise Cannot_expand; *) + link_type ty (!forward_try_expand_once env ty); update_level env level expand ty - | Tobject(_, ({contents=Some(p, _tl)} as nm)) - when level < get_level env p -> - set_name nm None; + with Cannot_expand -> + (* +++ Levels should be restored... *) + (* Format.printf "update_level: %i < %i@." level (get_level env p); *) + if level < get_level env p then raise (Unify [(ty, newvar2 level)]); + iter_type_expr (update_level env level expand) ty) + | Tconstr (_, _ :: _, _) when expand -> ( + try + link_type ty (!forward_try_expand_once env ty); update_level env level expand ty - | Tvariant row -> - let row = row_repr row in - begin match row.row_name with - | Some (p, _tl) when level < get_level env p -> - log_type ty; - ty.desc <- Tvariant {row with row_name = None} - | _ -> () - end; + with Cannot_expand -> set_level ty level; - iter_type_expr (update_level env level expand) ty - | Tfield(lab, _, ty1, _) + iter_type_expr (update_level env level expand) ty) + | 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); + update_level env level expand ty + | Tobject (_, ({contents = Some (p, _tl)} as nm)) + when level < get_level env p -> + set_name nm None; + update_level env level expand ty + | Tvariant row -> + let row = row_repr row in + (match row.row_name with + | Some (p, _tl) when level < get_level env p -> + log_type ty; + ty.desc <- Tvariant {row with row_name = None} + | _ -> ()); + set_level ty level; + iter_type_expr (update_level env level expand) ty + | Tfield (lab, _, ty1, _) when lab = dummy_method && (repr ty1).level > level -> - raise (Unify [(ty1, newvar2 level)]) + raise (Unify [(ty1, newvar2 level)]) | _ -> - set_level ty level; - (* XXX what about abbreviations in Tconstr ? *) - iter_type_expr (update_level env level expand) ty - end + set_level ty level; + (* XXX what about abbreviations in Tconstr ? *) + iter_type_expr (update_level env level expand) ty) (* First try without expanding, then expand everything, to avoid combinatorial blow-up *) let update_level env level ty = let ty = repr ty in - if ty.level > level then begin + if ty.level > level then ( let snap = snapshot () in - try - update_level env level false ty + try update_level env level false ty with Unify _ -> backtrack snap; - update_level env level true ty - end + update_level env level true ty) (* Generalize and lower levels of contravariant branches simultaneously *) let rec generalize_expansive env var_level visited ty = let ty = repr ty in - if ty.level = generic_level || ty.level <= var_level then () else - if not (Hashtbl.mem visited ty.id) then begin + if ty.level = generic_level || ty.level <= var_level then () + else if not (Hashtbl.mem visited ty.id) then ( Hashtbl.add visited ty.id (); match ty.desc with - Tconstr (path, tyl, abbrev) -> - let variance = - try (Env.find_type path env).type_variance - with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in - abbrev := Mnil; - List.iter2 - (fun v t -> - if Variance.(mem May_weak v) - then generalize_structure var_level t - else generalize_expansive env var_level visited t) - variance tyl - | Tpackage (_, _, tyl) -> - List.iter (generalize_structure var_level) tyl + | Tconstr (path, tyl, abbrev) -> + let variance = + try (Env.find_type path env).type_variance + with Not_found -> List.map (fun _ -> Variance.may_inv) tyl + in + abbrev := Mnil; + List.iter2 + (fun v t -> + if Variance.(mem May_weak v) then generalize_structure var_level t + else generalize_expansive env var_level visited t) + variance tyl + | Tpackage (_, _, tyl) -> List.iter (generalize_structure var_level) tyl | Tarrow (_, t1, t2, _) -> - generalize_structure var_level t1; - generalize_expansive env var_level visited t2 - | _ -> - iter_type_expr (generalize_expansive env var_level visited) ty - end + generalize_structure var_level t1; + generalize_expansive env var_level visited t2 + | _ -> iter_type_expr (generalize_expansive env var_level visited) ty) let generalize_expansive env ty = simple_abbrevs := Mnil; - try - generalize_expansive env !nongen_level (Hashtbl.create 7) ty - with Unify ([_, ty'] as tr) -> - raise (Unify ((ty, ty') :: tr)) + try generalize_expansive env !nongen_level (Hashtbl.create 7) ty + with Unify ([(_, ty')] as tr) -> raise (Unify ((ty, ty') :: tr)) let generalize_global ty = generalize_structure !global_level ty let generalize_structure ty = generalize_structure !current_level ty (* Correct the levels of type [ty]. *) -let correct_levels ty = - duplicate_type ty +let correct_levels ty = duplicate_type ty (* Only generalize the type ty0 in ty *) let limited_generalize ty0 ty = @@ -757,50 +725,45 @@ let limited_generalize ty0 ty = let rec inverse pty ty = let ty = repr ty in - if (ty.level > !current_level) || (ty.level = generic_level) then begin + if ty.level > !current_level || ty.level = generic_level then ( decr idx; Hashtbl.add graph !idx (ty, ref pty); - if (ty.level = generic_level) || (ty == ty0) then - roots := ty :: !roots; + if ty.level = generic_level || ty == ty0 then roots := ty :: !roots; set_level ty !idx; - iter_type_expr (inverse [ty]) ty - end else if ty.level < lowest_level then begin - let (_, parents) = Hashtbl.find graph ty.level in + iter_type_expr (inverse [ty]) ty) + else if ty.level < lowest_level then + let _, parents = Hashtbl.find graph ty.level in parents := pty @ !parents - end - and generalize_parents ty = let idx = ty.level in - if idx <> generic_level then begin + if idx <> generic_level then ( set_level ty generic_level; List.iter generalize_parents !(snd (Hashtbl.find graph idx)); (* Special case for rows: must generalize the row variable *) match ty.desc with - Tvariant row -> - let more = row_more row in - let lv = more.level in - if (lv < lowest_level || lv > !current_level) - && lv <> generic_level then set_level more generic_level - | _ -> () - end + | Tvariant row -> + let more = row_more row in + let lv = more.level in + if (lv < lowest_level || lv > !current_level) && lv <> generic_level + then set_level more generic_level + | _ -> ()) in inverse [] ty; - if ty0.level < lowest_level then - iter_type_expr (inverse []) ty0; + if ty0.level < lowest_level then iter_type_expr (inverse []) ty0; List.iter generalize_parents !roots; Hashtbl.iter (fun _ (ty, _) -> - if ty.level <> generic_level then set_level ty !current_level) + if ty.level <> generic_level then set_level ty !current_level) graph - (* Compute statically the free univars of all nodes in a type *) (* This avoids doing it repeatedly during instantiation *) -type inv_type_expr = - { inv_type : type_expr; - mutable inv_parents : inv_type_expr list } +type inv_type_expr = { + inv_type: type_expr; + mutable inv_parents: inv_type_expr list; +} let rec inv_type hash pty ty = let ty = repr ty in @@ -808,7 +771,7 @@ let rec inv_type hash pty ty = let inv = TypeHash.find hash ty in inv.inv_parents <- pty @ inv.inv_parents with Not_found -> - let inv = { inv_type = ty; inv_parents = pty } in + let inv = {inv_type = ty; inv_parents = pty} in TypeHash.add hash ty inv; iter_type_expr (inv_type hash [inv]) ty @@ -818,39 +781,30 @@ let compute_univars ty = let node_univars = TypeHash.create 17 in let rec add_univar univ inv = match inv.inv_type.desc with - Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () - | _ -> - try - let univs = TypeHash.find node_univars inv.inv_type in - if not (TypeSet.mem univ !univs) then begin - univs := TypeSet.add univ !univs; - List.iter (add_univar univ) inv.inv_parents - end - with Not_found -> - TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); - List.iter (add_univar univ) inv.inv_parents + | Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () + | _ -> ( + try + let univs = TypeHash.find node_univars inv.inv_type in + if not (TypeSet.mem univ !univs) then ( + univs := TypeSet.add univ !univs; + List.iter (add_univar univ) inv.inv_parents) + with Not_found -> + TypeHash.add node_univars inv.inv_type (ref (TypeSet.singleton univ)); + List.iter (add_univar univ) inv.inv_parents) in - TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) - inverted; + TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) inverted; fun ty -> try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty +(*******************) +(* Instantiation *) +(*******************) - (*******************) - (* Instantiation *) - (*******************) - - -let rec find_repr p1 = - function - Mnil -> - None - | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> - Some ty - | Mcons (_, _, _, _, rem) -> - find_repr p1 rem - | Mlink {contents = rem} -> - find_repr p1 rem +let rec find_repr p1 = function + | Mnil -> None + | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> Some ty + | Mcons (_, _, _, _, rem) -> find_repr p1 rem + | Mlink {contents = rem} -> find_repr p1 rem (* Generic nodes are duplicated, while non-generic nodes are left @@ -863,7 +817,7 @@ let rec find_repr p1 = *) let abbreviations = ref (ref Mnil) - (* Abbreviation memorized. *) +(* Abbreviation memorized. *) (* partial: we may not wish to copy the non generic types before we call type_pat *) @@ -871,42 +825,43 @@ let rec copy ?env ?partial ?keep_names ty = let copy = copy ?env ?partial ?keep_names in let ty = repr ty in match ty.desc with - Tsubst ty -> ty + | Tsubst ty -> ty | _ -> - if ty.level <> generic_level && partial = None then ty else - (* We only forget types that are non generic and do not contain - free univars *) - let forget = - if ty.level = generic_level then generic_level else - match partial with - None -> assert false - | Some (free_univars, keep) -> - if TypeSet.is_empty (free_univars ty) then - if keep then ty.level else !current_level - else generic_level - in - if forget <> generic_level then newty2 forget (Tvar None) else - let desc = ty.desc in - save_desc ty desc; - let t = newvar() in (* Stub *) - begin match env with - Some env when Env.has_local_constraints env -> - begin match Env.gadt_instance_level env ty with - Some lv -> Env.add_gadt_instances env lv [t] - | None -> () - end - | _ -> () - end; - ty.desc <- Tsubst t; - t.desc <- - begin match desc with - | Tconstr (p, tl, _) -> - let abbrevs = proper_abbrevs p tl !abbreviations in - begin match find_repr p !abbrevs with - Some ty when repr ty != t -> - Tlink ty - | _ -> - (* + if ty.level <> generic_level && partial = None then ty + else + (* We only forget types that are non generic and do not contain + free univars *) + let forget = + if ty.level = generic_level then generic_level + else + match partial with + | None -> assert false + | Some (free_univars, keep) -> + if TypeSet.is_empty (free_univars ty) then + if keep then ty.level else !current_level + else generic_level + in + if forget <> generic_level then newty2 forget (Tvar None) + else + let desc = ty.desc in + save_desc ty desc; + let t = newvar () in + (* Stub *) + (match env with + | Some env when Env.has_local_constraints env -> ( + match Env.gadt_instance_level env ty with + | Some lv -> Env.add_gadt_instances env lv [t] + | None -> ()) + | _ -> ()); + ty.desc <- Tsubst t; + t.desc <- + (match desc with + | Tconstr (p, tl, _) -> ( + let abbrevs = proper_abbrevs p tl !abbreviations in + match find_repr p !abbrevs with + | Some ty when repr ty != t -> Tlink ty + | _ -> + (* One must allocate a new reference, so that abbrevia- tions belonging to different branches of a type are independent. @@ -915,98 +870,103 @@ let rec copy ?env ?partial ?keep_names ty = ation can be released by changing the content of just one reference. *) - Tconstr (p, List.map copy tl, - ref (match !(!abbreviations) with - Mcons _ -> Mlink !abbreviations - | abbrev -> abbrev)) - end - | Tvariant row0 -> - let row = row_repr row0 in - let more = repr row.row_more in - (* We must substitute in a subtle way *) - (* Tsubst takes a tuple containing the row var and the variant *) - begin match more.desc with - Tsubst {desc = Ttuple [_;ty2]} -> + Tconstr + ( p, + List.map copy tl, + ref + (match !(!abbreviations) with + | Mcons _ -> Mlink !abbreviations + | abbrev -> abbrev) )) + | Tvariant row0 -> ( + let row = row_repr row0 in + let more = repr row.row_more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + match more.desc with + | Tsubst {desc = Ttuple [_; ty2]} -> (* This variant type has been already copied *) - ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) + ty.desc <- Tsubst ty2; + (* avoid Tlink in the new type *) Tlink ty2 - | _ -> + | _ -> (* If the row variable is not generic, we must keep it *) let keep = more.level <> generic_level in let more' = match more.desc with - Tsubst ty -> ty + | Tsubst ty -> ty | Tconstr _ | Tnil -> - if keep then save_desc more more.desc; - copy more + if keep then save_desc more more.desc; + copy more | Tvar _ | Tunivar _ -> - save_desc more more.desc; - if keep then more else newty more.desc - | _ -> assert false + save_desc more more.desc; + if keep then more else newty more.desc + | _ -> assert false in let row = - match repr more' with (* PR#6163 *) - {desc=Tconstr _} when not row.row_fixed -> - {row with row_fixed = true} + match repr more' with + (* PR#6163 *) + | {desc = Tconstr _} when not row.row_fixed -> + {row with row_fixed = true} | _ -> row in (* Open row if partial for pattern and contains Reither *) let more', row = match partial with - Some (free_univars, false) -> - let more' = - if more.id != more'.id then more' else + | Some (free_univars, false) -> + let more' = + if more.id != more'.id then more' + else let lv = if keep then more.level else !current_level in newty2 lv (Tvar None) - in - let not_reither (_, f) = - match row_field_repr f with - Reither _ -> false - | _ -> true - in - if row.row_closed && not row.row_fixed + in + let not_reither (_, f) = + match row_field_repr f with + | Reither _ -> false + | _ -> true + in + if + row.row_closed && (not row.row_fixed) && TypeSet.is_empty (free_univars ty) - && not (List.for_all not_reither row.row_fields) then - (more', - {row_fields = Ext_list.filter row.row_fields not_reither; - row_more = more'; row_bound = (); - row_closed = false; row_fixed = false; row_name = None}) - else (more', row) + && not (List.for_all not_reither row.row_fields) + then + ( more', + { + row_fields = Ext_list.filter row.row_fields not_reither; + row_more = more'; + row_bound = (); + row_closed = false; + row_fixed = false; + row_name = None; + } ) + else (more', row) | _ -> (more', row) in (* Register new type first for recursion *) - more.desc <- Tsubst(newgenty(Ttuple[more';t])); + more.desc <- Tsubst (newgenty (Ttuple [more'; t])); (* Return a new copy *) - Tvariant (copy_row copy true row keep more') - end - | Tfield (_p, k, _ty1, ty2) -> - begin match field_kind_repr k with - Fabsent -> Tlink (copy ty2) - | Fpresent -> copy_type_desc copy desc - | Fvar r -> + Tvariant (copy_row copy true row keep more')) + | Tfield (_p, k, _ty1, ty2) -> ( + match field_kind_repr k with + | Fabsent -> Tlink (copy ty2) + | Fpresent -> copy_type_desc copy desc + | Fvar r -> dup_kind r; - copy_type_desc copy desc - end - | Tobject (ty1, _) when partial <> None -> - Tobject (copy ty1, ref None) - | _ -> copy_type_desc ?keep_names copy desc - end; - t + copy_type_desc copy desc) + | Tobject (ty1, _) when partial <> None -> Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc); + t let simple_copy t = copy t (**** Variants of instantiations ****) -let gadt_env env = - if Env.has_local_constraints env - then Some env - else None +let gadt_env env = if Env.has_local_constraints env then Some env else None let instance ?partial env sch = let env = gadt_env env in let partial = match partial with - None -> None + | None -> None | Some keep -> Some (compute_univars sch, keep) in let ty = copy ?env ?partial sch in @@ -1032,19 +992,16 @@ let instance_list env schl = tyl let reified_var_counter = ref Vars.empty -let reset_reified_var_counter () = - reified_var_counter := Vars.empty +let reset_reified_var_counter () = reified_var_counter := Vars.empty (* names given to new type constructors. Used for existential types and local constraints *) let get_new_abstract_name s = - let index = - try Vars.find s !reified_var_counter + 1 - with Not_found -> 0 in + let index = try Vars.find s !reified_var_counter + 1 with Not_found -> 0 in reified_var_counter := Vars.add s index !reified_var_counter; - if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else - Printf.sprintf "%s%d" s index + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s + else Printf.sprintf "%s%d" s index let new_declaration newtype manifest = { @@ -1062,28 +1019,27 @@ let new_declaration newtype manifest = } let instance_constructor ?in_pattern cstr = - begin match in_pattern with + (match in_pattern with | None -> () | Some (env, newtype_lev) -> - let process existential = - let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in - let name = - match repr existential with - {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name - | _ -> "$" ^ cstr.cstr_name - in - let path = Path.Pident (Ident.create (get_new_abstract_name name)) in - let new_env = Env.add_local_type path decl !env in - env := new_env; - let to_unify = newty (Tconstr (path,[],ref Mnil)) in - let tv = copy existential in - assert (is_Tvar tv); - link_type tv to_unify + let process existential = + let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in + let name = + match repr existential with + | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name + | _ -> "$" ^ cstr.cstr_name in - List.iter process cstr.cstr_existentials - end; + let path = Path.Pident (Ident.create (get_new_abstract_name name)) in + let new_env = Env.add_local_type path decl !env in + env := new_env; + let to_unify = newty (Tconstr (path, [], ref Mnil)) in + let tv = copy existential in + assert (is_Tvar tv); + link_type tv to_unify + in + List.iter process cstr.cstr_existentials); let ty_res = copy cstr.cstr_res in - let ty_args = List.map simple_copy cstr.cstr_args in + let ty_args = List.map simple_copy cstr.cstr_args in cleanup_types (); (ty_args, ty_res) @@ -1104,27 +1060,25 @@ 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 = map_type_expr_cstr_args f c.cd_args; - cd_res = may_map f c.cd_res - }) - cl) + Type_variant + (List.map + (fun c -> + { + c with + cd_args = map_type_expr_cstr_args 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) - + 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 = map_kind simple_copy decl.type_kind; + { + decl with + type_params = List.map simple_copy decl.type_params; + type_manifest = may_map simple_copy decl.type_manifest; + type_kind = map_kind simple_copy decl.type_kind; } in cleanup_types (); @@ -1133,45 +1087,50 @@ let instance_declaration decl = (**** Instantiation for types with free universal variables ****) let rec diff_list l1 l2 = - if l1 == l2 then [] else - match l1 with [] -> invalid_arg "Ctype.diff_list" - | a :: l1 -> a :: diff_list l1 l2 + if l1 == l2 then [] + else + match l1 with + | [] -> invalid_arg "Ctype.diff_list" + | a :: l1 -> a :: diff_list l1 l2 let conflicts free bound = let bound = List.map repr bound in TypeSet.exists (fun t -> List.memq (repr t) bound) free let delayed_copy = ref [] - (* copying to do later *) +(* copying to do later *) (* Copy without sharing until there are no free univars left *) (* all free univars must be included in [visited] *) let rec copy_sep fixed free bound visited ty = let ty = repr ty in let univars = free ty in - if TypeSet.is_empty univars then - if ty.level <> generic_level then ty else - let t = newvar () in - delayed_copy := - lazy (t.desc <- Tlink (copy ty)) - :: !delayed_copy; - t - else try - let t, bound_t = List.assq ty visited in - let dl = if is_Tunivar ty then [] else diff_list bound bound_t in - if dl <> [] && conflicts univars dl then raise Not_found; - t - with Not_found -> begin - let t = newvar() in (* Stub *) - let visited = - match ty.desc with - Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> - (ty,(t,bound)) :: visited - | _ -> visited in - let copy_rec = copy_sep fixed free bound visited in - t.desc <- - begin match ty.desc with - | Tvariant row0 -> + if TypeSet.is_empty univars then ( + if ty.level <> generic_level then ty + else + let t = newvar () in + delayed_copy := lazy (t.desc <- Tlink (copy ty)) :: !delayed_copy; + t) + else + try + let t, bound_t = List.assq ty visited in + let dl = if is_Tunivar ty then [] else diff_list bound bound_t in + if dl <> [] && conflicts univars dl then raise Not_found; + t + with Not_found -> + let t = newvar () in + (* Stub *) + let visited = + match ty.desc with + | Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ + -> + (ty, (t, bound)) :: visited + | _ -> visited + in + let copy_rec = copy_sep fixed free bound visited in + t.desc <- + (match ty.desc with + | Tvariant row0 -> let row = row_repr row0 in let more = repr row.row_more in (* We shall really check the level on the row variable *) @@ -1180,49 +1139,47 @@ let rec copy_sep fixed free bound visited ty = let fixed' = fixed && is_Tvar (repr more') in let row = copy_row copy_rec fixed' row keep more' in Tvariant row - | Tpoly (t1, tl) -> + | Tpoly (t1, tl) -> let tl = List.map repr tl in let tl' = List.map (fun t -> newty t.desc) tl in let bound = tl @ bound in let visited = - List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in + List.map2 (fun ty t -> (ty, (t, bound))) tl tl' @ visited + in Tpoly (copy_sep fixed free bound visited t1, tl') - | _ -> copy_type_desc copy_rec ty.desc - end; - t - end + | _ -> copy_type_desc copy_rec ty.desc); + t -let instance_poly ?(keep_names=false) fixed univars sch = +let instance_poly ?(keep_names = false) fixed univars sch = let univars = List.map repr univars in let copy_var ty = match ty.desc with - Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | Tunivar name -> if keep_names then newty (Tvar name) else newvar () | _ -> assert false in let vars = List.map copy_var univars in - let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in + let pairs = List.map2 (fun u v -> (u, (v, []))) univars vars in delayed_copy := []; let ty = copy_sep fixed (compute_univars sch) [] pairs sch in List.iter Lazy.force !delayed_copy; delayed_copy := []; cleanup_types (); - vars, ty + (vars, ty) let instance_label fixed lbl = let ty_res = copy lbl.lbl_res in let vars, ty_arg = match repr lbl.lbl_arg with - {desc = Tpoly (ty, tl)} -> - instance_poly fixed tl ty - | _ -> - [], copy lbl.lbl_arg + | {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty + | _ -> ([], copy lbl.lbl_arg) in cleanup_types (); (vars, ty_arg, ty_res) (**** Instantiation with parameter substitution ****) -let unify' = (* Forward declaration *) +let unify' = + (* Forward declaration *) ref (fun _env _ty1 _ty2 -> raise (Unify [])) let subst env level priv abbrev ty params args body = @@ -1230,17 +1187,16 @@ let subst env level priv abbrev ty params args body = let old_level = !current_level in current_level := level; try - let body0 = newvar () in (* Stub *) - begin match ty with - None -> () + let body0 = newvar () in + (* Stub *) + (match ty with + | None -> () | Some ({desc = Tconstr (path, tl, _)} as ty) -> - let abbrev = proper_abbrevs path tl abbrev in - memorize_abbrev abbrev priv path ty body0 - | _ -> - assert false - end; + let abbrev = proper_abbrevs path tl abbrev in + memorize_abbrev abbrev priv path ty body0 + | _ -> assert false); abbreviations := abbrev; - let (params', body') = instance_parameterized_type params body in + let params', body' = instance_parameterized_type params body in abbreviations := ref Mnil; !unify' env body0 body'; List.iter2 (!unify' env) params' args; @@ -1257,16 +1213,14 @@ let subst env level priv abbrev ty params args body = care about efficiency here. *) let apply env params body args = - try - subst env generic_level Public (ref Mnil) None params args body - with - Unify _ -> raise Cannot_apply + try subst env generic_level Public (ref Mnil) None params args body + with Unify _ -> raise Cannot_apply let () = Subst.ctype_apply_env_empty := apply Env.empty - (****************************) - (* Abbreviation expansion *) - (****************************) +(****************************) +(* Abbreviation expansion *) +(****************************) (* If the environment has changed, memorized expansions might not @@ -1275,14 +1229,13 @@ let () = Subst.ctype_apply_env_empty := apply Env.empty type or module definition is overridden in the environment. *) let previous_env = ref Env.empty + (*let string_of_kind = function Public -> "public" | Private -> "private"*) let check_abbrev_env env = - if env != !previous_env then begin + if env != !previous_env then ( (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); - previous_env := env - end - + previous_env := env) (* Expand an abbreviation. The expansion is memorized. *) (* @@ -1305,48 +1258,46 @@ let check_abbrev_env env = let expand_abbrev_gen kind find_type_expansion env ty = check_abbrev_env env; match ty with - {desc = Tconstr (path, args, abbrev); level = level} -> - let lookup_abbrev = proper_abbrevs path args abbrev in - begin match find_expans kind path !lookup_abbrev with - Some ty' -> - (* prerr_endline - ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) - if level <> generic_level then - begin try - update_level env level ty' - with Unify _ -> - (* XXX This should not happen. - However, levels are not correctly restored after a - typing error *) - () - end; - let ty' = repr ty' in - (* assert (ty != ty'); *) (* PR#7324 *) - ty' - | None -> - match find_type_expansion path env with - | exception Not_found -> - (* another way to expand is to normalize the path itself *) - let path' = Env.normalize_path None env path in - if Path.same path path' then raise Cannot_expand - else newty2 level (Tconstr (path', args, abbrev)) - | (params, body, lv) -> - (* prerr_endline - ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) - let ty' = subst env level kind abbrev (Some ty) params args body in - (* For gadts, remember type as non exportable *) - (* The ambiguous level registered for ty' should be the highest *) - if !trace_gadt_instances then begin - match Ext_pervasives.max_int_option lv (Env.gadt_instance_level env ty) with - None -> () - | Some lv -> - if level < lv then raise (Unify [(ty, newvar2 level)]); - Env.add_gadt_instances env lv [ty; ty'] - end; - ty' - end - | _ -> - assert false + | {desc = Tconstr (path, args, abbrev); level} -> ( + let lookup_abbrev = proper_abbrevs path args abbrev in + match find_expans kind path !lookup_abbrev with + | Some ty' -> + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) + (if level <> generic_level then + try update_level env level ty' + with Unify _ -> + (* XXX This should not happen. + However, levels are not correctly restored after a + typing error *) + ()); + let ty' = repr ty' in + (* assert (ty != ty'); *) + (* PR#7324 *) + ty' + | None -> ( + match find_type_expansion path env with + | exception Not_found -> + (* another way to expand is to normalize the path itself *) + let path' = Env.normalize_path None env path in + if Path.same path path' then raise Cannot_expand + else newty2 level (Tconstr (path', args, abbrev)) + | params, body, lv -> + (* prerr_endline + ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) + let ty' = subst env level kind abbrev (Some ty) params args body in + (* For gadts, remember type as non exportable *) + (* The ambiguous level registered for ty' should be the highest *) + (if !trace_gadt_instances then + match + Ext_pervasives.max_int_option lv (Env.gadt_instance_level env ty) + with + | None -> () + | Some lv -> + if level < lv then raise (Unify [(ty, newvar2 level)]); + Env.add_gadt_instances env lv [ty; ty']); + ty')) + | _ -> assert false (* Expand respecting privacy *) let expand_abbrev env ty = @@ -1359,7 +1310,9 @@ let expand_head_once env ty = (* Check whether a type can be expanded *) let safe_abbrev env ty = let snap = Btype.snapshot () in - try ignore (expand_abbrev env ty); true + try + ignore (expand_abbrev env ty); + true with Cannot_expand | Unify _ -> Btype.backtrack snap; false @@ -1370,7 +1323,7 @@ let safe_abbrev env ty = let try_expand_once env ty = let ty = repr ty in match ty.desc with - Tconstr _ -> repr (expand_abbrev env ty) + | Tconstr _ -> repr (expand_abbrev env ty) | _ -> raise Cannot_expand (* This one only raises Cannot_expand *) @@ -1378,20 +1331,19 @@ let try_expand_safe env ty = let snap = Btype.snapshot () in try try_expand_once env ty with Unify _ -> - Btype.backtrack snap; raise Cannot_expand + Btype.backtrack snap; + raise Cannot_expand (* Fully expand the head of a type. *) let rec try_expand_head try_once env ty = let ty' = try_once env ty in - try try_expand_head try_once env ty' - with Cannot_expand -> ty' + try try_expand_head try_once env ty' with Cannot_expand -> ty' let try_expand_head try_once env ty = let ty' = try_expand_head try_once env ty in - begin match Env.gadt_instance_level env ty' with - None -> () - | Some lv -> Env.add_gadt_instance_chain env lv ty - end; + (match Env.gadt_instance_level env ty' with + | None -> () + | Some lv -> Env.add_gadt_instance_chain env lv ty); ty' (* Unsafe full expansion, may raise Unify. *) @@ -1404,20 +1356,20 @@ let expand_head env ty = let _ = forward_try_expand_once := try_expand_safe - (* Expand until we find a non-abstract type declaration *) let rec extract_concrete_typedecl env ty = let ty = repr ty in match ty.desc with - Tconstr (p, _, _) -> - let decl = Env.find_type p env in - if decl.type_kind <> Type_abstract then (p, p, decl) else + | Tconstr (p, _, _) -> + let decl = Env.find_type p env in + if decl.type_kind <> Type_abstract then (p, p, decl) + else let ty = try try_expand_once env ty with Cannot_expand -> raise Not_found in - let (_, p', decl) = extract_concrete_typedecl env ty in - (p, p', decl) + let _, p', decl = extract_concrete_typedecl env ty in + (p, p', decl) | _ -> raise Not_found (* Implementing function [expand_head_opt], the compiler's own version of @@ -1427,27 +1379,23 @@ let rec extract_concrete_typedecl env ty = normally hidden to the type-checker out of the implementation module of the private abbreviation. *) -let expand_abbrev_opt = - expand_abbrev_gen Private Env.find_type_expansion_opt +let expand_abbrev_opt = expand_abbrev_gen Private Env.find_type_expansion_opt let try_expand_once_opt env ty = let ty = repr ty in match ty.desc with - Tconstr _ -> repr (expand_abbrev_opt env ty) + | Tconstr _ -> repr (expand_abbrev_opt env ty) | _ -> raise Cannot_expand let rec try_expand_head_opt env ty = let ty' = try_expand_once_opt env ty in - begin try - try_expand_head_opt env ty' - with Cannot_expand -> - ty' - end + try try_expand_head_opt env ty' with Cannot_expand -> ty' let expand_head_opt env ty = let snap = Btype.snapshot () in try try_expand_head_opt env ty - with Cannot_expand | Unify _ -> (* expand_head shall never fail *) + with Cannot_expand | Unify _ -> + (* expand_head shall never fail *) Btype.backtrack snap; repr ty @@ -1455,26 +1403,23 @@ let expand_head_opt env ty = respect the type constraints *) let enforce_constraints env ty = match ty with - {desc = Tconstr (path, args, _abbrev); level = level} -> - begin try - let decl = Env.find_type path env in - ignore - (subst env level Public (ref Mnil) None decl.type_params args - (newvar2 level)) - with Not_found -> () - end - | _ -> - assert false + | {desc = Tconstr (path, args, _abbrev); level} -> ( + try + let decl = Env.find_type path env in + ignore + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) + with Not_found -> ()) + | _ -> assert false (* Recursively expand the head of a type. Also expand #-types. *) let full_expand env ty = let ty = repr (expand_head env ty) in match ty.desc with - Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> - newty2 ty.level (Tobject (fi, ref None)) - | _ -> - ty + | Tobject (fi, {contents = Some (_, v :: _)}) when is_Tvar (repr v) -> + newty2 ty.level (Tobject (fi, ref None)) + | _ -> ty (* Check whether the abbreviation expands to a well-defined type. @@ -1483,84 +1428,88 @@ let full_expand env ty = *) let generic_abbrev env path = try - let (_, body, _) = Env.find_type_expansion path env in + let _, body, _ = Env.find_type_expansion path env in (repr body).level = generic_level - with - Not_found -> - false + with Not_found -> false let generic_private_abbrev env path = try match Env.find_type path env with - {type_kind = Type_abstract; - type_private = Private; - type_manifest = Some body} -> - (repr body).level = generic_level + | { + type_kind = Type_abstract; + type_private = Private; + type_manifest = Some body; + } -> + (repr body).level = generic_level | _ -> false with Not_found -> false let is_contractive env p = try let decl = Env.find_type p env in - in_pervasives p && decl.type_manifest = None || is_datatype decl + (in_pervasives p && decl.type_manifest = None) || is_datatype decl with Not_found -> false - - (*****************) - (* Occur check *) - (*****************) - +(*****************) +(* Occur check *) +(*****************) exception Occur let rec occur_rec env allow_recursive visited ty0 = function - | {desc=Tlink ty} -> - occur_rec env allow_recursive visited ty0 ty - | ty -> - if ty == ty0 then raise Occur; - match ty.desc with - Tconstr(p, _tl, _abbrev) -> - if allow_recursive && is_contractive env p then () else - begin try - if TypeSet.mem ty visited then raise Occur; - let visited = TypeSet.add ty visited in - iter_type_expr (occur_rec env allow_recursive visited ty0) ty - with Occur -> try - let ty' = try_expand_head try_expand_once env ty in - (* This call used to be inlined, but there seems no reason for it. - Message was referring to change in rev. 1.58 of the CVS repo. *) - occur_rec env allow_recursive visited ty0 ty' - with Cannot_expand -> - raise Occur - end - | Tobject _ | Tvariant _ -> - () - | _ -> - if allow_recursive || TypeSet.mem ty visited then () else begin + | {desc = Tlink ty} -> occur_rec env allow_recursive visited ty0 ty + | ty -> ( + if ty == ty0 then raise Occur; + match ty.desc with + | Tconstr (p, _tl, _abbrev) -> ( + if allow_recursive && is_contractive env p then () + else + try + if TypeSet.mem ty visited then raise Occur; + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + with Occur -> ( + try + let ty' = try_expand_head try_expand_once env ty in + (* This call used to be inlined, but there seems no reason for it. + Message was referring to change in rev. 1.58 of the CVS repo. *) + occur_rec env allow_recursive visited ty0 ty' + with Cannot_expand -> raise Occur)) + | Tobject _ | Tvariant _ -> () + | _ -> + if allow_recursive || TypeSet.mem ty visited then () + else let visited = TypeSet.add ty visited in - iter_type_expr (occur_rec env allow_recursive visited ty0) ty - end + iter_type_expr (occur_rec env allow_recursive visited ty0) ty) let type_changed = ref false (* trace possible changes to the studied type *) let merge r b = if b then r := true let occur env ty0 ty = - let allow_recursive = (*!Clflags.recursive_types ||*) !umode = Pattern in + let allow_recursive = (*!Clflags.recursive_types ||*) !umode = Pattern in let old = !type_changed in try while type_changed := false; occur_rec env allow_recursive TypeSet.empty ty0 ty; !type_changed - do () (* prerr_endline "changed" *) done; + do + () (* prerr_endline "changed" *) + done; merge type_changed old with exn -> merge type_changed old; - raise (match exn with Occur -> Unify [] | _ -> exn) + raise + (match exn with + | Occur -> Unify [] + | _ -> exn) let occur_in env ty0 t = - try occur env ty0 t; false with Unify _ -> true + try + occur env ty0 t; + false + with Unify _ -> true (* Check that a local constraint is well-founded *) (* PR#6405: not needed since we allow recursion and work on normalized types *) @@ -1570,65 +1519,60 @@ let occur_in env ty0 t = let rec local_non_recursive_abbrev strict visited env p ty = (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) let ty = repr ty in - if not (List.memq ty visited) then begin + if not (List.memq ty visited) then match ty.desc with - Tconstr(p', args, _abbrev) -> - if Path.same p p' then raise Occur; - if not strict && is_contractive env p' then () else + | Tconstr (p', args, _abbrev) -> ( + if Path.same p p' then raise Occur; + if (not strict) && is_contractive env p' then () + else let visited = ty :: visited in - begin try + try (* try expanding, since [p] could be hidden *) local_non_recursive_abbrev strict visited env p (try_expand_head try_expand_once env ty) with Cannot_expand -> let params = - try (Env.find_type p' env).type_params - with Not_found -> args + try (Env.find_type p' env).type_params with Not_found -> args in List.iter2 (fun tv ty -> let strict = strict || not (is_Tvar (repr tv)) in local_non_recursive_abbrev strict visited env p ty) - params args - end + params args) | _ -> - if strict then (* PR#7374 *) - let visited = ty :: visited in - iter_type_expr (local_non_recursive_abbrev true visited env p) ty - end + if strict then + (* PR#7374 *) + let visited = ty :: visited in + iter_type_expr (local_non_recursive_abbrev true visited env p) ty let local_non_recursive_abbrev env p ty = - try (* PR#7397: need to check trace_gadt_instances *) - wrap_trace_gadt_instances env - (local_non_recursive_abbrev false [] env p) ty; + try + (* PR#7397: need to check trace_gadt_instances *) + wrap_trace_gadt_instances env (local_non_recursive_abbrev false [] env p) ty; true with Occur -> false - - (*****************************) - (* Polymorphic Unification *) - (*****************************) +(*****************************) +(* Polymorphic Unification *) +(*****************************) (* Since we cannot duplicate universal variables, unification must be done at meta-level, using bindings in univar_pairs *) let rec unify_univar t1 t2 = function - (cl1, cl2) :: rem -> - let find_univ t cl = - try - let (_, r) = List.find (fun (t',_) -> t == repr t') cl in - Some r - with Not_found -> None - in - begin match find_univ t1 cl1, find_univ t2 cl2 with - Some {contents=Some t'2}, Some _ when t2 == repr t'2 -> - () - | Some({contents=None} as r1), Some({contents=None} as r2) -> - set_univar r1 t2; set_univar r2 t1 - | None, None -> - unify_univar t1 t2 rem - | _ -> - raise (Unify []) - end + | (cl1, cl2) :: rem -> ( + let find_univ t cl = + try + let _, r = List.find (fun (t', _) -> t == repr t') cl in + Some r + with Not_found -> None + in + match (find_univ t1 cl1, find_univ t2 cl2) with + | Some {contents = Some t'2}, Some _ when t2 == repr t'2 -> () + | Some ({contents = None} as r1), Some ({contents = None} as r2) -> + set_univar r1 t2; + set_univar r2 t1 + | None, None -> unify_univar t1 t2 rem + | _ -> raise (Unify [])) | [] -> raise (Unify []) (* Test the occurrence of free univars in a type *) @@ -1637,59 +1581,63 @@ let occur_univar env ty = let visited = ref TypeMap.empty in let rec occur_rec bound ty = let ty = repr ty in - if ty.level >= lowest_level && - if TypeSet.is_empty bound then - (ty.level <- pivot_level - ty.level; true) - else try - let bound' = TypeMap.find ty !visited in - if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then - (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; - true) - else false - with Not_found -> - visited := TypeMap.add ty bound !visited; - true + if + ty.level >= lowest_level + && + if TypeSet.is_empty bound then ( + ty.level <- pivot_level - ty.level; + true) + else + try + let bound' = TypeMap.find ty !visited in + if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then ( + visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; + true) + else false + with Not_found -> + visited := TypeMap.add ty bound !visited; + true then match ty.desc with - Tunivar _ -> - if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()]) + | Tunivar _ -> + if not (TypeSet.mem ty bound) then raise (Unify [(ty, newgenvar ())]) | Tpoly (ty, tyl) -> - let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in - occur_rec bound ty + let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + occur_rec bound ty | Tconstr (_, [], _) -> () - | Tconstr (p, tl, _) -> - begin try - let td = Env.find_type p env in - List.iter2 - (fun t v -> - if Variance.(mem May_pos v || mem May_neg v) - then occur_rec bound t) - tl td.type_variance - with Not_found -> - List.iter (occur_rec bound) tl - end + | Tconstr (p, tl, _) -> ( + try + let td = Env.find_type p env in + List.iter2 + (fun t v -> + if Variance.(mem May_pos v || mem May_neg v) then + occur_rec bound t) + tl td.type_variance + with Not_found -> List.iter (occur_rec bound) tl) | _ -> iter_type_expr (occur_rec bound) ty in try - occur_rec TypeSet.empty ty; unmark_type ty + occur_rec TypeSet.empty ty; + unmark_type ty with exn -> - unmark_type ty; raise exn + unmark_type ty; + raise exn (* Grouping univars by families according to their binders *) -let add_univars = - List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s) +let add_univars = List.fold_left (fun s (t, _) -> TypeSet.add (repr t) s) let get_univar_family univar_pairs univars = - if univars = [] then TypeSet.empty else - let insert s = function - cl1, (_::_ as cl2) -> - if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then + if univars = [] then TypeSet.empty + else + let insert s = function + | cl1, (_ :: _ as cl2) -> + if List.exists (fun (t1, _) -> TypeSet.mem (repr t1) s) cl1 then add_univars s cl2 else s - | _ -> s - in - let s = List.fold_right TypeSet.add univars TypeSet.empty in - List.fold_left insert s univar_pairs + | _ -> s + in + let s = List.fold_right TypeSet.add univars TypeSet.empty in + List.fold_left insert s univar_pairs (* Whether a family of univars escapes from a type *) let univars_escape env univar_pairs vl ty = @@ -1697,64 +1645,65 @@ let univars_escape env univar_pairs vl ty = let visited = ref TypeSet.empty in let rec occur t = let t = repr t in - if TypeSet.mem t !visited then () else begin + if TypeSet.mem t !visited then () + else ( visited := TypeSet.add t !visited; match t.desc with - Tpoly (t, tl) -> - if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () - else occur t - | Tunivar _ -> - if TypeSet.mem t family then raise Occur + | Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () + else occur t + | Tunivar _ -> if TypeSet.mem t family then raise Occur | Tconstr (_, [], _) -> () - | Tconstr (p, tl, _) -> - begin try - let td = Env.find_type p env in - List.iter2 - (fun t v -> - if Variance.(mem May_pos v || mem May_neg v) then occur t) - tl td.type_variance - with Not_found -> - List.iter occur tl - end - | _ -> - iter_type_expr occur t - end + | Tconstr (p, tl, _) -> ( + try + let td = Env.find_type p env in + List.iter2 + (fun t v -> + if Variance.(mem May_pos v || mem May_neg v) then occur t) + tl td.type_variance + with Not_found -> List.iter occur tl) + | _ -> iter_type_expr occur t) in - try occur ty; false with Occur -> true + try + occur ty; + false + with Occur -> true (* Wrapper checking that no variable escapes and updating univar_pairs *) let enter_poly env univar_pairs t1 tl1 t2 tl2 f = let old_univars = !univar_pairs in let known_univars = - List.fold_left (fun s (cl,_) -> add_univars s cl) - TypeSet.empty old_univars + List.fold_left (fun s (cl, _) -> add_univars s cl) TypeSet.empty old_univars in let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in - if List.exists (fun t -> TypeSet.mem t known_univars) tl1 && - univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))) - || List.exists (fun t -> TypeSet.mem t known_univars) tl2 && - univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))) + if + List.exists (fun t -> TypeSet.mem t known_univars) tl1 + && univars_escape env old_univars tl1 (newty (Tpoly (t2, tl2))) + || List.exists (fun t -> TypeSet.mem t known_univars) tl2 + && univars_escape env old_univars tl2 (newty (Tpoly (t1, tl1))) then raise (Unify []); - let cl1 = List.map (fun t -> t, ref None) tl1 - and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - try let res = f t1 t2 in univar_pairs := old_univars; res - with exn -> univar_pairs := old_univars; raise exn + let cl1 = List.map (fun t -> (t, ref None)) tl1 + and cl2 = List.map (fun t -> (t, ref None)) tl2 in + univar_pairs := (cl1, cl2) :: (cl2, cl1) :: old_univars; + try + let res = f t1 t2 in + univar_pairs := old_univars; + res + with exn -> + univar_pairs := old_univars; + raise exn let univar_pairs = ref [] - - (*****************) - (* Unification *) - (*****************) - - +(*****************) +(* Unification *) +(*****************) let rec has_cached_expansion p abbrev = match abbrev with - Mnil -> false - | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem - | Mlink rem -> has_cached_expansion p !rem + | Mnil -> false + | Mcons (_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mlink rem -> has_cached_expansion p !rem (**** Transform error trace ****) (* +++ Move it to some other place ? *) @@ -1762,15 +1711,21 @@ let rec has_cached_expansion p abbrev = let expand_trace env trace = List.fold_right (fun (t1, t2) rem -> - (repr t1, full_expand env t1)::(repr t2, full_expand env t2)::rem) + (repr t1, full_expand env t1) :: (repr t2, full_expand env t2) :: rem) trace [] (* build a dummy variant type *) let mkvariant fields closed = newgenty (Tvariant - {row_fields = fields; row_closed = closed; row_more = newvar(); - row_bound = (); row_fixed = false; row_name = None }) + { + row_fields = fields; + row_closed = closed; + row_more = newvar (); + row_bound = (); + row_fixed = false; + row_name = None; + }) (**** Unification ****) @@ -1778,16 +1733,18 @@ let mkvariant fields closed = let deep_occur t0 ty = let rec occur_rec ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( if ty == t0 then raise Occur; ty.level <- pivot_level - ty.level; - iter_type_expr occur_rec ty - end + iter_type_expr occur_rec ty) in try - occur_rec ty; unmark_type ty; false + occur_rec ty; + unmark_type ty; + false with Occur -> - unmark_type ty; true + unmark_type ty; + true (* 1. When unifying two non-abbreviated types, one type is made a link @@ -1827,54 +1784,57 @@ let reify env t = let newtype_level = get_newtype_level () in let create_fresh_constr lev name = let decl = new_declaration (Some (newtype_level, newtype_level)) None in - let name = match name with Some s -> "$'"^s | _ -> "$" in + let name = + match name with + | Some s -> "$'" ^ s + | _ -> "$" + in let path = Path.Pident (Ident.create (get_new_abstract_name name)) in let new_env = Env.add_local_type path decl !env in - let t = newty2 lev (Tconstr (path,[],ref Mnil)) in + let t = newty2 lev (Tconstr (path, [], ref Mnil)) in env := new_env; t in let visited = ref TypeSet.empty in let rec iterator ty = let ty = repr ty in - if TypeSet.mem ty !visited then () else begin + if TypeSet.mem ty !visited then () + else ( visited := TypeSet.add ty !visited; match ty.desc with - Tvar o -> - let t = create_fresh_constr ty.level o in - link_type ty t; - if ty.level < newtype_level then - raise (Unify [t, newvar2 ty.level]) + | Tvar o -> + let t = create_fresh_constr ty.level o in + link_type ty t; + if ty.level < newtype_level then raise (Unify [(t, newvar2 ty.level)]) | Tvariant r -> - let r = row_repr r in - if not (static_row r) then begin - if r.row_fixed then iterator (row_more r) else - let m = r.row_more in - match m.desc with - Tvar o -> - let t = create_fresh_constr m.level o in - let row = - {r with row_fields=[]; row_fixed=true; row_more = t} in - link_type m (newty2 m.level (Tvariant row)); - if m.level < newtype_level then - raise (Unify [t, newvar2 m.level]) - | _ -> assert false - end; - iter_row iterator r + let r = row_repr r in + (if not (static_row r) then + if r.row_fixed then iterator (row_more r) + else + let m = r.row_more in + match m.desc with + | Tvar o -> + let t = create_fresh_constr m.level o in + let row = + {r with row_fields = []; row_fixed = true; row_more = t} + in + link_type m (newty2 m.level (Tvariant row)); + if m.level < newtype_level then + raise (Unify [(t, newvar2 m.level)]) + | _ -> assert false); + iter_row iterator r | Tconstr (p, _, _) when is_object_type p -> - iter_type_expr iterator (full_expand !env ty) - | _ -> - iter_type_expr iterator ty - end + iter_type_expr iterator (full_expand !env ty) + | _ -> iter_type_expr iterator ty) in iterator t let is_newtype env p = try let decl = Env.find_type p env in - decl.type_newtype_level <> None && - decl.type_kind = Type_abstract && - decl.type_private = Public + decl.type_newtype_level <> None + && decl.type_kind = Type_abstract + && decl.type_private = Public with Not_found -> false let non_aliasable p decl = @@ -1884,14 +1844,12 @@ let non_aliasable p decl = let is_instantiable env p = try let decl = Env.find_type p env in - decl.type_kind = Type_abstract && - decl.type_private = Public && - decl.type_arity = 0 && - decl.type_manifest = None && - not (non_aliasable p decl) + decl.type_kind = Type_abstract + && decl.type_private = Public && decl.type_arity = 0 + && decl.type_manifest = None + && not (non_aliasable p decl) with Not_found -> false - (* PR#7113: -safe-string should be a global property *) let compatible_paths p1 p2 = Path.same p1 p2 @@ -1899,12 +1857,11 @@ let compatible_paths p1 p2 = Path.same p1 p2 let rec expands_to_datatype env ty = let ty = repr ty in match ty.desc with - Tconstr (p, _, _) -> - begin try - is_datatype (Env.find_type p env) || - expands_to_datatype env (try_expand_once env ty) - with Not_found | Cannot_expand -> false - end + | Tconstr (p, _, _) -> ( + try + is_datatype (Env.find_type p env) + || expands_to_datatype env (try_expand_once env ty) + with Not_found | Cannot_expand -> false) | _ -> false (* mcomp type_pairs subst env t1 t2 does not raise an @@ -1913,121 +1870,118 @@ let rec expands_to_datatype env ty = that the mapping subst holds. Assumes that both t1 and t2 do not contain any tvars and that both their objects and variants are closed - *) +*) let rec mcomp type_pairs env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - match (t1.desc, t2.desc) with - | (Tvar _, _) - | (_, Tvar _) -> - () - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head_opt env t1 in - let t2' = expand_head_opt env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, Tvar _) -> assert false - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) - when Asttypes.same_arg_label l1 l2 || not (is_optional l1 || is_optional l2) -> - mcomp type_pairs env t1 t2; - mcomp type_pairs env u1 u2; - | (Ttuple tl1, Ttuple tl2) -> - mcomp_list type_pairs env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> - mcomp_type_decl type_pairs env p1 p2 tl1 tl2 - | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> - begin try - let decl = Env.find_type p env in - if non_aliasable p decl || is_datatype decl then raise (Unify []) - with Not_found -> () - end - (* + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then () + else + match (t1.desc, t2.desc) with + | Tvar _, _ | _, Tvar _ -> () + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> () + | _ -> ( + let t1' = expand_head_opt env t1 in + let t2' = expand_head_opt env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () + else + try TypePairs.find type_pairs (t1', t2') + with Not_found -> ( + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + | Tvar _, Tvar _ -> assert false + | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + when Asttypes.same_arg_label l1 l2 + || not (is_optional l1 || is_optional l2) -> + mcomp type_pairs env t1 t2; + mcomp type_pairs env u1 u2 + | Ttuple tl1, Ttuple tl2 -> mcomp_list type_pairs env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) -> + mcomp_type_decl type_pairs env p1 p2 tl1 tl2 + | Tconstr (p, _, _), _ | _, Tconstr (p, _, _) -> ( + try + let decl = Env.find_type p env in + if non_aliasable p decl || is_datatype decl then + raise (Unify []) + with Not_found -> ()) + (* | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> mcomp_list type_pairs env tl1 tl2 *) - | (Tpackage _, Tpackage _) -> () - | (Tvariant row1, Tvariant row2) -> - mcomp_row type_pairs env row1 row2 - | (Tobject (fi1, _), Tobject (fi2, _)) -> - mcomp_fields type_pairs env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - mcomp_fields type_pairs env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - mcomp type_pairs env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (mcomp type_pairs env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end + | Tpackage _, Tpackage _ -> () + | Tvariant row1, Tvariant row2 -> mcomp_row type_pairs env row1 row2 + | Tobject (fi1, _), Tobject (fi2, _) -> + mcomp_fields type_pairs env fi1 fi2 + | Tfield _, Tfield _ -> + (* Actually unused *) + mcomp_fields type_pairs env t1' t2' + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> mcomp type_pairs env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 (mcomp type_pairs env) + | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | _, _ -> raise (Unify []))) and mcomp_list type_pairs env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); + if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (mcomp type_pairs env) tl1 tl2 and mcomp_fields type_pairs env ty1 ty2 = if not (concrete_object ty1 && concrete_object ty2) then assert false; - let (fields2, rest2) = flatten_fields ty2 in - let (fields1, rest1) = flatten_fields ty1 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let fields2, rest2 = flatten_fields ty2 in + let fields1, rest1 = flatten_fields ty1 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in let has_present = - List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in + List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) + in mcomp type_pairs env rest1 rest2; - if has_present miss1 && (object_row ty2).desc = Tnil - || has_present miss2 && (object_row ty1).desc = Tnil then raise (Unify []); + if + (has_present miss1 && (object_row ty2).desc = Tnil) + || (has_present miss2 && (object_row ty1).desc = Tnil) + then raise (Unify []); List.iter - (function (_n, k1, t1, k2, t2) -> - mcomp_kind k1 k2; - mcomp type_pairs env t1 t2) + (function + | _n, k1, t1, k2, t2 -> + mcomp_kind k1 k2; + mcomp type_pairs env t1 t2) pairs and mcomp_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in - match k1, k2 with - (Fpresent, Fabsent) - | (Fabsent, Fpresent) -> raise (Unify []) - | _ -> () + match (k1, k2) with + | Fpresent, Fabsent | Fabsent, Fpresent -> raise (Unify []) + | _ -> () and mcomp_row type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - let cannot_erase (_,f) = + let cannot_erase (_, f) = match row_field_repr f with - Rpresent _ -> true + | Rpresent _ -> true | Rabsent | Reither _ -> false in - if row1.row_closed && List.exists cannot_erase r2 - || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []); + if + (row1.row_closed && List.exists cannot_erase r2) + || (row2.row_closed && List.exists cannot_erase r1) + then raise (Unify []); List.iter - (fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent) + (fun (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | Rpresent None, (Rpresent (Some _) | Reither (_, _ :: _, _, _) | Rabsent) | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent) - | (Reither (_, _::_, _, _) | Rabsent), Rpresent None + | (Reither (_, _ :: _, _, _) | Rabsent), Rpresent None | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) -> - raise (Unify []) - | Rpresent(Some t1), Rpresent(Some t2) -> - mcomp type_pairs env t1 t2 - | Rpresent(Some t1), Reither(false, tl2, _, _) -> - List.iter (mcomp type_pairs env t1) tl2 - | Reither(false, tl1, _, _), Rpresent(Some t2) -> - List.iter (mcomp type_pairs env t2) tl1 + raise (Unify []) + | Rpresent (Some t1), Rpresent (Some t2) -> mcomp type_pairs env t1 t2 + | Rpresent (Some t1), Reither (false, tl2, _, _) -> + List.iter (mcomp type_pairs env t1) tl2 + | Reither (false, tl1, _, _), Rpresent (Some t2) -> + List.iter (mcomp type_pairs env t2) tl1 | _ -> ()) pairs @@ -2035,104 +1989,102 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = try let decl = Env.find_type p1 env in let decl' = Env.find_type p2 env in - if compatible_paths p1 p2 then begin + if compatible_paths p1 p2 then let inj = try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance with Not_found -> List.map (fun _ -> false) tl1 in List.iter2 - (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) + (fun i (t1, t2) -> if i then mcomp type_pairs env t1 t2) inj (List.combine tl1 tl2) - end else if non_aliasable p1 decl && non_aliasable p2 decl' then + else if non_aliasable p1 decl && non_aliasable p2 decl' then raise (Unify []) else - match decl.type_kind, decl'.type_kind with - | Type_record (lst,r), Type_record (lst',r') when Types.same_record_representation r r' -> - mcomp_list type_pairs env tl1 tl2; - mcomp_record_description type_pairs env lst lst' + match (decl.type_kind, decl'.type_kind) with + | Type_record (lst, r), Type_record (lst', r') + when Types.same_record_representation r r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' | Type_variant v1, Type_variant v2 -> - mcomp_list type_pairs env tl1 tl2; - mcomp_variant_description type_pairs env v1 v2 - | Type_open, Type_open -> - mcomp_list type_pairs env tl1 tl2 + mcomp_list type_pairs env tl1 tl2; + mcomp_variant_description type_pairs env v1 v2 + | Type_open, Type_open -> mcomp_list type_pairs env tl1 tl2 | Type_abstract, Type_abstract -> () - | Type_abstract, _ when not (non_aliasable p1 decl)-> () + | Type_abstract, _ when not (non_aliasable p1 decl) -> () | _, Type_abstract when not (non_aliasable p2 decl') -> () | _ -> raise (Unify []) with Not_found -> () and mcomp_type_option type_pairs env t t' = - match t, t' with - None, None -> () + match (t, t') with + | None, None -> () | Some t, Some t' -> mcomp type_pairs env t t' | _ -> raise (Unify []) and mcomp_variant_description type_pairs env xs ys = - let rec iter = fun x y -> - match x, y with - | c1 :: xs, c2 :: ys -> + let rec iter x y = + match (x, y) with + | c1 :: xs, c2 :: ys -> mcomp_type_option type_pairs env c1.cd_res c2.cd_res; - begin match c1.cd_args, c2.cd_args with + (match (c1.cd_args, c2.cd_args) with | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 | Cstr_record l1, Cstr_record l2 -> - mcomp_record_description type_pairs env l1 l2 - | _ -> raise (Unify []) - end; - if Ident.name c1.cd_id = Ident.name c2.cd_id - then iter xs ys + mcomp_record_description type_pairs env l1 l2 + | _ -> raise (Unify [])); + if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys else raise (Unify []) - | [],[] -> () + | [], [] -> () | _ -> raise (Unify []) in iter xs ys and mcomp_record_description type_pairs env = let rec iter x y = - match x, y with + match (x, y) with | l1 :: xs, l2 :: ys -> - mcomp type_pairs env l1.ld_type l2.ld_type; - if Ident.name l1.ld_id = Ident.name l2.ld_id && - l1.ld_mutable = l2.ld_mutable - then iter xs ys - else raise (Unify []) + mcomp type_pairs env l1.ld_type l2.ld_type; + if + Ident.name l1.ld_id = Ident.name l2.ld_id + && l1.ld_mutable = l2.ld_mutable + then iter xs ys + else raise (Unify []) | [], [] -> () | _ -> raise (Unify []) in iter -let mcomp env t1 t2 = - mcomp (TypePairs.create 4) env t1 t2 +let mcomp env t1 t2 = mcomp (TypePairs.create 4) env t1 t2 (* Real unification *) - let find_newtype_level env path = - try match (Env.find_type path env).type_newtype_level with - Some x -> x - | None -> raise Not_found - with Not_found -> let lev = Path.binding_time path in (lev, lev) + try + match (Env.find_type path env).type_newtype_level with + | Some x -> x + | None -> raise Not_found + with Not_found -> + let lev = Path.binding_time path in + (lev, lev) let add_gadt_equation env source destination = - if local_non_recursive_abbrev !env source destination then begin + if local_non_recursive_abbrev !env source destination then ( let destination = duplicate_type destination in let source_lev = find_newtype_level !env source in let decl = new_declaration (Some source_lev) (Some destination) in let newtype_level = get_newtype_level () in env := Env.add_local_constraint source decl newtype_level !env; - cleanup_abbrev () - end + cleanup_abbrev ()) let unify_eq_set = TypePairs.create 11 -let order_type_pair t1 t2 = - if t1.id <= t2.id then (t1, t2) else (t2, t1) +let order_type_pair t1 t2 = if t1.id <= t2.id then (t1, t2) else (t2, t1) let add_type_equality t1 t2 = TypePairs.add unify_eq_set (order_type_pair t1 t2) () let eq_package_path env p1 p2 = - Path.same p1 p2 || - Path.same (normalize_package_path env p1) (normalize_package_path env p2) + Path.same p1 p2 + || Path.same (normalize_package_path env p1) (normalize_package_path env p2) let nondep_type' = ref (fun _ _ _ -> assert false) let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) @@ -2140,45 +2092,55 @@ let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) let rec concat_longident lid1 = let open Longident in function - Lident s -> Ldot (lid1, s) + | Lident s -> Ldot (lid1, s) | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s) | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid) let nondep_instance env level id ty = let ty = !nondep_type' env id ty in - if level = generic_level then duplicate_type ty else - let old = !current_level in - current_level := level; - let ty = instance env ty in - current_level := old; - ty + if level = generic_level then duplicate_type ty + else + let old = !current_level in + current_level := level; + let ty = instance env ty in + current_level := old; + ty (* Find the type paths nl1 in the module type mty2, and add them to the list (nl2, tl2). raise Not_found if impossible *) -let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = +let complete_type_list ?(allow_absent = false) env nl1 lv2 mty2 nl2 tl2 = let id2 = Ident.create "Pkg" in let env' = Env.add_module id2 mty2 env in let rec complete nl1 ntl2 = - match nl1, ntl2 with - [], _ -> ntl2 - | n :: nl, (n2, _ as nt2) :: ntl' when Longident.cmp n n2 >= 0 -> - nt2 :: complete (if Longident.cmp n n2 = 0 then nl else nl1) ntl' - | n :: nl, _ -> - try - let path = - Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env' - in - match Env.find_type path env' with - {type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = Some t2} -> - (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 - | {type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = None} when allow_absent -> - complete nl ntl2 - | _ -> raise Exit - with - | Not_found when allow_absent -> complete nl ntl2 - | Exit -> raise Not_found + match (nl1, ntl2) with + | [], _ -> ntl2 + | n :: nl, ((n2, _) as nt2) :: ntl' when Longident.cmp n n2 >= 0 -> + nt2 :: complete (if Longident.cmp n n2 = 0 then nl else nl1) ntl' + | n :: nl, _ -> ( + try + let path = + Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env' + in + match Env.find_type path env' with + | { + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some t2; + } -> + (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 + | { + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + } + when allow_absent -> + complete nl ntl2 + | _ -> raise Exit + with + | Not_found when allow_absent -> complete nl ntl2 + | Exit -> raise Not_found) in complete nl1 (List.combine nl2 tl2) @@ -2187,10 +2149,12 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2 and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in unify_list (List.map snd ntl1) (List.map snd ntl2); - if eq_package_path env p1 p2 - || !package_subtype env p1 n1 tl1 p2 n2 tl2 - && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found - + if + eq_package_path env p1 p2 + || !package_subtype env p1 n1 tl1 p2 n2 tl2 + && !package_subtype env p2 n2 tl2 p1 n1 tl1 + then () + else raise Not_found (* force unification in Reither when one side has a non-conjunctive type *) let rigid_variants = ref false @@ -2199,18 +2163,29 @@ let rigid_variants = ref false (not sound, only use it when checking exhaustiveness) *) let passive_variants = ref false let with_passive_variants f x = - if !passive_variants then f x else - match passive_variants := true; f x with - | r -> passive_variants := false; r - | exception e -> passive_variants := false; raise e + if !passive_variants then f x + else + match + passive_variants := true; + f x + with + | r -> + passive_variants := false; + r + | exception e -> + passive_variants := false; + raise e let unify_eq t1 t2 = - t1 == t2 || + t1 == t2 + || match !umode with | Expression -> false - | Pattern -> - try TypePairs.find unify_eq_set (order_type_pair t1 t2); true - with Not_found -> false + | Pattern -> ( + try + TypePairs.find unify_eq_set (order_type_pair t1 t2); + true + with Not_found -> false) let unify1_var env t1 t2 = assert (is_Tvar t1); @@ -2218,65 +2193,59 @@ let unify1_var env t1 t2 = occur_univar env t2; let d1 = t1.desc in link_type t1 t2; - try - update_level env t1.level t2 + try update_level env t1.level t2 with Unify _ as e -> t1.desc <- d1; raise e -let rec unify (env:Env.t ref) t1 t2 = +let rec unify (env : Env.t ref) t1 t2 = (* First step: special cases (optimizations) *) - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if unify_eq t1 t2 then () else - let reset_tracing = check_trace_gadt_instances !env in - - try - type_changed := true; - begin match (t1.desc, t2.desc) with - (Tvar _, Tconstr _) when deep_occur t1 t2 -> - unify2 env t1 t2 - | (Tconstr _, Tvar _) when deep_occur t2 t1 -> - unify2 env t1 t2 - | (Tvar _, _) -> - unify1_var !env t1 t2 - | (_, Tvar _) -> - unify1_var !env t2 t1 - | (Tunivar _, Tunivar _) -> - unify_univar t1 t2 !univar_pairs; - update_level !env t1.level t2; - link_type t1 t2 - | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if unify_eq t1 t2 then () + else + let reset_tracing = check_trace_gadt_instances !env in + + try + type_changed := true; + (match (t1.desc, t2.desc) with + | Tvar _, Tconstr _ when deep_occur t1 t2 -> unify2 env t1 t2 + | Tconstr _, Tvar _ when deep_occur t2 t1 -> unify2 env t1 t2 + | Tvar _, _ -> unify1_var !env t1 t2 + | _, Tvar _ -> unify1_var !env t2 t1 + | Tunivar _, Tunivar _ -> + unify_univar t1 t2 !univar_pairs; + update_level !env t1.level t2; + link_type t1 t2 + | Tconstr (p1, [], a1), Tconstr (p2, [], a2) when Path.same p1 p2 (* && actual_mode !env = Old *) - (* This optimization assumes that t1 does not expand to t2 - (and conversely), so we fall back to the general case - when any of the types has a cached expansion. *) - && not (has_cached_expansion p1 !a1 - || has_cached_expansion p2 !a2) -> - update_level !env t1.level t2; - link_type t1 t2 - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) - when Env.has_local_constraints !env - && is_newtype !env p1 && is_newtype !env p2 -> - (* Do not use local constraints more than necessary *) - begin try - let [@local] (<) ((a : int) ,(b : int)) (c,d) = - a < c || (a = c && b < d) in - if find_newtype_level !env p1 < find_newtype_level !env p2 then - unify env t1 (try_expand_once !env t2) - else - unify env (try_expand_once !env t1) t2 - with Cannot_expand -> - unify2 env t1 t2 - end - | _ -> - unify2 env t1 t2 - end; - reset_trace_gadt_instances reset_tracing; - with Unify trace -> - reset_trace_gadt_instances reset_tracing; - raise (Unify ((t1, t2)::trace)) + (* This optimization assumes that t1 does not expand to t2 + (and conversely), so we fall back to the general case + when any of the types has a cached expansion. *) + && not + (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + -> + update_level !env t1.level t2; + link_type t1 t2 + | Tconstr (p1, [], _), Tconstr (p2, [], _) + when Env.has_local_constraints !env + && is_newtype !env p1 && is_newtype !env p2 -> ( + (* Do not use local constraints more than necessary *) + try + let[@local] ( < ) ((a : int), (b : int)) (c, d) = + a < c || (a = c && b < d) + in + if find_newtype_level !env p1 < find_newtype_level !env p2 then + unify env t1 (try_expand_once !env t2) + else unify env (try_expand_once !env t1) t2 + with Cannot_expand -> unify2 env t1 t2) + | _ -> unify2 env t1 t2); + reset_trace_gadt_instances reset_tracing + with Unify trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify ((t1, t2) :: trace)) and unify2 env t1 t2 = (* Second step: expansion of abbreviations *) @@ -2288,214 +2257,215 @@ and unify2 env t1 t2 = let lv = Ext_pervasives.min_int t1'.level t2'.level in update_level !env lv t2; update_level !env lv t1; - if unify_eq t1' t2' then () else - - let t1 = repr t1 and t2 = repr t2 in - if !trace_gadt_instances then begin - (* All types in chains already have the same ambiguity levels *) - let ilevel t = - match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in - let lv1 = ilevel t1 and lv2 = ilevel t2 in - if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else - if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1 - end; - if unify_eq t1 t1' || not (unify_eq t2 t2') then - unify3 env t1 t1' t2 t2' + if unify_eq t1' t2' then () else - try unify3 env t2 t2' t1 t1' with Unify trace -> - raise (Unify (List.map (fun (x, y) -> (y, x)) trace)) + let t1 = repr t1 and t2 = repr t2 in + (if !trace_gadt_instances then + (* All types in chains already have the same ambiguity levels *) + let ilevel t = + match Env.gadt_instance_level !env t with + | None -> 0 + | Some lv -> lv + in + let lv1 = ilevel t1 and lv2 = ilevel t2 in + if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 + else if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1); + if unify_eq t1 t1' || not (unify_eq t2 t2') then unify3 env t1 t1' t2 t2' + else + try unify3 env t2 t2' t1 t1' + with Unify trace -> + raise (Unify (List.map (fun (x, y) -> (y, x)) trace)) and unify3 env t1 t1' t2 t2' = (* Third step: truly unification *) (* Assumes either [t1 == t1'] or [t2 != t2'] *) let d1 = t1'.desc and d2 = t2'.desc in - let create_recursion = (t2 != t2') && (deep_occur t1' t2) in - - begin match (d1, d2) with (* handle vars and univars specially *) - (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs; - link_type t1' t2' - | (Tvar _, _) -> - occur !env t1' t2; - occur_univar !env t2; - link_type t1' t2; - | (_, Tvar _) -> - occur !env t2' t1; - occur_univar !env t1; - link_type t2' t1; - | (Tfield _, Tfield _) -> (* special case for GADTs *) - unify_fields env t1' t2' - | (Tconstr (Pident {name="function$"}, [t_fun; _], _), Tarrow _) -> - (* subtype: an uncurried function is cast to a curried one *) - unify2 env t_fun t2 - | _ -> - begin match !umode with + let create_recursion = t2 != t2' && deep_occur t1' t2 in + + match (d1, d2) with + (* handle vars and univars specially *) + | Tunivar _, Tunivar _ -> + unify_univar t1' t2' !univar_pairs; + link_type t1' t2' + | Tvar _, _ -> + occur !env t1' t2; + occur_univar !env t2; + link_type t1' t2 + | _, Tvar _ -> + occur !env t2' t1; + occur_univar !env t1; + link_type t2' t1 + | Tfield _, Tfield _ -> + (* special case for GADTs *) + unify_fields env t1' t2' + | Tconstr (Pident {name = "function$"}, [t_fun; _], _), Tarrow _ -> + (* subtype: an uncurried function is cast to a curried one *) + unify2 env t_fun t2 + | _ -> ( + (match !umode with | Expression -> - occur !env t1' t2'; - link_type t1' t2 - | Pattern -> - add_type_equality t1' t2' - end; + occur !env t1' t2'; + link_type t1' t2 + | Pattern -> add_type_equality t1' t2'); try - begin match (d1, d2) with - (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when Asttypes.same_arg_label l1 l2 || - (!umode = Pattern) && - not (is_optional l1 || is_optional l2) -> - unify env t1 t2; unify env u1 u2; - begin match commu_repr c1, commu_repr c2 with - Clink r, c2 -> set_commu r c2 - | c1, Clink r -> set_commu r c1 - | _ -> () - end - | (Ttuple tl1, Ttuple tl2) -> + (match (d1, d2) with + | Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2) + when Asttypes.same_arg_label l1 l2 + || (!umode = Pattern && not (is_optional l1 || is_optional l2)) + -> ( + unify env t1 t2; + unify env u1 u2; + match (commu_repr c1, commu_repr c2) with + | Clink r, c2 -> set_commu r c2 + | c1, Clink r -> set_commu r c1 + | _ -> ()) + | Ttuple tl1, Ttuple tl2 -> unify_list env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 -> + if !umode = Expression || not !generate_equations then unify_list env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if !umode = Expression || not !generate_equations then - unify_list env tl1 tl2 - else if !assume_injective then - set_mode_pattern ~generate:true ~injective:false - (fun () -> unify_list env tl1 tl2) - else if in_current_module p1 (* || in_pervasives p1 *) - || List.exists (expands_to_datatype !env) [t1'; t1; t2] then - unify_list env tl1 tl2 - else - let inj = - try List.map Variance.(mem Inj) - (Env.find_type p1 !env).type_variance - with Not_found -> List.map (fun _ -> false) tl1 - in - List.iter2 - (fun i (t1, t2) -> - if i then unify env t1 t2 else - set_mode_pattern ~generate:false ~injective:false - begin fun () -> + else if !assume_injective then + set_mode_pattern ~generate:true ~injective:false (fun () -> + unify_list env tl1 tl2) + else if + in_current_module p1 (* || in_pervasives p1 *) + || List.exists (expands_to_datatype !env) [t1'; t1; t2] + then unify_list env tl1 tl2 + else + let inj = + try + List.map Variance.(mem Inj) (Env.find_type p1 !env).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1, t2) -> + if i then unify env t1 t2 + else + set_mode_pattern ~generate:false ~injective:false (fun () -> let snap = snapshot () in - try unify env t1 t2 with Unify _ -> + try unify env t1 t2 + with Unify _ -> backtrack snap; - reify env t1; reify env t2 - end) - inj (List.combine tl1 tl2) - | (Tconstr (path,[],_), - Tconstr (path',[],_)) + reify env t1; + reify env t2)) + inj (List.combine tl1 tl2) + | Tconstr (path, [], _), Tconstr (path', [], _) when is_instantiable !env path && is_instantiable !env path' - && !generate_equations -> - let [@local] (>) ((a:int),(b:int)) (c,d) = - a > c || (a = c && b > d) - in - let source, destination = - if find_newtype_level !env path > find_newtype_level !env path' - then path , t2' - else path', t1' - in - add_gadt_equation env source destination - | (Tconstr (path,[],_), _) + && !generate_equations -> + let[@local] ( > ) ((a : int), (b : int)) (c, d) = + a > c || (a = c && b > d) + in + let source, destination = + if find_newtype_level !env path > find_newtype_level !env path' then + (path, t2') + else (path', t1') + in + add_gadt_equation env source destination + | Tconstr (path, [], _), _ when is_instantiable !env path && !generate_equations -> - reify env t2'; - add_gadt_equation env path t2' - | (_, Tconstr (path,[],_)) + reify env t2'; + add_gadt_equation env path t2' + | _, Tconstr (path, [], _) when is_instantiable !env path && !generate_equations -> - reify env t1'; - add_gadt_equation env path t1' - | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern -> - reify env t1'; - reify env t2'; - if !generate_equations then mcomp !env t1' t2' - | (Tobject (fi1, nm1), Tobject (fi2, _)) -> - unify_fields env fi1 fi2; - (* Type [t2'] may have been instantiated by [unify_fields] *) - (* XXX One should do some kind of unification... *) - begin match (repr t2').desc with - Tobject (_, {contents = Some (_, va::_)}) when - (match (repr va).desc with - Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () - | Tobject (_, nm2) -> set_name nm2 !nm1 - | _ -> () - end - | (Tvariant row1, Tvariant row2) -> - if !umode = Expression then - unify_row env row1 row2 - else begin - let snap = snapshot () in - try unify_row env row1 row2 - with Unify _ -> - backtrack snap; - reify env t1'; - reify env t2'; - if !generate_equations then mcomp !env t1' t2' - end - | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> - begin match field_kind_repr kind with - Fvar r when f <> dummy_method -> - set_kind r Fabsent; - if d2 = Tnil then unify env rem t2' - else unify env (newty2 rem.level Tnil) rem - | _ -> raise (Unify []) - end - | (Tnil, Tnil) -> + reify env t1'; + add_gadt_equation env path t1' + | (Tconstr (_, _, _), _ | _, Tconstr (_, _, _)) when !umode = Pattern -> + reify env t1'; + reify env t2'; + if !generate_equations then mcomp !env t1' t2' + | Tobject (fi1, nm1), Tobject (fi2, _) -> ( + unify_fields env fi1 fi2; + (* Type [t2'] may have been instantiated by [unify_fields] *) + (* XXX One should do some kind of unification... *) + match (repr t2').desc with + | Tobject (_, {contents = Some (_, va :: _)}) + when match (repr va).desc with + | Tvar _ | Tunivar _ | Tnil -> true + | _ -> false -> () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - unify env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> - begin try - unify_package !env (unify_list env) - t1.level p1 n1 tl1 t2.level p2 n2 tl2 - with Not_found -> - if !umode = Expression then raise (Unify []); - List.iter (reify env) (tl1 @ tl2); - (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) - end - | (_, _) -> - raise (Unify []) - end; + | Tobject (_, nm2) -> set_name nm2 !nm1 + | _ -> ()) + | Tvariant row1, Tvariant row2 -> ( + if !umode = Expression then unify_row env row1 row2 + else + let snap = snapshot () in + try unify_row env row1 row2 + with Unify _ -> + backtrack snap; + reify env t1'; + reify env t2'; + if !generate_equations then mcomp !env t1' t2') + | Tfield (f, kind, _, rem), Tnil | Tnil, Tfield (f, kind, _, rem) -> ( + match field_kind_repr kind with + | Fvar r when f <> dummy_method -> + set_kind r Fabsent; + if d2 = Tnil then unify env rem t2' + else unify env (newty2 rem.level Tnil) rem + | _ -> raise (Unify [])) + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> unify env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) + | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( + try + unify_package !env (unify_list env) t1.level p1 n1 tl1 t2.level p2 n2 + tl2 + with Not_found -> + if !umode = Expression then raise (Unify []); + List.iter (reify env) (tl1 @ tl2) + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)) + | _, _ -> raise (Unify [])); (* XXX Commentaires + changer "create_recursion" ||| Comments + change "create_recursion" *) if create_recursion then match t2.desc with - Tconstr (p, tl, abbrev) -> - forget_abbrev abbrev p; - let t2'' = expand_head_unif !env t2 in - if not (closed_parameterized_type tl t2'') then - link_type (repr t2) (repr t2') - | _ -> - () (* t2 has already been expanded by update_level *) + | Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif !env t2 in + if not (closed_parameterized_type tl t2'') then + link_type (repr t2) (repr t2') + | _ -> () (* t2 has already been expanded by update_level *) with Unify trace -> t1'.desc <- d1; - raise (Unify trace) - end + raise (Unify trace)) and unify_list env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); + if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (unify env) tl1 tl2 (* Build a fresh row variable for unification *) -and make_rowvar level use1 rest1 use2 rest2 = +and make_rowvar level use1 rest1 use2 rest2 = let set_name ty name = match ty.desc with - Tvar None -> log_type ty; ty.desc <- Tvar name + | Tvar None -> + log_type ty; + ty.desc <- Tvar name | _ -> () in let name = - match rest1.desc, rest2.desc with - Tvar (Some _ as name1), Tvar (Some _ as name2) -> - if rest1.level <= rest2.level then name1 else name2 + match (rest1.desc, rest2.desc) with + | Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if rest1.level <= rest2.level then name1 else name2 | Tvar (Some _ as name), _ -> - if use2 then set_name rest2 name; name + if use2 then set_name rest2 name; + name | _, Tvar (Some _ as name) -> - if use1 then set_name rest2 name; name + if use1 then set_name rest2 name; + name | _ -> None in - if use1 then rest1 else - if use2 then rest2 else newvar2 ?name level + if use1 then rest1 else if use2 then rest2 else newvar2 ?name level -and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = (* Optimization *) - let (fields1, rest1) = flatten_fields ty1 - and (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in +and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = + (* Optimization *) + let fields1, rest1 = flatten_fields ty1 + and fields2, rest2 = flatten_fields ty2 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in let l1 = (repr ty1).level and l2 = (repr ty2).level in - let va = make_rowvar (Ext_pervasives.min_int l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let va = + make_rowvar + (Ext_pervasives.min_int l1 l2) + (miss2 = []) rest1 (miss1 = []) rest2 + in let d1 = rest1.desc and d2 = rest2.desc in try unify env (build_fields l1 miss1 va) rest2; @@ -2507,197 +2477,239 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = if !trace_gadt_instances then update_level !env va.level t1; unify env t1 t2 with Unify trace -> - raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)), - newty (Tfield(n, k2, t2, newty Tnil)))::trace))) + raise + (Unify + (( newty (Tfield (n, k1, t1, newty Tnil)), + newty (Tfield (n, k2, t2, newty Tnil)) ) + :: trace))) pairs with exn -> - log_type rest1; rest1.desc <- d1; - log_type rest2; rest2.desc <- d2; + log_type rest1; + rest1.desc <- d1; + log_type rest2; + rest2.desc <- d2; raise exn and unify_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in - if k1 == k2 then () else - match k1, k2 with - (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 - | (Fpresent, Fvar r) -> set_kind r k1 - | (Fpresent, Fpresent) -> () - | _ -> assert false + if k1 == k2 then () + else + match (k1, k2) with + | Fvar r, (Fvar _ | Fpresent) -> set_kind r k2 + | Fpresent, Fvar r -> set_kind r k1 + | Fpresent, Fpresent -> () + | _ -> assert false and unify_row env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = row_more row1 and rm2 = row_more row2 in - if unify_eq rm1 rm2 then () else - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in - let more = - if fixed1 then rm1 else - if fixed2 then rm2 else - newty2 (Ext_pervasives.min_int rm1.level rm2.level) (Tvar None) in - let fixed = fixed1 || fixed2 - and closed = row1.row_closed || row2.row_closed in - let keep switch = - List.for_all - (fun (_,f1,f2) -> - let f1, f2 = switch f1 f2 in - row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) - pairs - in - let empty fields = - List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in - (* Check whether we are going to build an empty type *) - if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed) - && List.for_all - (fun (_,f1,f2) -> - row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) - pairs - then raise (Unify [mkvariant [] true, mkvariant [] true]); - let name = - if row1.row_name <> None && (row1.row_closed || empty r2) && - (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1) - then row1.row_name - else if row2.row_name <> None && (row2.row_closed || empty r1) && - (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2) - then row2.row_name - else None - in - let row0 = {row_fields = []; row_more = more; row_bound = (); - row_closed = closed; row_fixed = fixed; row_name = name} in - let set_more row rest = - let rest = - if closed then - filter_row_fields row.row_closed rest - else rest in - if rest <> [] && (row.row_closed || row_fixed row) - || closed && row_fixed row && not row.row_closed then begin - let t1 = mkvariant [] true and t2 = mkvariant rest false in - raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) - end; - (* The following test is not principal... should rather use Tnil *) - let rm = row_more row in - (*if !trace_gadt_instances && rm.desc = Tnil then () else*) - if !trace_gadt_instances then - update_level !env rm.level (newgenty (Tvariant row)); - if row_fixed row then - if more == rm then () else - if is_Tvar rm then link_type rm more else unify env rm more - else - let ty = newgenty (Tvariant {row0 with row_fields = rest}) in - update_level !env rm.level ty; - link_type rm ty - in - let md1 = rm1.desc and md2 = rm2.desc in - begin try - set_more row2 r1; - set_more row1 r2; - List.iter - (fun (l,f1,f2) -> - try unify_row_field env fixed1 fixed2 more l f1 f2 - with Unify trace -> - raise (Unify ((mkvariant [l,f1] true, - mkvariant [l,f2] true) :: trace))) - pairs; - if static_row row1 then begin - let rm = row_more row1 in - if is_Tvar rm then link_type rm (newty2 rm.level Tnil) - end - with exn -> - log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn - end + if unify_eq rm1 rm2 then () + else + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in + let more = + if fixed1 then rm1 + else if fixed2 then rm2 + else newty2 (Ext_pervasives.min_int rm1.level rm2.level) (Tvar None) + in + let fixed = fixed1 || fixed2 + and closed = row1.row_closed || row2.row_closed in + let keep switch = + List.for_all + (fun (_, f1, f2) -> + let f1, f2 = switch f1 f2 in + row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) + pairs + in + let empty fields = + List.for_all (fun (_, f) -> row_field_repr f = Rabsent) fields + in + (* Check whether we are going to build an empty type *) + if + closed + && (empty r1 || row2.row_closed) + && (empty r2 || row1.row_closed) + && List.for_all + (fun (_, f1, f2) -> + row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) + pairs + then raise (Unify [(mkvariant [] true, mkvariant [] true)]); + let name = + if + row1.row_name <> None + && (row1.row_closed || empty r2) + && ((not row2.row_closed) || (keep (fun f1 f2 -> (f1, f2)) && empty r1)) + then row1.row_name + else if + row2.row_name <> None + && (row2.row_closed || empty r1) + && ((not row1.row_closed) || (keep (fun f1 f2 -> (f2, f1)) && empty r2)) + then row2.row_name + else None + in + let row0 = + { + row_fields = []; + row_more = more; + row_bound = (); + row_closed = closed; + row_fixed = fixed; + row_name = name; + } + in + let set_more row rest = + let rest = + if closed then filter_row_fields row.row_closed rest else rest + in + (if + (rest <> [] && (row.row_closed || row_fixed row)) + || (closed && row_fixed row && not row.row_closed) + then + let t1 = mkvariant [] true and t2 = mkvariant rest false in + raise (Unify [(if row == row1 then (t1, t2) else (t2, t1))])); + (* The following test is not principal... should rather use Tnil *) + let rm = row_more row in + (*if !trace_gadt_instances && rm.desc = Tnil then () else*) + if !trace_gadt_instances then + update_level !env rm.level (newgenty (Tvariant row)); + if row_fixed row then + if more == rm then () + else if is_Tvar rm then link_type rm more + else unify env rm more + else + let ty = newgenty (Tvariant {row0 with row_fields = rest}) in + update_level !env rm.level ty; + link_type rm ty + in + let md1 = rm1.desc and md2 = rm2.desc in + try + set_more row2 r1; + set_more row1 r2; + List.iter + (fun (l, f1, f2) -> + try unify_row_field env fixed1 fixed2 more l f1 f2 + with Unify trace -> + raise + (Unify + ((mkvariant [(l, f1)] true, mkvariant [(l, f2)] true) :: trace))) + pairs; + if static_row row1 then + let rm = row_more row1 in + if is_Tvar rm then link_type rm (newty2 rm.level Tnil) + with exn -> + log_type rm1; + rm1.desc <- md1; + log_type rm2; + rm2.desc <- md2; + raise exn and unify_row_field env fixed1 fixed2 more l f1 f2 = let f1 = row_field_repr f1 and f2 = row_field_repr f2 in - if f1 == f2 then () else - match f1, f2 with - Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 - | Rpresent None, Rpresent None -> () - | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> - if e1 == e2 then () else - if (fixed1 || fixed2) && not (c1 || c2) - && List.length tl1 = List.length tl2 then begin + if f1 == f2 then () + else + match (f1, f2) with + | Rpresent (Some t1), Rpresent (Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither (c1, tl1, m1, e1), Reither (c2, tl2, m2, e2) -> + if e1 == e2 then () + else if + (fixed1 || fixed2) + && (not (c1 || c2)) + && List.length tl1 = List.length tl2 + then ( (* PR#7496 *) let f = Reither (c1 || c2, [], m1 || m2, ref None) in - set_row_field e1 f; set_row_field e2 f; - List.iter2 (unify env) tl1 tl2 - end - else let redo = - not !passive_variants && - (m1 || m2 || fixed1 || fixed2 || - !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && - begin match tl1 @ tl2 with [] -> false - | t1 :: tl -> + set_row_field e1 f; + set_row_field e2 f; + List.iter2 (unify env) tl1 tl2) + else + let redo = + (not !passive_variants) + && (m1 || m2 || fixed1 || fixed2 + || (!rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) + ) + && + match tl1 @ tl2 with + | [] -> false + | t1 :: tl -> if c1 || c2 then raise (Unify []); List.iter (unify env t1) tl; !e1 <> None || !e2 <> None - end in - if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in - let rec remq tl = function [] -> [] - | ty :: tl' -> - if List.memq ty tl then remq tl tl' else ty :: remq tl tl' - in - let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in - (* PR#6744 *) - let split_univars = - List.partition - (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in - let (tl1',tlu1) = split_univars tl1' - and (tl2',tlu2) = split_univars tl2' in - begin match tlu1, tlu2 with - [], [] -> () - | (tu1::tlu1), _ :: _ -> - (* Attempt to merge all the types containing univars *) - if not !passive_variants then - List.iter (unify env tu1) (tlu1@tlu2) - | (tu::_, []) | ([], tu::_) -> occur_univar !env tu - end; - (* Is this handling of levels really principal? *) - List.iter (update_level !env (repr more).level) (tl1' @ tl2'); - let e = ref None in - let f1' = Reither(c1 || c2, tl1', m1 || m2, e) - and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in - set_row_field e1 f1'; set_row_field e2 f2'; - | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 - | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1 - | Rabsent, Rabsent -> () - | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> + in + if redo then unify_row_field env fixed1 fixed2 more l f1 f2 + else + let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in + let rec remq tl = function + | [] -> [] + | ty :: tl' -> + if List.memq ty tl then remq tl tl' else ty :: remq tl tl' + in + let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in + (* PR#6744 *) + let split_univars = + List.partition (fun ty -> + try + occur_univar !env ty; + true + with Unify _ -> false) + in + let tl1', tlu1 = split_univars tl1' + and tl2', tlu2 = split_univars tl2' in + (match (tlu1, tlu2) with + | [], [] -> () + | tu1 :: tlu1, _ :: _ -> + (* Attempt to merge all the types containing univars *) + if not !passive_variants then List.iter (unify env tu1) (tlu1 @ tlu2) + | tu :: _, [] | [], tu :: _ -> occur_univar !env tu); + (* Is this handling of levels really principal? *) + List.iter (update_level !env (repr more).level) (tl1' @ tl2'); + let e = ref None in + let f1' = Reither (c1 || c2, tl1', m1 || m2, e) + and f2' = Reither (c1 || c2, tl2', m1 || m2, e) in + set_row_field e1 f1'; + set_row_field e2 f2' + | Reither (_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 + | Rabsent, Reither (_, _, false, e2) when not fixed2 -> set_row_field e2 f1 + | Rabsent, Rabsent -> () + | Reither (false, tl, _, e1), Rpresent (Some t2) when not fixed1 -> ( set_row_field e1 f2; update_level !env (repr more).level t2; - (try List.iter (fun t1 -> unify env t1 t2) tl - with exn -> e1 := None; raise exn) - | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> + try List.iter (fun t1 -> unify env t1 t2) tl + with exn -> + e1 := None; + raise exn) + | Rpresent (Some t1), Reither (false, tl, _, e2) when not fixed2 -> ( set_row_field e2 f1; update_level !env (repr more).level t1; - (try List.iter (unify env t1) tl - with exn -> e2 := None; raise exn) - | Reither(true, [], _, e1), Rpresent None when not fixed1 -> + try List.iter (unify env t1) tl + with exn -> + e2 := None; + raise exn) + | Reither (true, [], _, e1), Rpresent None when not fixed1 -> set_row_field e1 f2 - | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> + | Rpresent None, Reither (true, [], _, e2) when not fixed2 -> set_row_field e2 f1 - | _ -> raise (Unify []) - + | _ -> raise (Unify []) let unify env ty1 ty2 = let snap = Btype.snapshot () in - try - unify env ty1 ty2 - with - Unify trace -> - undo_compress snap; - raise (Unify (expand_trace !env trace)) + try unify env ty1 ty2 with + | Unify trace -> + undo_compress snap; + raise (Unify (expand_trace !env trace)) | Recursive_abbrev -> - undo_compress snap; - raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)])) + undo_compress snap; + raise (Unification_recursive_abbrev (expand_trace !env [(ty1, ty2)])) -let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = +let unify_gadt ~newtype_level:lev (env : Env.t ref) ty1 ty2 = try univar_pairs := []; newtype_level := Some lev; - set_mode_pattern ~generate:true ~injective:true - (fun () -> unify env ty1 ty2); + set_mode_pattern ~generate:true ~injective:true (fun () -> + unify env ty1 ty2); newtype_level := None; - TypePairs.clear unify_eq_set; + TypePairs.clear unify_eq_set with e -> newtype_level := None; TypePairs.clear unify_eq_set; @@ -2705,24 +2717,22 @@ let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = let unify_var env t1 t2 = let t1 = repr t1 and t2 = repr t2 in - if t1 == t2 then () else - match t1.desc, t2.desc with - Tvar _, Tconstr _ when deep_occur t1 t2 -> - unify (ref env) t1 t2 - | Tvar _, _ -> + if t1 == t2 then () + else + match (t1.desc, t2.desc) with + | Tvar _, Tconstr _ when deep_occur t1 t2 -> unify (ref env) t1 t2 + | Tvar _, _ -> ( let reset_tracing = check_trace_gadt_instances env in - begin try + try occur env t1 t2; update_level env t1.level t2; link_type t1 t2; - reset_trace_gadt_instances reset_tracing; + reset_trace_gadt_instances reset_tracing with Unify trace -> reset_trace_gadt_instances reset_tracing; - let expanded_trace = expand_trace env ((t1,t2)::trace) in - raise (Unify expanded_trace) - end - | _ -> - unify (ref env) t1 t2 + let expanded_trace = expand_trace env ((t1, t2) :: trace) in + raise (Unify expanded_trace)) + | _ -> unify (ref env) t1 t2 let _ = unify' := unify_var @@ -2730,10 +2740,7 @@ let unify_pairs env ty1 ty2 pairs = univar_pairs := pairs; unify env ty1 ty2 -let unify env ty1 ty2 = - unify_pairs (ref env) ty1 ty2 [] - - +let unify env ty1 ty2 = unify_pairs (ref env) ty1 ty2 [] (**** Special cases of unification ****) @@ -2753,76 +2760,69 @@ let expand_head_trace env t = let filter_arrow env t l = let t = expand_head_trace env t in match t.desc with - Tvar _ -> - let lv = t.level in - let t1 = newvar2 lv and t2 = newvar2 lv in - let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in - link_type t t'; - (t1, t2) - | Tarrow(l', t1, t2, _) - when Asttypes.same_arg_label l l' -> - (t1, t2) - | _ -> - raise (Unify []) + | Tvar _ -> + let lv = t.level in + let t1 = newvar2 lv and t2 = newvar2 lv in + let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in + link_type t t'; + (t1, t2) + | Tarrow (l', t1, t2, _) when Asttypes.same_arg_label l l' -> (t1, t2) + | _ -> raise (Unify []) (* Used by [filter_method]. *) let rec filter_method_field env name priv ty = let ty = expand_head_trace env ty in match ty.desc with - Tvar _ -> - let level = ty.level in - let ty1 = newvar2 level and ty2 = newvar2 level in - let ty' = newty2 level (Tfield (name, - begin match priv with - Private -> Fvar (ref None) - | Public -> Fpresent - end, - ty1, ty2)) - in - link_type ty ty'; - ty1 - | Tfield(n, kind, ty1, ty2) -> - let kind = field_kind_repr kind in - if (n = name) && (kind <> Fabsent) then begin - if priv = Public then - unify_kind kind Fpresent; - ty1 - end else - filter_method_field env name priv ty2 - | _ -> - raise (Unify []) + | Tvar _ -> + let level = ty.level in + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = + newty2 level + (Tfield + ( name, + (match priv with + | Private -> Fvar (ref None) + | Public -> Fpresent), + ty1, + ty2 )) + in + link_type ty ty'; + ty1 + | Tfield (n, kind, ty1, ty2) -> + let kind = field_kind_repr kind in + if n = name && kind <> Fabsent then ( + if priv = Public then unify_kind kind Fpresent; + ty1) + else filter_method_field env name priv ty2 + | _ -> raise (Unify []) (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) let filter_method env name priv ty = let ty = expand_head_trace env ty in match ty.desc with - Tvar _ -> - let ty1 = newvar () in - let ty' = newobj ty1 in - update_level env ty.level ty'; - link_type ty ty'; - filter_method_field env name priv ty1 - | Tobject(f, _) -> - filter_method_field env name priv f - | _ -> - raise (Unify []) + | Tvar _ -> + let ty1 = newvar () in + let ty' = newobj ty1 in + update_level env ty.level ty'; + link_type ty ty'; + filter_method_field env name priv ty1 + | Tobject (f, _) -> filter_method_field env name priv f + | _ -> raise (Unify []) let check_filter_method env name priv ty = - ignore(filter_method env name priv ty) + ignore (filter_method env name priv ty) let filter_self_method env lab priv meths ty = let ty' = filter_method env lab priv ty in - try - Meths.find lab !meths + try Meths.find lab !meths with Not_found -> let pair = (Ident.create lab, ty') in meths := Meths.add lab pair !meths; pair - - (***********************************) - (* Matching between type schemes *) - (***********************************) +(***********************************) +(* Matching between type schemes *) +(***********************************) (* Update the level of [ty]. First check that the levels of generic @@ -2831,183 +2831,179 @@ let filter_self_method env lab priv meths ty = let moregen_occur env level ty = let rec occur ty = let ty = repr ty in - if ty.level > level then begin + if ty.level > level then ( if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; ty.level <- pivot_level - ty.level; match ty.desc with - Tvariant row when static_row row -> - iter_row occur row - | _ -> - iter_type_expr occur ty - end + | Tvariant row when static_row row -> iter_row occur row + | _ -> iter_type_expr occur ty) in - begin try - occur ty; unmark_type ty - with Occur -> - unmark_type ty; raise (Unify []) - end; + (try + occur ty; + unmark_type ty + with Occur -> + unmark_type ty; + raise (Unify [])); (* also check for free univars *) occur_univar env ty; update_level env level ty let may_instantiate inst_nongen t1 = if inst_nongen then t1.level <> generic_level - 1 - else t1.level = generic_level + else t1.level = generic_level let rec moregen inst_nongen type_pairs env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - - try - match (t1.desc, t2.desc) with - (Tvar _, _) when may_instantiate inst_nongen t1 -> - moregen_occur env t1.level t2; - occur env t1 t2; - link_type t1 t2 - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head env t1 in - let t2' = expand_head env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try - TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, _) when may_instantiate inst_nongen t1' -> - moregen_occur env t1'.level t2; - link_type t1' t2 - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when Asttypes.same_arg_label l1 l2 - -> - moregen inst_nongen type_pairs env t1 t2; - moregen inst_nongen type_pairs env u1 u2 - | (Ttuple tl1, Ttuple tl2) -> - moregen_list inst_nongen type_pairs env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) - when Path.same p1 p2 -> - moregen_list inst_nongen type_pairs env tl1 tl2 - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> - begin try - unify_package env (moregen_list inst_nongen type_pairs env) - t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 - with Not_found -> raise (Unify []) - end - | (Tvariant row1, Tvariant row2) -> - moregen_row inst_nongen type_pairs env row1 row2 - | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> - moregen_fields inst_nongen type_pairs env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - moregen_fields inst_nongen type_pairs env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - moregen inst_nongen type_pairs env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (moregen inst_nongen type_pairs env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end - with Unify trace -> - raise (Unify ((t1, t2)::trace)) + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then () + else + try + match (t1.desc, t2.desc) with + | Tvar _, _ when may_instantiate inst_nongen t1 -> + moregen_occur env t1.level t2; + occur env t1 t2; + link_type t1 t2 + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> () + | _ -> ( + let t1' = expand_head env t1 in + let t2' = expand_head env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () + else + try TypePairs.find type_pairs (t1', t2') + with Not_found -> ( + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + | Tvar _, _ when may_instantiate inst_nongen t1' -> + moregen_occur env t1'.level t2; + link_type t1' t2 + | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + when Asttypes.same_arg_label l1 l2 -> + moregen inst_nongen type_pairs env t1 t2; + moregen inst_nongen type_pairs env u1 u2 + | Ttuple tl1, Ttuple tl2 -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 + -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( + try + unify_package env + (moregen_list inst_nongen type_pairs env) + t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 + with Not_found -> raise (Unify [])) + | Tvariant row1, Tvariant row2 -> + moregen_row inst_nongen type_pairs env row1 row2 + | Tobject (fi1, _nm1), Tobject (fi2, _nm2) -> + moregen_fields inst_nongen type_pairs env fi1 fi2 + | Tfield _, Tfield _ -> + (* Actually unused *) + moregen_fields inst_nongen type_pairs env t1' t2' + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> + moregen inst_nongen type_pairs env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (moregen inst_nongen type_pairs env) + | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | _, _ -> raise (Unify []))) + with Unify trace -> raise (Unify ((t1, t2) :: trace)) and moregen_list inst_nongen type_pairs env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); + if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 and moregen_fields inst_nongen type_pairs env ty1 ty2 = - let (fields1, rest1) = flatten_fields ty1 - and (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let fields1, rest1 = flatten_fields ty1 + and fields2, rest2 = flatten_fields ty2 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in if miss1 <> [] then raise (Unify []); moregen inst_nongen type_pairs env rest1 (build_fields (repr ty2).level miss2 rest2); List.iter (fun (n, k1, t1, k2, t2) -> - moregen_kind k1 k2; - try moregen inst_nongen type_pairs env t1 t2 with Unify trace -> - raise (Unify ((newty (Tfield(n, k1, t1, rest2)), - newty (Tfield(n, k2, t2, rest2)))::trace))) + moregen_kind k1 k2; + try moregen inst_nongen type_pairs env t1 t2 + with Unify trace -> + raise + (Unify + (( newty (Tfield (n, k1, t1, rest2)), + newty (Tfield (n, k2, t2, rest2)) ) + :: trace))) pairs and moregen_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in - if k1 == k2 then () else - match k1, k2 with - (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 - | (Fpresent, Fpresent) -> () - | _ -> raise (Unify []) + if k1 == k2 then () + else + match (k1, k2) with + | Fvar r, (Fvar _ | Fpresent) -> set_kind r k2 + | Fpresent, Fpresent -> () + | _ -> raise (Unify []) and moregen_row inst_nongen type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = repr row1.row_more and rm2 = repr row2.row_more in - if rm1 == rm2 then () else - let may_inst = - is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - let r1, r2 = - if row2.row_closed then - filter_row_fields may_inst r1, filter_row_fields false r2 - else r1, r2 - in - if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) - then raise (Unify []); - begin match rm1.desc, rm2.desc with - Tunivar _, Tunivar _ -> - unify_univar rm1 rm2 !univar_pairs - | Tunivar _, _ | _, Tunivar _ -> - raise (Unify []) - | _ when static_row row1 -> () - | _ when may_inst -> + if rm1 == rm2 then () + else + let may_inst = + (is_Tvar rm1 && may_instantiate inst_nongen rm1) || rm1.desc = Tnil + in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let r1, r2 = + if row2.row_closed then + (filter_row_fields may_inst r1, filter_row_fields false r2) + else (r1, r2) + in + if r1 <> [] || (row1.row_closed && ((not row2.row_closed) || r2 <> [])) then + raise (Unify []); + (match (rm1.desc, rm2.desc) with + | Tunivar _, Tunivar _ -> unify_univar rm1 rm2 !univar_pairs + | Tunivar _, _ | _, Tunivar _ -> raise (Unify []) + | _ when static_row row1 -> () + | _ when may_inst -> let ext = newgenty (Tvariant {row2 with row_fields = r2; row_name = None}) in moregen_occur env rm1.level ext; link_type rm1 ext - | Tconstr _, Tconstr _ -> - moregen inst_nongen type_pairs env rm1 rm2 - | _ -> raise (Unify []) - end; - List.iter - (fun (_l,f1,f2) -> - let f1 = row_field_repr f1 and f2 = row_field_repr f2 in - if f1 == f2 then () else - match f1, f2 with - Rpresent(Some t1), Rpresent(Some t2) -> - moregen inst_nongen type_pairs env t1 t2 - | Rpresent None, Rpresent None -> () - | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> - set_row_field e1 f2; - List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 - | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> - if e1 != e2 then begin - if c1 && not c2 then raise(Unify []); - set_row_field e1 (Reither (c2, [], m2, e2)); - if List.length tl1 = List.length tl2 then - List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 - else match tl2 with - t2 :: _ -> - List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) - tl1 - | [] -> - if tl1 <> [] then raise (Unify []) - end - | Reither(true, [], _, e1), Rpresent None when may_inst -> - set_row_field e1 f2 - | Reither(_, _, _, e1), Rabsent when may_inst -> - set_row_field e1 f2 - | Rabsent, Rabsent -> () - | _ -> raise (Unify [])) - pairs + | Tconstr _, Tconstr _ -> moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise (Unify [])); + List.iter + (fun (_l, f1, f2) -> + let f1 = row_field_repr f1 and f2 = row_field_repr f2 in + if f1 == f2 then () + else + match (f1, f2) with + | Rpresent (Some t1), Rpresent (Some t2) -> + moregen inst_nongen type_pairs env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither (false, tl1, _, e1), Rpresent (Some t2) when may_inst -> + set_row_field e1 f2; + List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 + | Reither (c1, tl1, _, e1), Reither (c2, tl2, m2, e2) -> + if e1 != e2 then ( + if c1 && not c2 then raise (Unify []); + set_row_field e1 (Reither (c2, [], m2, e2)); + if List.length tl1 = List.length tl2 then + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + else + match tl2 with + | t2 :: _ -> + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + | [] -> if tl1 <> [] then raise (Unify [])) + | Reither (true, [], _, e1), Rpresent None when may_inst -> + set_row_field e1 f2 + | Reither (_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2 + | Rabsent, Rabsent -> () + | _ -> raise (Unify [])) + pairs (* Must empty univar_pairs first *) let moregen inst_nongen type_pairs env patt subj = @@ -3036,38 +3032,37 @@ let moregeneral env inst_nongen pat_sch subj_sch = (* Duplicate generic variables *) let patt = instance env pat_sch in let res = - try moregen inst_nongen (TypePairs.create 13) env patt subj; true with - Unify _ -> false + try + moregen inst_nongen (TypePairs.create 13) env patt subj; + true + with Unify _ -> false in current_level := old_level; res - (* Alternative approach: "rigidify" a type scheme, and check validity after unification *) (* Simpler, no? *) let rec rigidify_rec vars ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; match ty.desc with - | Tvar _ -> - if not (List.memq ty !vars) then vars := ty :: !vars + | Tvar _ -> if not (List.memq ty !vars) then vars := ty :: !vars | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in - if is_Tvar more && not (row_fixed row) then begin - let more' = newty2 more.level more.desc in - let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} - in link_type more (newty2 ty.level (Tvariant row')) - end; - iter_row (rigidify_rec vars) row; - (* only consider the row variable if the variant is not static *) - if not (static_row row) then rigidify_rec vars (row_more row) - | _ -> - iter_type_expr (rigidify_rec vars) ty - end + let row = row_repr row in + let more = repr row.row_more in + (if is_Tvar more && not (row_fixed row) then + let more' = newty2 more.level more.desc in + let row' = + {row with row_fixed = true; row_fields = []; row_more = more'} + in + link_type more (newty2 ty.level (Tvariant row'))); + iter_row (rigidify_rec vars) row; + (* only consider the row variable if the variant is not static *) + if not (static_row row) then rigidify_rec vars (row_more row) + | _ -> iter_type_expr (rigidify_rec vars) ty) let rigidify ty = let vars = ref [] in @@ -3080,8 +3075,10 @@ let all_distinct_vars env vars = List.for_all (fun ty -> let ty = expand_head env ty in - if List.memq ty !tyl then false else - (tyl := ty :: !tyl; is_Tvar ty)) + if List.memq ty !tyl then false + else ( + tyl := ty :: !tyl; + is_Tvar ty)) vars let matches env ty ty' = @@ -3089,197 +3086,204 @@ let matches env ty ty' = let vars = rigidify ty in cleanup_abbrev (); let ok = - try unify env ty ty'; all_distinct_vars env vars + try + unify env ty ty'; + all_distinct_vars env vars with Unify _ -> false in backtrack snap; ok - - (*********************************************) - (* Equivalence between parameterized types *) - (*********************************************) +(*********************************************) +(* Equivalence between parameterized types *) +(*********************************************) let expand_head_rigid env ty = let old = !rigid_variants in rigid_variants := true; let ty' = expand_head env ty in - rigid_variants := old; ty' + rigid_variants := old; + ty' let normalize_subst subst = - if List.exists - (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) + if + List.exists + (function + | {desc = Tlink _}, _ | _, {desc = Tlink _} -> true + | _ -> false) !subst - then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst + then subst := List.map (fun (t1, t2) -> (repr t1, repr t2)) !subst let rec eqtype rename type_pairs subst env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - - try - match (t1.desc, t2.desc) with - (Tvar _, Tvar _) when rename -> - begin try - normalize_subst subst; - if List.assq t1 !subst != t2 then raise (Unify []) - with Not_found -> - if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); - subst := (t1, t2) :: !subst - end - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head_rigid env t1 in - let t2' = expand_head_rigid env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try - TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, Tvar _) when rename -> - begin try - normalize_subst subst; - if List.assq t1' !subst != t2' then raise (Unify []) - with Not_found -> - if List.exists (fun (_, t) -> t == t2') !subst - then raise (Unify []); - subst := (t1', t2') :: !subst - end - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when Asttypes.same_arg_label l1 l2 - -> - eqtype rename type_pairs subst env t1 t2; - eqtype rename type_pairs subst env u1 u2; - | (Ttuple tl1, Ttuple tl2) -> - eqtype_list rename type_pairs subst env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) - when Path.same p1 p2 -> - eqtype_list rename type_pairs subst env tl1 tl2 - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> - begin try - unify_package env (eqtype_list rename type_pairs subst env) - t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 - with Not_found -> raise (Unify []) - end - | (Tvariant row1, Tvariant row2) -> - eqtype_row rename type_pairs subst env row1 row2 - | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> - eqtype_fields rename type_pairs subst env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - eqtype_fields rename type_pairs subst env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - eqtype rename type_pairs subst env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (eqtype rename type_pairs subst env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end - with Unify trace -> - raise (Unify ((t1, t2)::trace)) + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then () + else + try + match (t1.desc, t2.desc) with + | Tvar _, Tvar _ when rename -> ( + try + normalize_subst subst; + if List.assq t1 !subst != t2 then raise (Unify []) + with Not_found -> + if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); + subst := (t1, t2) :: !subst) + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> () + | _ -> ( + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () + else + try TypePairs.find type_pairs (t1', t2') + with Not_found -> ( + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + | Tvar _, Tvar _ when rename -> ( + try + normalize_subst subst; + if List.assq t1' !subst != t2' then raise (Unify []) + with Not_found -> + if List.exists (fun (_, t) -> t == t2') !subst then + raise (Unify []); + subst := (t1', t2') :: !subst) + | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + when Asttypes.same_arg_label l1 l2 -> + eqtype rename type_pairs subst env t1 t2; + eqtype rename type_pairs subst env u1 u2 + | Ttuple tl1, Ttuple tl2 -> + eqtype_list rename type_pairs subst env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 + -> + eqtype_list rename type_pairs subst env tl1 tl2 + | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( + try + unify_package env + (eqtype_list rename type_pairs subst env) + t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 + with Not_found -> raise (Unify [])) + | Tvariant row1, Tvariant row2 -> + eqtype_row rename type_pairs subst env row1 row2 + | Tobject (fi1, _nm1), Tobject (fi2, _nm2) -> + eqtype_fields rename type_pairs subst env fi1 fi2 + | Tfield _, Tfield _ -> + (* Actually unused *) + eqtype_fields rename type_pairs subst env t1' t2' + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> + eqtype rename type_pairs subst env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (eqtype rename type_pairs subst env) + | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | _, _ -> raise (Unify []))) + with Unify trace -> raise (Unify ((t1, t2) :: trace)) and eqtype_list rename type_pairs subst env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); + if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = - let (fields1, rest1) = flatten_fields ty1 in - let (fields2, rest2) = flatten_fields ty2 in + let fields1, rest1 = flatten_fields ty1 in + let fields2, rest2 = flatten_fields ty2 in (* First check if same row => already equal *) let same_row = - rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) || - (rename && List.mem (rest1, rest2) !subst) + rest1 == rest2 + || TypePairs.mem type_pairs (rest1, rest2) + || (rename && List.mem (rest1, rest2) !subst) in - if same_row then () else - (* Try expansion, needed when called from Includecore.type_manifest *) - match expand_head_rigid env rest2 with - {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 - | _ -> - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - eqtype rename type_pairs subst env rest1 rest2; - if (miss1 <> []) || (miss2 <> []) then raise (Unify []); - List.iter - (function (n, k1, t1, k2, t2) -> - eqtype_kind k1 k2; - try eqtype rename type_pairs subst env t1 t2 with Unify trace -> - raise (Unify ((newty (Tfield(n, k1, t1, rest2)), - newty (Tfield(n, k2, t2, rest2)))::trace))) - pairs + if same_row then () + else + (* Try expansion, needed when called from Includecore.type_manifest *) + match expand_head_rigid env rest2 with + | {desc = Tobject (ty2, _)} -> + eqtype_fields rename type_pairs subst env ty1 ty2 + | _ -> + let pairs, miss1, miss2 = associate_fields fields1 fields2 in + eqtype rename type_pairs subst env rest1 rest2; + if miss1 <> [] || miss2 <> [] then raise (Unify []); + List.iter + (function + | n, k1, t1, k2, t2 -> ( + eqtype_kind k1 k2; + try eqtype rename type_pairs subst env t1 t2 + with Unify trace -> + raise + (Unify + (( newty (Tfield (n, k1, t1, rest2)), + newty (Tfield (n, k2, t2, rest2)) ) + :: trace)))) + pairs and eqtype_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in - match k1, k2 with - (Fvar _, Fvar _) - | (Fpresent, Fpresent) -> () - | _ -> raise (Unify []) + match (k1, k2) with + | Fvar _, Fvar _ | Fpresent, Fpresent -> () + | _ -> raise (Unify []) and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) match expand_head_rigid env (row_more row2) with - {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 + | {desc = Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 | _ -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - if row1.row_closed <> row2.row_closed - || not row1.row_closed && (r1 <> [] || r2 <> []) - || filter_row_fields false (r1 @ r2) <> [] - then raise (Unify []); - if not (static_row row1) then - eqtype rename type_pairs subst env row1.row_more row2.row_more; - List.iter - (fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent(Some t1), Rpresent(Some t2) -> + let row1 = row_repr row1 and row2 = row_repr row2 in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + if + row1.row_closed <> row2.row_closed + || ((not row1.row_closed) && (r1 <> [] || r2 <> [])) + || filter_row_fields false (r1 @ r2) <> [] + then raise (Unify []); + if not (static_row row1) then + eqtype rename type_pairs subst env row1.row_more row2.row_more; + List.iter + (fun (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | Rpresent (Some t1), Rpresent (Some t2) -> eqtype rename type_pairs subst env t1 t2 - | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 -> - () - | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 -> + | Reither (c1, [], _, _), Reither (c2, [], _, _) when c1 = c2 -> () + | Reither (c1, t1 :: tl1, _, _), Reither (c2, t2 :: tl2, _, _) + when c1 = c2 -> eqtype rename type_pairs subst env t1 t2; if List.length tl1 = List.length tl2 then (* if same length allow different types (meaning?) *) List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 - else begin + else ( (* otherwise everything must be equal *) List.iter (eqtype rename type_pairs subst env t1) tl2; - List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 - end - | Rpresent None, Rpresent None -> () - | Rabsent, Rabsent -> () - | _ -> raise (Unify [])) - pairs + List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1) + | Rpresent None, Rpresent None -> () + | Rabsent, Rabsent -> () + | _ -> raise (Unify [])) + pairs (* Must empty univar_pairs first *) let eqtype_list rename type_pairs subst env tl1 tl2 = univar_pairs := []; let snap = Btype.snapshot () in - try eqtype_list rename type_pairs subst env tl1 tl2; backtrack snap - with exn -> backtrack snap; raise exn + try + eqtype_list rename type_pairs subst env tl1 tl2; + backtrack snap + with exn -> + backtrack snap; + raise exn (* Two modes: with or without renaming of variables *) let equal env rename tyl1 tyl2 = try - eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true - with - Unify _ -> false - - - (*************************) - (* Class type matching *) - (*************************) + eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; + true + with Unify _ -> false +(*************************) +(* Class type matching *) +(*************************) type class_match_failure = - CM_Virtual_class + | CM_Virtual_class | CM_Parameter_arity_mismatch of int * int | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list @@ -3295,13 +3299,9 @@ type class_match_failure = | CM_Private_method of string | CM_Virtual_method of string - - - - (***************) - (* Subtyping *) - (***************) - +(***************) +(* Subtyping *) +(***************) (**** Build a subtype of a given type. ****) @@ -3312,70 +3312,69 @@ type class_match_failure = [posi] true if the current variance is positive [level] number of expansions/enlargement allowed on this branch *) -let warn = ref false (* whether double coercion might do better *) +let warn = ref false (* whether double coercion might do better *) let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n let pred_enlarge n = if n mod 2 = 1 then pred n else n type change = Unchanged | Equiv | Changed [@@immediate] -let [@inline] max (c1:change) (c2 :change)= - (Obj.magic (Ext_pervasives.max_int (Obj.magic c1 : int) (Obj.magic c2 : int)) : change) +let[@inline] max (c1 : change) (c2 : change) : change = + Obj.magic (Ext_pervasives.max_int (Obj.magic c1 : int) (Obj.magic c2 : int)) let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l let rec filter_visited = function - [] -> [] - | {desc=Tobject _|Tvariant _} :: _ as l -> l + | [] -> [] + | {desc = Tobject _ | Tvariant _} :: _ as l -> l | _ :: l -> filter_visited l let memq_warn t visited = - if List.memq t visited then (warn := true; true) else false - -let rec lid_of_path ?(hash="") = function - Path.Pident id -> - Longident.Lident (hash ^ Ident.name id) - | Path.Pdot (p1, s, _) -> - Longident.Ldot (lid_of_path p1, hash ^ s) + if List.memq t visited then ( + warn := true; + true) + else false + +let rec lid_of_path ?(hash = "") = function + | Path.Pident id -> Longident.Lident (hash ^ Ident.name id) + | Path.Pdot (p1, s, _) -> Longident.Ldot (lid_of_path p1, hash ^ s) | Path.Papply (p1, p2) -> - Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2) + Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2) let find_cltype_for_path env p = let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in let cl_abbr = Env.find_type cl_path env in match cl_abbr.type_manifest with - Some ty -> - begin match (repr ty).desc with - Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty - | _ -> raise Not_found - end + | Some ty -> ( + match (repr ty).desc with + | Tobject (_, {contents = Some (p', _)}) when Path.same p p' -> (cl_abbr, ty) + | _ -> raise Not_found) | None -> assert false -let has_constr_row' env t = - has_constr_row (expand_abbrev env t) +let has_constr_row' env t = has_constr_row (expand_abbrev env t) let rec build_subtype env visited loops posi level t = let t = repr t in match t.desc with - Tvar _ -> - if posi then - try - let t' = List.assq t loops in - warn := true; - (t', Equiv) - with Not_found -> - (t, Unchanged) - else - (t, Unchanged) - | Tarrow(l, t1, t2, _) -> - if memq_warn t visited then (t, Unchanged) else + | Tvar _ -> + if posi then + try + let t' = List.assq t loops in + warn := true; + (t', Equiv) + with Not_found -> (t, Unchanged) + else (t, Unchanged) + | Tarrow (l, t1, t2, _) -> + if memq_warn t visited then (t, Unchanged) + else let visited = t :: visited in - let (t1', c1) = build_subtype env visited loops (not posi) level t1 in - let (t2', c2) = build_subtype env visited loops posi level t2 in + let t1', c1 = build_subtype env visited loops (not posi) level t1 in + let t2', c2 = build_subtype env visited loops posi level t2 in let c = max c1 c2 in - if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c) + if c > Unchanged then (newty (Tarrow (l, t1', t2', Cok)), c) else (t, Unchanged) | Ttuple tlist -> - if memq_warn t visited then (t, Unchanged) else + if memq_warn t visited then (t, Unchanged) + else let visited = t :: visited in let tlist' = List.map (build_subtype env visited loops posi level) tlist @@ -3383,141 +3382,148 @@ let rec build_subtype env visited loops posi level t = let c = collect tlist' in if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) else (t, Unchanged) - | Tconstr(p, tl, abbrev) + | Tconstr (p, tl, abbrev) when level > 0 && generic_abbrev env p && safe_abbrev env t - && not (has_constr_row' env t) -> - let t' = repr (expand_abbrev env t) in - let level' = pred_expand level in - begin try match t'.desc with - Tobject _ when posi && not (opened_object t') -> - let cl_abbr, body = find_cltype_for_path env p in - let ty = - subst env !current_level Public abbrev None - cl_abbr.type_params tl body in - let ty = repr ty in - let ty1, tl1 = - match ty.desc with - Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> - ty1, tl1 - | _ -> raise Not_found - in - (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, - as this occurrence might break the occur check. - XXX not clear whether this correct anyway... *) - if List.exists (deep_occur ty) tl1 then raise Not_found; - ty.desc <- Tvar None; - let t'' = newvar () in - let loops = (ty, t'') :: loops in - (* May discard [visited] as level is going down *) - let (ty1', c) = - build_subtype env [t'] loops posi (pred_enlarge level') ty1 in - assert (is_Tvar t''); - let nm = - if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in - t''.desc <- Tobject (ty1', ref nm); - (try unify_var env ty t with Unify _ -> assert false); - (t'', Changed) + && not (has_constr_row' env t) -> ( + let t' = repr (expand_abbrev env t) in + let level' = pred_expand level in + try + match t'.desc with + | Tobject _ when posi && not (opened_object t') -> + let cl_abbr, body = find_cltype_for_path env p in + let ty = + subst env !current_level Public abbrev None cl_abbr.type_params tl + body + in + let ty = repr ty in + let ty1, tl1 = + match ty.desc with + | Tobject (ty1, {contents = Some (p', tl1)}) when Path.same p p' -> + (ty1, tl1) + | _ -> raise Not_found + in + (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, + as this occurrence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; + ty.desc <- Tvar None; + let t'' = newvar () in + let loops = (ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let ty1', c = + build_subtype env [t'] loops posi (pred_enlarge level') ty1 + in + assert (is_Tvar t''); + let nm = + if c > Equiv || deep_occur ty ty1' then None else Some (p, tl1) + in + t''.desc <- Tobject (ty1', ref nm); + (try unify_var env ty t with Unify _ -> assert false); + (t'', Changed) | _ -> raise Not_found - with Not_found -> - let (t'',c) = build_subtype env visited loops posi level' t' in - if c > Unchanged then (t'',c) - else (t, Unchanged) - end - | Tconstr(p, tl, _abbrev) -> + with Not_found -> + let t'', c = build_subtype env visited loops posi level' t' in + if c > Unchanged then (t'', c) else (t, Unchanged)) + | Tconstr (p, tl, _abbrev) -> ( + if (* Must check recursion on constructors, since we do not always expand them *) - if memq_warn t visited then (t, Unchanged) else + memq_warn t visited + then (t, Unchanged) + else let visited = t :: visited in - begin try + try let decl = Env.find_type p env in - if level = 0 && generic_abbrev env p && safe_abbrev env t - && not (has_constr_row' env t) + if + level = 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) then warn := true; let tl' = List.map2 (fun v t -> - let (co,cn) = Variance.get_upper v in + let co, cn = Variance.get_upper v in if cn then if co then (t, Unchanged) else build_subtype env visited loops (not posi) level t - else - if co then build_subtype env visited loops posi level t - else (newvar(), Changed)) + else if co then build_subtype env visited loops posi level t + else (newvar (), Changed)) decl.type_variance tl in let c = collect tl' in if c > Unchanged then (newconstr p (List.map fst tl'), c) else (t, Unchanged) - with Not_found -> - (t, Unchanged) - end + with Not_found -> (t, Unchanged)) | Tvariant row -> - let row = row_repr row in - if memq_warn t visited || not (static_row row) then (t, Unchanged) else + let row = row_repr row in + if memq_warn t visited || not (static_row row) then (t, Unchanged) + else let level' = pred_enlarge level in let visited = - t :: if level' < level then [] else filter_visited visited in + t :: (if level' < level then [] else filter_visited visited) + in let fields = filter_row_fields false row.row_fields in let fields = List.map - (fun (l,f as orig) -> match row_field_repr f with - Rpresent None -> - if posi then - (l, Reither(true, [], false, ref None)), Unchanged - else - orig, Unchanged - | Rpresent(Some t) -> - let (t', c) = build_subtype env visited loops posi level' t in + (fun ((l, f) as orig) -> + match row_field_repr f with + | Rpresent None -> + if posi then ((l, Reither (true, [], false, ref None)), Unchanged) + else (orig, Unchanged) + | Rpresent (Some t) -> + let t', c = build_subtype env visited loops posi level' t in let f = - if posi && level > 0 - then Reither(false, [t'], false, ref None) - else Rpresent(Some t') - in (l, f), c - | _ -> assert false) + if posi && level > 0 then Reither (false, [t'], false, ref None) + else Rpresent (Some t') + in + ((l, f), c) + | _ -> assert false) fields in let c = collect fields in let row = - { row_fields = List.map fst fields; row_more = newvar(); - row_bound = (); row_closed = posi; row_fixed = false; - row_name = if c > Unchanged then None else row.row_name } + { + row_fields = List.map fst fields; + row_more = newvar (); + row_bound = (); + row_closed = posi; + row_fixed = false; + row_name = (if c > Unchanged then None else row.row_name); + } in (newty (Tvariant row), Changed) | Tobject (t1, _) -> - if memq_warn t visited || opened_object t1 then (t, Unchanged) else + if memq_warn t visited || opened_object t1 then (t, Unchanged) + else let level' = pred_enlarge level in let visited = - t :: if level' < level then [] else filter_visited visited in - let (t1', c) = build_subtype env visited loops posi level' t1 in + t :: (if level' < level then [] else filter_visited visited) + in + let t1', c = build_subtype env visited loops posi level' t1 in if c > Unchanged then (newty (Tobject (t1', ref None)), c) else (t, Unchanged) - | Tfield(s, _, t1, t2) (* Always present *) -> - let (t1', c1) = build_subtype env visited loops posi level t1 in - let (t2', c2) = build_subtype env visited loops posi level t2 in - let c = max c1 c2 in - if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c) - else (t, Unchanged) + | Tfield (s, _, t1, t2) (* Always present *) -> + let t1', c1 = build_subtype env visited loops posi level t1 in + let t2', c2 = build_subtype env visited loops posi level t2 in + let c = max c1 c2 in + if c > Unchanged then (newty (Tfield (s, Fpresent, t1', t2')), c) + else (t, Unchanged) | Tnil -> - if posi then - let v = newvar () in - (v, Changed) - else begin - warn := true; - (t, Unchanged) - end - | Tsubst _ | Tlink _ -> - assert false - | Tpoly(t1, tl) -> - let (t1', c) = build_subtype env visited loops posi level t1 in - if c > Unchanged then (newty (Tpoly(t1', tl)), c) - else (t, Unchanged) - | Tunivar _ | Tpackage _ -> - (t, Unchanged) + if posi then + let v = newvar () in + (v, Changed) + else ( + warn := true; + (t, Unchanged)) + | Tsubst _ | Tlink _ -> assert false + | Tpoly (t1, tl) -> + let t1', c = build_subtype env visited loops posi level t1 in + if c > Unchanged then (newty (Tpoly (t1', tl)), c) else (t, Unchanged) + | Tunivar _ | Tpackage _ -> (t, Unchanged) let enlarge_type env ty = warn := false; (* [level = 4] allows 2 expansions involving objects/variants *) - let (ty', _) = build_subtype env [] [] true 4 ty in + let ty', _ = build_subtype env [] [] true 4 ty in (ty', !warn) (**** Check whether a type is a subtype of another type. ****) @@ -3541,287 +3547,328 @@ let subtypes = TypePairs.create 17 let subtype_error env trace = raise (Subtype (expand_trace env (List.rev trace), [])) -let extract_concrete_typedecl_opt env t = - match extract_concrete_typedecl env t with - | v -> Some v +let extract_concrete_typedecl_opt env t = + match extract_concrete_typedecl env t with + | v -> Some v | exception Not_found -> None let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in - if t1 == t2 then cstrs else - - begin try - TypePairs.find subtypes (t1, t2); - cstrs - with Not_found -> - TypePairs.add subtypes (t1, t2) (); - match (t1.desc, t2.desc) with - (Tvar _, _) | (_, Tvar _) -> - (trace, t1, t2, !univar_pairs)::cstrs - | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when Asttypes.same_arg_label l1 l2 - -> - let cstrs = subtype_rec env ((t2, t1)::trace) t2 t1 cstrs in - subtype_rec env ((u1, u2)::trace) u1 u2 cstrs - | (Ttuple tl1, Ttuple tl2) -> - subtype_list env trace tl1 tl2 cstrs - | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> - cstrs - | (Tconstr(p1, _tl1, _abbrev1), _) - when generic_abbrev env p1 && safe_abbrev env t1 -> + if t1 == t2 then cstrs + else + try + TypePairs.find subtypes (t1, t2); + cstrs + with Not_found -> ( + TypePairs.add subtypes (t1, t2) (); + match (t1.desc, t2.desc) with + | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs) :: cstrs + | Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _) + when Asttypes.same_arg_label l1 l2 -> + let cstrs = subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs in + subtype_rec env ((u1, u2) :: trace) u1 u2 cstrs + | Ttuple tl1, Ttuple tl2 -> subtype_list env trace tl1 tl2 cstrs + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> cstrs + | Tconstr (p1, _tl1, _abbrev1), _ + when generic_abbrev env p1 && safe_abbrev env t1 -> subtype_rec env trace (expand_abbrev env t1) t2 cstrs - | (_, Tconstr(p2, _tl2, _abbrev2)) - when generic_abbrev env p2 && safe_abbrev env t2 -> + | _, Tconstr (p2, _tl2, _abbrev2) + when generic_abbrev env p2 && safe_abbrev env t2 -> subtype_rec env trace t1 (expand_abbrev env t2) cstrs - | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 -> - begin try + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 -> ( + try let decl = Env.find_type p1 env in List.fold_left2 (fun cstrs v (t1, t2) -> - let (co, cn) = Variance.get_upper v in + let co, cn = Variance.get_upper v in if co then if cn then (* Invariant type argument: check both ways *) if - subtype_rec env ((t1, t2)::trace) t1 t2 [] = [] && - subtype_rec env ((t2, t1)::trace) t2 t1 [] = [] then - cstrs + subtype_rec env ((t1, t2) :: trace) t1 t2 [] = [] + && subtype_rec env ((t2, t1) :: trace) t2 t1 [] = [] + then cstrs else - (trace, newty2 t1.level (Ttuple[t1]), - newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs - else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - else - if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs - else cstrs) + ( trace, + newty2 t1.level (Ttuple [t1]), + newty2 t2.level (Ttuple [t2]), + !univar_pairs ) + :: cstrs + else subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + else if cn then subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs + else cstrs) cstrs decl.type_variance (List.combine tl1 tl2) - with Not_found -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 -> + with Not_found -> (trace, t1, t2, !univar_pairs) :: cstrs) + | Tconstr (p1, _, _), _ when generic_private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs - | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float -> - cstrs - | (Tconstr(path, [], _), Tconstr(_, [], _)) when Variant_coercion.can_coerce_primitive path && - extract_concrete_typedecl_opt env t2 |> Variant_coercion.can_try_coerce_variant_to_primitive_opt |> Option.is_some - -> - (* type coercion for primitives (int/float/string) to elgible unboxed variants: - - must be unboxed - - must have a constructor case with a supported and matching primitive payload *) - (match Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with - | Some (constructors, true) -> - if Variant_coercion.variant_has_catch_all_case constructors (fun p -> Path.same p path) then - cstrs - else - (trace, t1, t2, !univar_pairs)::cstrs - | _ -> (trace, t1, t2, !univar_pairs)::cstrs) - | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_primitive path && - extract_concrete_typedecl_opt env t1 |> Variant_coercion.can_try_coerce_variant_to_primitive_opt |> Option.is_some - -> - (* type coercion for variants to primitives *) - (match Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with - | Some (constructors, unboxed) -> - if constructors |> Variant_coercion.variant_has_same_runtime_representation_as_target ~target_path:path ~unboxed then - cstrs - else - (trace, t1, t2, !univar_pairs)::cstrs - | None -> (trace, t1, t2, !univar_pairs)::cstrs) - | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for variants and records *) - (match extract_concrete_typedecl env t1, extract_concrete_typedecl env t2 with - | (_, _, {type_kind=Type_variant (c1); type_attributes=t1attrs}), (_, _, {type_kind=Type_variant (c2); type_attributes=t2attrs}) -> - if - Variant_coercion.variant_configuration_can_be_coerced t1attrs t2attrs = false - then - (trace, t1, t2, !univar_pairs)::cstrs - else - let c1_len = List.length c1 in - if c1_len > List.length c2 then (trace, t1, t2, !univar_pairs)::cstrs - else - let constructor_map = Hashtbl.create c1_len in - c2 - |> List.iter (fun (c : Types.constructor_declaration) -> - Hashtbl.add constructor_map (Ident.name c.cd_id) c); - if c1 |> List.for_all (fun (c : Types.constructor_declaration) -> - match (c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id)) with - | ( {Types.cd_args = Cstr_record fields1; cd_attributes=c1_attributes}, - Some {Types.cd_args = Cstr_record fields2; cd_attributes=c2_attributes} ) -> - if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then - let violation, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in - if violation then false - else - begin try - let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs - with | _ -> false end - else false - | ( {Types.cd_args = Cstr_tuple tl1; cd_attributes=c1_attributes}, - Some {Types.cd_args = Cstr_tuple tl2; cd_attributes=c2_attributes} ) -> - if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then - begin try - let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs - with | _ -> false end - else false - | _ -> false) - then cstrs - else (trace, t1, t2, !univar_pairs)::cstrs - | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) -> - let same_repr = match repr1, repr2 with - | (Record_regular | Record_optional_labels _), (Record_regular | Record_optional_labels _) -> - true (* handled in the fields checks *) - | Record_unboxed b1, Record_unboxed b2 -> b1 = b2 - | Record_inlined _, Record_inlined _ -> repr1 = repr2 - | Record_extension, Record_extension -> true - | _ -> false in - if same_repr then - let violation, tl1, tl2 = Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 in - if violation - then (trace, t1, t2, !univar_pairs)::cstrs + | Tconstr (p1, [], _), Tconstr (p2, [], _) + when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float -> + cstrs + | Tconstr (path, [], _), Tconstr (_, [], _) + when Variant_coercion.can_coerce_primitive path + && extract_concrete_typedecl_opt env t2 + |> Variant_coercion.can_try_coerce_variant_to_primitive_opt + |> Option.is_some -> ( + (* type coercion for primitives (int/float/string) to elgible unboxed variants: + - must be unboxed + - must have a constructor case with a supported and matching primitive payload *) + match + Variant_coercion.can_try_coerce_variant_to_primitive_opt + (extract_concrete_typedecl_opt env t2) + with + | Some (constructors, true) -> + if + Variant_coercion.variant_has_catch_all_case constructors (fun p -> + Path.same p path) + then cstrs + else (trace, t1, t2, !univar_pairs) :: cstrs + | _ -> (trace, t1, t2, !univar_pairs) :: cstrs) + | Tconstr (_, [], _), Tconstr (path, [], _) + when Variant_coercion.can_coerce_primitive path + && extract_concrete_typedecl_opt env t1 + |> Variant_coercion.can_try_coerce_variant_to_primitive_opt + |> Option.is_some -> ( + (* type coercion for variants to primitives *) + match + Variant_coercion.can_try_coerce_variant_to_primitive_opt + (extract_concrete_typedecl_opt env t1) + with + | Some (constructors, unboxed) -> + if + constructors + |> Variant_coercion + .variant_has_same_runtime_representation_as_target + ~target_path:path ~unboxed + then cstrs + else (trace, t1, t2, !univar_pairs) :: cstrs + | None -> (trace, t1, t2, !univar_pairs) :: cstrs) + | Tconstr (_, [], _), Tconstr (_, [], _) -> ( + (* type coercion for variants and records *) + match + (extract_concrete_typedecl env t1, extract_concrete_typedecl env t2) + with + | ( (_, _, {type_kind = Type_variant c1; type_attributes = t1attrs}), + (_, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) ) + -> + if + Variant_coercion.variant_configuration_can_be_coerced t1attrs + t2attrs + = false + then (trace, t1, t2, !univar_pairs) :: cstrs else - subtype_list env trace tl1 tl2 cstrs - else - (trace, t1, t2, !univar_pairs)::cstrs - | _ -> (trace, t1, t2, !univar_pairs)::cstrs - | exception Not_found -> (trace, t1, t2, !univar_pairs)::cstrs - ) - (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> - subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) - | (Tobject (f1, _), Tobject (f2, _)) - when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> + let c1_len = List.length c1 in + if c1_len > List.length c2 then + (trace, t1, t2, !univar_pairs) :: cstrs + else + let constructor_map = Hashtbl.create c1_len in + c2 + |> List.iter (fun (c : Types.constructor_declaration) -> + Hashtbl.add constructor_map (Ident.name c.cd_id) c); + if + c1 + |> List.for_all (fun (c : Types.constructor_declaration) -> + match + ( c, + Hashtbl.find_opt constructor_map (Ident.name c.cd_id) + ) + with + | ( { + Types.cd_args = Cstr_record fields1; + cd_attributes = c1_attributes; + }, + Some + { + Types.cd_args = Cstr_record fields2; + cd_attributes = c2_attributes; + } ) -> + if + Variant_coercion.variant_representation_matches + c1_attributes c2_attributes + then + let violation, tl1, tl2 = + Record_coercion.check_record_fields fields1 fields2 + in + if violation then false + else + try + let lst = subtype_list env trace tl1 tl2 cstrs in + List.length lst = List.length cstrs + with _ -> false + else false + | ( { + Types.cd_args = Cstr_tuple tl1; + cd_attributes = c1_attributes; + }, + Some + { + Types.cd_args = Cstr_tuple tl2; + cd_attributes = c2_attributes; + } ) -> + if + Variant_coercion.variant_representation_matches + c1_attributes c2_attributes + then + try + let lst = subtype_list env trace tl1 tl2 cstrs in + List.length lst = List.length cstrs + with _ -> false + else false + | _ -> false) + then cstrs + else (trace, t1, t2, !univar_pairs) :: cstrs + | ( (_, _, {type_kind = Type_record (fields1, repr1)}), + (_, _, {type_kind = Type_record (fields2, repr2)}) ) -> + let same_repr = + match (repr1, repr2) with + | ( (Record_regular | Record_optional_labels _), + (Record_regular | Record_optional_labels _) ) -> + true (* handled in the fields checks *) + | Record_unboxed b1, Record_unboxed b2 -> b1 = b2 + | Record_inlined _, Record_inlined _ -> repr1 = repr2 + | Record_extension, Record_extension -> true + | _ -> false + in + if same_repr then + let violation, tl1, tl2 = + Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 + in + if violation then (trace, t1, t2, !univar_pairs) :: cstrs + else subtype_list env trace tl1 tl2 cstrs + else (trace, t1, t2, !univar_pairs) :: cstrs + | _ -> (trace, t1, t2, !univar_pairs) :: cstrs + | exception Not_found -> (trace, t1, t2, !univar_pairs) :: cstrs) + (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> + subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) + | Tobject (f1, _), Tobject (f2, _) + when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> (* Same row variable implies same object. *) - (trace, t1, t2, !univar_pairs)::cstrs - | (Tobject (f1, _), Tobject (f2, _)) -> - subtype_fields env trace f1 f2 cstrs - | (Tvariant row1, Tvariant row2) -> - begin try - subtype_row env trace row1 row2 cstrs - with Exit -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (Tvariant {row_closed=true; row_fields}, Tconstr (_, [], _)) - when extract_concrete_typedecl_opt env t2 |> Variant_coercion.type_is_variant -> - (match extract_concrete_typedecl env t2 with - | (_, _, {type_kind=Type_variant variant_constructors; type_attributes}) -> - (match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_attributes with - | Ok _ -> cstrs - | Error _ -> (trace, t1, t2, !univar_pairs)::cstrs) - | _ -> (trace, t1, t2, !univar_pairs)::cstrs) - | Tvariant v, _ when - !variant_is_subtype env (row_repr v) t2 - -> - cstrs - | (Tpoly (u1, []), Tpoly (u2, [])) -> - subtype_rec env trace u1 u2 cstrs - | (Tpoly (u1, tl1), Tpoly (u2, [])) -> + (trace, t1, t2, !univar_pairs) :: cstrs + | Tobject (f1, _), Tobject (f2, _) -> subtype_fields env trace f1 f2 cstrs + | Tvariant row1, Tvariant row2 -> ( + try subtype_row env trace row1 row2 cstrs + with Exit -> (trace, t1, t2, !univar_pairs) :: cstrs) + | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _) + when extract_concrete_typedecl_opt env t2 + |> Variant_coercion.type_is_variant -> ( + match extract_concrete_typedecl env t2 with + | _, _, {type_kind = Type_variant variant_constructors; type_attributes} + -> ( + match + Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields + ~variant_constructors ~type_attributes + with + | Ok _ -> cstrs + | Error _ -> (trace, t1, t2, !univar_pairs) :: cstrs) + | _ -> (trace, t1, t2, !univar_pairs) :: cstrs) + | Tvariant v, _ when !variant_is_subtype env (row_repr v) t2 -> cstrs + | Tpoly (u1, []), Tpoly (u2, []) -> subtype_rec env trace u1 u2 cstrs + | Tpoly (u1, tl1), Tpoly (u2, []) -> let _, u1' = instance_poly false tl1 u1 in subtype_rec env trace u1' u2 cstrs - | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> - begin try - enter_poly env univar_pairs u1 tl1 u2 tl2 - (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) - with Unify _ -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) -> - begin try + | Tpoly (u1, tl1), Tpoly (u2, tl2) -> ( + try + enter_poly env univar_pairs u1 tl1 u2 tl2 (fun t1 t2 -> + subtype_rec env trace t1 t2 cstrs) + with Unify _ -> (trace, t1, t2, !univar_pairs) :: cstrs) + | Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2) -> ( + try let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1 - and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2 - ~allow_absent:true in + and ntl2 = + complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2 + ~allow_absent:true + in let cstrs' = List.map - (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs)) + (fun (n2, t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs)) ntl2 in if eq_package_path env p1 p2 then cstrs' @ cstrs - else begin + else (* need to check module subtyping *) let snap = Btype.snapshot () in try List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs'; - if !package_subtype env p1 nl1 tl1 p2 nl2 tl2 - then (Btype.backtrack snap; cstrs' @ cstrs) + if !package_subtype env p1 nl1 tl1 p2 nl2 tl2 then ( + Btype.backtrack snap; + cstrs' @ cstrs) else raise (Unify []) with Unify _ -> - Btype.backtrack snap; raise Not_found - end - with Not_found -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (_, _) -> - (trace, t1, t2, !univar_pairs)::cstrs - end + Btype.backtrack snap; + raise Not_found + with Not_found -> (trace, t1, t2, !univar_pairs) :: cstrs) + | _, _ -> (trace, t1, t2, !univar_pairs) :: cstrs) and subtype_list env trace tl1 tl2 cstrs = - if List.length tl1 <> List.length tl2 then - subtype_error env trace; + if List.length tl1 <> List.length tl2 then subtype_error env trace; List.fold_left2 - (fun cstrs t1 t2 -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) + (fun cstrs t1 t2 -> subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs) cstrs tl1 tl2 and subtype_fields env trace ty1 ty2 cstrs = (* Assume that either rest1 or rest2 is not Tvar *) - let (fields1, rest1) = flatten_fields ty1 in - let (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let fields1, rest1 = flatten_fields ty1 in + let fields2, rest2 = flatten_fields ty2 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in let cstrs = - if rest2.desc = Tnil then cstrs else - if miss1 = [] then - subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs + if rest2.desc = Tnil then cstrs + else if miss1 = [] then + subtype_rec env ((rest1, rest2) :: trace) rest1 rest2 cstrs else - (trace, build_fields (repr ty1).level miss1 rest1, rest2, - !univar_pairs) :: cstrs + (trace, build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs) + :: cstrs in let cstrs = - if miss2 = [] then cstrs else - (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()), - !univar_pairs) :: cstrs + if miss2 = [] then cstrs + else + ( trace, + rest1, + build_fields (repr ty2).level miss2 (newvar ()), + !univar_pairs ) + :: cstrs in List.fold_left (fun cstrs (_, _k1, t1, _k2, t2) -> (* These fields are always present *) - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs) cstrs pairs and subtype_row env trace row1 row2 cstrs = let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = - merge_row_fields row1.row_fields row2.row_fields in - let more1 = repr row1.row_more - and more2 = repr row2.row_more in - match more1.desc, more2.desc with - Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> - subtype_rec env ((more1,more2)::trace) more1 more2 cstrs - | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let more1 = repr row1.row_more and more2 = repr row2.row_more in + match (more1.desc, more2.desc) with + | Tconstr (p1, _, _), Tconstr (p2, _, _) when Path.same p1 p2 -> + subtype_rec env ((more1, more2) :: trace) more1 more2 cstrs + | (Tvar _ | Tconstr _ | Tnil), (Tvar _ | Tconstr _ | Tnil) when row1.row_closed && r1 = [] -> - List.fold_left - (fun cstrs (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - (Rpresent None|Reither(true,_,_,_)), Rpresent None -> - cstrs - | Rpresent(Some t1), Rpresent(Some t2) -> - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | Reither(false, t1::_, _, _), Rpresent(Some t2) -> - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | Rabsent, _ -> cstrs - | _ -> raise Exit) - cstrs pairs + List.fold_left + (fun cstrs (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | (Rpresent None | Reither (true, _, _, _)), Rpresent None -> cstrs + | Rpresent (Some t1), Rpresent (Some t2) -> + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + | Reither (false, t1 :: _, _, _), Rpresent (Some t2) -> + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs | Tunivar _, Tunivar _ when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> - let cstrs = - subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in - List.fold_left - (fun cstrs (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent None, Rpresent None - | Reither(true,[],_,_), Reither(true,[],_,_) - | Rabsent, Rabsent -> - cstrs - | Rpresent(Some t1), Rpresent(Some t2) - | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | _ -> raise Exit) - cstrs pairs - | _ -> - raise Exit + let cstrs = subtype_rec env ((more1, more2) :: trace) more1 more2 cstrs in + List.fold_left + (fun cstrs (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | Rpresent None, Rpresent None + | Reither (true, [], _, _), Reither (true, [], _, _) + | Rabsent, Rabsent -> + cstrs + | Rpresent (Some t1), Rpresent (Some t2) + | Reither (false, [t1], _, _), Reither (false, [t2], _, _) -> + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + | _ -> raise Exit) + cstrs pairs + | _ -> raise Exit let subtype env ty1 ty2 = TypePairs.clear subtypes; @@ -3830,52 +3877,48 @@ let subtype env ty1 ty2 = let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in TypePairs.clear subtypes; (* Enforce constraints. *) - function () -> + function + | () -> List.iter - (function (trace0, t1, t2, pairs) -> - try unify_pairs (ref env) t1 t2 pairs with Unify trace -> - raise (Subtype (expand_trace env (List.rev trace0), - List.tl (List.tl trace)))) + (function + | trace0, t1, t2, pairs -> ( + try unify_pairs (ref env) t1 t2 pairs + with Unify trace -> + raise + (Subtype + (expand_trace env (List.rev trace0), List.tl (List.tl trace))))) (List.rev cstrs) - (*******************) - (* Miscellaneous *) - (*******************) +(*******************) +(* Miscellaneous *) +(*******************) (* Utility for printing. The resulting type is not used in computation. *) let rec unalias_object ty = let ty = repr ty in match ty.desc with - Tfield (s, k, t1, t2) -> - newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) - | Tvar _ | Tnil -> - newty2 ty.level ty.desc - | Tunivar _ -> - ty - | Tconstr _ -> - newvar2 ty.level - | _ -> - assert false + | Tfield (s, k, t1, t2) -> + newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil -> newty2 ty.level ty.desc + | Tunivar _ -> ty + | Tconstr _ -> newvar2 ty.level + | _ -> assert false let unalias ty = let ty = repr ty in match ty.desc with - Tvar _ | Tunivar _ -> - ty + | Tvar _ | Tunivar _ -> ty | Tvariant row -> - let row = row_repr row in - let more = row.row_more in - newty2 ty.level - (Tvariant {row with row_more = newty2 more.level more.desc}) - | Tobject (ty, nm) -> - newty2 ty.level (Tobject (unalias_object ty, nm)) - | _ -> - newty2 ty.level ty.desc + let row = row_repr row in + let more = row.row_more in + newty2 ty.level (Tvariant {row with row_more = newty2 more.level more.desc}) + | Tobject (ty, nm) -> newty2 ty.level (Tobject (unalias_object ty, nm)) + | _ -> newty2 ty.level ty.desc (* Return the arity (as for curried functions) of the given type. *) let rec arity ty = match (repr ty).desc with - Tarrow(_, _t1, t2, _) -> 1 + arity t2 + | Tarrow (_, _t1, t2, _) -> 1 + arity t2 | _ -> 0 (* Check whether an abbreviation expands to itself. *) @@ -3883,17 +3926,18 @@ let cyclic_abbrev env id ty = let rec check_cycle seen ty = let ty = repr ty in match ty.desc with - Tconstr (p, _tl, _abbrev) -> - (match p with Path.Pident p -> Ident.same p id | _ -> false) || List.memq ty seen || - begin try - check_cycle (ty :: seen) (expand_abbrev_opt env ty) - with - Cannot_expand -> false - | Unify _ -> true - end - | _ -> - false - in check_cycle [] ty + | Tconstr (p, _tl, _abbrev) -> ( + (match p with + | Path.Pident p -> Ident.same p id + | _ -> false) + || List.memq ty seen + || + try check_cycle (ty :: seen) (expand_abbrev_opt env ty) with + | Cannot_expand -> false + | Unify _ -> true) + | _ -> false + in + check_cycle [] ty (* Check for non-generalizable type variables *) exception Non_closed0 @@ -3901,31 +3945,27 @@ let visited = ref TypeSet.empty let rec closed_schema_rec env ty = let ty = repr ty in - if TypeSet.mem ty !visited then () else begin + if TypeSet.mem ty !visited then () + else ( visited := TypeSet.add ty !visited; match ty.desc with - Tvar _ when ty.level <> generic_level -> - raise Non_closed0 - | Tconstr _ -> - let old = !visited in - begin try iter_type_expr (closed_schema_rec env) ty - with Non_closed0 -> try + | Tvar _ when ty.level <> generic_level -> raise Non_closed0 + | Tconstr _ -> ( + let old = !visited in + try iter_type_expr (closed_schema_rec env) ty + with Non_closed0 -> ( + try visited := old; closed_schema_rec env (try_expand_head try_expand_safe env ty) - with Cannot_expand -> - raise Non_closed0 - end - | Tfield(_, kind, t1, t2) -> - if field_kind_repr kind = Fpresent then - closed_schema_rec env t1; - closed_schema_rec env t2 + with Cannot_expand -> raise Non_closed0)) + | Tfield (_, kind, t1, t2) -> + if field_kind_repr kind = Fpresent then closed_schema_rec env t1; + closed_schema_rec env t2 | Tvariant row -> - let row = row_repr row in - iter_row (closed_schema_rec env) row; - if not (static_row row) then closed_schema_rec env row.row_more - | _ -> - iter_type_expr (closed_schema_rec env) ty - end + let row = row_repr row in + iter_row (closed_schema_rec env) row; + if not (static_row row) then closed_schema_rec env row.row_more + | _ -> iter_type_expr (closed_schema_rec env) ty) (* Return whether all variables of type [ty] are generic. *) let closed_schema env ty = @@ -3942,76 +3982,84 @@ let closed_schema env ty = (* Cannot use mark_type because deep_occur uses it too *) let rec normalize_type_rec env visited ty = let ty = repr ty in - if not (TypeSet.mem ty !visited) then begin + if not (TypeSet.mem ty !visited) then ( visited := TypeSet.add ty !visited; let tm = row_of_type ty in - begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then - match tm.desc with (* PR#7348 *) - Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) -> - let i' = String.sub i 0 (String.length i - 4) in - log_type ty; - ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil) - | _ -> assert false - else match ty.desc with - | Tvariant row -> - let row = row_repr row in - let fields = List.map - (fun (l,f0) -> - let f = row_field_repr f0 in l, - match f with Reither(b, ty::(_::_ as tyl), m, e) -> - let tyl' = - List.fold_left - (fun tyl ty -> - if List.exists (fun ty' -> equal env false [ty] [ty']) tyl - then tyl else ty::tyl) - [ty] tyl - in - if f != f0 || List.length tyl' < List.length tyl then - Reither(b, List.rev tyl', m, e) - else f - | _ -> f) - row.row_fields in - let fields = - List.sort (fun (p,_) (q,_) -> compare p q) - (Ext_list.filter fields (fun (_,fi) -> fi <> Rabsent)) in - log_type ty; - ty.desc <- Tvariant {row with row_fields = fields} - | Tobject (fi, nm) -> - begin match !nm with - | None -> () - | Some (n, v :: l) -> - if deep_occur ty (newgenty (Ttuple l)) then - (* The abbreviation may be hiding something, so remove it *) - set_name nm None - else let v' = repr v in - begin match v'.desc with - | Tvar _ | Tunivar _ -> - if v' != v then set_name nm (Some (n, v' :: l)) - | Tnil -> - log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) - | _ -> set_name nm None - end - | _ -> - fatal_error "Ctype.normalize_type_rec" - end; - let fi = repr fi in - if fi.level < lowest_level then () else - let fields, row = flatten_fields fi in - let fi' = build_fields fi.level fields row in - log_type ty; fi.desc <- fi'.desc - | _ -> () - end; - iter_type_expr (normalize_type_rec env visited) ty - end - -let normalize_type env ty = - normalize_type_rec env (ref TypeSet.empty) ty - - - (*************************) - (* Remove dependencies *) - (*************************) - + (if (not (is_Tconstr ty)) && is_constr_row ~allow_ident:false tm then + match tm.desc with + (* PR#7348 *) + | Tconstr (Path.Pdot (m, i, pos), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + log_type ty; + ty.desc <- Tconstr (Path.Pdot (m, i', pos), tl, ref Mnil) + | _ -> assert false + else + match ty.desc with + | Tvariant row -> + let row = row_repr row in + let fields = + List.map + (fun (l, f0) -> + let f = row_field_repr f0 in + ( l, + match f with + | Reither (b, ty :: (_ :: _ as tyl), m, e) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if + List.exists + (fun ty' -> equal env false [ty] [ty']) + tyl + then tyl + else ty :: tyl) + [ty] tyl + in + if f != f0 || List.length tyl' < List.length tyl then + Reither (b, List.rev tyl', m, e) + else f + | _ -> f )) + row.row_fields + in + let fields = + List.sort + (fun (p, _) (q, _) -> compare p q) + (Ext_list.filter fields (fun (_, fi) -> fi <> Rabsent)) + in + log_type ty; + ty.desc <- Tvariant {row with row_fields = fields} + | Tobject (fi, nm) -> + (match !nm with + | None -> () + | Some (n, v :: l) -> ( + if deep_occur ty (newgenty (Ttuple l)) then + (* The abbreviation may be hiding something, so remove it *) + set_name nm None + else + let v' = repr v in + match v'.desc with + | Tvar _ | Tunivar _ -> + if v' != v then set_name nm (Some (n, v' :: l)) + | Tnil -> + log_type ty; + ty.desc <- Tconstr (n, l, ref Mnil) + | _ -> set_name nm None) + | _ -> fatal_error "Ctype.normalize_type_rec"); + let fi = repr fi in + if fi.level < lowest_level then () + else + let fields, row = flatten_fields fi in + let fi' = build_fields fi.level fields row in + log_type ty; + fi.desc <- fi'.desc + | _ -> ()); + iter_type_expr (normalize_type_rec env visited) ty) + +let normalize_type env ty = normalize_type_rec env (ref TypeSet.empty) ty + +(*************************) +(* Remove dependencies *) +(*************************) (* Variables are left unchanged. Other type nodes are duplicated, with @@ -4020,73 +4068,73 @@ let normalize_type env ty = expand_abbrev. *) -let nondep_hash = TypeHash.create 47 +let nondep_hash = TypeHash.create 47 let nondep_variants = TypeHash.create 17 -let clear_hash () = - TypeHash.clear nondep_hash; TypeHash.clear nondep_variants +let clear_hash () = + TypeHash.clear nondep_hash; + TypeHash.clear nondep_variants let rec nondep_type_rec env id ty = match ty.desc with - Tvar _ | Tunivar _ -> ty + | Tvar _ | Tunivar _ -> ty | Tlink ty -> nondep_type_rec env id ty - | _ -> try TypeHash.find nondep_hash ty - with Not_found -> - let ty' = newgenvar () in (* Stub *) - TypeHash.add nondep_hash ty ty'; - ty'.desc <- - begin match ty.desc with - | Tconstr(p, tl, _abbrev) -> + | _ -> ( + try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenvar () in + (* Stub *) + TypeHash.add nondep_hash ty ty'; + ty'.desc <- + (match ty.desc with + | Tconstr (p, tl, _abbrev) -> if Path.isfree id p then - begin try - Tlink (nondep_type_rec env id - (expand_abbrev env (newty2 ty.level ty.desc))) + try + Tlink + (nondep_type_rec env id + (expand_abbrev env (newty2 ty.level ty.desc))) (* The [Tlink] is important. The expanded type may be a variable, or may not be completely copied yet (recursive type), so one cannot just take its description. *) - with Cannot_expand | Unify _ -> - raise Not_found - end - else - Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil) - | Tpackage(p, nl, tl) when Path.isfree id p -> + with Cannot_expand | Unify _ -> raise Not_found + else Tconstr (p, List.map (nondep_type_rec env id) tl, ref Mnil) + | Tpackage (p, nl, tl) when Path.isfree id p -> let p' = normalize_package_path env p in if Path.isfree id p' then raise Not_found; Tpackage (p', nl, List.map (nondep_type_rec env id) tl) - | Tobject (t1, name) -> - Tobject (nondep_type_rec env id t1, - ref (match !name with - None -> None - | Some (p, tl) -> - if Path.isfree id p then None - else Some (p, List.map (nondep_type_rec env id) tl))) - | Tvariant row -> + | Tobject (t1, name) -> + Tobject + ( nondep_type_rec env id t1, + ref + (match !name with + | None -> None + | Some (p, tl) -> + if Path.isfree id p then None + else Some (p, List.map (nondep_type_rec env id) tl)) ) + | Tvariant row -> ( let row = row_repr row in let more = repr row.row_more in (* We must keep sharing according to the row variable *) - begin try + try let ty2 = TypeHash.find nondep_variants more in (* This variant type has been already copied *) TypeHash.add nondep_hash ty ty2; Tlink ty2 - with Not_found -> + with Not_found -> ( (* Register new type first for recursion *) TypeHash.add nondep_variants more ty'; let static = static_row row in let more' = if static then newgenty Tnil else more in (* Return a new copy *) - let row = - copy_row (nondep_type_rec env id) true row true more' in + let row = copy_row (nondep_type_rec env id) true row true more' in match row.row_name with - Some (p, _tl) when Path.isfree id p -> - Tvariant {row with row_name = None} - | _ -> Tvariant row - end - | _ -> copy_type_desc (nondep_type_rec env id) ty.desc - end; - ty' + | Some (p, _tl) when Path.isfree id p -> + Tvariant {row with row_name = None} + | _ -> Tvariant row)) + | _ -> copy_type_desc (nondep_type_rec env id) ty.desc); + ty') let nondep_type env id ty = try @@ -4101,9 +4149,7 @@ let () = nondep_type' := nondep_type let unroll_abbrev id tl ty = let ty = repr ty and path = Path.Pident id in - if is_Tvar ty || (List.exists (deep_occur ty) tl) - || is_object_type path then - ty + if is_Tvar ty || List.exists (deep_occur ty) tl || is_object_type path then ty else let ty' = newty2 ty.level ty.desc in link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil))); @@ -4117,12 +4163,11 @@ let nondep_type_decl env mid id is_covariant decl = 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 - None -> None - | Some ty -> - Some (unroll_abbrev id params (nondep_type_rec env mid ty)) - with Not_found when is_covariant -> - None + try + match decl.type_manifest with + | None -> None + | Some ty -> Some (unroll_abbrev id params (nondep_type_rec env mid ty)) + with Not_found when is_covariant -> None in clear_hash (); let priv = @@ -4130,7 +4175,8 @@ let nondep_type_decl env mid id is_covariant decl = | Some ty when Btype.has_constr_row ty -> Private | _ -> decl.type_private in - { type_params = params; + { + type_params = params; type_arity = decl.type_arity; type_kind = tk; type_manifest = tm; @@ -4151,90 +4197,85 @@ let nondep_extension_constructor env mid ext = try let type_path, type_params = if Path.isfree mid ext.ext_type_path then - begin - let ty = - newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) - in - let ty' = nondep_type_rec env mid ty in - match (repr ty').desc with - Tconstr(p, tl, _) -> p, tl - | _ -> raise Not_found - end + let ty = + newgenty (Tconstr (ext.ext_type_path, ext.ext_type_params, ref Mnil)) + in + let ty' = nondep_type_rec env mid ty in + match (repr ty').desc with + | Tconstr (p, tl, _) -> (p, tl) + | _ -> raise Not_found else let type_params = List.map (nondep_type_rec env mid) ext.ext_type_params in - ext.ext_type_path, type_params + (ext.ext_type_path, type_params) in let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in - clear_hash (); - { ext_type_path = type_path; - ext_type_params = type_params; - ext_args = args; - ext_ret_type = ret_type; - ext_private = ext.ext_private; - ext_attributes = ext.ext_attributes; - ext_loc = ext.ext_loc; - ext_is_exception = ext.ext_is_exception; - } + clear_hash (); + { + ext_type_path = type_path; + ext_type_params = type_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = ext.ext_loc; + ext_is_exception = ext.ext_is_exception; + } with Not_found -> clear_hash (); raise Not_found - (* collapse conjunctive types in class parameters *) let rec collapse_conj env visited ty = let ty = repr ty in - if List.memq ty visited then () else - let visited = ty :: visited in - match ty.desc with - Tvariant row -> + if List.memq ty visited then () + else + let visited = ty :: visited in + match ty.desc with + | Tvariant row -> let row = row_repr row in List.iter - (fun (_l,fi) -> + (fun (_l, fi) -> match row_field_repr fi with - Reither (c, t1::(_::_ as tl), m, e) -> - List.iter (unify env t1) tl; - set_row_field e (Reither (c, [t1], m, ref None)) - | _ -> - ()) + | Reither (c, t1 :: (_ :: _ as tl), m, e) -> + List.iter (unify env t1) tl; + set_row_field e (Reither (c, [t1], m, ref None)) + | _ -> ()) row.row_fields; iter_row (collapse_conj env visited) row - | _ -> - iter_type_expr (collapse_conj env visited) ty + | _ -> iter_type_expr (collapse_conj env visited) ty -let collapse_conj_params env params = - List.iter (collapse_conj env []) params +let collapse_conj_params env params = List.iter (collapse_conj env []) params let same_constr env t1 t2 = let t1 = expand_head env t1 in let t2 = expand_head env t2 in - match t1.desc, t2.desc with + match (t1.desc, t2.desc) with | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 | _ -> false -let () = - Env.same_constr := same_constr +let () = Env.same_constr := same_constr let maybe_pointer_type env typ = - match (repr typ).desc with - | Tconstr(p, _args, _abbrev) -> - begin try + match (repr typ).desc with + | Tconstr (p, _args, _abbrev) -> ( + try let type_decl = Env.find_type p env in not type_decl.type_immediate - with Not_found -> true - (* This can happen due to e.g. missing -I options, - causing some .cmi files to be unavailable. - Maybe we should emit a warning. *) - end + with Not_found -> + true + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *)) | Tvariant row -> - let row = Btype.row_repr row in - (* if all labels are devoid of arguments, not a pointer *) - not row.row_closed - || List.exists - (function - | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true - | _ -> false) - row.row_fields + let row = Btype.row_repr row in + (* if all labels are devoid of arguments, not a pointer *) + (not row.row_closed) + || List.exists + (function + | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true + | _ -> false) + row.row_fields | _ -> true diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 0fae1711bd..b231dc61ac 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -20,178 +20,222 @@ open Types exception Unify of (type_expr * type_expr) list exception Tags of label * label -exception Subtype of - (type_expr * type_expr) list * (type_expr * type_expr) list +exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list exception Cannot_expand exception Cannot_apply exception Recursive_abbrev exception Unification_recursive_abbrev of (type_expr * type_expr) list -val init_def: int -> unit - (* Set the initial variable level *) -val begin_def: unit -> unit - (* Raise the variable level by one at the beginning of a definition. *) -val end_def: unit -> unit - (* Lower the variable level by one at the end of a definition *) -val begin_class_def: unit -> unit -val raise_nongen_level: unit -> unit -val reset_global_level: unit -> unit - (* Reset the global level before typing an expression *) -val increase_global_level: unit -> int -val restore_global_level: int -> unit - (* This pair of functions is only used in Typetexp *) -type levels = - { current_level: int; nongen_level: int; global_level: int; - saved_level: (int * int) list; } -val save_levels: unit -> levels -val set_levels: levels -> unit - -val newty: type_desc -> type_expr -val newvar: ?name:string -> unit -> type_expr -val newvar2: ?name:string -> int -> type_expr - (* Return a fresh variable *) -val new_global_var: ?name:string -> unit -> type_expr - (* Return a fresh variable, bound at toplevel - (as type variables ['a] in type constraints). *) -val newobj: type_expr -> type_expr -val newconstr: Path.t -> type_expr list -> type_expr -val none: type_expr - (* A dummy type expression *) - -val repr: type_expr -> type_expr - (* Return the canonical representative of a type. *) - -val object_fields: type_expr -> type_expr -val flatten_fields: - type_expr -> (string * field_kind * type_expr) list * type_expr - (* Transform a field type into a list of pairs label-type *) - (* The fields are sorted *) -val associate_fields: - (string * field_kind * type_expr) list -> - (string * field_kind * type_expr) list -> - (string * field_kind * type_expr * field_kind * type_expr) list * - (string * field_kind * type_expr) list * - (string * field_kind * type_expr) list -val opened_object: type_expr -> bool -val close_object: type_expr -> unit -val row_variable: type_expr -> type_expr - (* Return the row variable of an open object type *) -val set_object_name: - Ident.t -> type_expr -> type_expr list -> type_expr -> unit -val remove_object_name: type_expr -> unit -val hide_private_methods: type_expr -> unit -val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr -val lid_of_path: ?hash:string -> Path.t -> Longident.t - -val sort_row_fields: (label * row_field) list -> (label * row_field) list -val merge_row_fields: - (label * row_field) list -> (label * row_field) list -> - (label * row_field) list * (label * row_field) list * - (label * row_field * row_field) list -val filter_row_fields: - bool -> (label * row_field) list -> (label * row_field) list - -val generalize: type_expr -> unit - (* Generalize in-place the given type *) -val generalize_expansive: Env.t -> type_expr -> unit - (* Generalize the covariant part of a type, making - contravariant branches non-generalizable *) -val generalize_global: type_expr -> unit - (* Generalize the structure of a type, lowering variables - to !global_level *) -val generalize_structure: type_expr -> unit - (* Same, but variables are only lowered to !current_level *) -val correct_levels: type_expr -> type_expr - (* Returns a copy with decreasing levels *) -val limited_generalize: type_expr -> type_expr -> unit - (* Only generalize some part of the type - Make the remaining of the type non-generalizable *) - -val instance: ?partial:bool -> Env.t -> type_expr -> type_expr - (* Take an instance of a type scheme *) - (* partial=None -> normal - partial=false -> newvar() for non generic subterms - partial=true -> newty2 ty.level Tvar for non generic subterms *) -val instance_def: type_expr -> type_expr - (* use defaults *) -val generic_instance: Env.t -> type_expr -> type_expr - (* Same as instance, but new nodes at generic_level *) -val instance_list: Env.t -> type_expr list -> type_expr list - (* Take an instance of a list of type schemes *) -val instance_constructor: - ?in_pattern:Env.t ref * int -> - constructor_description -> type_expr list * type_expr - (* Same, for a constructor *) -val instance_parameterized_type: - ?keep_names:bool -> - type_expr list -> type_expr -> type_expr list * type_expr -val instance_parameterized_type_2: - type_expr list -> type_expr list -> type_expr -> - type_expr list * type_expr list * type_expr -val instance_declaration: type_declaration -> type_declaration -val instance_poly: - ?keep_names:bool -> - bool -> type_expr list -> type_expr -> type_expr list * type_expr - (* Take an instance of a type scheme containing free univars *) -val instance_label: - bool -> label_description -> type_expr list * type_expr * type_expr - (* Same, for a label *) -val apply: - Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr - (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to - the parameters [pi] and returns the corresponding instance of - [t]. Exception [Cannot_apply] is raised in case of failure. *) - -val expand_head_once: Env.t -> type_expr -> type_expr -val expand_head: Env.t -> type_expr -> type_expr -val try_expand_once_opt: Env.t -> type_expr -> type_expr -val expand_head_opt: Env.t -> type_expr -> type_expr +val init_def : int -> unit +(* Set the initial variable level *) + +val begin_def : unit -> unit +(* Raise the variable level by one at the beginning of a definition. *) + +val end_def : unit -> unit +(* Lower the variable level by one at the end of a definition *) + +val begin_class_def : unit -> unit +val raise_nongen_level : unit -> unit +val reset_global_level : unit -> unit +(* Reset the global level before typing an expression *) + +val increase_global_level : unit -> int +val restore_global_level : int -> unit +(* This pair of functions is only used in Typetexp *) + +type levels = { + current_level: int; + nongen_level: int; + global_level: int; + saved_level: (int * int) list; +} +val save_levels : unit -> levels +val set_levels : levels -> unit + +val newty : type_desc -> type_expr +val newvar : ?name:string -> unit -> type_expr +val newvar2 : ?name:string -> int -> type_expr +(* Return a fresh variable *) + +val new_global_var : ?name:string -> unit -> type_expr +(* Return a fresh variable, bound at toplevel + (as type variables ['a] in type constraints). *) + +val newobj : type_expr -> type_expr +val newconstr : Path.t -> type_expr list -> type_expr +val none : type_expr +(* A dummy type expression *) + +val repr : type_expr -> type_expr +(* Return the canonical representative of a type. *) + +val object_fields : type_expr -> type_expr +val flatten_fields : + type_expr -> (string * field_kind * type_expr) list * type_expr + +(* Transform a field type into a list of pairs label-type *) +(* The fields are sorted *) +val associate_fields : + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr * field_kind * type_expr) list + * (string * field_kind * type_expr) list + * (string * field_kind * type_expr) list +val opened_object : type_expr -> bool +val close_object : type_expr -> unit +val row_variable : type_expr -> type_expr +(* Return the row variable of an open object type *) + +val set_object_name : + Ident.t -> type_expr -> type_expr list -> type_expr -> unit +val remove_object_name : type_expr -> unit +val hide_private_methods : type_expr -> unit +val find_cltype_for_path : Env.t -> Path.t -> type_declaration * type_expr +val lid_of_path : ?hash:string -> Path.t -> Longident.t + +val sort_row_fields : (label * row_field) list -> (label * row_field) list +val merge_row_fields : + (label * row_field) list -> + (label * row_field) list -> + (label * row_field) list + * (label * row_field) list + * (label * row_field * row_field) list +val filter_row_fields : + bool -> (label * row_field) list -> (label * row_field) list + +val generalize : type_expr -> unit +(* Generalize in-place the given type *) + +val generalize_expansive : Env.t -> type_expr -> unit +(* Generalize the covariant part of a type, making + contravariant branches non-generalizable *) + +val generalize_global : type_expr -> unit +(* Generalize the structure of a type, lowering variables + to !global_level *) + +val generalize_structure : type_expr -> unit +(* Same, but variables are only lowered to !current_level *) + +val correct_levels : type_expr -> type_expr +(* Returns a copy with decreasing levels *) + +val limited_generalize : type_expr -> type_expr -> unit +(* Only generalize some part of the type + Make the remaining of the type non-generalizable *) + +val instance : ?partial:bool -> Env.t -> type_expr -> type_expr + +(* Take an instance of a type scheme *) +(* partial=None -> normal + partial=false -> newvar() for non generic subterms + partial=true -> newty2 ty.level Tvar for non generic subterms *) +val instance_def : type_expr -> type_expr +(* use defaults *) + +val generic_instance : Env.t -> type_expr -> type_expr +(* Same as instance, but new nodes at generic_level *) + +val instance_list : Env.t -> type_expr list -> type_expr list +(* Take an instance of a list of type schemes *) + +val instance_constructor : + ?in_pattern:Env.t ref * int -> + constructor_description -> + type_expr list * type_expr +(* Same, for a constructor *) + +val instance_parameterized_type : + ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr +val instance_parameterized_type_2 : + type_expr list -> + type_expr list -> + type_expr -> + type_expr list * type_expr list * type_expr +val instance_declaration : type_declaration -> type_declaration +val instance_poly : + ?keep_names:bool -> + bool -> + type_expr list -> + type_expr -> + type_expr list * type_expr +(* Take an instance of a type scheme containing free univars *) + +val instance_label : + bool -> label_description -> type_expr list * type_expr * type_expr +(* Same, for a label *) + +val apply : Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr +(* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to + the parameters [pi] and returns the corresponding instance of + [t]. Exception [Cannot_apply] is raised in case of failure. *) + +val expand_head_once : Env.t -> type_expr -> type_expr +val expand_head : Env.t -> type_expr -> type_expr +val try_expand_once_opt : Env.t -> type_expr -> type_expr + +val expand_head_opt : Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) -val full_expand: Env.t -> type_expr -> type_expr -val extract_concrete_typedecl: - Env.t -> type_expr -> Path.t * Path.t * type_declaration - (* Return the original path of the types, and the first concrete - type declaration found expanding it. - Raise [Not_found] if none appears or not a type constructor. *) - -val enforce_constraints: Env.t -> type_expr -> unit - -val unify: Env.t -> type_expr -> type_expr -> unit - (* Unify the two types given. Raise [Unify] if not possible. *) -val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit - (* Unify the two types given and update the environment with the - local constraints. Raise [Unify] if not possible. *) -val unify_var: Env.t -> type_expr -> type_expr -> unit - (* Same as [unify], but allow free univars when first type - is a variable. *) -val with_passive_variants: ('a -> 'b) -> ('a -> 'b) - (* Call [f] in passive_variants mode, for exhaustiveness check. *) -val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr - (* A special case of unification (with l:'a -> 'b). *) -val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr - (* A special case of unification (with {m : 'a; 'b}). *) -val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit - (* A special case of unification (with {m : 'a; 'b}), returning unit. *) -val occur_in: Env.t -> type_expr -> type_expr -> bool -val deep_occur: type_expr -> type_expr -> bool -val filter_self_method: - Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref -> - type_expr -> Ident.t * type_expr -val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool - (* Check if the first type scheme is more general than the second. *) - -val rigidify: type_expr -> type_expr list - (* "Rigidify" a type and return its type variable *) -val all_distinct_vars: Env.t -> type_expr list -> bool - (* Check those types are all distinct type variables *) -val matches: Env.t -> type_expr -> type_expr -> bool - (* Same as [moregeneral false], implemented using the two above - functions and backtracking. Ignore levels *) +val full_expand : Env.t -> type_expr -> type_expr +val extract_concrete_typedecl : + Env.t -> type_expr -> Path.t * Path.t * type_declaration +(* Return the original path of the types, and the first concrete + type declaration found expanding it. + Raise [Not_found] if none appears or not a type constructor. *) + +val enforce_constraints : Env.t -> type_expr -> unit + +val unify : Env.t -> type_expr -> type_expr -> unit +(* Unify the two types given. Raise [Unify] if not possible. *) + +val unify_gadt : + newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit +(* Unify the two types given and update the environment with the + local constraints. Raise [Unify] if not possible. *) + +val unify_var : Env.t -> type_expr -> type_expr -> unit +(* Same as [unify], but allow free univars when first type + is a variable. *) + +val with_passive_variants : ('a -> 'b) -> 'a -> 'b +(* Call [f] in passive_variants mode, for exhaustiveness check. *) + +val filter_arrow : Env.t -> type_expr -> arg_label -> type_expr * type_expr +(* A special case of unification (with l:'a -> 'b). *) + +val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr +(* A special case of unification (with {m : 'a; 'b}). *) + +val check_filter_method : Env.t -> string -> private_flag -> type_expr -> unit +(* A special case of unification (with {m : 'a; 'b}), returning unit. *) + +val occur_in : Env.t -> type_expr -> type_expr -> bool +val deep_occur : type_expr -> type_expr -> bool +val filter_self_method : + Env.t -> + string -> + private_flag -> + (Ident.t * type_expr) Meths.t ref -> + type_expr -> + Ident.t * type_expr +val moregeneral : Env.t -> bool -> type_expr -> type_expr -> bool +(* Check if the first type scheme is more general than the second. *) + +val rigidify : type_expr -> type_expr list +(* "Rigidify" a type and return its type variable *) + +val all_distinct_vars : Env.t -> type_expr list -> bool +(* Check those types are all distinct type variables *) + +val matches : Env.t -> type_expr -> type_expr -> bool +(* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels *) type class_match_failure = - CM_Virtual_class + | CM_Virtual_class | CM_Parameter_arity_mismatch of int * int | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list @@ -206,66 +250,76 @@ type class_match_failure = | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string -val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool - (* [equal env [x1...xn] tau [y1...yn] sigma] - checks whether the parameterized types - [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) - -val enlarge_type: Env.t -> type_expr -> type_expr * bool - (* Make a type larger, flag is true if some pruning had to be done *) -val subtype: Env.t -> type_expr -> type_expr -> unit -> unit - (* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. - It accumulates the constraints the type variables must - enforce and returns a function that enforces this - constraints. *) - -val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr - (* Return a type equivalent to the given type but without - references to the given module identifier. Raise [Not_found] - if no such type exists. *) -val nondep_type_decl: - Env.t -> Ident.t -> Ident.t -> bool -> type_declaration -> - type_declaration - (* Same for type declarations. *) -val nondep_extension_constructor: - Env.t -> Ident.t -> extension_constructor -> - extension_constructor - (* Same for extension constructor *) +val equal : Env.t -> bool -> type_expr list -> type_expr list -> bool +(* [equal env [x1...xn] tau [y1...yn] sigma] + checks whether the parameterized types + [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) + +val enlarge_type : Env.t -> type_expr -> type_expr * bool +(* Make a type larger, flag is true if some pruning had to be done *) + +val subtype : Env.t -> type_expr -> type_expr -> unit -> unit +(* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. + It accumulates the constraints the type variables must + enforce and returns a function that enforces this + constraints. *) + +val nondep_type : Env.t -> Ident.t -> type_expr -> type_expr +(* Return a type equivalent to the given type but without + references to the given module identifier. Raise [Not_found] + if no such type exists. *) + +val nondep_type_decl : + Env.t -> Ident.t -> Ident.t -> bool -> type_declaration -> type_declaration +(* Same for type declarations. *) + +val nondep_extension_constructor : + Env.t -> Ident.t -> extension_constructor -> extension_constructor + +(* Same for extension constructor *) (*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) -val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool -val is_contractive: Env.t -> Path.t -> bool -val normalize_type: Env.t -> type_expr -> unit - -val closed_schema: Env.t -> type_expr -> bool - (* Check whether the given type scheme contains no non-generic - type variables *) - -val free_variables: ?env:Env.t -> type_expr -> type_expr list - (* If env present, then check for incomplete definitions too *) -val closed_type_decl: type_declaration -> type_expr option -val closed_extension_constructor: extension_constructor -> type_expr option +val cyclic_abbrev : Env.t -> Ident.t -> type_expr -> bool +val is_contractive : Env.t -> Path.t -> bool +val normalize_type : Env.t -> type_expr -> unit + +val closed_schema : Env.t -> type_expr -> bool +(* Check whether the given type scheme contains no non-generic + type variables *) + +val free_variables : ?env:Env.t -> type_expr -> type_expr list +(* If env present, then check for incomplete definitions too *) + +val closed_type_decl : type_declaration -> type_expr option +val closed_extension_constructor : extension_constructor -> type_expr option type closed_class_failure = - CC_Method of type_expr * bool * string * type_expr + | CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr -val unalias: type_expr -> type_expr -val arity: type_expr -> int - (* Return the arity (as for curried functions) of the given type. *) +val unalias : type_expr -> type_expr +val arity : type_expr -> int +(* Return the arity (as for curried functions) of the given type. *) -val collapse_conj_params: Env.t -> type_expr list -> unit - (* Collapse conjunctive types in class parameters *) +val collapse_conj_params : Env.t -> type_expr list -> unit +(* Collapse conjunctive types in class parameters *) -val get_current_level: unit -> int -val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b -val reset_reified_var_counter: unit -> unit +val get_current_level : unit -> int +val wrap_trace_gadt_instances : Env.t -> ('a -> 'b) -> 'a -> 'b +val reset_reified_var_counter : unit -> unit val maybe_pointer_type : Env.t -> type_expr -> bool - (* True if type is possibly pointer, false if definitely not a pointer *) +(* True if type is possibly pointer, false if definitely not a pointer *) (* Stubs *) val package_subtype : - (Env.t -> Path.t -> Longident.t list -> type_expr list -> - Path.t -> Longident.t list -> type_expr list -> bool) ref + (Env.t -> + Path.t -> + Longident.t list -> + type_expr list -> + Path.t -> + Longident.t list -> + type_expr list -> + bool) + ref -val variant_is_subtype: - (Env.t -> Types.row_desc -> Types.type_expr -> bool) ref \ No newline at end of file +val variant_is_subtype : + (Env.t -> Types.row_desc -> Types.type_expr -> bool) ref diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 227fb63d24..ef5245fcf4 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -21,27 +21,23 @@ open Types open Btype (* Simplified version of Ctype.free_vars *) -let free_vars ?(param=false) ty = +let free_vars ?(param = false) ty = let ret = ref TypeSet.empty in let rec loop ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( ty.level <- pivot_level - ty.level; match ty.desc with - | Tvar _ -> - ret := TypeSet.add ty !ret - | Tvariant row -> - let row = row_repr row in - iter_row loop row; - if not (static_row row) then begin - match row.row_more.desc with - | Tvar _ when param -> ret := TypeSet.add ty !ret - | _ -> loop row.row_more - end + | Tvar _ -> ret := TypeSet.add ty !ret + | Tvariant row -> ( + let row = row_repr row in + iter_row loop row; + if not (static_row row) then + match row.row_more.desc with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop row.row_more) (* XXX: What about Tobject ? *) - | _ -> - iter_type_expr loop ty - end + | _ -> iter_type_expr loop ty) in loop ty; unmark_type ty; @@ -59,164 +55,189 @@ let constructor_existentials cd_args cd_res = match cd_res with | None -> [] | Some type_ret -> - let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in - let res_vars = free_vars type_ret in - TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in + let res_vars = free_vars type_ret in + TypeSet.elements (TypeSet.diff arg_vars_set res_vars) in (tyl, existentials) let constructor_args priv cd_args cd_res path rep = let tyl, existentials = constructor_existentials cd_args cd_res in match cd_args with - | Cstr_tuple l -> existentials, l, None + | Cstr_tuple l -> (existentials, l, None) | Cstr_record lbls -> - let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in - let type_params = TypeSet.elements arg_vars_set in - let type_unboxed = - match rep with - | Record_unboxed _ -> unboxed_true_default_false - | _ -> unboxed_false_default_false - in - let tdecl = - { - type_params; - type_arity = List.length type_params; - type_kind = Type_record (lbls, rep); - type_private = priv; - type_manifest = None; - type_variance = List.map (fun _ -> Variance.full) type_params; - type_newtype_level = None; - type_loc = Location.none; - type_attributes = []; - type_immediate = false; - type_unboxed; - } - in - existentials, - [ newgenconstr path type_params ], - Some tdecl + let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in + let type_params = TypeSet.elements arg_vars_set in + let type_unboxed = + match rep with + | Record_unboxed _ -> unboxed_true_default_false + | _ -> unboxed_false_default_false + in + let tdecl = + { + type_params; + type_arity = List.length type_params; + type_kind = Type_record (lbls, rep); + type_private = priv; + type_manifest = None; + type_variance = List.map (fun _ -> Variance.full) type_params; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_unboxed; + } + in + (existentials, [newgenconstr path type_params], Some tdecl) let internal_optional = "internal.optional" - -let optional_shape : Parsetree.attribute = - {txt = internal_optional ; loc = Location.none}, Parsetree.PStr [] -let constructor_has_optional_shape ({cstr_attributes = attrs} : constructor_description) = - List.exists (fun (x,_) -> x.txt = internal_optional) attrs +let optional_shape : Parsetree.attribute = + ({txt = internal_optional; loc = Location.none}, Parsetree.PStr []) +let constructor_has_optional_shape + ({cstr_attributes = attrs} : constructor_description) = + List.exists (fun (x, _) -> x.txt = internal_optional) attrs 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 + let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter (fun {cd_args; cd_res; _} -> if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; if cd_res = None then incr num_normal) cstrs; - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in + let has_optional attrs = + Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.optional") + in let rec describe_constructors idx_const idx_nonconst = function - [] -> [] + | [] -> [] | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> - let ty_res = - match cd_res with - | Some ty_res' -> ty_res' - | None -> ty_res - in - let (tag, descr_rem) = - match cd_args with - | _ when decl.type_unboxed.unboxed -> - assert (rem = []); - (Cstr_unboxed, []) - | Cstr_tuple [] -> (Cstr_constant idx_const, - describe_constructors (idx_const+1) idx_nonconst rem) - | _ -> (Cstr_block idx_nonconst, - describe_constructors idx_const (idx_nonconst+1) rem) in - let cstr_name = Ident.name cd_id in - let optional_labels = match cd_args with - | Cstr_tuple _ -> [] - | Cstr_record lbls -> - Ext_list.filter_map lbls (fun ({ld_id;ld_attributes; _}) -> + let ty_res = + match cd_res with + | Some ty_res' -> ty_res' + | None -> ty_res + in + let tag, descr_rem = + match cd_args with + | _ when decl.type_unboxed.unboxed -> + assert (rem = []); + (Cstr_unboxed, []) + | Cstr_tuple [] -> + ( Cstr_constant idx_const, + describe_constructors (idx_const + 1) idx_nonconst rem ) + | _ -> + ( Cstr_block idx_nonconst, + describe_constructors idx_const (idx_nonconst + 1) rem ) + in + let cstr_name = Ident.name cd_id in + let optional_labels = + match cd_args with + | Cstr_tuple _ -> [] + | Cstr_record lbls -> + Ext_list.filter_map lbls (fun {ld_id; ld_attributes; _} -> if has_optional ld_attributes then Some ld_id.name else None) + in + let existentials, cstr_args, cstr_inlined = + let representation = + if decl.type_unboxed.unboxed then Record_unboxed true + else + Record_inlined + { + tag = idx_nonconst; + name = cstr_name; + num_nonconsts = !num_nonconsts; + optional_labels; + attrs = cd_attributes; + } in - let existentials, cstr_args, cstr_inlined = - let representation = - if decl.type_unboxed.unboxed - then Record_unboxed true - else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; optional_labels; attrs = cd_attributes} - in - constructor_args decl.type_private cd_args cd_res - (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation - in - let cstr = - { cstr_name; - cstr_res = ty_res; - cstr_existentials = existentials; - 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 = decl.type_private; - cstr_generalized = cd_res <> None; - cstr_loc = cd_loc; - cstr_attributes = cd_attributes; - cstr_inlined; - } in - (cd_id, cstr) :: descr_rem in - let result = describe_constructors 0 0 cstrs in + constructor_args decl.type_private cd_args cd_res + (Path.Pdot (ty_path, cstr_name, Path.nopos)) + representation + in + let cstr = + { + cstr_name; + cstr_res = ty_res; + cstr_existentials = existentials; + 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 = decl.type_private; + cstr_generalized = cd_res <> None; + cstr_loc = cd_loc; + cstr_attributes = cd_attributes; + cstr_inlined; + } + in + (cd_id, cstr) :: descr_rem + in + let result = describe_constructors 0 0 cstrs in match result with - | ( - [ ({Ident.name = "None"} as a_id, ({cstr_args = []} as a_descr) ) ; - ({Ident.name = "Some"} as b_id, ({ cstr_args = [_]} as b_descr)) - ] | - [ ({Ident.name = "Some"} as a_id, ({cstr_args = [_]} as a_descr) ) ; - ({Ident.name = "None"} as b_id, ({ cstr_args = []} as b_descr)) + | [ + (({Ident.name = "None"} as a_id), ({cstr_args = []} as a_descr)); + (({Ident.name = "Some"} as b_id), ({cstr_args = [_]} as b_descr)); ] - ) - -> - [ - (a_id, {a_descr with - cstr_attributes = - optional_shape :: a_descr.cstr_attributes}); - (b_id, {b_descr with - cstr_attributes = - optional_shape :: b_descr.cstr_attributes - }) - ] - | _ -> result + | [ + (({Ident.name = "Some"} as a_id), ({cstr_args = [_]} as a_descr)); + (({Ident.name = "None"} as b_id), ({cstr_args = []} as b_descr)); + ] -> + [ + ( a_id, + { + a_descr with + cstr_attributes = optional_shape :: a_descr.cstr_attributes; + } ); + ( b_id, + { + b_descr with + cstr_attributes = optional_shape :: b_descr.cstr_attributes; + } ); + ] + | _ -> result let extension_descr path_ext ext = let ty_res = match ext.ext_ret_type with - Some type_ret -> type_ret - | None -> newgenconstr ext.ext_type_path ext.ext_type_params + | Some type_ret -> type_ret + | None -> newgenconstr ext.ext_type_path ext.ext_type_params in let existentials, cstr_args, cstr_inlined = - constructor_args ext.ext_private ext.ext_args ext.ext_ret_type - path_ext Record_extension + constructor_args ext.ext_private ext.ext_args ext.ext_ret_type path_ext + Record_extension in - { cstr_name = Path.last path_ext; - cstr_res = ty_res; - cstr_existentials = existentials; - cstr_args; - cstr_arity = List.length cstr_args; - cstr_tag = Cstr_extension(path_ext); - cstr_consts = -1; - cstr_nonconsts = -1; - cstr_private = ext.ext_private; - cstr_normal = -1; - cstr_generalized = ext.ext_ret_type <> None; - cstr_loc = ext.ext_loc; - cstr_attributes = ext.ext_attributes; - cstr_inlined; - } + { + cstr_name = Path.last path_ext; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = Cstr_extension path_ext; + cstr_consts = -1; + cstr_nonconsts = -1; + cstr_private = ext.ext_private; + cstr_normal = -1; + cstr_generalized = ext.ext_ret_type <> None; + cstr_loc = ext.ext_loc; + cstr_attributes = ext.ext_attributes; + cstr_inlined; + } let none = {desc = Ttuple []; level = -1; id = -1} - (* Clearly ill-formed type *) +(* Clearly ill-formed type *) + let dummy_label = - { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; - lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; + { + lbl_name = ""; + lbl_res = none; + lbl_arg = none; + lbl_mut = Immutable; + lbl_pos = -1; + lbl_all = [||]; + lbl_repres = Record_regular; lbl_private = Public; lbl_loc = Location.none; lbl_attributes = []; @@ -225,40 +246,40 @@ let dummy_label = let label_descrs ty_res lbls repres priv = let all_labels = Array.make (List.length lbls) dummy_label in let rec describe_labels num = function - [] -> [] + | [] -> [] | l :: rest -> - let lbl = - { lbl_name = Ident.name l.ld_id; - lbl_res = ty_res; - lbl_arg = l.ld_type; - lbl_mut = l.ld_mutable; - lbl_pos = num; - lbl_all = all_labels; - lbl_repres = repres; - lbl_private = priv; - lbl_loc = l.ld_loc; - lbl_attributes = l.ld_attributes; - } in - all_labels.(num) <- lbl; - (l.ld_id, lbl) :: describe_labels (num+1) rest in + let lbl = + { + lbl_name = Ident.name l.ld_id; + lbl_res = ty_res; + lbl_arg = l.ld_type; + lbl_mut = l.ld_mutable; + lbl_pos = num; + lbl_all = all_labels; + lbl_repres = repres; + lbl_private = priv; + lbl_loc = l.ld_loc; + lbl_attributes = l.ld_attributes; + } + in + all_labels.(num) <- lbl; + (l.ld_id, lbl) :: describe_labels (num + 1) rest + in describe_labels 0 lbls exception Constr_not_found let rec find_constr tag num_const num_nonconst = function - [] -> - raise Constr_not_found - | {cd_args = Cstr_tuple []; _} as c :: rem -> - if Types.equal_tag tag (Cstr_constant num_const) - then c - else find_constr tag (num_const + 1) num_nonconst rem + | [] -> raise Constr_not_found + | ({cd_args = Cstr_tuple []; _} as c) :: rem -> + if Types.equal_tag tag (Cstr_constant num_const) then c + else find_constr tag (num_const + 1) num_nonconst rem | c :: rem -> - if Types.equal_tag tag (Cstr_block num_nonconst) || tag = Cstr_unboxed - then c - else find_constr tag num_const (num_nonconst + 1) rem + if Types.equal_tag tag (Cstr_block num_nonconst) || tag = Cstr_unboxed then + c + else find_constr tag num_const (num_nonconst + 1) rem -let find_constr_by_tag tag cstrlist = - find_constr tag 0 0 cstrlist +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 @@ -267,20 +288,22 @@ let constructors_of_type ty_path decl = 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_record (labels, rep) -> + label_descrs + (newgenconstr ty_path decl.type_params) + labels rep decl.type_private | Type_variant _ | Type_abstract | Type_open -> [] (* Set row_name in Env, cf. GPR#1204/1329 *) let set_row_name decl path = match decl.type_manifest with - None -> () - | Some ty -> - let ty = repr ty in - match ty.desc with - Tvariant row when static_row row -> - let row = {(row_repr row) with - row_name = Some (path, decl.type_params)} in - ty.desc <- Tvariant row - | _ -> () + | None -> () + | Some ty -> ( + let ty = repr ty in + match ty.desc with + | Tvariant row when static_row row -> + let row = + {(row_repr row) with row_name = Some (path, decl.type_params)} + in + ty.desc <- Tvariant row + | _ -> ()) diff --git a/compiler/ml/datarepr.mli b/compiler/ml/datarepr.mli index f6bc50f08c..47113d87e8 100644 --- a/compiler/ml/datarepr.mli +++ b/compiler/ml/datarepr.mli @@ -18,34 +18,27 @@ open Types -val constructor_has_optional_shape: - Types.constructor_description -> bool +val constructor_has_optional_shape : Types.constructor_description -> bool -val extension_descr: - Path.t -> extension_constructor -> constructor_description - -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 +val extension_descr : Path.t -> extension_constructor -> constructor_description +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 -val find_constr_by_tag: - constructor_tag -> constructor_declaration list -> - constructor_declaration +val find_constr_by_tag : + constructor_tag -> constructor_declaration list -> constructor_declaration val constructor_existentials : - constructor_arguments -> type_expr option -> type_expr list * type_expr list + constructor_arguments -> type_expr option -> type_expr list * type_expr list (** Takes [cd_args] and [cd_res] from a [constructor_declaration] and returns: - the types of the constructor's arguments - the existential variables introduced by the constructor *) - (* Set the polymorphic variant row_name field *) val set_row_name : type_declaration -> Path.t -> unit diff --git a/compiler/ml/delayed_checks.ml b/compiler/ml/delayed_checks.ml index 029831a745..631425ce6d 100644 --- a/compiler/ml/delayed_checks.ml +++ b/compiler/ml/delayed_checks.ml @@ -8,8 +8,10 @@ let force_delayed_checks () = let snap = Btype.snapshot () in let w_old = Warnings.backup () in List.iter - (fun (f, w) -> Warnings.restore w; f ()) + (fun (f, w) -> + Warnings.restore w; + f ()) (List.rev !delayed_checks); Warnings.restore w_old; reset_delayed_checks (); - Btype.backtrack snap \ No newline at end of file + Btype.backtrack snap diff --git a/compiler/ml/delayed_checks.mli b/compiler/ml/delayed_checks.mli index df0a34692b..ac83a671c8 100644 --- a/compiler/ml/delayed_checks.mli +++ b/compiler/ml/delayed_checks.mli @@ -1,6 +1,3 @@ - - - val reset_delayed_checks : unit -> unit val add_delayed_check : (unit -> unit) -> unit val force_delayed_checks : unit -> unit diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 0daaa97f56..8d012e9787 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -20,20 +20,23 @@ open Parsetree let pp_deps = ref [] -module StringSet = Set.Make(struct type t = string let compare = compare end) -module StringMap = Map.Make(String) +module StringSet = Set.Make (struct + type t = string + let compare = compare +end) +module StringMap = Map.Make (String) (* Module resolution map *) (* Node (set of imports for this path, map for submodules) *) type map_tree = Node of StringSet.t * bound_map -and bound_map = map_tree StringMap.t +and bound_map = map_tree StringMap.t let bound = Node (StringSet.empty, StringMap.empty) (*let get_free (Node (s, _m)) = s*) let get_map (Node (_s, m)) = m let make_leaf s = Node (StringSet.singleton s, StringMap.empty) -let make_node m = Node (StringSet.empty, m) -let rec weaken_map s (Node(s0,m0)) = +let make_node m = Node (StringSet.empty, m) +let rec weaken_map s (Node (s0, m0)) = Node (StringSet.union s s0, StringMap.map (weaken_map s) m0) let rec collect_free (Node (s, m)) = StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s @@ -42,17 +45,17 @@ let rec collect_free (Node (s, m)) = (* Only raises Not_found if the head of p is not in the toplevel map *) let rec lookup_free p m = match p with - [] -> raise Not_found - | s::p -> - let Node (f, m') = StringMap.find s m in - try lookup_free p m' with Not_found -> f + | [] -> raise Not_found + | s :: p -> ( + let (Node (f, m')) = StringMap.find s m in + try lookup_free p m' with Not_found -> f) (* Returns the node corresponding to the structure at path p *) let rec lookup_map lid m = match lid with - Lident s -> StringMap.find s m + | Lident s -> StringMap.find s m | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m)) - | Lapply _ -> raise Not_found + | Lapply _ -> raise Not_found (* Collect free module identifiers in the a.s.t. *) @@ -61,28 +64,31 @@ let free_structure_names = ref StringSet.empty let add_names s = free_structure_names := StringSet.union s !free_structure_names -let rec add_path bv ?(p=[]) = function +let rec add_path bv ?(p = []) = function | Lident s -> - let free = - try lookup_free (s::p) bv with Not_found -> StringSet.singleton s - in - (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free; - prerr_endline "";*) - add_names free - | Ldot(l, s) -> add_path bv ~p:(s::p) l - | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 + let free = + try lookup_free (s :: p) bv with Not_found -> StringSet.singleton s + in + (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free; + prerr_endline "";*) + add_names free + | Ldot (l, s) -> add_path bv ~p:(s :: p) l + | Lapply (l1, l2) -> + add_path bv l1; + add_path bv l2 let open_module bv lid = match lookup_map lid bv with | Node (s, m) -> - add_names s; - StringMap.fold StringMap.add m bv + add_names s; + StringMap.fold StringMap.add m bv | exception Not_found -> - add_path bv lid; bv + add_path bv lid; + bv let add_parent bv lid = match lid.txt with - Ldot(l, _s) -> add_path bv l + | Ldot (l, _s) -> add_path bv l | _ -> () let add = add_parent @@ -92,30 +98,35 @@ let addmodule bv lid = add_path bv lid.txt let handle_extension ext = match (fst ext).txt with | "error" | "ocaml.error" -> - raise (Location.Error - (Builtin_attributes.error_of_extension ext)) - | _ -> - () + raise (Location.Error (Builtin_attributes.error_of_extension ext)) + | _ -> () let rec add_type bv ty = match ty.ptyp_desc with - Ptyp_any -> () + | Ptyp_any -> () | Ptyp_var _ -> () - | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 + | Ptyp_arrow (_, t1, t2) -> + add_type bv t1; + add_type bv t2 | Ptyp_tuple tl -> List.iter (add_type bv) tl - | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl + | Ptyp_constr (c, tl) -> + add bv c; + List.iter (add_type bv) tl | Ptyp_object (fl, _) -> - List.iter - (function Otag (_, _, t) -> add_type bv t - | Oinherit t -> add_type bv t) fl - | Ptyp_class() -> () - | Ptyp_alias(t, _) -> add_type bv t - | Ptyp_variant(fl, _, _) -> - List.iter - (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl - | Rinherit sty -> add_type bv sty) - fl - | Ptyp_poly(_, t) -> add_type bv t + List.iter + (function + | Otag (_, _, t) -> add_type bv t + | Oinherit t -> add_type bv t) + fl + | Ptyp_class () -> () + | Ptyp_alias (t, _) -> add_type bv t + | Ptyp_variant (fl, _, _) -> + List.iter + (function + | Rtag (_, _, _, stl) -> List.iter (add_type bv) stl + | Rinherit sty -> add_type bv sty) + fl + | Ptyp_poly (_, t) -> add_type bv t | Ptyp_package pt -> add_package_type bv pt | Ptyp_extension e -> handle_extension e @@ -124,7 +135,7 @@ and add_package_type bv (lid, l) = List.iter (add_type bv) (List.map (fun (_, e) -> e) l) let add_opt add_fn bv = function - None -> () + | None -> () | Some x -> add_fn bv x let add_constructor_arguments bv = function @@ -137,23 +148,24 @@ let add_constructor_decl bv pcd = let add_type_declaration bv td = List.iter - (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) + (fun (ty1, ty2, _) -> + add_type bv ty1; + add_type bv ty2) td.ptype_cstrs; add_opt add_type bv td.ptype_manifest; let add_tkind = function - Ptype_abstract -> () - | Ptype_variant cstrs -> - List.iter (add_constructor_decl bv) cstrs - | Ptype_record lbls -> - List.iter (fun pld -> add_type bv pld.pld_type) lbls - | Ptype_open -> () in + | Ptype_abstract -> () + | Ptype_variant cstrs -> List.iter (add_constructor_decl bv) cstrs + | Ptype_record lbls -> List.iter (fun pld -> add_type bv pld.pld_type) lbls + | Ptype_open -> () + in add_tkind td.ptype_kind let add_extension_constructor bv ext = match ext.pext_kind with - Pext_decl(args, rty) -> - add_constructor_arguments bv args; - Misc.may (add_type bv) rty + | Pext_decl (args, rty) -> + add_constructor_arguments bv args; + Misc.may (add_type bv) rty | Pext_rebind lid -> add bv lid let add_type_extension bv te = @@ -164,23 +176,34 @@ let pattern_bv = ref StringMap.empty let rec add_pattern bv pat = match pat.ppat_desc with - Ppat_any -> () + | Ppat_any -> () | Ppat_var _ -> () - | Ppat_alias(p, _) -> add_pattern bv p - | Ppat_interval _ - | Ppat_constant _ -> () + | Ppat_alias (p, _) -> add_pattern bv p + | Ppat_interval _ | Ppat_constant _ -> () | Ppat_tuple pl -> List.iter (add_pattern bv) pl - | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op - | Ppat_record(pl, _) -> - List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl + | Ppat_construct (c, op) -> + add bv c; + add_opt add_pattern bv op + | Ppat_record (pl, _) -> + List.iter + (fun (lbl, p) -> + add bv lbl; + add_pattern bv p) + pl | Ppat_array pl -> List.iter (add_pattern bv) pl - | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 - | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty - | Ppat_variant(_, op) -> add_opt add_pattern bv op + | Ppat_or (p1, p2) -> + add_pattern bv p1; + add_pattern bv p2 + | Ppat_constraint (p, ty) -> + add_pattern bv p; + add_type bv ty + | Ppat_variant (_, op) -> add_opt add_pattern bv op | Ppat_type li -> add bv li | Ppat_lazy p -> add_pattern bv p | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv - | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p + | Ppat_open (m, p) -> + let bv = open_module bv m.txt in + add_pattern bv p | Ppat_exception p -> add_pattern bv p | Ppat_extension e -> handle_extension e @@ -191,67 +214,93 @@ let add_pattern bv pat = let rec add_expr bv exp = match exp.pexp_desc with - Pexp_ident l -> add bv l + | Pexp_ident l -> add bv l | Pexp_constant _ -> () - | Pexp_let(rf, pel, e) -> - let bv = add_bindings rf bv pel in add_expr bv e + | Pexp_let (rf, pel, e) -> + let bv = add_bindings rf bv pel in + add_expr bv e | Pexp_fun (_, opte, p, e) -> - add_opt add_expr bv opte; add_expr (add_pattern bv p) e - | Pexp_function pel -> - add_cases bv pel - | Pexp_apply(e, el) -> - add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el - | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel - | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel + add_opt add_expr bv opte; + add_expr (add_pattern bv p) e + | Pexp_function pel -> add_cases bv pel + | Pexp_apply (e, el) -> + add_expr bv e; + List.iter (fun (_, e) -> add_expr bv e) el + | Pexp_match (e, pel) -> + add_expr bv e; + add_cases bv pel + | Pexp_try (e, pel) -> + add_expr bv e; + add_cases bv pel | Pexp_tuple el -> List.iter (add_expr bv) el - | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte - | Pexp_variant(_, opte) -> add_opt add_expr bv opte - | Pexp_record(lblel, opte) -> - List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; - add_opt add_expr bv opte - | Pexp_field(e, fld) -> add_expr bv e; add bv fld - | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 + | Pexp_construct (c, opte) -> + add bv c; + add_opt add_expr bv opte + | Pexp_variant (_, opte) -> add_opt add_expr bv opte + | Pexp_record (lblel, opte) -> + List.iter + (fun (lbl, e) -> + add bv lbl; + add_expr bv e) + lblel; + add_opt add_expr bv opte + | Pexp_field (e, fld) -> + add_expr bv e; + add bv fld + | Pexp_setfield (e1, fld, e2) -> + add_expr bv e1; + add bv fld; + add_expr bv e2 | Pexp_array el -> List.iter (add_expr bv) el - | Pexp_ifthenelse(e1, e2, opte3) -> - add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 - | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_for( _, e1, e2, _, e3) -> - add_expr bv e1; add_expr bv e2; add_expr bv e3 - | Pexp_coerce(e1, (), ty3) -> - add_expr bv e1; - add_type bv ty3 - | Pexp_constraint(e1, ty2) -> - add_expr bv e1; - add_type bv ty2 - | Pexp_send(e, _m) -> add_expr bv e + | Pexp_ifthenelse (e1, e2, opte3) -> + add_expr bv e1; + add_expr bv e2; + add_opt add_expr bv opte3 + | Pexp_sequence (e1, e2) -> + add_expr bv e1; + add_expr bv e2 + | Pexp_while (e1, e2) -> + add_expr bv e1; + add_expr bv e2 + | Pexp_for (_, e1, e2, _, e3) -> + add_expr bv e1; + add_expr bv e2; + add_expr bv e3 + | Pexp_coerce (e1, (), ty3) -> + add_expr bv e1; + add_type bv ty3 + | Pexp_constraint (e1, ty2) -> + add_expr bv e1; + add_type bv ty2 + | Pexp_send (e, _m) -> add_expr bv e | Pexp_new li -> add bv li - | Pexp_setinstvar(_v, e) -> add_expr bv e + | Pexp_setinstvar (_v, e) -> add_expr bv e | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel - | Pexp_letmodule(id, m, e) -> - let b = add_module_binding bv m in - add_expr (StringMap.add id.txt b bv) e - | Pexp_letexception(_, e) -> add_expr bv e - | Pexp_assert (e) -> add_expr bv e - | Pexp_lazy (e) -> add_expr bv e - | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t + | Pexp_letmodule (id, m, e) -> + let b = add_module_binding bv m in + add_expr (StringMap.add id.txt b bv) e + | Pexp_letexception (_, e) -> add_expr bv e + | Pexp_assert e -> add_expr bv e + | Pexp_lazy e -> add_expr bv e + | Pexp_poly (e, t) -> + add_expr bv e; + add_opt add_type bv t | Pexp_object () -> () | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m | Pexp_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_expr bv e - | Pexp_extension (({ txt = ("ocaml.extension_constructor"| - "extension_constructor"); _ }, - PStr [item]) as e) -> - begin match item.pstr_desc with - | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c - | _ -> handle_extension e - end + let bv = open_module bv m.txt in + add_expr bv e + | Pexp_extension + (( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, + PStr [item] ) as e) -> ( + match item.pstr_desc with + | Pstr_eval ({pexp_desc = Pexp_construct (c, None)}, _) -> add bv c + | _ -> handle_extension e) | Pexp_extension e -> handle_extension e | Pexp_unreachable -> () -and add_cases bv cases = - List.iter (add_case bv) cases +and add_cases bv cases = List.iter (add_case bv) cases and add_case bv {pc_lhs; pc_guard; pc_rhs} = let bv = add_pattern bv pc_lhs in @@ -266,22 +315,21 @@ and add_bindings recf bv pel = and add_modtype bv mty = match mty.pmty_desc with - Pmty_ident l -> add bv l + | Pmty_ident l -> add bv l | Pmty_alias l -> addmodule bv l | Pmty_signature s -> add_signature bv s - | Pmty_functor(id, mty1, mty2) -> - Misc.may (add_modtype bv) mty1; - add_modtype (StringMap.add id.txt bound bv) mty2 - | Pmty_with(mty, cstrl) -> - add_modtype bv mty; - List.iter - (function - | Pwith_type (_, td) -> add_type_declaration bv td - | Pwith_module (_, lid) -> addmodule bv lid - | Pwith_typesubst (_, td) -> add_type_declaration bv td - | Pwith_modsubst (_, lid) -> addmodule bv lid - ) - cstrl + | Pmty_functor (id, mty1, mty2) -> + Misc.may (add_modtype bv) mty1; + add_modtype (StringMap.add id.txt bound bv) mty2 + | Pmty_with (mty, cstrl) -> + add_modtype bv mty; + List.iter + (function + | Pwith_type (_, td) -> add_type_declaration bv td + | Pwith_module (_, lid) -> addmodule bv lid + | Pwith_typesubst (_, td) -> add_type_declaration bv td + | Pwith_modsubst (_, lid) -> addmodule bv lid) + cstrl | Pmty_typeof m -> add_module bv m | Pmty_extension e -> handle_extension e @@ -289,108 +337,107 @@ and add_module_alias bv l = try add_parent bv l; lookup_map l.txt bv - with Not_found -> + with Not_found -> ( match l.txt with - Lident s -> make_leaf s - | _ -> addmodule bv l; bound (* cannot delay *) + | Lident s -> make_leaf s + | _ -> + addmodule bv l; + bound (* cannot delay *)) and add_modtype_binding bv mty = if not !Clflags.transparent_modules then add_modtype bv mty; match mty.pmty_desc with - Pmty_alias l -> - add_module_alias bv l - | Pmty_signature s -> - make_node (add_signature_binding bv s) - | Pmty_typeof modl -> - add_module_binding bv modl + | Pmty_alias l -> add_module_alias bv l + | Pmty_signature s -> make_node (add_signature_binding bv s) + | Pmty_typeof modl -> add_module_binding bv modl | _ -> - if !Clflags.transparent_modules then add_modtype bv mty; bound + if !Clflags.transparent_modules then add_modtype bv mty; + bound -and add_signature bv sg = - ignore (add_signature_binding bv sg) +and add_signature bv sg = ignore (add_signature_binding bv sg) and add_signature_binding bv sg = snd (List.fold_left add_sig_item (bv, StringMap.empty) sg) and add_sig_item (bv, m) item = match item.psig_desc with - Psig_value vd -> - add_type bv vd.pval_type; (bv, m) + | Psig_value vd -> + add_type bv vd.pval_type; + (bv, m) | Psig_type (_, dcls) -> - List.iter (add_type_declaration bv) dcls; (bv, m) + List.iter (add_type_declaration bv) dcls; + (bv, m) | Psig_typext te -> - add_type_extension bv te; (bv, m) + add_type_extension bv te; + (bv, m) | Psig_exception pext -> - add_extension_constructor bv pext; (bv, m) + add_extension_constructor bv pext; + (bv, m) | Psig_module pmd -> - let m' = add_modtype_binding bv pmd.pmd_type in - let add = StringMap.add pmd.pmd_name.txt m' in - (add bv, add m) + let m' = add_modtype_binding bv pmd.pmd_type in + let add = StringMap.add pmd.pmd_name.txt m' in + (add bv, add m) | Psig_recmodule decls -> - let add = - List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound) - decls - in - let bv' = add bv and m' = add m in - List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; - (bv', m') + let add = + List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound) decls + in + let bv' = add bv and m' = add m in + List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; + (bv', m') | Psig_modtype x -> - begin match x.pmtd_type with - None -> () - | Some mty -> add_modtype bv mty - end; - (bv, m) - | Psig_open od -> - (open_module bv od.popen_lid.txt, m) + (match x.pmtd_type with + | None -> () + | Some mty -> add_modtype bv mty); + (bv, m) + | Psig_open od -> (open_module bv od.popen_lid.txt, m) | Psig_include incl -> - let Node (s, m') = add_modtype_binding bv incl.pincl_mod in - add_names s; - let add = StringMap.fold StringMap.add m' in - (add bv, add m) - | Psig_class () -> - (bv, m) - | Psig_class_type () -> - (bv, m) + let (Node (s, m')) = add_modtype_binding bv incl.pincl_mod in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) + | Psig_class () -> (bv, m) + | Psig_class_type () -> (bv, m) | Psig_attribute _ -> (bv, m) | Psig_extension (e, _) -> - handle_extension e; - (bv, m) + handle_extension e; + (bv, m) and add_module_binding bv modl = if not !Clflags.transparent_modules then add_module bv modl; match modl.pmod_desc with - Pmod_ident l -> - begin try - add_parent bv l; - lookup_map l.txt bv - with Not_found -> - match l.txt with - Lident s -> make_leaf s - | _ -> addmodule bv l; bound - end - | Pmod_structure s -> - make_node (snd (add_structure_binding bv s)) + | Pmod_ident l -> ( + try + add_parent bv l; + lookup_map l.txt bv + with Not_found -> ( + match l.txt with + | Lident s -> make_leaf s + | _ -> + addmodule bv l; + bound)) + | Pmod_structure s -> make_node (snd (add_structure_binding bv s)) | _ -> - if !Clflags.transparent_modules then add_module bv modl; bound + if !Clflags.transparent_modules then add_module bv modl; + bound and add_module bv modl = match modl.pmod_desc with - Pmod_ident l -> addmodule bv l + | Pmod_ident l -> addmodule bv l | Pmod_structure s -> ignore (add_structure bv s) - | Pmod_functor(id, mty, modl) -> - Misc.may (add_modtype bv) mty; - add_module (StringMap.add id.txt bound bv) modl - | Pmod_apply(mod1, mod2) -> - add_module bv mod1; add_module bv mod2 - | Pmod_constraint(modl, mty) -> - add_module bv modl; add_modtype bv mty - | Pmod_unpack(e) -> - add_expr bv e - | Pmod_extension e -> - handle_extension e + | Pmod_functor (id, mty, modl) -> + Misc.may (add_modtype bv) mty; + add_module (StringMap.add id.txt bound bv) modl + | Pmod_apply (mod1, mod2) -> + add_module bv mod1; + add_module bv mod2 + | Pmod_constraint (modl, mty) -> + add_module bv modl; + add_modtype bv mty + | Pmod_unpack e -> add_expr bv e + | Pmod_extension e -> handle_extension e and add_structure bv item_list = - let (bv, m) = add_structure_binding bv item_list in + let bv, m = add_structure_binding bv item_list in add_names (collect_free (make_node m)); bv @@ -399,60 +446,55 @@ and add_structure_binding bv item_list = and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = match item.pstr_desc with - Pstr_eval (e, _attrs) -> - add_expr bv e; (bv, m) - | Pstr_value(rf, pel) -> - let bv = add_bindings rf bv pel in (bv, m) + | Pstr_eval (e, _attrs) -> + add_expr bv e; + (bv, m) + | Pstr_value (rf, pel) -> + let bv = add_bindings rf bv pel in + (bv, m) | Pstr_primitive vd -> - add_type bv vd.pval_type; (bv, m) + add_type bv vd.pval_type; + (bv, m) | Pstr_type (_, dcls) -> - List.iter (add_type_declaration bv) dcls; (bv, m) + List.iter (add_type_declaration bv) dcls; + (bv, m) | Pstr_typext te -> - add_type_extension bv te; - (bv, m) + add_type_extension bv te; + (bv, m) | Pstr_exception pext -> - add_extension_constructor bv pext; (bv, m) + add_extension_constructor bv pext; + (bv, m) | Pstr_module x -> - let b = add_module_binding bv x.pmb_expr in - let add = StringMap.add x.pmb_name.txt b in - (add bv, add m) + let b = add_module_binding bv x.pmb_expr in + let add = StringMap.add x.pmb_name.txt b in + (add bv, add m) | Pstr_recmodule bindings -> - let add = - List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings - in - let bv' = add bv and m = add m in - List.iter - (fun x -> add_module bv' x.pmb_expr) - bindings; - (bv', m) + let add = + List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings + in + let bv' = add bv and m = add m in + List.iter (fun x -> add_module bv' x.pmb_expr) bindings; + (bv', m) | Pstr_modtype x -> - begin match x.pmtd_type with - None -> () - | Some mty -> add_modtype bv mty - end; - (bv, m) - | Pstr_open od -> - (open_module bv od.popen_lid.txt, m) - | Pstr_class () -> - (bv,m) - | Pstr_class_type () -> - (bv, m) + (match x.pmtd_type with + | None -> () + | Some mty -> add_modtype bv mty); + (bv, m) + | Pstr_open od -> (open_module bv od.popen_lid.txt, m) + | Pstr_class () -> (bv, m) + | Pstr_class_type () -> (bv, m) | Pstr_include incl -> - let Node (s, m') = add_module_binding bv incl.pincl_mod in - add_names s; - let add = StringMap.fold StringMap.add m' in - (add bv, add m) + let (Node (s, m')) = add_module_binding bv incl.pincl_mod in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) | Pstr_attribute _ -> (bv, m) | Pstr_extension (e, _) -> - handle_extension e; - (bv, m) - + handle_extension e; + (bv, m) and add_implementation bv l = - if !Clflags.transparent_modules then - ignore (add_structure_binding bv l) + if !Clflags.transparent_modules then ignore (add_structure_binding bv l) else ignore (add_structure bv l) -and add_implementation_binding bv l = - snd (add_structure_binding bv l) - +and add_implementation_binding bv l = snd (add_structure_binding bv l) diff --git a/compiler/ml/depend.mli b/compiler/ml/depend.mli index 23ad60dd1f..b4fb4c884e 100644 --- a/compiler/ml/depend.mli +++ b/compiler/ml/depend.mli @@ -19,7 +19,7 @@ module StringSet : Set.S with type elt = string module StringMap : Map.S with type key = string type map_tree = Node of StringSet.t * bound_map -and bound_map = map_tree StringMap.t +and bound_map = map_tree StringMap.t val make_leaf : string -> map_tree val make_node : bound_map -> map_tree val weaken_map : StringSet.t -> map_tree -> map_tree @@ -31,8 +31,6 @@ val pp_deps : string list ref val open_module : bound_map -> Longident.t -> bound_map - - val add_signature : bound_map -> Parsetree.signature -> unit val add_implementation : bound_map -> Parsetree.structure -> unit diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index 1f34347025..30bfed3736 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -24,26 +24,23 @@ open Path open Types open Btype - - -let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = +let value_declarations : (string * Location.t, unit -> unit) Hashtbl.t = Hashtbl.create 16 - (* This table is used to usage of value declarations. A declaration is - identified with its name and location. The callback attached to a - declaration is called whenever the value is used explicitly - (lookup_value) or implicitly (inclusion test between signatures, - cf Includemod.value_descriptions). *) +(* This table is used to usage of value declarations. A declaration is + identified with its name and location. The callback attached to a + declaration is called whenever the value is used explicitly + (lookup_value) or implicitly (inclusion test between signatures, + cf Includemod.value_descriptions). *) let type_declarations = Hashtbl.create 16 let module_declarations = Hashtbl.create 16 type constructor_usage = Positive | Pattern | Privatize -type constructor_usages = - { - mutable cu_positive: bool; - mutable cu_pattern: bool; - mutable cu_privatize: bool; - } +type constructor_usages = { + mutable cu_positive: bool; + mutable cu_pattern: bool; + mutable cu_privatize: bool; +} let add_constructor_usage cu = function | Positive -> cu.cu_positive <- true | Pattern -> cu.cu_pattern <- true @@ -52,8 +49,8 @@ let constructor_usages () = {cu_positive = false; cu_pattern = false; cu_privatize = false} let used_constructors : - (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t - = Hashtbl.create 16 + (string * Location.t * string, constructor_usage -> unit) Hashtbl.t = + Hashtbl.create 16 let prefixed_sg = Hashtbl.create 113 @@ -69,33 +66,26 @@ exception Error of error let error err = raise (Error err) module EnvLazy : sig - type ('a,'b) t + type ('a, 'b) t type log - val force : ('a -> 'b) -> ('a,'b) t -> 'b - val create : 'a -> ('a,'b) t - val get_arg : ('a,'b) t -> 'a option + val force : ('a -> 'b) -> ('a, 'b) t -> 'b + val create : 'a -> ('a, 'b) t + val get_arg : ('a, 'b) t -> 'a option (* [force_logged log f t] is equivalent to [force f t] but if [f] returns [None] then [t] is recorded in [log]. [backtrack log] will then reset all the recorded [t]s back to their original state. *) val log : unit -> log - val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option + val force_logged : log -> ('a -> 'b option) -> ('a, 'b option) t -> 'b option val backtrack : log -> unit +end = struct + type ('a, 'b) t = ('a, 'b) eval ref -end = struct - - type ('a,'b) t = ('a,'b) eval ref + and ('a, 'b) eval = Done of 'b | Raise of exn | Thunk of 'a - and ('a,'b) eval = - | Done of 'b - | Raise of exn - | Thunk of 'a - - type undo = - | Nil - | Cons : ('a, 'b) t * 'a * undo -> undo + type undo = Nil | Cons : ('a, 'b) t * 'a * undo -> undo type log = undo ref @@ -103,56 +93,55 @@ end = struct match !x with | Done x -> x | Raise e -> raise e - | Thunk e -> - match f e with - | y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e + | Thunk e -> ( + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e) let get_arg x = - match !x with Thunk a -> Some a | _ -> None + match !x with + | Thunk a -> Some a + | _ -> None - let create x = - ref (Thunk x) + let create x = ref (Thunk x) - let log () = - ref Nil + let log () = ref Nil let force_logged log f x = match !x with | Done x -> x | Raise e -> raise e - | Thunk e -> + | Thunk e -> ( match f e with | None -> - x := Done None; - log := Cons(x, e, !log); - None + x := Done None; + log := Cons (x, e, !log); + None | Some _ as y -> - x := Done y; - y + x := Done y; + y | exception e -> - x := Raise e; - raise e + x := Raise e; + raise e) let backtrack log = let rec loop = function | Nil -> () - | Cons(x, e, rest) -> - x := Thunk e; - loop rest + | Cons (x, e, rest) -> + x := Thunk e; + loop rest in loop !log - end -module PathMap = Map.Make(Path) +module PathMap = Map.Make (Path) type summary = - Env_empty + | Env_empty | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration | Env_extension of summary * Ident.t * extension_constructor @@ -165,274 +154,239 @@ type summary = | Env_constraints of summary * type_declaration PathMap.t | Env_copy_types of summary * string list -module TycompTbl = - struct - (** This module is used to store components of types (i.e. labels +module TycompTbl = struct + (** This module is used to store components of types (i.e. labels and constructors). We keep a representation of each nested "open" and the set of local bindings between each of them. *) - type 'a t = { - current: 'a Ident.tbl; - (** Local bindings since the last open. *) - - opened: 'a opened option; - (** Symbolic representation of the last (innermost) open, if any. *) - } + type 'a t = { + current: 'a Ident.tbl; (** Local bindings since the last open. *) + opened: 'a opened option; + (** Symbolic representation of the last (innermost) open, if any. *) + } - and 'a opened = { - components: (string, 'a list) Tbl.t; - (** Components from the opened module. We keep a list of + and 'a opened = { + components: (string, 'a list) Tbl.t; + (** Components from the opened module. We keep a list of bindings for each name, as in comp_labels and comp_constrs. *) - - using: (string -> ('a * 'a) option -> unit) option; - (** A callback to be applied when a component is used from this + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this "open". This is used to detect unused "opens". The arguments are used to detect shadowing. *) + next: 'a t; (** The table before opening the module. *) + } - next: 'a t; - (** The table before opening the module. *) - } - - let empty = { current = Ident.empty; opened = None } - - let add id x tbl = - {tbl with current = Ident.add id x tbl.current} + let empty = {current = Ident.empty; opened = None} - let add_open slot wrap components next = - let using = - match slot with - | None -> None - | Some f -> Some (fun s x -> f s (wrap x)) - in - { - current = Ident.empty; - opened = Some {using; components; next}; - } + let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let rec find_same id tbl = - try Ident.find_same id tbl.current - with Not_found as exn -> - begin match tbl.opened with - | Some {next; _} -> find_same id next - | None -> raise exn - end - - let nothing = fun () -> () - - let mk_callback rest name desc = function - | None -> nothing - | Some f -> - (fun () -> - match rest with - | [] -> f name None - | (hidden, _) :: _ -> f name (Some (desc, hidden)) - ) - - let rec find_all name tbl = - List.map (fun (_id, desc) -> desc, nothing) - (Ident.find_all name tbl.current) @ - match tbl.opened with - | None -> [] - | Some {using; next; components} -> - let rest = find_all name next in - match Tbl.find_str name components with - | exception Not_found -> rest - | opened -> - List.map - (fun desc -> desc, mk_callback rest name desc using) - opened - @ rest - - let rec fold_name f tbl acc = - let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in - match tbl.opened with - | Some {using = _; next; components} -> - acc - |> Tbl.fold - (fun _name -> List.fold_right (fun desc -> f desc)) - components - |> fold_name f next - | None -> - acc + let add_open slot wrap components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + {current = Ident.empty; opened = Some {using; components; next}} - let rec local_keys tbl acc = - let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> ( match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc - - let diff_keys is_local tbl1 tbl2 = - let keys2 = local_keys tbl2 [] in - Ext_list.filter keys2 - (fun id -> - is_local (find_same id tbl2) && - try ignore (find_same id tbl1); false - with Not_found -> true) - - end - + | Some {next; _} -> find_same id next + | None -> raise exn) + + let nothing () = () + + let mk_callback rest name desc = function + | None -> nothing + | Some f -> ( + fun () -> + match rest with + | [] -> f name None + | (hidden, _) :: _ -> f name (Some (desc, hidden))) + + let rec find_all name tbl = + List.map + (fun (_id, desc) -> (desc, nothing)) + (Ident.find_all name tbl.current) + @ + match tbl.opened with + | None -> [] + | Some {using; next; components} -> ( + let rest = find_all name next in + match Tbl.find_str name components with + | exception Not_found -> rest + | opened -> + List.map (fun desc -> (desc, mk_callback rest name desc using)) opened + @ rest) + + let rec fold_name f tbl acc = + let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in + match tbl.opened with + | Some {using = _; next; components} -> + acc + |> Tbl.fold (fun _name -> List.fold_right (fun desc -> f desc)) components + |> fold_name f next + | None -> acc + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k :: accu) tbl.current acc in + match tbl.opened with + | Some o -> local_keys o.next acc + | None -> acc + + let diff_keys is_local tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + Ext_list.filter keys2 (fun id -> + is_local (find_same id tbl2) + && + try + ignore (find_same id tbl1); + false + with Not_found -> true) +end -module IdTbl = - struct - (** This module is used to store all kinds of components except +module IdTbl = struct + (** This module is used to store all kinds of components except (labels and constructors) in environments. We keep a representation of each nested "open" and the set of local bindings between each of them. *) + type 'a t = { + current: 'a Ident.tbl; (** Local bindings since the last open *) + opened: 'a opened option; + (** Symbolic representation of the last (innermost) open, if any. *) + } - type 'a t = { - current: 'a Ident.tbl; - (** Local bindings since the last open *) - - opened: 'a opened option; - (** Symbolic representation of the last (innermost) open, if any. *) - } - - and 'a opened = { - root: Path.t; - (** The path of the opened module, to be prefixed in front of + and 'a opened = { + root: Path.t; + (** The path of the opened module, to be prefixed in front of its local names to produce a valid path in the current environment. *) - - components: (string, 'a * int) Tbl.t; - (** Components from the opened module. *) - - using: (string -> ('a * 'a) option -> unit) option; - (** A callback to be applied when a component is used from this + components: (string, 'a * int) Tbl.t; + (** Components from the opened module. *) + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this "open". This is used to detect unused "opens". The arguments are used to detect shadowing. *) + next: 'a t; (** The table before opening the module. *) + } - next: 'a t; - (** The table before opening the module. *) - } - - let empty = { current = Ident.empty; opened = None } - - let add id x tbl = - {tbl with current = Ident.add id x tbl.current} - - let add_open slot wrap root components next = - let using = - match slot with - | None -> None - | Some f -> Some (fun s x -> f s (wrap x)) - in - { - current = Ident.empty; - opened = Some {using; root; components; next}; - } - - let rec find_same id tbl = - try Ident.find_same id tbl.current - with Not_found as exn -> - begin match tbl.opened with - | Some {next; _} -> find_same id next - | None -> raise exn - end - - let rec find_name mark name tbl = - try - let (id, desc) = Ident.find_name name tbl.current in - Pident id, desc - with Not_found as exn -> - begin match tbl.opened with - | Some {using; root; next; components} -> - begin try - let (descr, pos) = Tbl.find_str name components in - let res = Pdot (root, name, pos), descr in - if mark then begin match using with - | None -> () - | Some f -> - begin try f name (Some (snd (find_name false name next), snd res)) - with Not_found -> f name None - end - end; - res - with Not_found -> - find_name mark name next - end - | None -> - raise exn - end - - let find_name name tbl = find_name true name tbl - - let rec update name f tbl = - try - let (id, desc) = Ident.find_name name tbl.current in - let new_desc = f desc in - {tbl with current = Ident.add id new_desc tbl.current} - with Not_found -> - begin match tbl.opened with - | Some {root; using; next; components} -> - begin try - let (desc, pos) = Tbl.find_str name components in - let new_desc = f desc in - let components = Tbl.add name (new_desc, pos) components in - {tbl with opened = Some {root; using; next; components}} - with Not_found -> - let next = update name f next in - {tbl with opened = Some {root; using; next; components}} - end - | None -> - tbl - end + let empty = {current = Ident.empty; opened = None} + let add id x tbl = {tbl with current = Ident.add id x tbl.current} + let add_open slot wrap root components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + {current = Ident.empty; opened = Some {using; root; components; next}} - let rec find_all name tbl = - List.map (fun (id, desc) -> Pident id, desc) (Ident.find_all name tbl.current) @ + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> ( match tbl.opened with - | None -> [] - | Some {root; using = _; next; components} -> - try - let (desc, pos) = Tbl.find_str name components in - (Pdot (root, name, pos), desc) :: find_all name next - with Not_found -> - find_all name next - - let rec fold_name f tbl acc = - let acc = Ident.fold_name (fun id d -> f (Ident.name id) (Pident id, d)) tbl.current acc in - match tbl.opened with - | Some {root; using = _; next; components} -> - acc - |> Tbl.fold - (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) - components - |> fold_name f next - | None -> - acc + | Some {next; _} -> find_same id next + | None -> raise exn) - let rec local_keys tbl acc = - let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in + let rec find_name mark name tbl = + try + let id, desc = Ident.find_name name tbl.current in + (Pident id, desc) + with Not_found as exn -> ( match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc - - - let rec iter f tbl = - Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; + | Some {using; root; next; components} -> ( + try + let descr, pos = Tbl.find_str name components in + let res = (Pdot (root, name, pos), descr) in + (if mark then + match using with + | None -> () + | Some f -> ( + try f name (Some (snd (find_name false name next), snd res)) + with Not_found -> f name None)); + res + with Not_found -> find_name mark name next) + | None -> raise exn) + + let find_name name tbl = find_name true name tbl + + let rec update name f tbl = + try + let id, desc = Ident.find_name name tbl.current in + let new_desc = f desc in + {tbl with current = Ident.add id new_desc tbl.current} + with Not_found -> ( match tbl.opened with - | Some {root; using = _; next; components} -> - Tbl.iter - (fun s (x, pos) -> f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) - components; - iter f next - | None -> () - - let diff_keys tbl1 tbl2 = - let keys2 = local_keys tbl2 [] in - Ext_list.filter keys2 - (fun id -> - try ignore (find_same id tbl1); false - with Not_found -> true) - - - end + | Some {root; using; next; components} -> ( + try + let desc, pos = Tbl.find_str name components in + let new_desc = f desc in + let components = Tbl.add name (new_desc, pos) components in + {tbl with opened = Some {root; using; next; components}} + with Not_found -> + let next = update name f next in + {tbl with opened = Some {root; using; next; components}}) + | None -> tbl) + + let rec find_all name tbl = + List.map + (fun (id, desc) -> (Pident id, desc)) + (Ident.find_all name tbl.current) + @ + match tbl.opened with + | None -> [] + | Some {root; using = _; next; components} -> ( + try + let desc, pos = Tbl.find_str name components in + (Pdot (root, name, pos), desc) :: find_all name next + with Not_found -> find_all name next) + + let rec fold_name f tbl acc = + let acc = + Ident.fold_name + (fun id d -> f (Ident.name id) (Pident id, d)) + tbl.current acc + in + match tbl.opened with + | Some {root; using = _; next; components} -> + acc + |> Tbl.fold + (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) + components + |> fold_name f next + | None -> acc + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k :: accu) tbl.current acc in + match tbl.opened with + | Some o -> local_keys o.next acc + | None -> acc + + let rec iter f tbl = + Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; + match tbl.opened with + | Some {root; using = _; next; components} -> + Tbl.iter + (fun s (x, pos) -> + f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) + components; + iter f next + | None -> () + + let diff_keys tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + Ext_list.filter keys2 (fun id -> + try + ignore (find_same id tbl1); + false + with Not_found -> true) +end -type type_descriptions = - constructor_description list * label_description list +type type_descriptions = constructor_description list * label_description list let in_signature_flag = 0x01 let implicit_coercion_flag = 0x02 @@ -452,20 +406,20 @@ type t = { flags: int; } -and module_components = - { - deprecated: string option; - loc: Location.t; - comps: - (t * Subst.t * Path.t * Types.module_type, module_components_repr option) - EnvLazy.t; - } +and module_components = { + deprecated: string option; + loc: Location.t; + comps: + ( t * Subst.t * Path.t * Types.module_type, + module_components_repr option ) + EnvLazy.t; +} and module_components_repr = - Structure_comps of structure_components + | Structure_comps of structure_components | Functor_comps of functor_components -and 'a comp_tbl = (string, ('a * int)) Tbl.t +and 'a comp_tbl = (string, 'a * int) Tbl.t and structure_components = { mutable comp_values: value_description comp_tbl; @@ -473,24 +427,26 @@ and structure_components = { mutable comp_labels: (string, label_description list) Tbl.t; mutable comp_types: (type_declaration * type_descriptions) comp_tbl; mutable comp_modules: - (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl; + (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl; mutable comp_modtypes: modtype_declaration comp_tbl; mutable comp_components: module_components comp_tbl; (* warning -69*) } and functor_components = { - fcomp_param: Ident.t; (* Formal parameter *) - fcomp_arg: module_type option; (* Argument signature *) - fcomp_res: module_type; (* Result signature *) - fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) - fcomp_subst_cache: (Path.t, module_type) Hashtbl.t + fcomp_param: Ident.t; (* Formal parameter *) + fcomp_arg: module_type option; (* Argument signature *) + fcomp_res: module_type; (* Result signature *) + fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) + fcomp_subst_cache: (Path.t, module_type) Hashtbl.t; } let copy_local ~from env = - { env with + { + env with local_constraints = from.local_constraints; gadt_instances = from.gadt_instances; - flags = from.flags } + flags = from.flags; + } let same_constr = ref (fun _ _ _ -> assert false) @@ -504,37 +460,45 @@ let same_constr = ref (fun _ _ _ -> assert false) let check_shadowing env = function | `Constructor (Some (c1, c2)) when not (!same_constr env c1.cstr_res c2.cstr_res) -> - Some "constructor" - | `Label (Some (l1, l2)) - when not (!same_constr env l1.lbl_res l2.lbl_res) -> - Some "label" + Some "constructor" + | `Label (Some (l1, l2)) when not (!same_constr env l1.lbl_res l2.lbl_res) -> + Some "label" | `Value (Some _) -> Some "value" | `Type (Some _) -> Some "type" | `Module (Some _) | `Component (Some _) -> Some "module" | `Module_type (Some _) -> Some "module type" | `Constructor _ | `Label _ - | `Value None | `Type None | `Module None | `Module_type None + | `Value None + | `Type None + | `Module None + | `Module_type None | `Component None -> - None + None let subst_modtype_maker (subst, md) = if subst == Subst.identity then md else {md with md_type = Subst.modtype subst md.md_type} -let empty = { - values = IdTbl.empty; constrs = TycompTbl.empty; - labels = TycompTbl.empty; types = IdTbl.empty; - modules = IdTbl.empty; modtypes = IdTbl.empty; - components = IdTbl.empty; - summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = []; - flags = 0; - functor_args = Ident.empty; - } +let empty = + { + values = IdTbl.empty; + constrs = TycompTbl.empty; + labels = TycompTbl.empty; + types = IdTbl.empty; + modules = IdTbl.empty; + modtypes = IdTbl.empty; + components = IdTbl.empty; + summary = Env_empty; + local_constraints = PathMap.empty; + gadt_instances = []; + flags = 0; + functor_args = Ident.empty; + } let in_signature b env = let flags = if b then env.flags lor in_signature_flag - else env.flags land (lnot in_signature_flag) + else env.flags land lnot in_signature_flag in {env with flags} @@ -545,30 +509,27 @@ let is_in_signature env = env.flags land in_signature_flag <> 0 let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 let is_ident = function - Pident _ -> true + | Pident _ -> true | Pdot _ | Papply _ -> false let is_local_ext = function - | {cstr_tag = Cstr_extension(p)} -> is_ident p + | {cstr_tag = Cstr_extension p} -> is_ident p | _ -> false let diff env1 env2 = - IdTbl.diff_keys env1.values env2.values @ - TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @ - IdTbl.diff_keys env1.modules env2.modules + IdTbl.diff_keys env1.values env2.values + @ TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs + @ IdTbl.diff_keys env1.modules env2.modules -type can_load_cmis = - | Can_load_cmis - | Cannot_load_cmis of EnvLazy.log +type can_load_cmis = Can_load_cmis | Cannot_load_cmis of EnvLazy.log let can_load_cmis = ref Can_load_cmis let without_cmis f x = let log = EnvLazy.log () in let res = - Misc.(protect_refs - [R (can_load_cmis, Cannot_load_cmis log)] - (fun () -> f x)) + Misc.( + protect_refs [R (can_load_cmis, Cannot_load_cmis log)] (fun () -> f x)) in EnvLazy.backtrack log; res @@ -576,43 +537,52 @@ let without_cmis f x = (* Forward declarations *) let components_of_module' = - ref ((fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false) : - deprecated:string option -> loc:Location.t -> t -> Subst.t -> - Path.t -> module_type -> - module_components) + ref + (fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false + : deprecated:string option -> + loc:Location.t -> + t -> + Subst.t -> + Path.t -> + module_type -> + module_components) let components_of_module_maker' = - ref ((fun (_env, _sub, _path, _mty) -> assert false) : - t * Subst.t * Path.t * module_type -> module_components_repr option) + ref + (fun (_env, _sub, _path, _mty) -> assert false + : t * Subst.t * Path.t * module_type -> module_components_repr option) let components_of_functor_appl' = - ref ((fun _f _env _p1 _p2 -> assert false) : - functor_components -> t -> Path.t -> Path.t -> module_components) + ref + (fun _f _env _p1 _p2 -> assert false + : functor_components -> t -> Path.t -> Path.t -> module_components) let check_modtype_inclusion = (* to be filled with Includemod.check_modtype_inclusion *) - ref ((fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false) : - loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) + ref + (fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false + : loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) let strengthen = (* to be filled with Mtype.strengthen *) - ref ((fun ~aliasable:_ _env _mty _path -> assert false) : - aliasable:bool -> t -> module_type -> Path.t -> module_type) + ref + (fun ~aliasable:_ _env _mty _path -> assert false + : aliasable:bool -> t -> module_type -> Path.t -> module_type) -let md md_type = - {md_type; md_attributes=[]; md_loc=Location.none} +let md md_type = {md_type; md_attributes = []; md_loc = Location.none} let get_components_opt c = match !can_load_cmis with - | Can_load_cmis -> - EnvLazy.force !components_of_module_maker' c.comps + | Can_load_cmis -> EnvLazy.force !components_of_module_maker' c.comps | Cannot_load_cmis log -> EnvLazy.force_logged log !components_of_module_maker' c.comps let empty_structure = - Structure_comps { - comp_values = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; - comp_types = Tbl.empty; - comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; - comp_components = Tbl.empty; + Structure_comps + { + comp_values = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; + comp_types = Tbl.empty; + comp_modules = Tbl.empty; + comp_modtypes = Tbl.empty; + comp_components = Tbl.empty; } let get_components c = @@ -627,47 +597,48 @@ let current_unit = ref "" (* Persistent structure descriptions *) -type [@warning "-69"] pers_struct = - { ps_name: string; - ps_sig: signature Lazy.t; - ps_comps: module_components; - ps_crcs: (string * Digest.t option) list; - ps_filename: string; - ps_flags: pers_flags list } +type pers_struct = { + ps_name: string; + ps_sig: signature Lazy.t; + ps_comps: module_components; + ps_crcs: (string * Digest.t option) list; + ps_filename: string; + ps_flags: pers_flags list; +} +[@@warning "-69"] let persistent_structures = (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) (* Consistency between persistent structures *) -let crc_units = Consistbl.create() +let crc_units = Consistbl.create () -module StringSet = - Set.Make(struct type t = string let compare = String.compare end) +module StringSet = Set.Make (struct + type t = string + let compare = String.compare +end) let imported_units = ref StringSet.empty -let add_import s = - imported_units := StringSet.add s !imported_units - +let add_import s = imported_units := StringSet.add s !imported_units let clear_imports () = Consistbl.clear crc_units; imported_units := StringSet.empty - let check_consistency ps = try List.iter (fun (name, crco) -> - match crco with - None -> () - | Some crc -> - add_import name; - Consistbl.check crc_units name crc ps.ps_filename) - ps.ps_crcs; - with Consistbl.Inconsistency(name, source, auth) -> - error (Inconsistent_import(name, auth, source)) + match crco with + | None -> () + | Some crc -> + add_import name; + Consistbl.check crc_units name crc ps.ps_filename) + ps.ps_crcs + with Consistbl.Inconsistency (name, source, auth) -> + error (Inconsistent_import (name, auth, source)) (* Reading persistent structures from .cmi files *) @@ -678,41 +649,43 @@ let save_pers_struct crc ps = add_import modname module Persistent_signature = struct - type t = - { filename : string; - cmi : Cmi_format.cmi_infos } - - let load = ref (fun ~unit_name -> - match find_in_path_uncap !load_path (unit_name ^ ".cmi") with - | filename -> Some { filename; cmi = read_cmi filename } - | exception Not_found -> None) + type t = {filename: string; cmi: Cmi_format.cmi_infos} + + let load = + ref (fun ~unit_name -> + match find_in_path_uncap !load_path (unit_name ^ ".cmi") with + | filename -> Some {filename; cmi = read_cmi filename} + | exception Not_found -> None) end -let acknowledge_pers_struct check modname - { Persistent_signature.filename; cmi } = +let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = let name = cmi.cmi_name in let sign = cmi.cmi_sign in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in let deprecated = - List.fold_left (fun _ -> function Deprecated s -> Some s ) None - flags + List.fold_left + (fun _ -> function + | Deprecated s -> Some s) + None flags in let comps = - !components_of_module' ~deprecated ~loc:Location.none - empty Subst.identity - (Pident(Ident.create_persistent name)) - (Mty_signature sign) + !components_of_module' ~deprecated ~loc:Location.none empty Subst.identity + (Pident (Ident.create_persistent name)) + (Mty_signature sign) + in + let ps = + { + ps_name = name; + ps_sig = lazy (Subst.signature Subst.identity sign); + ps_comps = comps; + ps_crcs = crcs; + ps_filename = filename; + ps_flags = flags; + } in - let ps = { ps_name = name; - ps_sig = lazy (Subst.signature Subst.identity sign); - ps_comps = comps; - ps_crcs = crcs; - ps_filename = filename; - ps_flags = flags; - } in if ps.ps_name <> modname then - error (Illegal_renaming(modname, ps.ps_name, filename)); + error (Illegal_renaming (modname, ps.ps_name, filename)); if check then check_consistency ps; Hashtbl.add persistent_structures modname (Some ps); ps @@ -720,75 +693,65 @@ let acknowledge_pers_struct check modname let read_pers_struct check modname filename = add_import modname; let cmi = read_cmi filename in - acknowledge_pers_struct check modname - { Persistent_signature.filename; cmi } + acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} let find_pers_struct check name = if name = "*predef*" then raise Not_found; match Hashtbl.find persistent_structures name with | Some ps -> ps | None -> raise Not_found - | exception Not_found -> + | exception Not_found -> ( match !can_load_cmis with | Cannot_load_cmis _ -> raise Not_found | Can_load_cmis -> - let ps = - match !Persistent_signature.load ~unit_name:name with - | Some ps -> ps - | None -> - Hashtbl.add persistent_structures name None; - raise Not_found - in - add_import name; - acknowledge_pers_struct check name ps + let ps = + match !Persistent_signature.load ~unit_name:name with + | Some ps -> ps + | None -> + Hashtbl.add persistent_structures name None; + raise Not_found + in + add_import name; + acknowledge_pers_struct check name ps) (* Emits a warning if there is no valid cmi for name *) let check_pers_struct name = - try - ignore (find_pers_struct false name) - with + try ignore (find_pers_struct false name) with | Not_found -> - let warn = Warnings.No_cmi_file(name, None) in - Location.prerr_warning Location.none warn + let warn = Warnings.No_cmi_file (name, None) in + Location.prerr_warning Location.none warn | Cmi_format.Error err -> - let msg = Format.asprintf "%a" Cmi_format.report_error err in - let warn = Warnings.No_cmi_file(name, Some msg) in - Location.prerr_warning Location.none warn + let msg = Format.asprintf "%a" Cmi_format.report_error err in + let warn = Warnings.No_cmi_file (name, Some msg) in + Location.prerr_warning Location.none warn | Error err -> - let msg = - match err with - | Illegal_renaming(name, ps_name, filename) -> - Format.asprintf - " %a@ contains the compiled interface for @ \ - %s when %s was expected" - Location.print_filename filename ps_name name - | Inconsistent_import _ -> assert false - | Need_recursive_types(name, _) -> - Format.sprintf - "%s uses recursive types" - name - | Missing_module _ -> assert false - | Illegal_value_name _ -> assert false - in - let warn = Warnings.No_cmi_file(name, Some msg) in - Location.prerr_warning Location.none warn + let msg = + match err with + | Illegal_renaming (name, ps_name, filename) -> + Format.asprintf + " %a@ contains the compiled interface for @ %s when %s was expected" + Location.print_filename filename ps_name name + | Inconsistent_import _ -> assert false + | Need_recursive_types (name, _) -> + Format.sprintf "%s uses recursive types" name + | Missing_module _ -> assert false + | Illegal_value_name _ -> assert false + in + let warn = Warnings.No_cmi_file (name, Some msg) in + Location.prerr_warning Location.none warn -let read_pers_struct modname filename = - read_pers_struct true modname filename +let read_pers_struct modname filename = read_pers_struct true modname filename -let find_pers_struct name = - find_pers_struct true name +let find_pers_struct name = find_pers_struct true name let check_pers_struct name = - if not (Hashtbl.mem persistent_structures name) then begin + if not (Hashtbl.mem persistent_structures name) then ( (* PR#6843: record the weak dependency ([add_import]) regardless of whether the check succeeds, to help make builds more deterministic. *) add_import name; - if (Warnings.is_active (Warnings.No_cmi_file("", None))) then - Delayed_checks.add_delayed_check - (fun () -> check_pers_struct name) - end + if Warnings.is_active (Warnings.No_cmi_file ("", None)) then + Delayed_checks.add_delayed_check (fun () -> check_pers_struct name)) let reset_cache () = current_unit := ""; @@ -814,192 +777,169 @@ let reset_cache_toplevel () = Hashtbl.clear used_constructors; Hashtbl.clear prefixed_sg +let set_unit_name name = current_unit := name -let set_unit_name name = - current_unit := name - -let get_unit_name () = - !current_unit +let get_unit_name () = !current_unit (* Lookup by identifier *) let rec find_module_descr path env = match path with - Pident id -> - begin try - IdTbl.find_same id env.components - with Not_found -> - if Ident.persistent id && not (Ident.name id = !current_unit) - then (find_pers_struct (Ident.name id)).ps_comps - else raise Not_found - end - | Pdot(p, s, _pos) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let (descr, _pos) = Tbl.find_str s c.comp_components in - descr - | Functor_comps _ -> - raise Not_found - end - | Papply(p1, p2) -> - begin match get_components (find_module_descr p1 env) with - Functor_comps f -> - !components_of_functor_appl' f env p1 p2 - | Structure_comps _ -> - raise Not_found - end + | Pident id -> ( + try IdTbl.find_same id env.components + with Not_found -> + if Ident.persistent id && not (Ident.name id = !current_unit) then + (find_pers_struct (Ident.name id)).ps_comps + else raise Not_found) + | Pdot (p, s, _pos) -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let descr, _pos = Tbl.find_str s c.comp_components in + descr + | Functor_comps _ -> raise Not_found) + | Papply (p1, p2) -> ( + match get_components (find_module_descr p1 env) with + | Functor_comps f -> !components_of_functor_appl' f env p1 p2 + | Structure_comps _ -> raise Not_found) let find proj1 proj2 path env = match path with - Pident id -> - IdTbl.find_same id (proj1 env) - | Pdot(p, s, _pos) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let (data, _pos) = Tbl.find_str s (proj2 c) in data - | Functor_comps _ -> - raise Not_found - end - | Papply _ -> - raise Not_found + | Pident id -> IdTbl.find_same id (proj1 env) + | Pdot (p, s, _pos) -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s (proj2 c) in + data + | Functor_comps _ -> raise Not_found) + | Papply _ -> raise Not_found + +let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) -let find_value = - find (fun env -> env.values) (fun sc -> sc.comp_values) -and find_type_full = - find (fun env -> env.types) (fun sc -> sc.comp_types) -and find_modtype = - find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) +and find_type_full = find (fun env -> env.types) (fun sc -> sc.comp_types) + +and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) let type_of_cstr path = function | {cstr_inlined = Some d; _} -> - (d, ([], List.map snd (Datarepr.labels_of_type path d))) - | _ -> - assert false + (d, ([], List.map snd (Datarepr.labels_of_type path d))) + | _ -> assert false let find_type_full path env = match Path.constructor_typath path with - | Regular p -> - (try (PathMap.find p env.local_constraints, ([], [])) - with Not_found -> find_type_full p env) + | Regular p -> ( + try (PathMap.find p env.local_constraints, ([], [])) + with Not_found -> find_type_full p env) | Cstr (ty_path, s) -> - let (_, (cstrs, _)) = - try find_type_full ty_path env - with Not_found -> assert false - in - let cstr = - try List.find (fun cstr -> cstr.cstr_name = s) cstrs - with Not_found -> assert false - in - type_of_cstr path cstr + let _, (cstrs, _) = + try find_type_full ty_path env with Not_found -> assert false + in + let cstr = + try List.find (fun cstr -> cstr.cstr_name = s) cstrs + with Not_found -> assert false + in + type_of_cstr path cstr | LocalExt id -> - let cstr = - try TycompTbl.find_same id env.constrs - with Not_found -> assert false - in - type_of_cstr path cstr - | Ext (mod_path, s) -> - let comps = - try find_module_descr mod_path env - with Not_found -> assert false - in - let comps = - match get_components comps with - | Structure_comps c -> c - | Functor_comps _ -> assert false - in - let exts = - Ext_list.filter - (try Tbl.find_str s comps.comp_constrs - with Not_found -> assert false) - (function {cstr_tag=Cstr_extension _} -> true | _ -> false) - - in - match exts with - | [cstr] -> type_of_cstr path cstr - | _ -> assert false + let cstr = + try TycompTbl.find_same id env.constrs with Not_found -> assert false + in + type_of_cstr path cstr + | Ext (mod_path, s) -> ( + let comps = + try find_module_descr mod_path env with Not_found -> assert false + in + let comps = + match get_components comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + Ext_list.filter + (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false) + (function + | {cstr_tag = Cstr_extension _} -> true + | _ -> false) + in -let find_type p env = - fst (find_type_full p env) -let find_type_descrs p env = - snd (find_type_full p env) + match exts with + | [cstr] -> type_of_cstr path cstr + | _ -> assert false) + +let find_type p env = fst (find_type_full p env) +let find_type_descrs p env = snd (find_type_full p env) let find_module ~alias path env = match path with - Pident id -> - begin try - let data = IdTbl.find_same id env.modules in - EnvLazy.force subst_modtype_maker data - with Not_found -> - if Ident.persistent id && not (Ident.name id = !current_unit) then - let ps = find_pers_struct (Ident.name id) in - md (Mty_signature(Lazy.force ps.ps_sig)) - else raise Not_found - end - | Pdot(p, s, _pos) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let (data, _pos) = Tbl.find_str s c.comp_modules in - EnvLazy.force subst_modtype_maker data - | Functor_comps _ -> - raise Not_found - end - | Papply(p1, p2) -> - let desc1 = find_module_descr p1 env in - begin match get_components desc1 with - Functor_comps f -> - md begin match f.fcomp_res with - | Mty_alias _ as mty -> mty - | mty -> - if alias then mty else - try - Hashtbl.find f.fcomp_subst_cache p2 - with Not_found -> - let mty = - Subst.modtype - (Subst.add_module f.fcomp_param p2 Subst.identity) - f.fcomp_res in - Hashtbl.add f.fcomp_subst_cache p2 mty; - mty - end - | Structure_comps _ -> - raise Not_found - end - - + | Pident id -> ( + try + let data = IdTbl.find_same id env.modules in + EnvLazy.force subst_modtype_maker data + with Not_found -> + if Ident.persistent id && not (Ident.name id = !current_unit) then + let ps = find_pers_struct (Ident.name id) in + md (Mty_signature (Lazy.force ps.ps_sig)) + else raise Not_found) + | Pdot (p, s, _pos) -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s c.comp_modules in + EnvLazy.force subst_modtype_maker data + | Functor_comps _ -> raise Not_found) + | Papply (p1, p2) -> ( + let desc1 = find_module_descr p1 env in + match get_components desc1 with + | Functor_comps f -> + md + (match f.fcomp_res with + | Mty_alias _ as mty -> mty + | mty -> ( + if alias then mty + else + try Hashtbl.find f.fcomp_subst_cache p2 + with Not_found -> + let mty = + Subst.modtype + (Subst.add_module f.fcomp_param p2 Subst.identity) + f.fcomp_res + in + Hashtbl.add f.fcomp_subst_cache p2 mty; + mty)) + | Structure_comps _ -> raise Not_found) let rec normalize_path lax env path = let path = match path with - Pdot(p, s, pos) -> - Pdot(normalize_path lax env p, s, pos) - | Papply(p1, p2) -> - Papply(normalize_path lax env p1, normalize_path true env p2) + | Pdot (p, s, pos) -> Pdot (normalize_path lax env p, s, pos) + | Papply (p1, p2) -> + Papply (normalize_path lax env p1, normalize_path true env p2) | _ -> path in - try match find_module ~alias:true path env with - {md_type=Mty_alias(_, path1)} -> - normalize_path lax env path1 - | _ -> path - with Not_found when lax - || (match path with Pident id -> not (Ident.persistent id) | _ -> true) -> - path + try + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path + with + | Not_found + when lax + || + match path with + | Pident id -> not (Ident.persistent id) + | _ -> true + -> + path let normalize_path oloc env path = try normalize_path (oloc = None) env path - with Not_found -> - match oloc with None -> assert false + with Not_found -> ( + match oloc with + | None -> assert false | Some loc -> - raise (Error(Missing_module(loc, path, normalize_path true env path))) + raise (Error (Missing_module (loc, path, normalize_path true env path)))) let normalize_path_prefix oloc env path = match path with - Pdot(p, s, pos) -> - Pdot(normalize_path oloc env p, s, pos) - | Pident _ -> - path - | Papply _ -> - assert false - + | Pdot (p, s, pos) -> Pdot (normalize_path oloc env p, s, pos) + | Pident _ -> path + | Papply _ -> assert false let find_module = find_module ~alias:false @@ -1009,10 +949,11 @@ let find_module = find_module ~alias:false let find_type_expansion path env = let decl = find_type path env in match decl.type_manifest with - | Some body when decl.type_private = Public - || decl.type_kind <> Type_abstract - || Btype.has_constr_row body -> - (decl.type_params, body, may_map snd decl.type_newtype_level) + | Some body + when decl.type_private = Public + || decl.type_kind <> Type_abstract + || Btype.has_constr_row body -> + (decl.type_params, body, may_map snd decl.type_newtype_level) (* The manifest type of Private abstract data types without private row are still considered unknown to the type system. Hence, this case is caught by the following clause that also handles @@ -1038,10 +979,11 @@ let find_modtype_expansion path env = let rec is_functor_arg path env = match path with - Pident id -> - begin try Ident.find_same id env.functor_args; true - with Not_found -> false - end + | Pident id -> ( + try + Ident.find_same id env.functor_args; + true + with Not_found -> false) | Pdot (p, _s, _) -> is_functor_arg p env | Papply _ -> true @@ -1050,53 +992,50 @@ let rec is_functor_arg path env = exception Recmodule let report_deprecated ?loc p deprecated = - match loc, deprecated with + match (loc, deprecated) with | Some loc, Some txt -> - let txt = if txt = "" then "" else "\n" ^ txt in - Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt) + let txt = if txt = "" then "" else "\n" ^ txt in + Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt) | _ -> () let mark_module_used env name loc = if not (is_implicit_coercion env) then - try Hashtbl.find module_declarations (name, loc) () - with Not_found -> () + try Hashtbl.find module_declarations (name, loc) () with Not_found -> () let rec lookup_module_descr_aux ?loc lid env = match lid with - Lident s -> - begin try - IdTbl.find_name s env.components - with Not_found -> - if s = !current_unit then raise Not_found; - let ps = find_pers_struct s in - (Pident(Ident.create_persistent s), ps.ps_comps) - end - | Ldot(l, s) -> - let (p, descr) = lookup_module_descr ?loc l env in - begin match get_components descr with - Structure_comps c -> - let (descr, pos) = Tbl.find_str s c.comp_components in - (Pdot(p, s, pos), descr) - | Functor_comps _ -> - raise Not_found - end - | Lapply(l1, l2) -> - let (p1, desc1) = lookup_module_descr ?loc l1 env in - let p2 = lookup_module ~load:true ?loc l2 env in - let {md_type=mty2} = find_module p2 env in - begin match get_components desc1 with - Functor_comps f -> - let loc = match loc with Some l -> l | None -> Location.none in - Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; - (Papply(p1, p2), !components_of_functor_appl' f env p1 p2) - | Structure_comps _ -> - raise Not_found - end + | Lident s -> ( + try IdTbl.find_name s env.components + with Not_found -> + if s = !current_unit then raise Not_found; + let ps = find_pers_struct s in + (Pident (Ident.create_persistent s), ps.ps_comps)) + | Ldot (l, s) -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let descr, pos = Tbl.find_str s c.comp_components in + (Pdot (p, s, pos), descr) + | Functor_comps _ -> raise Not_found) + | Lapply (l1, l2) -> ( + let p1, desc1 = lookup_module_descr ?loc l1 env in + let p2 = lookup_module ~load:true ?loc l2 env in + let {md_type = mty2} = find_module p2 env in + match get_components desc1 with + | Functor_comps f -> + let loc = + match loc with + | Some l -> l + | None -> Location.none + in + Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; + (Papply (p1, p2), !components_of_functor_appl' f env p1 p2) + | Structure_comps _ -> raise Not_found) and lookup_module_descr ?loc lid env = - let (p, comps) as res = lookup_module_descr_aux ?loc lid env in + let ((p, comps) as res) = lookup_module_descr_aux ?loc lid env in mark_module_used env (Path.last p) comps.loc; -(* + (* Format.printf "USE module %s at %a@." (Path.last p) Location.print comps.loc; *) @@ -1105,131 +1044,122 @@ and lookup_module_descr ?loc lid env = and lookup_module ~load ?loc lid env : Path.t = match lid with - Lident s -> - begin try - let (p, data) = IdTbl.find_name s env.modules in - let {md_loc; md_attributes; md_type} = - EnvLazy.force subst_modtype_maker data - in - mark_module_used env s md_loc; - begin match md_type with - | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" -> - (* see #5965 *) - raise Recmodule - | Mty_alias (_, Path.Pident id) -> - if not !Clflags.transparent_modules && Ident.persistent id then - find_pers_struct (Ident.name id) |> ignore - | _ -> () - end; - report_deprecated ?loc p - (Builtin_attributes.deprecated_of_attrs md_attributes); - p - with Not_found -> - if s = !current_unit then raise Not_found; - let p = Pident(Ident.create_persistent s) in - if !Clflags.transparent_modules && not load then check_pers_struct s - else begin - let ps = find_pers_struct s in - report_deprecated ?loc p ps.ps_comps.deprecated - end; - p - end - | Ldot(l, s) -> - let (p, descr) = lookup_module_descr ?loc l env in - begin match get_components descr with - Structure_comps c -> - let (_data, pos) = Tbl.find_str s c.comp_modules in - let (comps, _) = Tbl.find_str s c.comp_components in - mark_module_used env s comps.loc; - let p = Pdot(p, s, pos) in - report_deprecated ?loc p comps.deprecated; - p - | Functor_comps _ -> - raise Not_found - end - | Lapply(l1, l2) -> - let (p1, desc1) = lookup_module_descr ?loc l1 env in - let p2 = lookup_module ~load:true ?loc l2 env in - let {md_type=mty2} = find_module p2 env in - let p = Papply(p1, p2) in - begin match get_components desc1 with - Functor_comps f -> - let loc = match loc with Some l -> l | None -> Location.none in - Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; - p - | Structure_comps _ -> - raise Not_found - end + | Lident s -> ( + try + let p, data = IdTbl.find_name s env.modules in + let {md_loc; md_attributes; md_type} = + EnvLazy.force subst_modtype_maker data + in + mark_module_used env s md_loc; + (match md_type with + | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" -> + (* see #5965 *) + raise Recmodule + | Mty_alias (_, Path.Pident id) -> + if (not !Clflags.transparent_modules) && Ident.persistent id then + find_pers_struct (Ident.name id) |> ignore + | _ -> ()); + report_deprecated ?loc p + (Builtin_attributes.deprecated_of_attrs md_attributes); + p + with Not_found -> + if s = !current_unit then raise Not_found; + let p = Pident (Ident.create_persistent s) in + (if !Clflags.transparent_modules && not load then check_pers_struct s + else + let ps = find_pers_struct s in + report_deprecated ?loc p ps.ps_comps.deprecated); + p) + | Ldot (l, s) -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let _data, pos = Tbl.find_str s c.comp_modules in + let comps, _ = Tbl.find_str s c.comp_components in + mark_module_used env s comps.loc; + let p = Pdot (p, s, pos) in + report_deprecated ?loc p comps.deprecated; + p + | Functor_comps _ -> raise Not_found) + | Lapply (l1, l2) -> ( + let p1, desc1 = lookup_module_descr ?loc l1 env in + let p2 = lookup_module ~load:true ?loc l2 env in + let {md_type = mty2} = find_module p2 env in + let p = Papply (p1, p2) in + match get_components desc1 with + | Functor_comps f -> + let loc = + match loc with + | Some l -> l + | None -> Location.none + in + Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; + p + | Structure_comps _ -> raise Not_found) let lookup proj1 proj2 ?loc lid env = match lid with - Lident s -> - IdTbl.find_name s (proj1 env) - | Ldot(l, s) -> - let (p, desc) = lookup_module_descr ?loc l env in - begin match get_components desc with - Structure_comps c -> - let (data, pos) = Tbl.find_str s (proj2 c) in - (Pdot(p, s, pos), data) - | Functor_comps _ -> - raise Not_found - end - | Lapply _ -> - raise Not_found + | Lident s -> IdTbl.find_name s (proj1 env) + | Ldot (l, s) -> ( + let p, desc = lookup_module_descr ?loc l env in + match get_components desc with + | Structure_comps c -> + let data, pos = Tbl.find_str s (proj2 c) in + (Pdot (p, s, pos), data) + | Functor_comps _ -> raise Not_found) + | Lapply _ -> raise Not_found let lookup_all_simple proj1 proj2 shadow ?loc lid env = match lid with - Lident s -> - let xl = TycompTbl.find_all s (proj1 env) in - let rec do_shadow = - function - | [] -> [] - | ((x, f) :: xs) -> - (x, f) :: - (do_shadow (Ext_list.filter xs (fun (y, _) -> not (shadow x y)))) - in - do_shadow xl - | Ldot(l, s) -> - let (_p, desc) = lookup_module_descr ?loc l env in - begin match get_components desc with - Structure_comps c -> - let comps = - try Tbl.find_str s (proj2 c) with Not_found -> [] - in - List.map - (fun data -> (data, (fun () -> ()))) - comps - | Functor_comps _ -> - raise Not_found - end - | Lapply _ -> - raise Not_found + | Lident s -> + let xl = TycompTbl.find_all s (proj1 env) in + let rec do_shadow = function + | [] -> [] + | (x, f) :: xs -> + (x, f) + :: do_shadow (Ext_list.filter xs (fun (y, _) -> not (shadow x y))) + in + do_shadow xl + | Ldot (l, s) -> ( + let _p, desc = lookup_module_descr ?loc l env in + match get_components desc with + | Structure_comps c -> + let comps = try Tbl.find_str s (proj2 c) with Not_found -> [] in + List.map (fun data -> (data, fun () -> ())) comps + | Functor_comps _ -> raise Not_found) + | Lapply _ -> raise Not_found let has_local_constraints env = not (PathMap.is_empty env.local_constraints) let cstr_shadow cstr1 cstr2 = - match cstr1.cstr_tag, cstr2.cstr_tag with + match (cstr1.cstr_tag, cstr2.cstr_tag) with | Cstr_extension _, Cstr_extension _ -> true | _ -> false let lbl_shadow _lbl1 _lbl2 = false -let lookup_value = - lookup (fun env -> env.values) (fun sc -> sc.comp_values) +let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) let lookup_all_constructors = - lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) + lookup_all_simple + (fun env -> env.constrs) + (fun sc -> sc.comp_constrs) cstr_shadow let lookup_all_labels = - lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) + lookup_all_simple + (fun env -> env.labels) + (fun sc -> sc.comp_labels) lbl_shadow -let lookup_type = - lookup (fun env -> env.types) (fun sc -> sc.comp_types) +let lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) let lookup_modtype = lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) let copy_types l env = - let f desc = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in - let values = List.fold_left (fun env s -> IdTbl.update s f env) env.values l in + let f desc = + {desc with val_type = Subst.type_expr Subst.identity desc.val_type} + in + let values = + List.fold_left (fun env s -> IdTbl.update s f env) env.values l + in {env with values; summary = Env_copy_types (env.summary, l)} let mark_value_used env name vd = @@ -1257,31 +1187,32 @@ let set_value_used_callback name vd callback = let key = (name, vd.val_loc) in try let old = Hashtbl.find value_declarations key in - Hashtbl.replace value_declarations key (fun () -> old (); callback ()) - (* this is to support cases like: - let x = let x = 1 in x in x - where the two declarations have the same location - (e.g. resulting from Camlp4 expansion of grammar entries) *) - with Not_found -> - Hashtbl.add value_declarations key callback + Hashtbl.replace value_declarations key (fun () -> + old (); + callback ()) + (* this is to support cases like: + let x = let x = 1 in x in x + where the two declarations have the same location + (e.g. resulting from Camlp4 expansion of grammar entries) *) + with Not_found -> Hashtbl.add value_declarations key callback let set_type_used_callback name td callback = let loc = td.type_loc in if loc.Location.loc_ghost then () - else let key = (name, loc) in - let old = - try Hashtbl.find type_declarations key - with Not_found -> assert false - in - Hashtbl.replace type_declarations key (fun () -> callback old) + else + let key = (name, loc) in + let old = + try Hashtbl.find type_declarations key with Not_found -> assert false + in + Hashtbl.replace type_declarations key (fun () -> callback old) let lookup_value ?loc lid env = - let (_, desc) as r = lookup_value ?loc lid env in + let ((_, desc) as r) = lookup_value ?loc lid env in mark_value_used env (Longident.last lid) desc; r let lookup_type ?loc lid env = - let (path, (decl, _)) = lookup_type ?loc lid env in + let path, (decl, _) = lookup_type ?loc lid env in mark_type_used env (Longident.last lid) decl; path @@ -1293,19 +1224,19 @@ let mark_type_path env path = let ty_path t = match repr t with - | {desc=Tconstr(path, _, _)} -> path + | {desc = Tconstr (path, _, _)} -> path | _ -> assert false let lookup_constructor ?loc lid env = match lookup_all_constructors ?loc lid env with - [] -> raise Not_found + | [] -> raise Not_found | (desc, use) :: _ -> - mark_type_path env (ty_path desc.cstr_res); - use (); - desc + mark_type_path env (ty_path desc.cstr_res); + use (); + desc let is_lident = function - Lident _ -> true + | Lident _ -> true | _ -> false let lookup_all_constructors ?loc lid env = @@ -1316,32 +1247,31 @@ let lookup_all_constructors ?loc lid env = use () in List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs - with - Not_found when is_lident lid -> [] + with Not_found when is_lident lid -> [] let mark_constructor usage env name desc = - if not (is_implicit_coercion env) - then match desc.cstr_tag with - | Cstr_extension _ -> - begin - let ty_path = ty_path desc.cstr_res in - let ty_name = Path.last ty_path in - try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage - with Not_found -> () - end - | _ -> + if not (is_implicit_coercion env) then + match desc.cstr_tag with + | Cstr_extension _ -> ( + let ty_path = ty_path desc.cstr_res in + let ty_name = Path.last ty_path in + try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage + with Not_found -> ()) + | _ -> let ty_path = ty_path desc.cstr_res in - let ty_decl = try find_type ty_path env with Not_found -> assert false in + let ty_decl = + try find_type ty_path env with Not_found -> assert false + in let ty_name = Path.last ty_path in mark_constructor_used usage env ty_name ty_decl name let lookup_label ?loc lid env = match lookup_all_labels ?loc lid env with - [] -> raise Not_found + | [] -> raise Not_found | (desc, use) :: _ -> - mark_type_path env (ty_path desc.lbl_res); - use (); - desc + mark_type_path env (ty_path desc.lbl_res); + use (); + desc let lookup_all_labels ?loc lid env = try @@ -1351,9 +1281,7 @@ let lookup_all_labels ?loc lid env = use () in List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls - with - Not_found when is_lident lid -> [] - + with Not_found when is_lident lid -> [] (* Iter on an environment (ignoring the body of functors and not yet evaluated structures) *) @@ -1363,13 +1291,14 @@ let iter_env_cont = ref [] let rec scrape_alias_for_visit env mty = match mty with - | Mty_alias(_, Pident id) + | Mty_alias (_, Pident id) when Ident.persistent id - && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false - | Mty_alias(_, path) -> (* PR#6600: find_module may raise Not_found *) - begin try scrape_alias_for_visit env (find_module path env).md_type - with Not_found -> false - end + && not (Hashtbl.mem persistent_structures (Ident.name id)) -> + false + | Mty_alias (_, path) -> ( + (* PR#6600: find_module may raise Not_found *) + try scrape_alias_for_visit env (find_module path env).md_type + with Not_found -> false) | _ -> true let iter_env proj1 proj2 f env () = @@ -1381,9 +1310,10 @@ let iter_env proj1 proj2 f env () = | None -> true | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty in - if not visit then () else - match get_components mcomps with - Structure_comps comps -> + if not visit then () + else + match get_components mcomps with + | Structure_comps comps -> Tbl.iter (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) (proj2 comps); @@ -1391,15 +1321,17 @@ let iter_env proj1 proj2 f env () = (fun s (c, n) -> iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c) comps.comp_components - | Functor_comps _ -> () - in iter_env_cont := (path, cont) :: !iter_env_cont + | Functor_comps _ -> () + in + iter_env_cont := (path, cont) :: !iter_env_cont in Hashtbl.iter (fun s pso -> - match pso with None -> () + match pso with + | None -> () | Some ps -> - let id = Pident (Ident.create_persistent s) in - iter_components id id ps.ps_comps) + let id = Pident (Ident.create_persistent s) in + iter_components id id ps.ps_comps) persistent_structures; IdTbl.iter (fun id (path, comps) -> iter_components (Pident id) path comps) @@ -1419,109 +1351,108 @@ let same_types env1 env2 = let used_persistent () = let r = ref Concr.empty in - Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r) + Hashtbl.iter + (fun s pso -> if pso != None then r := Concr.add s !r) persistent_structures; !r -let find_all_comps proj s (p,mcomps) = +let find_all_comps proj s (p, mcomps) = match get_components mcomps with - Functor_comps _ -> [] - | Structure_comps comps -> - try let (c,n) = Tbl.find_str s (proj comps) in [Pdot(p,s,n), c] - with Not_found -> [] + | Functor_comps _ -> [] + | Structure_comps comps -> ( + try + let c, n = Tbl.find_str s (proj comps) in + [(Pdot (p, s, n), c)] + with Not_found -> []) let rec find_shadowed_comps path env = match path with - Pident id -> - IdTbl.find_all (Ident.name id) env.components + | Pident id -> IdTbl.find_all (Ident.name id) env.components | Pdot (p, s, _) -> - let l = find_shadowed_comps p env in - let l' = - List.map (find_all_comps (fun comps -> comps.comp_components) s) l in - List.flatten l' + let l = find_shadowed_comps p env in + let l' = + List.map (find_all_comps (fun comps -> comps.comp_components) s) l + in + List.flatten l' | Papply _ -> [] let find_shadowed proj1 proj2 path env = match path with - Pident id -> - IdTbl.find_all (Ident.name id) (proj1 env) + | Pident id -> IdTbl.find_all (Ident.name id) (proj1 env) | Pdot (p, s, _) -> - let l = find_shadowed_comps p env in - let l' = List.map (find_all_comps proj2 s) l in - List.flatten l' + let l = find_shadowed_comps p env in + let l' = List.map (find_all_comps proj2 s) l in + List.flatten l' | Papply _ -> [] let find_shadowed_types path env = List.map fst (find_shadowed - (fun env -> env.types) (fun comps -> comps.comp_types) path env) - + (fun env -> env.types) + (fun comps -> comps.comp_types) + path env) (* GADT instance tracking *) let add_gadt_instance_level lv env = - {env with - gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} + {env with gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} -let is_Tlink = function {desc = Tlink _} -> true | _ -> false +let is_Tlink = function + | {desc = Tlink _} -> true + | _ -> false let gadt_instance_level env t = let rec find_instance = function - [] -> None + | [] -> None | (lv, r) :: rem -> - if TypeSet.exists is_Tlink !r then - (* Should we use set_typeset ? *) - r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; - if TypeSet.mem t !r then Some lv else find_instance rem - in find_instance env.gadt_instances + if TypeSet.exists is_Tlink !r then + (* Should we use set_typeset ? *) + r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; + if TypeSet.mem t !r then Some lv else find_instance rem + in + find_instance env.gadt_instances let add_gadt_instances env lv tl = let r = - try List.assoc lv env.gadt_instances with Not_found -> assert false in + try List.assoc lv env.gadt_instances with Not_found -> assert false + in (* Format.eprintf "Added"; - List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; - Format.eprintf "@."; *) + List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; + Format.eprintf "@."; *) set_typeset r (List.fold_right TypeSet.add tl !r) (* Only use this after expand_head! *) let add_gadt_instance_chain env lv t = let r = - try List.assoc lv env.gadt_instances with Not_found -> assert false in + try List.assoc lv env.gadt_instances with Not_found -> assert false + in let rec add_instance t = let t = repr t in - if not (TypeSet.mem t !r) then begin + if not (TypeSet.mem t !r) then ( (* Format.eprintf "@ %a" !Btype.print_raw t; *) set_typeset r (TypeSet.add t !r); match t.desc with - Tconstr (p, _, memo) -> - may add_instance (find_expans Private p !memo) - | _ -> () - end + | Tconstr (p, _, memo) -> may add_instance (find_expans Private p !memo) + | _ -> ()) in (* Format.eprintf "Added chain"; *) add_instance t - (* Format.eprintf "@." *) +(* Format.eprintf "@." *) (* Expand manifest module type names at the top of the given module type *) let rec scrape_alias env ?path mty = - match mty, path with - Mty_ident p, _ -> - begin try - scrape_alias env (find_modtype_expansion p env) ?path - with Not_found -> - mty - end - | Mty_alias(_, path), _ -> - begin try - scrape_alias env (find_module path env).md_type ~path - with Not_found -> - (*Location.prerr_warning Location.none - (Warnings.No_cmi_file (Path.name path));*) - mty - end - | mty, Some path -> - !strengthen ~aliasable:true env mty path + match (mty, path) with + | Mty_ident p, _ -> ( + try scrape_alias env (find_modtype_expansion p env) ?path + with Not_found -> mty) + | Mty_alias (_, path), _ -> ( + try scrape_alias env (find_module path env).md_type ~path + with Not_found -> + (*Location.prerr_warning Location.none + (Warnings.No_cmi_file (Path.name path));*) + mty) + | mty, Some path -> !strengthen ~aliasable:true env mty path | _ -> mty let scrape_alias env mty = scrape_alias env mty @@ -1530,236 +1461,231 @@ let scrape_alias env mty = scrape_alias env mty by the root path and build the corresponding substitution. *) let rec prefix_idents root pos sub = function - [] -> ([], sub) - | Sig_value(id, decl) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in - let (pl, final_sub) = prefix_idents root nextpos sub rem in - (p::pl, final_sub) - | Sig_type(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, nopos) in - let (pl, final_sub) = - prefix_idents root pos (Subst.add_type id p sub) rem in - (p::pl, final_sub) - | Sig_typext(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - (* we extend the substitution in case of an inlined record *) - let (pl, final_sub) = - prefix_idents root (pos+1) (Subst.add_type id p sub) rem in - (p::pl, final_sub) - | Sig_module(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - let (pl, final_sub) = - prefix_idents root (pos+1) (Subst.add_module id p sub) rem in - (p::pl, final_sub) - | Sig_modtype(id, _) :: rem -> - let p = Pdot(root, Ident.name id, nopos) in - let (pl, final_sub) = - prefix_idents root pos - (Subst.add_modtype id (Mty_ident p) sub) rem in - (p::pl, final_sub) - | Sig_class _ :: _ -> - assert false - | Sig_class_type _ :: _ -> - assert false + | [] -> ([], sub) + | Sig_value (id, decl) :: rem -> + let p = Pdot (root, Ident.name id, pos) in + let nextpos = + match decl.val_kind with + | Val_prim _ -> pos + | _ -> pos + 1 + in + let pl, final_sub = prefix_idents root nextpos sub rem in + (p :: pl, final_sub) + | Sig_type (id, _, _) :: rem -> + let p = Pdot (root, Ident.name id, nopos) in + let pl, final_sub = prefix_idents root pos (Subst.add_type id p sub) rem in + (p :: pl, final_sub) + | Sig_typext (id, _, _) :: rem -> + let p = Pdot (root, Ident.name id, pos) in + (* we extend the substitution in case of an inlined record *) + let pl, final_sub = + prefix_idents root (pos + 1) (Subst.add_type id p sub) rem + in + (p :: pl, final_sub) + | Sig_module (id, _, _) :: rem -> + let p = Pdot (root, Ident.name id, pos) in + let pl, final_sub = + prefix_idents root (pos + 1) (Subst.add_module id p sub) rem + in + (p :: pl, final_sub) + | Sig_modtype (id, _) :: rem -> + let p = Pdot (root, Ident.name id, nopos) in + let pl, final_sub = + prefix_idents root pos (Subst.add_modtype id (Mty_ident p) sub) rem + in + (p :: pl, final_sub) + | Sig_class _ :: _ -> assert false + | Sig_class_type _ :: _ -> assert false let prefix_idents root sub sg = - if sub = Subst.identity then + if sub = Subst.identity then ( let sgs = - try - Hashtbl.find prefixed_sg root + try Hashtbl.find prefixed_sg root with Not_found -> let sgs = ref [] in Hashtbl.add prefixed_sg root sgs; sgs in - try - List.assq sg !sgs + try List.assq sg !sgs with Not_found -> let r = prefix_idents root 0 sub sg in sgs := (sg, r) :: !sgs; - r - else - prefix_idents root 0 sub sg + r) + else prefix_idents root 0 sub sg (* Compute structure descriptions *) let add_to_tbl id decl tbl = - let decls = - try Tbl.find_str id tbl with Not_found -> [] in + let decls = try Tbl.find_str id tbl with Not_found -> [] in Tbl.add id (decl :: decls) tbl let rec components_of_module ~deprecated ~loc env sub path mty = - { - deprecated; - loc; - comps = EnvLazy.create (env, sub, path, mty) - } + {deprecated; loc; comps = EnvLazy.create (env, sub, path, mty)} and components_of_module_maker (env, sub, path, mty) = match scrape_alias env mty with - Mty_signature sg -> - let c = - { comp_values = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; comp_types = Tbl.empty; - comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; - comp_components = Tbl.empty; - } in - let pl, sub = prefix_idents path sub sg in - let env = ref env in - let pos = ref 0 in - List.iter2 (fun item path -> + | Mty_signature sg -> + let c = + { + comp_values = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; + comp_types = Tbl.empty; + comp_modules = Tbl.empty; + comp_modtypes = Tbl.empty; + comp_components = Tbl.empty; + } + in + let pl, sub = prefix_idents path sub sg in + let env = ref env in + let pos = ref 0 in + List.iter2 + (fun item path -> match item with - Sig_value(id, decl) -> - let decl' = Subst.value_description sub decl in - c.comp_values <- - Tbl.add (Ident.name id) (decl', !pos) c.comp_values; - begin match decl.val_kind with - Val_prim _ -> () | _ -> incr pos - end - | Sig_type(id, decl, _) -> - let decl' = Subst.type_declaration sub decl in - Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); - 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) - c.comp_types; - List.iter - (fun descr -> - c.comp_constrs <- - add_to_tbl descr.cstr_name descr c.comp_constrs) - constructors; - List.iter - (fun descr -> - c.comp_labels <- - add_to_tbl descr.lbl_name descr c.comp_labels) - labels; - env := store_type_infos id decl !env - | Sig_typext(id, ext, _) -> - let ext' = Subst.extension_constructor sub ext in - let descr = Datarepr.extension_descr path ext' in - c.comp_constrs <- - add_to_tbl (Ident.name id) descr c.comp_constrs; - incr pos - | Sig_module(id, md, _) -> - let md' = EnvLazy.create (sub, md) in - c.comp_modules <- - Tbl.add (Ident.name id) (md', !pos) c.comp_modules; - let deprecated = - Builtin_attributes.deprecated_of_attrs md.md_attributes - in - let comps = - components_of_module ~deprecated ~loc:md.md_loc !env sub path - md.md_type - in - c.comp_components <- - Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module ~check:false id md !env; - incr pos - | Sig_modtype(id, decl) -> - let decl' = Subst.modtype_declaration sub decl in - c.comp_modtypes <- - Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; - env := store_modtype id decl !env + | Sig_value (id, decl) -> ( + let decl' = Subst.value_description sub decl in + c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; + match decl.val_kind with + | Val_prim _ -> () + | _ -> incr pos) + | Sig_type (id, decl, _) -> + let decl' = Subst.type_declaration sub decl in + Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); + 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) + c.comp_types; + List.iter + (fun descr -> + c.comp_constrs <- add_to_tbl descr.cstr_name descr c.comp_constrs) + constructors; + List.iter + (fun descr -> + c.comp_labels <- add_to_tbl descr.lbl_name descr c.comp_labels) + labels; + env := store_type_infos id decl !env + | Sig_typext (id, ext, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = Datarepr.extension_descr path ext' in + c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; + incr pos + | Sig_module (id, md, _) -> + let md' = EnvLazy.create (sub, md) in + c.comp_modules <- Tbl.add (Ident.name id) (md', !pos) c.comp_modules; + let deprecated = + Builtin_attributes.deprecated_of_attrs md.md_attributes + in + let comps = + components_of_module ~deprecated ~loc:md.md_loc !env sub path + md.md_type + in + c.comp_components <- + Tbl.add (Ident.name id) (comps, !pos) c.comp_components; + env := store_module ~check:false id md !env; + incr pos + | Sig_modtype (id, decl) -> + let decl' = Subst.modtype_declaration sub decl in + c.comp_modtypes <- + Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; + env := store_modtype id decl !env | Sig_class () -> assert false | Sig_class_type () -> assert false) - sg pl; - Some (Structure_comps c) - | Mty_functor(param, ty_arg, ty_res) -> - Some (Functor_comps { - fcomp_param = param; - (* fcomp_arg and fcomp_res must be prefixed eagerly, because - they are interpreted in the outer environment *) - fcomp_arg = may_map (Subst.modtype sub) ty_arg; - fcomp_res = Subst.modtype sub ty_res; - fcomp_cache = Hashtbl.create 17; - fcomp_subst_cache = Hashtbl.create 17 }) - | Mty_ident _ - | Mty_alias _ -> None + sg pl; + Some (Structure_comps c) + | Mty_functor (param, ty_arg, ty_res) -> + Some + (Functor_comps + { + fcomp_param = param; + (* fcomp_arg and fcomp_res must be prefixed eagerly, because + they are interpreted in the outer environment *) + fcomp_arg = may_map (Subst.modtype sub) ty_arg; + fcomp_res = Subst.modtype sub ty_res; + fcomp_cache = Hashtbl.create 17; + fcomp_subst_cache = Hashtbl.create 17; + }) + | Mty_ident _ | Mty_alias _ -> None (* Insertion of bindings by identifier + path *) and check_usage loc id warn tbl = - if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin + if (not loc.Location.loc_ghost) && Warnings.is_active (warn "") then ( let name = Ident.name id in let key = (name, loc) in if Hashtbl.mem tbl key then () - else let used = ref false in - Hashtbl.add tbl key (fun () -> used := true); - if not (name = "" || name.[0] = '_' || name.[0] = '#') - then - Delayed_checks.add_delayed_check - (fun () -> if not !used then Location.prerr_warning loc (warn name)) - end; + else + let used = ref false in + Hashtbl.add tbl key (fun () -> used := true); + if not (name = "" || name.[0] = '_' || name.[0] = '#') then + Delayed_checks.add_delayed_check (fun () -> + if not !used then Location.prerr_warning loc (warn name))) and check_value_name name loc = (* Note: we could also check here general validity of the identifier, to protect against bad identifiers forged by -pp or -ppx preprocessors. *) - if name = "|." then raise (Error(Illegal_value_name(loc, name))) - else if String.length name > 0 && (name.[0] = '#') then + if name = "|." then raise (Error (Illegal_value_name (loc, name))) + else if String.length name > 0 && name.[0] = '#' then for i = 1 to String.length name - 1 do - if name.[i] = '#' then - raise (Error(Illegal_value_name(loc, name))) + if name.[i] = '#' then raise (Error (Illegal_value_name (loc, name))) done - and store_value ?check id decl env = check_value_name (Ident.name id) decl.val_loc; may (fun f -> check_usage decl.val_loc id f value_declarations) check; - { env with + { + env with values = IdTbl.add id decl env.values; - summary = Env_value(env.summary, id, decl) } + summary = Env_value (env.summary, id, decl); + } and store_type ~check id info env = let loc = info.type_loc in if check then - check_usage loc id (fun s -> Warnings.Unused_type_declaration s) + check_usage loc id + (fun s -> Warnings.Unused_type_declaration s) type_declarations; let path = Pident id 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 && - Warnings.is_active (Warnings.Unused_constructor ("", false, false)) - then begin - let ty = Ident.name id in - List.iter - begin fun (_, {cstr_name = c; _}) -> - let k = (ty, loc, c) in - if not (Hashtbl.mem used_constructors k) then - let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); - if not (ty = "" || ty.[0] = '_') - then Delayed_checks.add_delayed_check - (fun () -> - if not (is_in_signature env) && not used.cu_positive then - Location.prerr_warning loc - (Warnings.Unused_constructor - (c, used.cu_pattern, used.cu_privatize))) - end - constructors - end; - { env with + (if + check + && (not loc.Location.loc_ghost) + && Warnings.is_active (Warnings.Unused_constructor ("", false, false)) + then + let ty = Ident.name id in + List.iter + (fun (_, {cstr_name = c; _}) -> + let k = (ty, loc, c) in + if not (Hashtbl.mem used_constructors k) then ( + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); + if not (ty = "" || ty.[0] = '_') then + Delayed_checks.add_delayed_check (fun () -> + if (not (is_in_signature env)) && not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_constructor + (c, used.cu_pattern, used.cu_privatize))))) + constructors); + { + env with constrs = List.fold_right (fun (id, descr) constrs -> TycompTbl.add id descr constrs) - constructors - env.constrs; + constructors env.constrs; labels = List.fold_right (fun (id, descr) labels -> TycompTbl.add id descr labels) - labels - env.labels; - types = - IdTbl.add id (info, descrs) env.types; - summary = Env_type(env.summary, id, info) } + labels env.labels; + types = IdTbl.add id (info, descrs) env.types; + summary = Env_type (env.summary, id, info); + } and store_type_infos id info env = (* Simplified version of store_type that doesn't compute and store @@ -1767,71 +1693,73 @@ and store_type_infos id info env = manifest-ness of the type. Used in components_of_module to keep track of type abbreviations (e.g. type t = float) in the computation of label representations. *) - { env with - types = IdTbl.add id (info,([],[])) - env.types; - summary = Env_type(env.summary, id, info) } + { + env with + types = IdTbl.add id (info, ([], [])) env.types; + summary = Env_type (env.summary, id, info); + } and store_extension ~check id ext env = let loc = ext.ext_loc in - if check && not loc.Location.loc_ghost && - Warnings.is_active (Warnings.Unused_extension ("", false, false, false)) - then begin - let ty = Path.last ext.ext_type_path in - let n = Ident.name id in - let k = (ty, loc, n) in - if not (Hashtbl.mem used_constructors k) then begin - let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); - Delayed_checks.add_delayed_check - (fun () -> - if not (is_in_signature env) && not used.cu_positive then - Location.prerr_warning loc - (Warnings.Unused_extension - (n, ext.ext_is_exception, used.cu_pattern, used.cu_privatize) - ) - ) - end; - end; - { env with - constrs = TycompTbl.add id - (Datarepr.extension_descr (Pident id) ext) - env.constrs; - summary = Env_extension(env.summary, id, ext) } + (if + check + && (not loc.Location.loc_ghost) + && Warnings.is_active (Warnings.Unused_extension ("", false, false, false)) + then + let ty = Path.last ext.ext_type_path in + let n = Ident.name id in + let k = (ty, loc, n) in + if not (Hashtbl.mem used_constructors k) then ( + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); + Delayed_checks.add_delayed_check (fun () -> + if (not (is_in_signature env)) && not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_extension + (n, ext.ext_is_exception, used.cu_pattern, used.cu_privatize))))); + { + env with + constrs = + TycompTbl.add id (Datarepr.extension_descr (Pident id) ext) env.constrs; + summary = Env_extension (env.summary, id, ext); + } and store_module ~check id md env = let loc = md.md_loc in if check then - check_usage loc id (fun s -> Warnings.Unused_module s) - module_declarations; + check_usage loc id (fun s -> Warnings.Unused_module s) module_declarations; let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in - { env with + { + env with modules = IdTbl.add id (EnvLazy.create (Subst.identity, md)) env.modules; components = IdTbl.add id - (components_of_module ~deprecated ~loc:md.md_loc - env Subst.identity (Pident id) md.md_type) + (components_of_module ~deprecated ~loc:md.md_loc env Subst.identity + (Pident id) md.md_type) env.components; - summary = Env_module(env.summary, id, md) } + summary = Env_module (env.summary, id, md); + } and store_modtype id info env = - { env with + { + env with modtypes = IdTbl.add id info env.modtypes; - summary = Env_modtype(env.summary, id, info) } + summary = Env_modtype (env.summary, id, info); + } (* Compute the components of a functor application in a path. *) let components_of_functor_appl f env p1 p2 = - try - Hashtbl.find f.fcomp_cache p2 + try Hashtbl.find f.fcomp_cache p2 with Not_found -> - let p = Papply(p1, p2) in + let p = Papply (p1, p2) in let sub = Subst.add_module f.fcomp_param p2 Subst.identity in let mty = Subst.modtype sub f.fcomp_res in - let comps = components_of_module ~deprecated:None ~loc:Location.none - (*???*) - env Subst.identity p mty in + let comps = + components_of_module ~deprecated:None ~loc:Location.none (*???*) + env Subst.identity p mty + in Hashtbl.add f.fcomp_cache p2 comps; comps @@ -1845,57 +1773,56 @@ let _ = (* Insertion of bindings by identifier *) let add_functor_arg id env = - {env with - functor_args = Ident.add id () env.functor_args; - summary = Env_functor_arg (env.summary, id)} + { + env with + functor_args = Ident.add id () env.functor_args; + summary = Env_functor_arg (env.summary, id); + } -let add_value ?check id desc env = - store_value ?check id desc env +let add_value ?check id desc env = store_value ?check id desc env -let add_type ~check id info env = - store_type ~check id info env +let add_type ~check id info env = store_type ~check id info env -and add_extension ~check id ext env = - store_extension ~check id ext env +and add_extension ~check id ext env = store_extension ~check id ext env -and add_module_declaration ?(arg=false) ~check id md env = +and add_module_declaration ?(arg = false) ~check id md env = let env = store_module ~check id md env in if arg then add_functor_arg id env else env -and add_modtype id info env = - store_modtype id info env - +and add_modtype id info env = store_modtype id info env let add_module ?arg id mty env = add_module_declaration ~check:false ?arg id (md mty) env let add_local_type path info env = - { env with - local_constraints = PathMap.add path info env.local_constraints } + {env with local_constraints = PathMap.add path info env.local_constraints} let add_local_constraint path info elv env = match info with - {type_manifest = Some _; type_newtype_level = Some (lv, _)} -> - (* elv is the expansion level, lv is the definition level *) - let info = {info with type_newtype_level = Some (lv, elv)} in - add_local_type path info env + | {type_manifest = Some _; type_newtype_level = Some (lv, _)} -> + (* elv is the expansion level, lv is the definition level *) + let info = {info with type_newtype_level = Some (lv, elv)} in + add_local_type path info env | _ -> assert false - (* Insertion of bindings by name *) let enter store_fun name data env = - let id = Ident.create name in (id, store_fun id data env) + let id = Ident.create name in + (id, store_fun id data env) let enter_value ?check = enter (store_value ?check) + and enter_type = enter (store_type ~check:true) + and enter_extension = enter (store_extension ~check:true) + and enter_module_declaration ?arg id md env = add_module_declaration ?arg ~check:true id md env - (* let (id, env) = enter store_module name md env in - (id, add_functor_arg ?arg id env) *) -and enter_modtype = enter store_modtype +(* let (id, env) = enter store_module name md env in + (id, add_functor_arg ?arg id env) *) +and enter_modtype = enter store_modtype let enter_module ?arg s mty env = let id = Ident.create s in @@ -1905,41 +1832,33 @@ let enter_module ?arg s mty env = let add_item comp env = match comp with - 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 ~check:false id md env - | Sig_modtype(id, decl) -> add_modtype id decl env - | Sig_class () -> 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 ~check:false id md env + | Sig_modtype (id, decl) -> add_modtype id decl env + | Sig_class () -> env | Sig_class_type () -> env let rec add_signature sg env = match sg with - [] -> env + | [] -> env | comp :: rem -> add_signature rem (add_item comp env) (* Open a signature path *) let add_components slot root env0 comps = - let add_l w comps env0 = - TycompTbl.add_open slot w comps env0 - in + let add_l w comps env0 = TycompTbl.add_open slot w comps env0 in let add w comps env0 = IdTbl.add_open slot w root comps env0 in let constrs = add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs in - let labels = - add_l (fun x -> `Label x) comps.comp_labels env0.labels - in + let labels = add_l (fun x -> `Label x) comps.comp_labels env0.labels in - let values = - add (fun x -> `Value x) comps.comp_values env0.values - in - let types = - add (fun x -> `Type x) comps.comp_types env0.types - in + let values = add (fun x -> `Value x) comps.comp_values env0.values in + let types = add (fun x -> `Type x) comps.comp_types env0.types in let modtypes = add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes in @@ -1947,12 +1866,11 @@ let add_components slot root env0 comps = add (fun x -> `Component x) comps.comp_components env0.components in - let modules = - add (fun x -> `Module x) comps.comp_modules env0.modules - in + let modules = add (fun x -> `Module x) comps.comp_modules env0.modules in - { env0 with - summary = Env_open(env0.summary, root); + { + env0 with + summary = Env_open (env0.summary, root); constrs; labels; values; @@ -1967,48 +1885,43 @@ let open_signature slot root env0 = | Functor_comps _ -> None | Structure_comps comps -> Some (add_components slot root env0 comps) - (* Open a signature from a file *) let open_pers_signature name env = - match open_signature None (Pident(Ident.create_persistent name)) env with + match open_signature None (Pident (Ident.create_persistent name)) env with | Some env -> env | None -> assert false (* a compilation unit cannot refer to a functor *) -let open_signature - ?(used_slot = ref false) - ?(loc = Location.none) ?(toplevel = false) ovf root env = - if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost - && (Warnings.is_active (Warnings.Unused_open "") - || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) - || Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))) - then begin +let open_signature ?(used_slot = ref false) ?(loc = Location.none) + ?(toplevel = false) ovf root env = + if + (not toplevel) && ovf = Asttypes.Fresh + && (not loc.Location.loc_ghost) + && (Warnings.is_active (Warnings.Unused_open "") + || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) + || Warnings.is_active (Warnings.Open_shadow_label_constructor ("", ""))) + then ( let used = used_slot in - Delayed_checks.add_delayed_check - (fun () -> - if not !used then begin - used := true; - Location.prerr_warning loc (Warnings.Unused_open (Path.name root)) - end - ); + Delayed_checks.add_delayed_check (fun () -> + if not !used then ( + used := true; + Location.prerr_warning loc (Warnings.Unused_open (Path.name root)))); let shadowed = ref [] in let slot s b = - begin match check_shadowing env b with + (match check_shadowing env b with | Some kind when not (List.mem (kind, s) !shadowed) -> - shadowed := (kind, s) :: !shadowed; - let w = - match kind with - | "label" | "constructor" -> - Warnings.Open_shadow_label_constructor (kind, s) - | _ -> Warnings.Open_shadow_identifier (kind, s) - in - Location.prerr_warning loc w - | _ -> () - end; + shadowed := (kind, s) :: !shadowed; + let w = + match kind with + | "label" | "constructor" -> + Warnings.Open_shadow_label_constructor (kind, s) + | _ -> Warnings.Open_shadow_identifier (kind, s) + in + Location.prerr_warning loc w + | _ -> ()); used := true in - open_signature (Some slot) root env - end + open_signature (Some slot) root env) else open_signature None root env (* Read a signature from a file *) @@ -2021,62 +1934,60 @@ let read_signature modname filename = let crc_of_unit name = let ps = find_pers_struct name in - let crco = - try - List.assoc name ps.ps_crcs - with Not_found -> - assert false - in - match crco with - None -> assert false - | Some crc -> crc + let crco = try List.assoc name ps.ps_crcs with Not_found -> assert false in + match crco with + | None -> assert false + | Some crc -> crc (* Return the list of imported interfaces with their CRCs *) let imports () = - let dont_record_crc_unit = !Clflags.dont_record_crc_unit in - match dont_record_crc_unit with + let dont_record_crc_unit = !Clflags.dont_record_crc_unit in + match dont_record_crc_unit with | None -> Consistbl.extract (StringSet.elements !imported_units) crc_units - | Some x -> - Consistbl.extract - (StringSet.fold - (fun m acc -> if m = x then acc else m::acc) - !imported_units []) crc_units + | Some x -> + Consistbl.extract + (StringSet.fold + (fun m acc -> if m = x then acc else m :: acc) + !imported_units []) + crc_units (* Save a signature to a file *) -let save_signature_with_imports ?check_exists ~deprecated sg modname filename imports = +let save_signature_with_imports ?check_exists ~deprecated sg modname filename + imports = (*prerr_endline filename; - List.iter (fun (name, crc) -> prerr_endline name) imports;*) + List.iter (fun (name, crc) -> prerr_endline name) imports;*) Btype.cleanup_abbrev (); Subst.reset_for_saving (); let sg = Subst.signature (Subst.for_saving Subst.identity) sg in let flags = - (match deprecated with Some s -> [Deprecated s] | None -> []) + match deprecated with + | Some s -> [Deprecated s] + | None -> [] in try - let cmi = { - cmi_name = modname; - cmi_sign = sg; - cmi_crcs = imports; - cmi_flags = flags; - } in - let crc = - create_cmi ?check_exists filename cmi in + let cmi = + {cmi_name = modname; cmi_sign = sg; cmi_crcs = imports; cmi_flags = flags} + in + let crc = create_cmi ?check_exists filename cmi in (* Enter signature in persistent table so that imported_unit() will also return its crc *) let comps = - components_of_module ~deprecated ~loc:Location.none - empty Subst.identity - (Pident(Ident.create_persistent modname)) (Mty_signature sg) in + components_of_module ~deprecated ~loc:Location.none empty Subst.identity + (Pident (Ident.create_persistent modname)) + (Mty_signature sg) + in let ps = - { ps_name = modname; + { + ps_name = modname; ps_sig = lazy (Subst.signature Subst.identity sg); ps_comps = comps; ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; ps_flags = cmi.cmi_flags; - } in + } + in save_pers_struct crc ps; cmi with exn -> @@ -2084,99 +1995,88 @@ let save_signature_with_imports ?check_exists ~deprecated sg modname filename im raise exn let save_signature ?check_exists ~deprecated sg modname filename = - save_signature_with_imports ?check_exists ~deprecated sg modname filename (imports()) + save_signature_with_imports ?check_exists ~deprecated sg modname filename + (imports ()) (* Folding on environments *) let find_all proj1 proj2 f lid env acc = match lid with - | None -> - IdTbl.fold_name - (fun name (p, data) acc -> f name p data acc) - (proj1 env) acc - | Some l -> - let p, desc = lookup_module_descr l env in - begin match get_components desc with - Structure_comps c -> - Tbl.fold - (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) - (proj2 c) acc - | Functor_comps _ -> - acc - end + | None -> + IdTbl.fold_name + (fun name (p, data) acc -> f name p data acc) + (proj1 env) acc + | Some l -> ( + let p, desc = lookup_module_descr l env in + match get_components desc with + | Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) + (proj2 c) acc + | Functor_comps _ -> acc) let find_all_simple_list proj1 proj2 f lid env acc = match lid with - | None -> - TycompTbl.fold_name - (fun data acc -> f data acc) - (proj1 env) acc - | Some l -> - let (_p, desc) = lookup_module_descr l env in - begin match get_components desc with - Structure_comps c -> - Tbl.fold - (fun _s comps acc -> - match comps with - [] -> acc - | data :: _ -> - f data acc) - (proj2 c) acc - | Functor_comps _ -> - acc - end + | None -> TycompTbl.fold_name (fun data acc -> f data acc) (proj1 env) acc + | Some l -> ( + let _p, desc = lookup_module_descr l env in + match get_components desc with + | Structure_comps c -> + Tbl.fold + (fun _s comps acc -> + match comps with + | [] -> acc + | data :: _ -> f data acc) + (proj2 c) acc + | Functor_comps _ -> acc) let fold_modules f lid env acc = match lid with - | None -> - let acc = - IdTbl.fold_name - (fun name (p, data) acc -> - let data = EnvLazy.force subst_modtype_maker data in - f name p data acc - ) - env.modules - acc - in - Hashtbl.fold - (fun name ps acc -> - match ps with - None -> acc - | Some ps -> - f name (Pident(Ident.create_persistent name)) - (md (Mty_signature (Lazy.force ps.ps_sig))) acc) - persistent_structures - acc - | Some l -> - let p, desc = lookup_module_descr l env in - begin match get_components desc with - Structure_comps c -> - Tbl.fold - (fun s (data, pos) acc -> - f s (Pdot (p, s, pos)) - (EnvLazy.force subst_modtype_maker data) acc) - c.comp_modules - acc - | Functor_comps _ -> - acc - end + | None -> + let acc = + IdTbl.fold_name + (fun name (p, data) acc -> + let data = EnvLazy.force subst_modtype_maker data in + f name p data acc) + env.modules acc + in + Hashtbl.fold + (fun name ps acc -> + match ps with + | None -> acc + | Some ps -> + f name + (Pident (Ident.create_persistent name)) + (md (Mty_signature (Lazy.force ps.ps_sig))) + acc) + persistent_structures acc + | Some l -> ( + let p, desc = lookup_module_descr l env in + match get_components desc with + | Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> + f s (Pdot (p, s, pos)) (EnvLazy.force subst_modtype_maker data) acc) + c.comp_modules acc + | Functor_comps _ -> acc) let fold_values f = find_all (fun env -> env.values) (fun sc -> sc.comp_values) f + and fold_constructors f = find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f + and fold_labels f = find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f -and fold_types f = - find_all (fun env -> env.types) (fun sc -> sc.comp_types) f + +and fold_types f = find_all (fun env -> env.types) (fun sc -> sc.comp_types) f + and fold_modtypes f = find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f - (* Make the initial environment *) let initial_safe_string = - Predef.build_initial_env - (add_type ~check:false) + Predef.build_initial_env (add_type ~check:false) (add_extension ~check:false) empty @@ -2191,27 +2091,22 @@ let last_reduced_env = ref empty let keep_only_summary env = if !last_env == env then !last_reduced_env - else begin + else let new_env = { - empty with - summary = env.summary; - local_constraints = env.local_constraints; - flags = env.flags; + empty with + summary = env.summary; + local_constraints = env.local_constraints; + flags = env.flags; } in last_env := env; last_reduced_env := new_env; new_env - end - let env_of_only_summary env_from_summary env = let new_env = env_from_summary env.summary Subst.identity in - { new_env with - local_constraints = env.local_constraints; - flags = env.flags; - } + {new_env with local_constraints = env.local_constraints; flags = env.flags} (* Error report *) @@ -2220,47 +2115,45 @@ open Format (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/env.ml#L1842 *) (* modified branches are commented *) let report_error ppf = function - | Illegal_renaming(name, modname, _filename) -> + | Illegal_renaming (name, modname, _filename) -> (* modified *) fprintf ppf - "@[You referred to the module %s, but we've found one called %s instead.@ \ - Is the name's casing right?@]" + "@[You referred to the module %s, but we've found one called %s \ + instead.@ Is the name's casing right?@]" name modname - | Inconsistent_import(name, source1, source2) -> + | Inconsistent_import (name, source1, source2) -> (* modified *) - fprintf ppf "@[\ - @[@{It's possible that your build is stale.@}@ Try to clean the artifacts and build again?@]@,@,\ - @[@{Here's the original error message@}@]@,\ - @]"; fprintf ppf - "@[The files %a@ and %a@ \ - make inconsistent assumptions@ over interface %s@]" + "@[@[@{It's possible that your build is stale.@}@ Try to clean \ + the artifacts and build again?@]@,\ + @,\ + @[@{Here's the original error message@}@]@,\ + @]"; + fprintf ppf + "@[The files %a@ and %a@ make inconsistent assumptions@ over \ + interface %s@]" Location.print_filename source1 Location.print_filename source2 name - | Need_recursive_types(import, export) -> + | Need_recursive_types (import, export) -> fprintf ppf - "@[Unit %s imports from %s, which uses recursive types.@ %s@]" - export import "The compilation flag -rectypes is required" - | Missing_module(_, path1, path2) -> + "@[Unit %s imports from %s, which uses recursive types.@ %s@]" export + import "The compilation flag -rectypes is required" + | Missing_module (_, path1, path2) -> fprintf ppf "@[@["; if Path.same path1 path2 then fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1) else fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling." (Path.name path1) (Path.name path2); - fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" - "The compiled interface for module" (Ident.name (Path.head path2)) + fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" "The compiled interface for module" + (Ident.name (Path.head path2)) "was not found" - | Illegal_value_name(_loc, name) -> - fprintf ppf "'%s' is not a valid value identifier." - name + | Illegal_value_name (_loc, name) -> + fprintf ppf "'%s' is not a valid value identifier." name let () = - Location.register_error_of_exn - (function - | Error (Missing_module (loc, _, _) - | Illegal_value_name (loc, _) - as err) when loc <> Location.none -> - Some (Location.error_of_printer loc report_error err) - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) + Location.register_error_of_exn (function + | Error ((Missing_module (loc, _, _) | Illegal_value_name (loc, _)) as err) + when loc <> Location.none -> + Some (Location.error_of_printer loc report_error err) + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None) diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli index d1d1b5028e..8c178452c5 100644 --- a/compiler/ml/env.mli +++ b/compiler/ml/env.mli @@ -17,11 +17,11 @@ open Types -module PathMap : Map.S with type key = Path.t - and type 'a t = 'a Map.Make(Path).t +module PathMap : + Map.S with type key = Path.t and type 'a t = 'a Map.Make(Path).t type summary = - Env_empty + | Env_empty | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration | Env_extension of summary * Ident.t * extension_constructor @@ -36,183 +36,196 @@ type summary = type t -val empty: t -val initial_safe_string: t +val empty : t +val initial_safe_string : t -val diff: t -> t -> Ident.t list -val copy_local: from:t -> t -> t +val diff : t -> t -> Ident.t list +val copy_local : from:t -> t -> t -type type_descriptions = - constructor_description list * label_description list +type type_descriptions = constructor_description list * label_description list (* For short-paths *) type iter_cont -val iter_types: - (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> - t -> iter_cont -val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list -val same_types: t -> t -> bool -val used_persistent: unit -> Concr.t -val find_shadowed_types: Path.t -> t -> Path.t list -val without_cmis: ('a -> 'b) -> 'a -> 'b - (* [without_cmis f arg] applies [f] to [arg], but does not - allow opening cmis during its execution *) +val iter_types : + (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> + t -> + iter_cont +val run_iter_cont : iter_cont list -> (Path.t * iter_cont) list +val same_types : t -> t -> bool +val used_persistent : unit -> Concr.t +val find_shadowed_types : Path.t -> t -> Path.t list +val without_cmis : ('a -> 'b) -> 'a -> 'b +(* [without_cmis f arg] applies [f] to [arg], but does not + allow opening cmis during its execution *) (* Lookup by paths *) -val find_value: Path.t -> t -> value_description -val find_type: Path.t -> t -> type_declaration -val find_type_descrs: Path.t -> t -> type_descriptions -val find_module: Path.t -> t -> module_declaration -val find_modtype: Path.t -> t -> modtype_declaration +val find_value : Path.t -> t -> value_description +val find_type : Path.t -> t -> type_declaration +val find_type_descrs : Path.t -> t -> type_descriptions +val find_module : Path.t -> t -> module_declaration +val find_modtype : Path.t -> t -> modtype_declaration + +val find_type_expansion : Path.t -> t -> type_expr list * type_expr * int option +val find_type_expansion_opt : + Path.t -> t -> type_expr list * type_expr * int option -val find_type_expansion: - Path.t -> t -> type_expr list * type_expr * int option -val find_type_expansion_opt: - Path.t -> t -> type_expr list * type_expr * int option (* 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 +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. If the option is None, allow returning dangling paths. Otherwise raise a Missing_module error, and may add forgotten head as required global. *) -val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t +val normalize_path_prefix : Location.t option -> t -> Path.t -> Path.t (* Only normalize the prefix part of the path *) - - - -val has_local_constraints: t -> bool -val add_gadt_instance_level: int -> t -> t -val gadt_instance_level: t -> type_expr -> int option -val add_gadt_instances: t -> int -> type_expr list -> unit -val add_gadt_instance_chain: t -> int -> type_expr -> unit +val has_local_constraints : t -> bool +val add_gadt_instance_level : int -> t -> t +val gadt_instance_level : t -> type_expr -> int option +val add_gadt_instances : t -> int -> type_expr list -> unit +val add_gadt_instance_chain : t -> int -> type_expr -> unit (* Lookup by long identifiers *) (* ?loc is used to report 'deprecated module' warnings *) -val lookup_value: +val lookup_value : ?loc:Location.t -> Longident.t -> t -> Path.t * value_description -val lookup_constructor: +val lookup_constructor : ?loc:Location.t -> Longident.t -> t -> constructor_description -val lookup_all_constructors: +val lookup_all_constructors : ?loc:Location.t -> - Longident.t -> t -> (constructor_description * (unit -> unit)) list -val lookup_label: - ?loc:Location.t -> Longident.t -> t -> label_description -val lookup_all_labels: + Longident.t -> + t -> + (constructor_description * (unit -> unit)) list +val lookup_label : ?loc:Location.t -> Longident.t -> t -> label_description +val lookup_all_labels : ?loc:Location.t -> - Longident.t -> t -> (label_description * (unit -> unit)) list -val lookup_type: - ?loc:Location.t -> Longident.t -> t -> Path.t - (* Since 4.04, this function no longer returns [type_description]. - To obtain it, you should either call [Env.find_type], or replace - it by [Typetexp.find_type] *) -val lookup_module: - load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t -val lookup_modtype: + Longident.t -> + t -> + (label_description * (unit -> unit)) list +val lookup_type : ?loc:Location.t -> Longident.t -> t -> Path.t +(* Since 4.04, this function no longer returns [type_description]. + To obtain it, you should either call [Env.find_type], or replace + it by [Typetexp.find_type] *) + +val lookup_module : load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t +val lookup_modtype : ?loc:Location.t -> Longident.t -> t -> Path.t * modtype_declaration -val copy_types: string list -> t -> t - (* Used only in Typecore.duplicate_ident_types. *) +val copy_types : string list -> t -> t +(* Used only in Typecore.duplicate_ident_types. *) exception Recmodule - (* Raise by lookup_module when the identifier refers - to one of the modules of a recursive definition - during the computation of its approximation (see #5965). *) +(* Raise by lookup_module when the identifier refers + to one of the modules of a recursive definition + during the computation of its approximation (see #5965). *) (* Insertion by identifier *) -val add_value: - ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t -val add_type: check:bool -> Ident.t -> type_declaration -> t -> t -val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t -val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t -val add_module_declaration: ?arg:bool -> check:bool -> Ident.t -> - module_declaration -> t -> t -val add_modtype: Ident.t -> modtype_declaration -> t -> t +val add_value : + ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t +val add_type : check:bool -> Ident.t -> type_declaration -> t -> t +val add_extension : check:bool -> Ident.t -> extension_constructor -> t -> t +val add_module : ?arg:bool -> Ident.t -> module_type -> t -> t +val add_module_declaration : + ?arg:bool -> check:bool -> Ident.t -> module_declaration -> t -> t +val add_modtype : Ident.t -> modtype_declaration -> t -> t -val add_local_constraint: Path.t -> type_declaration -> int -> t -> t -val add_local_type: Path.t -> type_declaration -> t -> t +val add_local_constraint : Path.t -> type_declaration -> int -> t -> t +val add_local_type : Path.t -> type_declaration -> t -> t (* Insertion of all fields of a signature. *) -val add_item: signature_item -> t -> t -val add_signature: signature -> t -> t +val add_item : signature_item -> t -> t +val add_signature : signature -> t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. Returns None if the path refers to a functor, not a structure. *) -val open_signature: - ?used_slot:bool ref -> - ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t -> - t -> t option +val open_signature : + ?used_slot:bool ref -> + ?loc:Location.t -> + ?toplevel:bool -> + Asttypes.override_flag -> + Path.t -> + t -> + t option -val open_pers_signature: string -> t -> t +val open_pers_signature : string -> t -> t (* Insertion by name *) -val enter_value: - ?check:(string -> Warnings.t) -> - string -> value_description -> t -> Ident.t * t -val enter_type: string -> type_declaration -> t -> Ident.t * t -val enter_extension: string -> extension_constructor -> t -> Ident.t * t -val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t -val enter_module_declaration: - ?arg:bool -> Ident.t -> module_declaration -> t -> t -val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t - +val enter_value : + ?check:(string -> Warnings.t) -> + string -> + value_description -> + t -> + Ident.t * t +val enter_type : string -> type_declaration -> t -> Ident.t * t +val enter_extension : string -> extension_constructor -> t -> Ident.t * t +val enter_module : ?arg:bool -> string -> module_type -> t -> Ident.t * t +val enter_module_declaration : + ?arg:bool -> Ident.t -> module_declaration -> t -> t +val enter_modtype : string -> modtype_declaration -> t -> Ident.t * t (* Initialize the cache of in-core module interfaces. *) -val reset_cache: unit -> unit +val reset_cache : unit -> unit (* To be called before each toplevel phrase. *) -val reset_cache_toplevel: unit -> unit +val reset_cache_toplevel : unit -> unit (* Remember the name of the current compilation unit. *) -val set_unit_name: string -> unit -val get_unit_name: unit -> string +val set_unit_name : string -> unit +val get_unit_name : unit -> string (* Read, save a signature to/from a file *) -val read_signature: string -> string -> signature - (* Arguments: module name, file name. Results: signature. *) -val save_signature: +val read_signature : string -> string -> signature +(* Arguments: module name, file name. Results: signature. *) + +val save_signature : + ?check_exists:unit -> + deprecated:string option -> + signature -> + string -> + string -> + Cmi_format.cmi_infos +(* Arguments: signature, module name, file name. *) + +val save_signature_with_imports : ?check_exists:unit -> - deprecated:string option -> signature -> string -> string -> Cmi_format.cmi_infos - (* Arguments: signature, module name, file name. *) -val save_signature_with_imports: - ?check_exists:unit -> deprecated:string option -> - signature -> string -> string -> (string * Digest.t option) list - -> Cmi_format.cmi_infos - (* Arguments: signature, module name, file name, - imported units with their CRCs. *) + signature -> + string -> + string -> + (string * Digest.t option) list -> + Cmi_format.cmi_infos +(* Arguments: signature, module name, file name, + imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) -val crc_of_unit: string -> Digest.t +val crc_of_unit : string -> Digest.t (* Return the set of compilation units imported, with their CRC *) -val imports: unit -> (string * Digest.t option) list - - +val imports : unit -> (string * Digest.t option) list (* Direct access to the table of imported compilation units with their CRC *) -val crc_units: Consistbl.t -val add_import: string -> unit +val crc_units : Consistbl.t +val add_import : string -> unit (* Summaries -- compact representation of an environment, to be exported in debugging information. *) -val summary: t -> summary +val summary : t -> summary (* Return an equivalent environment where all fields have been reset, except the summary. The initial environment can be rebuilt from the @@ -234,76 +247,88 @@ exception Error of error open Format -val report_error: formatter -> error -> unit - +val report_error : formatter -> error -> unit -val mark_value_used: t -> string -> value_description -> unit -val mark_module_used: t -> string -> Location.t -> unit -val mark_type_used: t -> string -> type_declaration -> unit +val mark_value_used : t -> string -> value_description -> unit +val mark_module_used : t -> string -> Location.t -> unit +val mark_type_used : t -> string -> type_declaration -> unit type constructor_usage = Positive | Pattern | Privatize -val mark_constructor_used: - constructor_usage -> t -> string -> type_declaration -> string -> unit -val mark_constructor: - constructor_usage -> t -> string -> constructor_description -> unit -val mark_extension_used: - constructor_usage -> t -> extension_constructor -> string -> unit +val mark_constructor_used : + constructor_usage -> t -> string -> type_declaration -> string -> unit +val mark_constructor : + constructor_usage -> t -> string -> constructor_description -> unit +val mark_extension_used : + constructor_usage -> t -> extension_constructor -> string -> unit -val in_signature: bool -> t -> t -val implicit_coercion: t -> t +val in_signature : bool -> t -> t +val implicit_coercion : t -> t -val is_in_signature: t -> bool +val is_in_signature : t -> bool -val set_value_used_callback: - string -> value_description -> (unit -> unit) -> unit -val set_type_used_callback: - string -> type_declaration -> ((unit -> unit) -> unit) -> unit +val set_value_used_callback : + string -> value_description -> (unit -> unit) -> unit +val set_type_used_callback : + string -> type_declaration -> ((unit -> unit) -> unit) -> unit (* Forward declaration to break mutual recursion with Includemod. *) -val check_modtype_inclusion: - (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref +val check_modtype_inclusion : + (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref (* Forward declaration to break mutual recursion with Mtype. *) -val strengthen: - (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref +val strengthen : + (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref + (* Forward declaration to break mutual recursion with Ctype. *) -val same_constr: (t -> type_expr -> type_expr -> bool) ref +val same_constr : (t -> type_expr -> type_expr -> bool) ref (** Folding over all identifiers (for analysis purpose) *) -val fold_values: +val fold_values : (string -> Path.t -> value_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_types: + Longident.t option -> + t -> + 'a -> + 'a +val fold_types : (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_constructors: - (constructor_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_labels: - (label_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a - -(** Persistent structures are only traversed if they are already loaded. *) -val fold_modules: + Longident.t option -> + t -> + 'a -> + 'a +val fold_constructors : + (constructor_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a +val fold_labels : + (label_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a + +val fold_modules : (string -> Path.t -> module_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a + Longident.t option -> + t -> + 'a -> + 'a +(** Persistent structures are only traversed if they are already loaded. *) -val fold_modtypes: +val fold_modtypes : (string -> Path.t -> modtype_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a + Longident.t option -> + t -> + 'a -> + 'a +val scrape_alias : t -> module_type -> module_type (** Utilities *) -val scrape_alias: t -> module_type -> module_type -val check_value_name: string -> Location.t -> unit + +val check_value_name : string -> Location.t -> unit module Persistent_signature : sig - type t = - { filename : string; (** Name of the file containing the signature. *) - cmi : Cmi_format.cmi_infos } + type t = { + filename: string; (** Name of the file containing the signature. *) + cmi: Cmi_format.cmi_infos; + } + val load : (unit_name:string -> t option) ref (** Function used to load a persistent signature. The default is to look for the .cmi file in the load path. This function can be overridden to load it from memory, for instance to build a self-contained toplevel. *) - val load : (unit_name:string -> t option) ref end diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index a105e12cdc..27768a77ec 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -166,14 +166,16 @@ let print_extra_type_clash_help ppf trace type_clash_context = freely, and compiles to a JavaScript array. Example of a tuple: `let \ myTuple = (10, \"hello\", 15.5, true)" | ( _, - [ - ({Types.desc = Tconstr (_p1, _, _)}, _); ({desc = Tconstr (p2, _, _)}, _); - ] ) + [ + ({Types.desc = Tconstr (_p1, _, _)}, _); ({desc = Tconstr (p2, _, _)}, _); + ] ) when Path.same Predef.path_unit p2 -> fprintf ppf - "\n\n\ - \ - Did you mean to assign this to a variable?\n\ - \ - If you don't care about the result of this expression, you can assign it to @{_@} via @{let _ = ...@} or pipe it to @{ignore@} via @{expression->ignore@}\n\n" + "\n\n\ + \ - Did you mean to assign this to a variable?\n\ + \ - If you don't care about the result of this expression, you can \ + assign it to @{_@} via @{let _ = ...@} or pipe it to \ + @{ignore@} via @{expression->ignore@}\n\n" | _ -> () let type_clash_context_from_function sexp sfunct = @@ -216,7 +218,7 @@ let type_clash_context_maybe_option ty_expected ty_res = | ( {Types.desc = Tconstr (expected_path, _, _)}, {Types.desc = Tconstr (type_path, _, _)} ) when Path.same Predef.path_option type_path - && Path.same expected_path Predef.path_option = false + && Path.same expected_path Predef.path_option = false && Path.same expected_path Predef.path_uncurried = false -> Some MaybeUnwrapOption | _ -> None @@ -227,27 +229,28 @@ let type_clash_context_in_statement sexp = | _ -> None let print_contextual_unification_error ppf t1 t2 = - (* TODO: Maybe we should do the same for Null.t and Nullable.t as we do for options - below, now that they also are more first class for values that might not exist? *) - + (* TODO: Maybe we should do the same for Null.t and Nullable.t as we do for options + below, now that they also are more first class for values that might not exist? *) match (t1.Types.desc, t2.Types.desc) with | Tconstr (p1, _, _), Tconstr (p2, _, _) when Path.same p1 Predef.path_option - && Path.same p2 Predef.path_option <> true -> + && Path.same p2 Predef.path_option <> true -> fprintf ppf - "@,@\n\ - @[You're expecting the value you're pattern matching on to be an \ - @{option@}, but the value is actually not an option.@ Change your \ - pattern match to work on the concrete value (remove @{Some(_)@} \ - or @{None@} from the pattern) to make it work.@]" + "@,\ + @\n\ + @[You're expecting the value you're pattern matching on to be an \ + @{option@}, but the value is actually not an option.@ Change your \ + pattern match to work on the concrete value (remove @{Some(_)@} \ + or @{None@} from the pattern) to make it work.@]" | Tconstr (p1, _, _), Tconstr (p2, _, _) when Path.same p2 Predef.path_option - && Path.same p1 Predef.path_option <> true -> + && Path.same p1 Predef.path_option <> true -> fprintf ppf - "@,@\n\ - @[The value you're pattern matching on here is wrapped in an \ - @{option@}, but you're trying to match on the actual value.@ Wrap \ - the highlighted pattern in @{Some()@} to make it work.@]" + "@,\ + @\n\ + @[The value you're pattern matching on here is wrapped in an \ + @{option@}, but you're trying to match on the actual value.@ Wrap \ + the highlighted pattern in @{Some()@} to make it work.@]" | _ -> () type jsx_prop_error_info = { @@ -290,7 +293,8 @@ let print_component_wrong_prop_error ppf (p : Path.t) (match name with | "children" -> fprintf ppf - "@[<2>This JSX component does not accept child elements. It has no @{children@} prop " + "@[<2>This JSX component does not accept child elements. It has no \ + @{children@} prop " | _ -> fprintf ppf "@[<2>The prop @{%s@} does not belong to the JSX component " name); @@ -305,8 +309,9 @@ let print_component_labels_missing_error ppf labels labels |> List.iter (fun lbl -> fprintf ppf "@ %s" lbl); fprintf ppf "@]" -let get_jsx_component_error_info ~extract_concrete_typedecl opath env ty_record () = +let get_jsx_component_error_info ~extract_concrete_typedecl opath env ty_record + () = match opath with | Some (p, _) -> get_jsx_component_props ~extract_concrete_typedecl env ty_record p - | None -> None \ No newline at end of file + | None -> None diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index d68d0546eb..0703e06ddc 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -24,108 +24,122 @@ open Typedtree exception Dont_match -let value_descriptions ~loc env name - (vd1 : Types.value_description) +let value_descriptions ~loc env name (vd1 : Types.value_description) (vd2 : Types.value_description) = - Builtin_attributes.check_deprecated_inclusion - ~def:vd1.val_loc - ~use:vd2.val_loc - loc - vd1.val_attributes vd2.val_attributes - (Ident.name name); - if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin + Builtin_attributes.check_deprecated_inclusion ~def:vd1.val_loc + ~use:vd2.val_loc loc vd1.val_attributes vd2.val_attributes (Ident.name name); + if Ctype.moregeneral env true vd1.val_type vd2.val_type then match (vd1.val_kind, vd2.val_kind) with - (Val_prim p1, Val_prim p2) -> - if !Primitive.coerce p1 p2 then Tcoerce_none else raise Dont_match - | (Val_prim p, _) -> - let pc = {pc_desc = p; pc_type = vd2.Types.val_type; - pc_env = env; pc_loc = vd1.Types.val_loc; - pc_id = name; - } in - Tcoerce_primitive pc - | (_, Val_prim _) -> raise Dont_match - | (_, _) -> Tcoerce_none - end else - raise Dont_match + | Val_prim p1, Val_prim p2 -> + if !Primitive.coerce p1 p2 then Tcoerce_none else raise Dont_match + | Val_prim p, _ -> + let pc = + { + pc_desc = p; + pc_type = vd2.Types.val_type; + pc_env = env; + pc_loc = vd1.Types.val_loc; + pc_id = name; + } + in + Tcoerce_primitive pc + | _, Val_prim _ -> raise Dont_match + | _, _ -> Tcoerce_none + else raise Dont_match (* Inclusion between "private" annotations *) let private_flags decl1 decl2 = - match decl1.type_private, decl2.type_private with + match (decl1.type_private, decl2.type_private) with | Private, Public -> - decl2.type_kind = Type_abstract && - (decl2.type_manifest = None || decl1.type_kind <> Type_abstract) + decl2.type_kind = Type_abstract + && (decl2.type_manifest = None || decl1.type_kind <> Type_abstract) | _, _ -> true (* Inclusion between manifest types (particularly for private row types) *) let is_absrow env ty = match ty.desc with - Tconstr(Pident _, _, _) -> - begin match Ctype.expand_head env ty with - {desc=Tobject _|Tvariant _} -> true - | _ -> false - end + | Tconstr (Pident _, _, _) -> ( + match Ctype.expand_head env ty with + | {desc = Tobject _ | Tvariant _} -> true + | _ -> false) | _ -> false let type_manifest env ty1 params1 ty2 params2 priv2 = let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in - match ty1'.desc, ty2'.desc with - Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> - let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in - Ctype.equal env true (ty1::params1) (row2.row_more::params2) && - begin match row1.row_more with - {desc=Tvar _|Tconstr _|Tnil} -> true - | _ -> false - end && - let r1, r2, pairs = - Ctype.merge_row_fields row1.row_fields row2.row_fields in - (not row2.row_closed || - row1.row_closed && Ctype.filter_row_fields false r1 = []) && - List.for_all - (fun (_,f) -> match Btype.row_field_repr f with - Rabsent | Reither _ -> true | Rpresent _ -> false) - r2 && - let to_equal = ref (List.combine params1 params2) in - List.for_all - (fun (_, f1, f2) -> - match Btype.row_field_repr f1, Btype.row_field_repr f2 with - Rpresent(Some t1), - (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> - to_equal := (t1,t2) :: !to_equal; true - | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true - | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) - when List.length tl1 = List.length tl2 && c1 = c2 -> - to_equal := List.combine tl1 tl2 @ !to_equal; true - | Rabsent, (Reither _ | Rabsent) -> true - | _ -> false) - pairs && - let tl1, tl2 = List.split !to_equal in - Ctype.equal env true tl1 tl2 + match (ty1'.desc, ty2'.desc) with + | Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> + let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in + Ctype.equal env true (ty1 :: params1) (row2.row_more :: params2) + && (match row1.row_more with + | {desc = Tvar _ | Tconstr _ | Tnil} -> true + | _ -> false) + && + let r1, r2, pairs = + Ctype.merge_row_fields row1.row_fields row2.row_fields + in + ((not row2.row_closed) + || (row1.row_closed && Ctype.filter_row_fields false r1 = [])) + && List.for_all + (fun (_, f) -> + match Btype.row_field_repr f with + | Rabsent | Reither _ -> true + | Rpresent _ -> false) + r2 + && + let to_equal = ref (List.combine params1 params2) in + List.for_all + (fun (_, f1, f2) -> + match (Btype.row_field_repr f1, Btype.row_field_repr f2) with + | Rpresent (Some t1), (Rpresent (Some t2) | Reither (false, [t2], _, _)) + -> + to_equal := (t1, t2) :: !to_equal; + true + | Rpresent None, (Rpresent None | Reither (true, [], _, _)) -> true + | Reither (c1, tl1, _, _), Reither (c2, tl2, _, _) + when List.length tl1 = List.length tl2 && c1 = c2 -> + to_equal := List.combine tl1 tl2 @ !to_equal; + true + | Rabsent, (Reither _ | Rabsent) -> true + | _ -> false) + pairs + && + let tl1, tl2 = List.split !to_equal in + Ctype.equal env true tl1 tl2 | Tobject (fi1, _), Tobject (fi2, _) - when is_absrow env (snd(Ctype.flatten_fields fi2)) -> - let (fields2,rest2) = Ctype.flatten_fields fi2 in - Ctype.equal env true (ty1::params1) (rest2::params2) && - let (fields1,rest1) = Ctype.flatten_fields fi1 in - (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && - let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in - miss2 = [] && - let tl1, tl2 = - List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in - Ctype.equal env true (params1 @ tl1) (params2 @ tl2) + when is_absrow env (snd (Ctype.flatten_fields fi2)) -> + let fields2, rest2 = Ctype.flatten_fields fi2 in + Ctype.equal env true (ty1 :: params1) (rest2 :: params2) + && + let fields1, rest1 = Ctype.flatten_fields fi1 in + (match rest1 with + | {desc = Tnil | Tvar _ | Tconstr _} -> true + | _ -> false) + && + let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in + miss2 = [] + && + let tl1, tl2 = + List.split (List.map (fun (_, _, t1, _, t2) -> (t1, t2)) pairs) + in + Ctype.equal env true (params1 @ tl1) (params2 @ tl2) | _ -> - let rec check_super ty1 = - Ctype.equal env true (ty1 :: params1) (ty2 :: params2) || - priv2 = Private && - try check_super - (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) - with Ctype.Cannot_expand -> false - in check_super ty1 + let rec check_super ty1 = + Ctype.equal env true (ty1 :: params1) (ty2 :: params2) + || priv2 = Private + && + try + check_super + (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) + with Ctype.Cannot_expand -> false + in + check_super ty1 (* Inclusion between type declarations *) type type_mismatch = - Arity + | Arity | Privacy | Kind | Constraint @@ -137,7 +151,7 @@ type type_mismatch = | Field_names of int * string * string | Field_missing of bool * Ident.t | Record_representation of record_representation * record_representation - | Unboxed_representation of bool (* true means second one is unboxed *) + | Unboxed_representation of bool (* true means second one is unboxed *) | Immediate | Tag_name | Variant_representation of Ident.t @@ -145,112 +159,108 @@ type type_mismatch = let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in match err with - Arity -> pr "They have different arities" + | Arity -> pr "They have different arities" | Privacy -> pr "A private type would be revealed" | Kind -> pr "Their kinds differ" | Constraint -> pr "Their constraints differ" | Manifest -> () | Variance -> pr "Their variances do not agree" - | Field_type s -> - pr "The types for field %s are not equal" (Ident.name s) + | Field_type s -> pr "The types for field %s are not equal" (Ident.name s) | Field_mutable s -> - pr "The mutability of field %s is different" (Ident.name s) - | Field_arity s -> - pr "The arities for field %s differ" (Ident.name s) + pr "The mutability of field %s is different" (Ident.name s) + | Field_arity s -> pr "The arities for field %s differ" (Ident.name s) | Field_names (n, name1, name2) -> - pr "Fields number %i have different names, %s and %s" - n name1 name2 + pr "Fields number %i have different names, %s and %s" n name1 name2 | Field_missing (b, s) -> - pr "The field %s is only present in %s %s" - (Ident.name s) (if b then second else first) decl - | Record_representation (rep1, rep2) -> - let default () = pr "Their internal representations differ" in - ( match rep1, rep2 with - | Record_optional_labels lbls1, Record_optional_labels lbls2 -> - let only_in_lhs = - Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) in - let only_in_rhs = - Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l)) in - (match only_in_lhs, only_in_rhs with - | Some l, _ -> - pr "@optional label %s only in %s" l second - | _, Some l -> - pr "@optional label %s only in %s" l first - | None, None -> default ()) - | _ -> - default () - ) + pr "The field %s is only present in %s %s" (Ident.name s) + (if b then second else first) + decl + | Record_representation (rep1, rep2) -> ( + let default () = pr "Their internal representations differ" in + match (rep1, rep2) with + | Record_optional_labels lbls1, Record_optional_labels lbls2 -> ( + let only_in_lhs = + Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) + in + let only_in_rhs = + Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l)) + in + match (only_in_lhs, only_in_rhs) with + | Some l, _ -> pr "@optional label %s only in %s" l second + | _, Some l -> pr "@optional label %s only in %s" l first + | None, None -> default ()) + | _ -> default ()) | Unboxed_representation b -> - pr "Their internal representations differ:@ %s %s %s" - (if b then second else first) decl - "uses unboxed representation" + pr "Their internal representations differ:@ %s %s %s" + (if b then second else first) + decl "uses unboxed representation" | Immediate -> pr "%s is not an immediate type" first | Tag_name -> pr "Their @tag annotations differ" | Variant_representation s -> pr "The internal representations for case %s are not equal" (Ident.name s) let report_type_mismatch first second decl ppf = - List.iter - (fun err -> - if err = Manifest then () else - Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) + List.iter (fun err -> + if err = Manifest then () + else + Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 = - match arg1, arg2 with + match (arg1, arg2) with | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> - if List.length arg1 <> List.length arg2 then [Field_arity cstr] - else if - (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) - Ctype.equal env true (params1 @ arg1) (params2 @ arg2) - then [] else [Field_type cstr] + if List.length arg1 <> List.length arg2 then [Field_arity cstr] + else if + (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) + Ctype.equal env true (params1 @ arg1) (params2 @ arg2) + then [] + else [Field_type cstr] | Types.Cstr_record l1, Types.Cstr_record l2 -> - compare_records env ~loc params1 params2 0 l1 l2 + compare_records env ~loc params1 params2 0 l1 l2 | _ -> [Field_type cstr] and compare_variants ~loc env params1 params2 n (cstrs1 : Types.constructor_declaration list) (cstrs2 : Types.constructor_declaration list) = - match cstrs1, cstrs2 with - [], [] -> [] - | [], c::_ -> [Field_missing (true, c.Types.cd_id)] - | c::_, [] -> [Field_missing (false, c.Types.cd_id)] - | cd1::rem1, cd2::rem2 -> - if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then - [Field_names (n, cd1.cd_id.name, cd2.cd_id.name)] - else begin - Builtin_attributes.check_deprecated_inclusion - ~def:cd1.cd_loc - ~use:cd2.cd_loc - loc - cd1.cd_attributes cd2.cd_attributes - (Ident.name cd1.cd_id); - let r = - match cd1.cd_res, cd2.cd_res with - | Some r1, Some r2 -> - if Ctype.equal env true [r1] [r2] then - compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2] - cd1.cd_args cd2.cd_args - else [Field_type cd1.cd_id] - | Some _, None | None, Some _ -> - [Field_type cd1.cd_id] - | _ -> - compare_constructor_arguments ~loc env cd1.cd_id - params1 params2 cd1.cd_args cd2.cd_args - in - let r = - if r <> [] then r - else match Ast_untagged_variants.is_nullary_variant cd1.cd_args with + match (cstrs1, cstrs2) with + | [], [] -> [] + | [], c :: _ -> [Field_missing (true, c.Types.cd_id)] + | c :: _, [] -> [Field_missing (false, c.Types.cd_id)] + | cd1 :: rem1, cd2 :: rem2 -> + if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then + [Field_names (n, cd1.cd_id.name, cd2.cd_id.name)] + else ( + Builtin_attributes.check_deprecated_inclusion ~def:cd1.cd_loc + ~use:cd2.cd_loc loc cd1.cd_attributes cd2.cd_attributes + (Ident.name cd1.cd_id); + let r = + match (cd1.cd_res, cd2.cd_res) with + | Some r1, Some r2 -> + if Ctype.equal env true [r1] [r2] then + compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2] + cd1.cd_args cd2.cd_args + else [Field_type cd1.cd_id] + | Some _, None | None, Some _ -> [Field_type cd1.cd_id] + | _ -> + compare_constructor_arguments ~loc env cd1.cd_id params1 params2 + cd1.cd_args cd2.cd_args + in + let r = + if r <> [] then r + else + match Ast_untagged_variants.is_nullary_variant cd1.cd_args with | true -> - let tag_type1 = Ast_untagged_variants.process_tag_type cd1.cd_attributes in - let tag_type2 = Ast_untagged_variants.process_tag_type cd2.cd_attributes in + let tag_type1 = + Ast_untagged_variants.process_tag_type cd1.cd_attributes + in + let tag_type2 = + Ast_untagged_variants.process_tag_type cd2.cd_attributes + in if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id] else [] - | false -> - r - in - if r <> [] then r - else compare_variants ~loc env params1 params2 (n+1) rem1 rem2 - end + | false -> r + in + if r <> [] then r + else compare_variants ~loc env params1 params2 (n + 1) rem1 rem2) and compare_records ~loc env params1_ params2_ n_ (labels1_ : Types.label_declaration list) @@ -258,175 +268,210 @@ and compare_records ~loc env params1_ params2_ n_ (* First try a fast path that checks if all the fields at once are consistent. When that fails, try a slow path that blames the first inconsistent field *) let rec aux ~fast params1 params2 n labels1 labels2 = - match labels1, labels2 with - [], [] -> - if fast then - if Ctype.equal env true params1 params2 then - [] - else - aux ~fast:false params1_ params2_ n_ labels1_ labels2_ - else - [] - | [], l::_ -> [Field_missing (true, l.Types.ld_id)] - | l::_, [] -> [Field_missing (false, l.Types.ld_id)] - | ld1::rem1, ld2::rem2 -> - if Ident.name ld1.ld_id <> Ident.name ld2.ld_id - then [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)] - else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] else begin - Builtin_attributes.check_deprecated_mutable_inclusion - ~def:ld1.ld_loc - ~use:ld2.ld_loc - loc - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id); - let field_mismatch = !Builtin_attributes.check_bs_attributes_inclusion - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id) in - match field_mismatch with - | Some (a,b) -> [Field_names (n,a,b)] - | None -> + match (labels1, labels2) with + | [], [] -> + if fast then + if Ctype.equal env true params1 params2 then [] + else aux ~fast:false params1_ params2_ n_ labels1_ labels2_ + else [] + | [], l :: _ -> [Field_missing (true, l.Types.ld_id)] + | l :: _, [] -> [Field_missing (false, l.Types.ld_id)] + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id then + [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)] + else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] + else ( + Builtin_attributes.check_deprecated_mutable_inclusion ~def:ld1.ld_loc + ~use:ld2.ld_loc loc ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id); + let field_mismatch = + !Builtin_attributes.check_bs_attributes_inclusion + ld1.ld_attributes ld2.ld_attributes (Ident.name ld1.ld_id) + in + match field_mismatch with + | Some (a, b) -> [Field_names (n, a, b)] + | None -> let current_field_consistent = if fast then true - else Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2) in - if current_field_consistent - then (* add arguments to the parameters, cf. PR#7378 *) - aux ~fast - (ld1.ld_type::params1) (ld2.ld_type::params2) - (n+1) + else + Ctype.equal env true (ld1.ld_type :: params1) + (ld2.ld_type :: params2) + in + if current_field_consistent then + (* add arguments to the parameters, cf. PR#7378 *) + aux ~fast (ld1.ld_type :: params1) (ld2.ld_type :: params2) (n + 1) rem1 rem2 - else - [Field_type ld1.ld_id] - end in + else [Field_type ld1.ld_id]) + in aux ~fast:true params1_ params2_ n_ labels1_ labels2_ - let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = - Builtin_attributes.check_deprecated_inclusion - ~def:decl1.type_loc - ~use:decl2.type_loc - loc - decl1.type_attributes decl2.type_attributes - name; - if decl1.type_arity <> decl2.type_arity then [Arity] else - if not (private_flags decl1 decl2) then [Privacy] else - let err = match (decl1.type_manifest, decl2.type_manifest) with - (_, None) -> - if Ctype.equal env true decl1.type_params decl2.type_params - then [] else [Constraint] - | (Some ty1, Some ty2) -> - if type_manifest env ty1 decl1.type_params ty2 decl2.type_params + Builtin_attributes.check_deprecated_inclusion ~def:decl1.type_loc + ~use:decl2.type_loc loc decl1.type_attributes decl2.type_attributes name; + if decl1.type_arity <> decl2.type_arity then [Arity] + else if not (private_flags decl1 decl2) then [Privacy] + else + let err = + match (decl1.type_manifest, decl2.type_manifest) with + | _, None -> + if Ctype.equal env true decl1.type_params decl2.type_params then [] + else [Constraint] + | Some ty1, Some ty2 -> + if + type_manifest env ty1 decl1.type_params ty2 decl2.type_params decl2.type_private - then [] else [Manifest] - | (None, Some ty2) -> + then [] + else [Manifest] + | None, Some ty2 -> let ty1 = - Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil)) + Btype.newgenty (Tconstr (Pident id, decl2.type_params, ref Mnil)) in if Ctype.equal env true decl1.type_params decl2.type_params then - if Ctype.equal env false [ty1] [ty2] then [] - else [Manifest] + if Ctype.equal env false [ty1] [ty2] then [] else [Manifest] else [Constraint] - in - if err <> [] then err else - let err = - let untagged1 = Ast_untagged_variants.process_untagged decl1.type_attributes in - let untagged2 = Ast_untagged_variants.process_untagged decl2.type_attributes in - match (decl2.type_kind, decl1.type_unboxed.unboxed || untagged1, - decl2.type_unboxed.unboxed || untagged2) with - | Type_abstract, _, _ -> [] - | _, true, false -> [Unboxed_representation false] - | _, false, true -> [Unboxed_representation true] - | _ -> [] - in - if err <> [] then err else - let err = - let tag1 = Ast_untagged_variants.process_tag_name decl1.type_attributes in - let tag2 = Ast_untagged_variants.process_tag_name decl2.type_attributes in - if tag1 <> tag2 then [Tag_name] else err in - if err <> [] then err else - let err = match (decl1.type_kind, decl2.type_kind) with - (_, Type_abstract) -> [] - | (Type_variant cstrs1, Type_variant cstrs2) -> - let mark cstrs usage name decl = - List.iter - (fun c -> - Env.mark_constructor_used usage env name decl - (Ident.name c.Types.cd_id)) - cstrs + in + if err <> [] then err + else + let err = + let untagged1 = + Ast_untagged_variants.process_untagged decl1.type_attributes in - let usage = - if decl1.type_private = Private || decl2.type_private = Public - then Env.Positive else Env.Privatize + let untagged2 = + Ast_untagged_variants.process_untagged decl2.type_attributes in - mark cstrs1 usage name decl1; - if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; - compare_variants ~loc env decl1.type_params decl2.type_params 1 cstrs1 cstrs2 - | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - let err = compare_records ~loc env decl1.type_params decl2.type_params 1 labels1 labels2 in - if err <> [] || rep1 = rep2 then err else - [Record_representation (rep1, rep2)] - | (Type_open, Type_open) -> [] - | (_, _) -> [Kind] - in - if err <> [] then err else - let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in - (* If attempt to assign a non-immediate type (e.g. string) to a type that - * must be immediate, then we error *) - let err = - if abstr && - not decl1.type_immediate && - decl2.type_immediate then - [Immediate] - else [] - in - if err <> [] then err else - let need_variance = - abstr || decl1.type_private = Private || decl1.type_kind = Type_open in - if not need_variance then [] else - let abstr = abstr || decl2.type_private = Private in - let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in - let constrained ty = not (Btype.(is_Tvar (repr ty))) in - if List.for_all2 - (fun ty (v1,v2) -> - let open Variance in - let imp a b = not a || b in - let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in - (if abstr then (imp co1 co2 && imp cn1 cn2) - else if opn || constrained ty then (co1 = co2 && cn1 = cn2) - else true) && - let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in - imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1)) - decl2.type_params (List.combine decl1.type_variance decl2.type_variance) - then [] else [Variance] + match + ( decl2.type_kind, + decl1.type_unboxed.unboxed || untagged1, + decl2.type_unboxed.unboxed || untagged2 ) + with + | Type_abstract, _, _ -> [] + | _, true, false -> [Unboxed_representation false] + | _, false, true -> [Unboxed_representation true] + | _ -> [] + in + if err <> [] then err + else + let err = + let tag1 = + Ast_untagged_variants.process_tag_name decl1.type_attributes + in + let tag2 = + Ast_untagged_variants.process_tag_name decl2.type_attributes + in + if tag1 <> tag2 then [Tag_name] else err + in + if err <> [] then err + else + let err = + match (decl1.type_kind, decl2.type_kind) with + | _, Type_abstract -> [] + | Type_variant cstrs1, Type_variant cstrs2 -> + let mark cstrs usage name decl = + List.iter + (fun c -> + Env.mark_constructor_used usage env name decl + (Ident.name c.Types.cd_id)) + cstrs + in + let usage = + if decl1.type_private = Private || decl2.type_private = Public + then Env.Positive + else Env.Privatize + in + mark cstrs1 usage name decl1; + if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; + compare_variants ~loc env decl1.type_params decl2.type_params 1 + cstrs1 cstrs2 + | Type_record (labels1, rep1), Type_record (labels2, rep2) -> + let err = + compare_records ~loc env decl1.type_params decl2.type_params 1 + labels1 labels2 + in + if err <> [] || rep1 = rep2 then err + else [Record_representation (rep1, rep2)] + | Type_open, Type_open -> [] + | _, _ -> [Kind] + in + if err <> [] then err + else + let abstr = + decl2.type_kind = Type_abstract && decl2.type_manifest = None + in + (* If attempt to assign a non-immediate type (e.g. string) to a type that + * must be immediate, then we error *) + let err = + if abstr && (not decl1.type_immediate) && decl2.type_immediate + then [Immediate] + else [] + in + if err <> [] then err + else + let need_variance = + abstr + || decl1.type_private = Private + || decl1.type_kind = Type_open + in + if not need_variance then [] + else + let abstr = abstr || decl2.type_private = Private in + let opn = + decl2.type_kind = Type_open && decl2.type_manifest = None + in + let constrained ty = not Btype.(is_Tvar (repr ty)) in + if + List.for_all2 + (fun ty (v1, v2) -> + let open Variance in + let imp a b = (not a) || b in + let co1, cn1 = get_upper v1 and co2, cn2 = get_upper v2 in + (if abstr then imp co1 co2 && imp cn1 cn2 + else if opn || constrained ty then co1 = co2 && cn1 = cn2 + else true) + && + let p1, n1, i1, j1 = get_lower v1 + and p2, n2, i2, j2 = get_lower v2 in + imp abstr + (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1)) + decl2.type_params + (List.combine decl1.type_variance decl2.type_variance) + then [] + else [Variance] (* Inclusion between extension constructors *) let extension_constructors ~loc env id ext1 ext2 = let usage = - if ext1.ext_private = Private || ext2.ext_private = Public - then Env.Positive else Env.Privatize + if ext1.ext_private = Private || ext2.ext_private = Public then Env.Positive + else Env.Privatize in Env.mark_extension_used usage env ext1 (Ident.name id); let ty1 = - Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) + Btype.newgenty + (Tconstr (ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) in let ty2 = - Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) + Btype.newgenty + (Tconstr (ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) in - if Ctype.equal env true - (ty1 :: ext1.ext_type_params) - (ty2 :: ext2.ext_type_params) + if + Ctype.equal env true + (ty1 :: ext1.ext_type_params) + (ty2 :: ext2.ext_type_params) then - if compare_constructor_arguments ~loc env (Ident.create "") - ext1.ext_type_params ext2.ext_type_params - ext1.ext_args ext2.ext_args = [] then - if match ext1.ext_ret_type, ext2.ext_ret_type with - Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false + if + compare_constructor_arguments ~loc env (Ident.create "") + ext1.ext_type_params ext2.ext_type_params ext1.ext_args ext2.ext_args + = [] + then + if + match (ext1.ext_ret_type, ext2.ext_ret_type) with + | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false | Some _, None | None, Some _ -> false | _ -> true then - match ext1.ext_private, ext2.ext_private with - Private, Public -> false - | _, _ -> true + match (ext1.ext_private, ext2.ext_private) with + | Private, Public -> false + | _, _ -> true else false else false else false diff --git a/compiler/ml/includecore.mli b/compiler/ml/includecore.mli index 2908a07b3c..20ed150639 100644 --- a/compiler/ml/includecore.mli +++ b/compiler/ml/includecore.mli @@ -21,7 +21,7 @@ open Types exception Dont_match type type_mismatch = - Arity + | Arity | Privacy | Kind | Constraint @@ -38,24 +38,35 @@ type type_mismatch = | Tag_name | Variant_representation of Ident.t -val value_descriptions: - loc:Location.t -> Env.t -> Ident.t -> - value_description -> value_description -> module_coercion - -val type_declarations: +val value_descriptions : + loc:Location.t -> + Env.t -> + Ident.t -> + value_description -> + value_description -> + module_coercion + +val type_declarations : ?equality:bool -> loc:Location.t -> - Env.t -> string -> - type_declaration -> Ident.t -> type_declaration -> type_mismatch list + Env.t -> + string -> + type_declaration -> + Ident.t -> + type_declaration -> + type_mismatch list -val extension_constructors: +val extension_constructors : loc:Location.t -> - Env.t -> Ident.t -> - extension_constructor -> extension_constructor -> bool + Env.t -> + Ident.t -> + extension_constructor -> + extension_constructor -> + bool (* val class_types: Env.t -> class_type -> class_type -> bool *) -val report_type_mismatch: - string -> string -> string -> Format.formatter -> type_mismatch list -> unit +val report_type_mismatch : + string -> string -> string -> Format.formatter -> type_mismatch list -> unit diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index 4f02122d90..7c2686fa93 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -21,10 +21,13 @@ open Typedtree open Types type symptom = - Missing_field of Ident.t * Location.t * string (* kind *) + | Missing_field of Ident.t * Location.t * string (* kind *) | Value_descriptions of Ident.t * value_description * value_description - | Type_declarations of Ident.t * type_declaration - * type_declaration * Includecore.type_mismatch list + | Type_declarations of + Ident.t + * type_declaration + * type_declaration + * Includecore.type_mismatch list | Extension_constructors of Ident.t * extension_constructor * extension_constructor | Module_types of module_type * module_type @@ -36,7 +39,10 @@ type symptom = | Invalid_module_alias of Path.t type pos = - Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t + | Module of Ident.t + | Modtype of Ident.t + | Arg of Ident.t + | Body of Ident.t type error = pos list * Env.t * symptom exception Error of error list @@ -51,49 +57,45 @@ let value_descriptions ~loc env cxt subst id vd1 vd2 = Cmt_format.record_value_dependency vd1 vd2; Env.mark_value_used env (Ident.name id) vd1; let vd2 = Subst.value_description subst vd2 in - try - Includecore.value_descriptions ~loc env id vd1 vd2 + try Includecore.value_descriptions ~loc env id vd1 vd2 with Includecore.Dont_match -> - raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)]) + raise (Error [(cxt, env, Value_descriptions (id, vd1, vd2))]) (* Inclusion between type declarations *) -let type_declarations ~loc env ?(old_env=env) cxt subst id decl1 decl2 = +let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2 in if err <> [] then - raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)]) + raise (Error [(cxt, old_env, Type_declarations (id, decl1, decl2, err))]) (* Inclusion between extension constructors *) let extension_constructors ~loc env cxt subst id ext1 ext2 = let ext2 = Subst.extension_constructor subst ext2 in - if Includecore.extension_constructors ~loc env id ext1 ext2 - then () - else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)]) - + if Includecore.extension_constructors ~loc env id ext1 ext2 then () + else raise (Error [(cxt, env, Extension_constructors (id, ext1, ext2))]) (* Expand a module type identifier when possible *) exception Dont_match let may_expand_module_path env path = - try ignore (Env.find_modtype_expansion path env); true + try + ignore (Env.find_modtype_expansion path env); + true with Not_found -> false let expand_module_path env cxt path = - try - Env.find_modtype_expansion path env - with Not_found -> - raise(Error[cxt, env, Unbound_modtype_path path]) + try Env.find_modtype_expansion path env + with Not_found -> raise (Error [(cxt, env, Unbound_modtype_path path)]) let expand_module_alias env cxt path = try (Env.find_module path env).md_type - with Not_found -> - raise(Error[cxt, env, Unbound_module_path path]) + with Not_found -> raise (Error [(cxt, env, Unbound_module_path path)]) (* let rec normalize_module_path env cxt path = @@ -105,7 +107,7 @@ let rec normalize_module_path env cxt path = (* Extract name, kind and ident from a signature item *) type field_desc = - Field_value of string + | Field_value of string | Field_type of string | Field_typext of string | Field_module of string @@ -119,68 +121,70 @@ let kind_of_field_desc = function | Field_modtype _ -> "module type" let item_ident_name = function - Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id)) - | Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id)) - | Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id)) - | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id)) - | Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id)) + | Sig_value (id, d) -> (id, d.val_loc, Field_value (Ident.name id)) + | Sig_type (id, d, _) -> (id, d.type_loc, Field_type (Ident.name id)) + | Sig_typext (id, d, _) -> (id, d.ext_loc, Field_typext (Ident.name id)) + | Sig_module (id, d, _) -> (id, d.md_loc, Field_module (Ident.name id)) + | Sig_modtype (id, d) -> (id, d.mtd_loc, Field_modtype (Ident.name id)) | Sig_class () -> assert false | Sig_class_type () -> assert false let is_runtime_component = function - | Sig_value(_,{val_kind = Val_prim _}) - | Sig_type(_,_,_) - | Sig_modtype(_,_) - | Sig_class_type() -> false - | Sig_value(_,_) - | Sig_typext(_,_,_) - | Sig_module(_,_,_) - | Sig_class() -> true + | Sig_value (_, {val_kind = Val_prim _}) + | Sig_type (_, _, _) + | Sig_modtype (_, _) + | Sig_class_type () -> + false + | Sig_value (_, _) + | Sig_typext (_, _, _) + | Sig_module (_, _, _) + | Sig_class () -> + true (* Print a coercion *) let rec print_list pr ppf = function - [] -> () + | [] -> () | [a] -> pr ppf a - | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l -let print_list pr ppf l = - Format.fprintf ppf "[@[%a@]]" (print_list pr) l + | a :: l -> + pr ppf a; + Format.fprintf ppf ";@ "; + print_list pr ppf l +let print_list pr ppf l = Format.fprintf ppf "[@[%a@]]" (print_list pr) l let rec print_coercion ppf c = let pr fmt = Format.fprintf ppf fmt in match c with - Tcoerce_none -> pr "id" + | Tcoerce_none -> pr "id" | Tcoerce_structure (fl, nl, _) -> - pr "@[<2>struct@ %a@ %a@]" - (print_list print_coercion2) fl - (print_list print_coercion3) nl + pr "@[<2>struct@ %a@ %a@]" + (print_list print_coercion2) + fl + (print_list print_coercion3) + nl | Tcoerce_functor (inp, out) -> - pr "@[<2>functor@ (%a)@ (%a)@]" - print_coercion inp - print_coercion out - | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> - pr "prim %s@ (%a)" pc_desc.Primitive.prim_name - Printtyp.raw_type_expr pc_type + pr "@[<2>functor@ (%a)@ (%a)@]" print_coercion inp print_coercion out + | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> + pr "prim %s@ (%a)" pc_desc.Primitive.prim_name Printtyp.raw_type_expr + pc_type | Tcoerce_alias (p, c) -> - pr "@[<2>alias %a@ (%a)@]" - Printtyp.path p - print_coercion c + pr "@[<2>alias %a@ (%a)@]" Printtyp.path p print_coercion c + and print_coercion2 ppf (n, c) = Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c + and print_coercion3 ppf (i, n, c) = - Format.fprintf ppf "@[%s, %d,@ %a@]" - (Ident.unique_name i) n print_coercion c + Format.fprintf ppf "@[%s, %d,@ %a@]" (Ident.unique_name i) n print_coercion c (* Simplify a structure coercion *) let simplify_structure_coercion cc id_pos_list runtime_fields = let rec is_identity_coercion pos = function - | [] -> - true - | (n, c) :: rem -> - n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in - if is_identity_coercion 0 cc - then Tcoerce_none + | [] -> true + | (n, c) :: rem -> + n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem + in + if is_identity_coercion 0 cc then Tcoerce_none else Tcoerce_structure (cc, id_pos_list, runtime_fields) (* Inclusion between module types. @@ -188,140 +192,137 @@ let simplify_structure_coercion cc id_pos_list runtime_fields = into a value of the bigger type. *) let rec modtypes ~loc env cxt subst mty1 mty2 = - try - try_modtypes ~loc env cxt subst mty1 mty2 - with - Dont_match -> - raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)]) - | Error reasons as err -> - match mty1, mty2 with - Mty_alias _, _ - | _, Mty_alias _ -> raise err - | _ -> - raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2)) - :: reasons)) + try try_modtypes ~loc env cxt subst mty1 mty2 with + | Dont_match -> + raise (Error [(cxt, env, Module_types (mty1, Subst.modtype subst mty2))]) + | Error reasons as err -> ( + match (mty1, mty2) with + | Mty_alias _, _ | _, Mty_alias _ -> raise err + | _ -> + raise + (Error + ((cxt, env, Module_types (mty1, Subst.modtype subst mty2)) :: reasons)) + ) and try_modtypes ~loc env cxt subst mty1 mty2 = match (mty1, mty2) with - | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin - if Env.is_functor_arg p2 env then - raise (Error[cxt, env, Invalid_module_alias p2]); - if not (Path.same p1 p2) then begin - let p1 = Env.normalize_path None env p1 - and p2 = Env.normalize_path None env (Subst.module_path subst p2) in - if not (Path.same p1 p2) then raise Dont_match - end; - match pres1, pres2 with - | Mta_present, Mta_present -> Tcoerce_none - (* Should really be Tcoerce_ignore if it existed *) - | Mta_absent, Mta_absent -> Tcoerce_none - (* Should really be Tcoerce_empty if it existed *) - | Mta_present, Mta_absent -> Tcoerce_none - | Mta_absent, Mta_present -> - let p1 = try - Env.normalize_path (Some Location.none) env p1 - with Env.Error (Env.Missing_module (_, _, path)) -> - raise (Error[cxt, env, Unbound_module_path path]) - in - Tcoerce_alias (p1, Tcoerce_none) - end - | (Mty_alias(pres1, p1), _) -> begin - let p1 = try - Env.normalize_path (Some Location.none) env p1 - with Env.Error (Env.Missing_module (_, _, path)) -> - raise (Error[cxt, env, Unbound_module_path path]) + | Mty_alias (pres1, p1), Mty_alias (pres2, p2) -> ( + if Env.is_functor_arg p2 env then + raise (Error [(cxt, env, Invalid_module_alias p2)]); + (if not (Path.same p1 p2) then + let p1 = Env.normalize_path None env p1 + and p2 = Env.normalize_path None env (Subst.module_path subst p2) in + if not (Path.same p1 p2) then raise Dont_match); + match (pres1, pres2) with + | Mta_present, Mta_present -> + Tcoerce_none (* Should really be Tcoerce_ignore if it existed *) + | Mta_absent, Mta_absent -> + Tcoerce_none (* Should really be Tcoerce_empty if it existed *) + | Mta_present, Mta_absent -> Tcoerce_none + | Mta_absent, Mta_present -> + let p1 = + try Env.normalize_path (Some Location.none) env p1 + with Env.Error (Env.Missing_module (_, _, path)) -> + raise (Error [(cxt, env, Unbound_module_path path)]) in - let mty1 = - Mtype.strengthen ~aliasable:true env - (expand_module_alias env cxt p1) p1 - in - let cc = modtypes ~loc env cxt subst mty1 mty2 in - match pres1 with - | Mta_present -> cc - | Mta_absent -> Tcoerce_alias (p1, cc) - end - | (Mty_ident p1, _) when may_expand_module_path env p1 -> - try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2 - | (_, Mty_ident _) -> - try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2) - | (Mty_signature sig1, Mty_signature sig2) -> - signatures ~loc env cxt subst sig1 sig2 - | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) -> - begin match modtypes ~loc env (Body param1::cxt) subst res1 res2 with - Tcoerce_none -> Tcoerce_none - | cc -> Tcoerce_functor (Tcoerce_none, cc) - end - | (Mty_functor(param1, Some arg1, res1), - Mty_functor(param2, Some arg2, res2)) -> - let arg2' = Subst.modtype subst arg2 in - let cc_arg = modtypes ~loc env (Arg param1::cxt) Subst.identity arg2' arg1 in - let cc_res = - modtypes ~loc (Env.add_module param1 arg2' env) (Body param1::cxt) - (Subst.add_module param2 (Pident param1) subst) res1 res2 in - begin match (cc_arg, cc_res) with - (Tcoerce_none, Tcoerce_none) -> Tcoerce_none - | _ -> Tcoerce_functor(cc_arg, cc_res) - end - | (_, _) -> - raise Dont_match + Tcoerce_alias (p1, Tcoerce_none)) + | Mty_alias (pres1, p1), _ -> ( + let p1 = + try Env.normalize_path (Some Location.none) env p1 + with Env.Error (Env.Missing_module (_, _, path)) -> + raise (Error [(cxt, env, Unbound_module_path path)]) + in + let mty1 = + Mtype.strengthen ~aliasable:true env (expand_module_alias env cxt p1) p1 + in + let cc = modtypes ~loc env cxt subst mty1 mty2 in + match pres1 with + | Mta_present -> cc + | Mta_absent -> Tcoerce_alias (p1, cc)) + | Mty_ident p1, _ when may_expand_module_path env p1 -> + try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2 + | _, Mty_ident _ -> try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2) + | Mty_signature sig1, Mty_signature sig2 -> + signatures ~loc env cxt subst sig1 sig2 + | Mty_functor (param1, None, res1), Mty_functor (_param2, None, res2) -> ( + match modtypes ~loc env (Body param1 :: cxt) subst res1 res2 with + | Tcoerce_none -> Tcoerce_none + | cc -> Tcoerce_functor (Tcoerce_none, cc)) + | Mty_functor (param1, Some arg1, res1), Mty_functor (param2, Some arg2, res2) + -> ( + let arg2' = Subst.modtype subst arg2 in + let cc_arg = + modtypes ~loc env (Arg param1 :: cxt) Subst.identity arg2' arg1 + in + let cc_res = + modtypes ~loc + (Env.add_module param1 arg2' env) + (Body param1 :: cxt) + (Subst.add_module param2 (Pident param1) subst) + res1 res2 + in + match (cc_arg, cc_res) with + | Tcoerce_none, Tcoerce_none -> Tcoerce_none + | _ -> Tcoerce_functor (cc_arg, cc_res)) + | _, _ -> raise Dont_match and try_modtypes2 ~loc env cxt mty1 mty2 = (* mty2 is an identifier *) match (mty1, mty2) with - (Mty_ident p1, Mty_ident p2) - when Path.same (Env.normalize_path_prefix None env p1) - (Env.normalize_path_prefix None env p2) -> - Tcoerce_none - | (_, Mty_ident p2) when may_expand_module_path env p2 -> - try_modtypes ~loc env cxt Subst.identity mty1 (expand_module_path env cxt p2) - | (_, _) -> - raise Dont_match + | Mty_ident p1, Mty_ident p2 + when Path.same + (Env.normalize_path_prefix None env p1) + (Env.normalize_path_prefix None env p2) -> + Tcoerce_none + | _, Mty_ident p2 when may_expand_module_path env p2 -> + try_modtypes ~loc env cxt Subst.identity mty1 + (expand_module_path env cxt p2) + | _, _ -> raise Dont_match (* Inclusion between signatures *) and signatures ~loc env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) - let new_env = - Env.add_signature sig1 (Env.in_signature true env) in + let new_env = Env.add_signature sig1 (Env.in_signature true env) in (* Keep ids for module aliases *) - let (id_pos_list,_) = + let id_pos_list, _ = List.fold_left - (fun ((l,pos) as id_pos) -> function - Sig_module (id, _, _) -> - ((id,pos,Tcoerce_none)::l , pos+1) - | item -> - if is_runtime_component item then (l,pos+1 ) else id_pos - ) - ([], 0) sig1 in + (fun ((l, pos) as id_pos) -> function + | Sig_module (id, _, _) -> ((id, pos, Tcoerce_none) :: l, pos + 1) + | item -> if is_runtime_component item then (l, pos + 1) else id_pos) + ([], 0) sig1 + in let runtime_fields = let get_id = function - | Sig_value (i,_) - | Sig_module (i,_,_) - | Sig_typext (i,_,_) - | Sig_modtype(i,_) - | Sig_type(i,_,_) -> Ident.name i - | Sig_class () - | Sig_class_type () -> assert false in - List.fold_right (fun item fields -> - if is_runtime_component item then get_id item :: fields else fields) sig2 [] in + | Sig_value (i, _) + | Sig_module (i, _, _) + | Sig_typext (i, _, _) + | Sig_modtype (i, _) + | Sig_type (i, _, _) -> + Ident.name i + | Sig_class () | Sig_class_type () -> assert false + in + List.fold_right + (fun item fields -> + if is_runtime_component item then get_id item :: fields else fields) + sig2 [] + in (* Build a table of the components of sig1, along with their positions. The table is indexed by kind and name of component *) let rec build_component_table pos tbl = function - [] -> pos, tbl + | [] -> (pos, tbl) | item :: rem -> - let (id, _loc, name) = item_ident_name item in - let nextpos = if is_runtime_component item then pos + 1 else pos in - build_component_table nextpos - (Tbl.add name (id, item, pos) tbl) rem in - let len1, comps1 = - build_component_table 0 Tbl.empty sig1 in + let id, _loc, name = item_ident_name item in + let nextpos = if is_runtime_component item then pos + 1 else pos in + build_component_table nextpos (Tbl.add name (id, item, pos) tbl) rem + in + let len1, comps1 = build_component_table 0 Tbl.empty sig1 in let len2 = List.fold_left (fun n i -> if is_runtime_component i then n + 1 else n) - 0 - sig2 + 0 sig2 in (* Pair each component of sig2 with a component of sig1, identifying the names along the way. @@ -329,54 +330,49 @@ and signatures ~loc env cxt subst sig1 sig2 = of sig2, the position of the matching run-time components of sig1 and the coercion to be applied to it. *) let rec pair_components subst paired unpaired = function - [] -> - begin match unpaired with - [] -> - let cc = - signature_components ~loc env new_env cxt subst - (List.rev paired) - in - if len1 = len2 then (* see PR#5098 *) - simplify_structure_coercion cc id_pos_list runtime_fields - else - Tcoerce_structure (cc, id_pos_list, runtime_fields) - | _ -> raise(Error unpaired) - end - | item2 :: rem -> - let (id2, loc, name2) = item_ident_name item2 in - let name2, report = - match item2, name2 with - Sig_type (_, {type_manifest=None}, _), Field_type s - when Btype.is_row_name s -> - (* Do not report in case of failure, - as the main type will generate an error *) - Field_type (String.sub s 0 (String.length s - 4)), false - | _ -> name2, true + | [] -> ( + match unpaired with + | [] -> + let cc = + signature_components ~loc env new_env cxt subst (List.rev paired) + in + if len1 = len2 then + (* see PR#5098 *) + simplify_structure_coercion cc id_pos_list runtime_fields + else Tcoerce_structure (cc, id_pos_list, runtime_fields) + | _ -> raise (Error unpaired)) + | item2 :: rem -> ( + let id2, loc, name2 = item_ident_name item2 in + let name2, report = + match (item2, name2) with + | Sig_type (_, {type_manifest = None}, _), Field_type s + when Btype.is_row_name s -> + (* Do not report in case of failure, + as the main type will generate an error *) + (Field_type (String.sub s 0 (String.length s - 4)), false) + | _ -> (name2, true) + in + match Tbl.find name2 comps1 with + | id1, item1, pos1 -> + let new_subst = + match item2 with + | Sig_type _ -> Subst.add_type id2 (Pident id1) subst + | Sig_module _ -> Subst.add_module id2 (Pident id1) subst + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Pident id1)) subst + | Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type () -> + subst + in + pair_components new_subst ((item1, item2, pos1) :: paired) unpaired rem + | exception Not_found -> + let unpaired = + if report then + (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) + :: unpaired + else unpaired in - begin match Tbl.find name2 comps1 with - | (id1, item1, pos1) -> - let new_subst = - match item2 with - Sig_type _ -> - Subst.add_type id2 (Pident id1) subst - | Sig_module _ -> - Subst.add_module id2 (Pident id1) subst - | Sig_modtype _ -> - Subst.add_modtype id2 (Mty_ident (Pident id1)) subst - | Sig_value _ | Sig_typext _ - | Sig_class _ | Sig_class_type () -> - subst - in - pair_components new_subst - ((item1, item2, pos1) :: paired) unpaired rem - | exception Not_found -> - let unpaired = - if report then - (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) :: - unpaired - else unpaired in - pair_components subst paired unpaired rem - end in + pair_components subst paired unpaired rem) + in (* Do the pairing and checking, and return the final coercion *) pair_components subst [] [] sig2 @@ -385,83 +381,72 @@ and signatures ~loc env cxt subst sig1 sig2 = and signature_components ~loc old_env env cxt subst paired = let comps_rec rem = signature_components ~loc old_env env cxt subst rem in match paired with - [] -> [] - | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem -> - let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in - begin match valdecl2.val_kind with - Val_prim _ -> comps_rec rem - | _ -> (pos, cc) :: comps_rec rem - end - | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem -> - type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2; - comps_rec rem - | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos) - :: rem -> - extension_constructors ~loc env cxt subst id1 ext1 ext2; - (pos, Tcoerce_none) :: comps_rec rem - | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem -> - let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in - (pos, cc) :: comps_rec rem - | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem -> - modtype_infos ~loc env cxt subst id1 info1 info2; - comps_rec rem - | (Sig_class (), Sig_class () , _) :: _ -> assert false - | (Sig_class_type(), - Sig_class_type(), _pos) :: _ -> assert false - | _ -> - assert false + | [] -> [] + | (Sig_value (id1, valdecl1), Sig_value (_id2, valdecl2), pos) :: rem -> ( + let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in + match valdecl2.val_kind with + | Val_prim _ -> comps_rec rem + | _ -> (pos, cc) :: comps_rec rem) + | (Sig_type (id1, tydecl1, _), Sig_type (_id2, tydecl2, _), _pos) :: rem -> + type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2; + comps_rec rem + | (Sig_typext (id1, ext1, _), Sig_typext (_id2, ext2, _), pos) :: rem -> + extension_constructors ~loc env cxt subst id1 ext1 ext2; + (pos, Tcoerce_none) :: comps_rec rem + | (Sig_module (id1, mty1, _), Sig_module (_id2, mty2, _), pos) :: rem -> + let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in + (pos, cc) :: comps_rec rem + | (Sig_modtype (id1, info1), Sig_modtype (_id2, info2), _pos) :: rem -> + modtype_infos ~loc env cxt subst id1 info1 info2; + comps_rec rem + | (Sig_class (), Sig_class (), _) :: _ -> assert false + | (Sig_class_type (), Sig_class_type (), _pos) :: _ -> assert false + | _ -> assert false and module_declarations ~loc env cxt subst id1 md1 md2 = - Builtin_attributes.check_deprecated_inclusion - ~def:md1.md_loc - ~use:md2.md_loc - loc - md1.md_attributes md2.md_attributes - (Ident.name id1); + Builtin_attributes.check_deprecated_inclusion ~def:md1.md_loc ~use:md2.md_loc + loc md1.md_attributes md2.md_attributes (Ident.name id1); let p1 = Pident id1 in Env.mark_module_used env (Ident.name id1) md1.md_loc; - modtypes ~loc env (Module id1::cxt) subst - (Mtype.strengthen ~aliasable:true env md1.md_type p1) md2.md_type + modtypes ~loc env (Module id1 :: cxt) subst + (Mtype.strengthen ~aliasable:true env md1.md_type p1) + md2.md_type (* Inclusion between module type specifications *) and modtype_infos ~loc env cxt subst id info1 info2 = - Builtin_attributes.check_deprecated_inclusion - ~def:info1.mtd_loc - ~use:info2.mtd_loc - loc - info1.mtd_attributes info2.mtd_attributes + Builtin_attributes.check_deprecated_inclusion ~def:info1.mtd_loc + ~use:info2.mtd_loc loc info1.mtd_attributes info2.mtd_attributes (Ident.name id); let info2 = Subst.modtype_declaration subst info2 in let cxt' = Modtype id :: cxt in try match (info1.mtd_type, info2.mtd_type) with - (None, None) -> () - | (Some _, None) -> () - | (Some mty1, Some mty2) -> - check_modtype_equiv ~loc env cxt' mty1 mty2 - | (None, Some mty2) -> - check_modtype_equiv ~loc env cxt' (Mty_ident(Pident id)) mty2 + | None, None -> () + | Some _, None -> () + | Some mty1, Some mty2 -> check_modtype_equiv ~loc env cxt' mty1 mty2 + | None, Some mty2 -> + check_modtype_equiv ~loc env cxt' (Mty_ident (Pident id)) mty2 with Error reasons -> - raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons)) + raise (Error ((cxt, env, Modtype_infos (id, info1, info2)) :: reasons)) and check_modtype_equiv ~loc env cxt mty1 mty2 = match - (modtypes ~loc env cxt Subst.identity mty1 mty2, - modtypes ~loc env cxt Subst.identity mty2 mty1) + ( modtypes ~loc env cxt Subst.identity mty1 mty2, + modtypes ~loc env cxt Subst.identity mty2 mty1 ) with - (Tcoerce_none, Tcoerce_none) -> () - | (_c1, _c2) -> - (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." - print_coercion _c1 print_coercion _c2; *) - raise(Error [cxt, env, Modtype_permutation]) + | Tcoerce_none, Tcoerce_none -> () + | _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) *) let can_alias env path = let rec no_apply = function | Pident _ -> true - | Pdot(p, _, _) -> no_apply p + | Pdot (p, _, _) -> no_apply p | Papply _ -> false in no_apply path && not (Env.is_functor_arg path env) @@ -469,10 +454,11 @@ let can_alias env path = let check_modtype_inclusion ~loc env mty1 path1 mty2 = try let aliasable = can_alias env path1 in - ignore(modtypes ~loc env [] Subst.identity - (Mtype.strengthen ~aliasable env mty1 path1) mty2) - with Error _ -> - raise Not_found + ignore + (modtypes ~loc env [] Subst.identity + (Mtype.strengthen ~aliasable env mty1 path1) + mty2) + with Error _ -> raise Not_found let _ = Env.check_modtype_inclusion := check_modtype_inclusion @@ -481,11 +467,13 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion let compunit env impl_name impl_sig intf_name intf_sig = try - signatures ~loc:(Location.in_file impl_name) env [] Subst.identity - impl_sig intf_sig + signatures + ~loc:(Location.in_file impl_name) + env [] Subst.identity impl_sig intf_sig with Error reasons -> - raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name)) - :: reasons)) + raise + (Error + (([], Env.empty, Interface_mismatch (impl_name, intf_name)) :: reasons)) (* Hide the context and substitution parameters to the outside world *) @@ -518,153 +506,149 @@ let show_locs ppf (loc1, loc2) = let include_err ~env ppf = function | Missing_field (id, loc, kind) -> - fprintf ppf "The %s `%a' is required but not provided" kind ident id; - show_loc "Expected declaration" ppf loc - | Value_descriptions(id, d1, d2) -> - let curry_kind_1, curry_kind_2 = - match (Ctype.expand_head env d1.val_type, Ctype.expand_head env d2.val_type ) with - | { desc = Tarrow _ }, - { desc = Tconstr (Pident {name = "function$"},_,_)} -> (" (curried)", " (uncurried)") - | { desc = Tconstr (Pident {name = "function$"},_,_)}, - { desc = Tarrow _ } -> (" (uncurried)", " (curried)") - | _ -> ("", "") - in - fprintf ppf - "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" - (value_description id) d1 curry_kind_1 (value_description id) d2 curry_kind_2; - show_locs ppf (d1.val_loc, d2.val_loc); - | Type_declarations(id, d1, d2, errs) -> - fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" - "Type declarations do not match" - (type_declaration id) d1 - "is not included in" - (type_declaration id) d2 - show_locs (d1.type_loc, d2.type_loc) - (Includecore.report_type_mismatch - "the first" "the second" "declaration") errs - | Extension_constructors(id, x1, x2) -> - fprintf ppf - "@[Extension declarations do not match:@ \ - %a@;<1 -2>is not included in@ %a@]" - (extension_constructor id) x1 + fprintf ppf "The %s `%a' is required but not provided" kind ident id; + show_loc "Expected declaration" ppf loc + | Value_descriptions (id, d1, d2) -> + let curry_kind_1, curry_kind_2 = + match + (Ctype.expand_head env d1.val_type, Ctype.expand_head env d2.val_type) + with + | {desc = Tarrow _}, {desc = Tconstr (Pident {name = "function$"}, _, _)} + -> + (" (curried)", " (uncurried)") + | {desc = Tconstr (Pident {name = "function$"}, _, _)}, {desc = Tarrow _} + -> + (" (uncurried)", " (curried)") + | _ -> ("", "") + in + fprintf ppf + "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" + (value_description id) d1 curry_kind_1 (value_description id) d2 + curry_kind_2; + show_locs ppf (d1.val_loc, d2.val_loc) + | Type_declarations (id, d1, d2, errs) -> + fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" + "Type declarations do not match" (type_declaration id) d1 + "is not included in" (type_declaration id) d2 show_locs + (d1.type_loc, d2.type_loc) + (Includecore.report_type_mismatch "the first" "the second" "declaration") + errs + | Extension_constructors (id, x1, x2) -> + fprintf ppf + "@[Extension declarations do not match:@ %a@;\ + <1 -2>is not included in@ %a@]" (extension_constructor id) x1 (extension_constructor id) x2; - show_locs ppf (x1.ext_loc, x2.ext_loc) - | Module_types(mty1, mty2)-> - fprintf ppf - "@[Modules do not match:@ \ - %a@;<1 -2>is not included in@ %a@]" - modtype mty1 - modtype mty2 - | Modtype_infos(id, d1, d2) -> - fprintf ppf - "@[Module type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]" - (modtype_declaration id) d1 + show_locs ppf (x1.ext_loc, x2.ext_loc) + | Module_types (mty1, mty2) -> + fprintf ppf + "@[Modules do not match:@ %a@;<1 -2>is not included in@ %a@]" + modtype mty1 modtype mty2 + | Modtype_infos (id, d1, d2) -> + fprintf ppf + "@[Module type declarations do not match:@ %a@;\ + <1 -2>does not match@ %a@]" (modtype_declaration id) d1 (modtype_declaration id) d2 - | Modtype_permutation -> - fprintf ppf "Illegal permutation of structure fields" - | Interface_mismatch(impl_name, intf_name) -> - fprintf ppf "@[The implementation %s@ does not match the interface %s:" - impl_name intf_name + | Modtype_permutation -> fprintf ppf "Illegal permutation of structure fields" + | Interface_mismatch (impl_name, intf_name) -> + fprintf ppf "@[The implementation %s@ does not match the interface %s:" + impl_name intf_name | Unbound_modtype_path path -> - fprintf ppf "Unbound module type %a" Printtyp.path path + fprintf ppf "Unbound module type %a" Printtyp.path path | Unbound_module_path path -> - fprintf ppf "Unbound module %a" Printtyp.path path + fprintf ppf "Unbound module %a" Printtyp.path path | Invalid_module_alias path -> - fprintf ppf "Module %a cannot be aliased" Printtyp.path path + fprintf ppf "Module %a cannot be aliased" Printtyp.path path let rec context ppf = function - Module id :: rem -> - fprintf ppf "@[<2>module %a%a@]" ident id args rem + | Module id :: rem -> fprintf ppf "@[<2>module %a%a@]" ident id args rem | Modtype id :: rem -> - fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem + fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem | Body x :: rem -> - fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> - fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem - | [] -> - fprintf ppf "" + fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem + | [] -> fprintf ppf "" + and context_mty ppf = function - (Module _ | Modtype _) :: _ as rem -> - fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | (Module _ | Modtype _) :: _ as rem -> + fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem | cxt -> context ppf cxt + and args ppf = function - Body x :: rem -> - fprintf ppf "(%s)%a" (argname x) args rem - | Arg x :: rem -> - fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem - | cxt -> - fprintf ppf " :@ %a" context_mty cxt + | Body x :: rem -> fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem + | cxt -> fprintf ppf " :@ %a" context_mty cxt + and argname x = let s = Ident.name x in if s = "*" then "" else s let path_of_context = function - Module id :: rem -> - let rec subm path = function - [] -> path - | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem - | _ -> assert false - in subm (Pident id) rem + | Module id :: rem -> + let rec subm path = function + | [] -> path + | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem + | _ -> assert false + in + subm (Pident id) rem | _ -> assert false let context ppf cxt = - if cxt = [] then () else - if List.for_all (function Module _ -> true | _ -> false) cxt then - fprintf ppf "In module %a:@ " path (path_of_context cxt) - else - fprintf ppf "@[At position@ %a@]@ " context cxt + if cxt = [] then () + else if + List.for_all + (function + | Module _ -> true + | _ -> false) + cxt + then fprintf ppf "In module %a:@ " path (path_of_context cxt) + else fprintf ppf "@[At position@ %a@]@ " context cxt let include_err ppf (cxt, env, err) = Printtyp.wrap_printing_env env (fun () -> - fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err ~env) err) + fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err ~env) err) let buffer = ref Bytes.empty let is_big obj = let size = !Clflags.error_size in - size > 0 && - begin - if Bytes.length !buffer < size then buffer := Bytes.create size; - try ignore (Marshal.to_buffer !buffer 0 size obj []); false - with _ -> true - end + size > 0 + && + (if Bytes.length !buffer < size then buffer := Bytes.create size; + try + ignore (Marshal.to_buffer !buffer 0 size obj []); + false + with _ -> true) let report_error ppf errs = - if errs = [] then () else - let (errs , err) = split_last errs in - let pe = ref true in - let include_err' ppf (_,_,obj as err) = - if not (is_big obj) then fprintf ppf "%a@ " include_err err - else if !pe then (fprintf ppf "...@ "; pe := false) - in - let print_errs ppf = List.iter (include_err' ppf) in - fprintf ppf "@[%a%a@]" print_errs errs include_err err - - -let better_candidate_loc (x : error list) = - match x with - | [ (_,_,Interface_mismatch _); (_,_,descr)] - -> - begin match descr with - | Value_descriptions (_,d1,_) -> Some d1.val_loc - | Type_declarations (_,tdcl1,_,_) -> - Some tdcl1.type_loc - | Missing_field (_,loc,_) -> Some loc - | _ -> None - end - | _ -> None + if errs = [] then () + else + let errs, err = split_last errs in + let pe = ref true in + let include_err' ppf ((_, _, obj) as err) = + if not (is_big obj) then fprintf ppf "%a@ " include_err err + else if !pe then ( + fprintf ppf "...@ "; + pe := false) + in + let print_errs ppf = List.iter (include_err' ppf) in + fprintf ppf "@[%a%a@]" print_errs errs include_err err + +let better_candidate_loc (x : error list) = + match x with + | [(_, _, Interface_mismatch _); (_, _, descr)] -> ( + match descr with + | Value_descriptions (_, d1, _) -> Some d1.val_loc + | Type_declarations (_, tdcl1, _, _) -> Some tdcl1.type_loc + | Missing_field (_, loc, _) -> Some loc + | _ -> None) + | _ -> None (* We could do a better job to split the individual error items as sub-messages of the main interface mismatch on the whole unit. *) let () = - Location.register_error_of_exn - (function - | Error err -> - begin match better_candidate_loc err with - | None -> - Some (Location.error_of_printer_file report_error err) - | Some loc -> - Some (Location.error_of_printer loc report_error err) - end - | _ -> None - ) + Location.register_error_of_exn (function + | Error err -> ( + match better_candidate_loc err with + | None -> Some (Location.error_of_printer_file report_error err) + | Some loc -> Some (Location.error_of_printer loc report_error err)) + | _ -> None) diff --git a/compiler/ml/includemod.mli b/compiler/ml/includemod.mli index bd3f37bc13..9399f2b63a 100644 --- a/compiler/ml/includemod.mli +++ b/compiler/ml/includemod.mli @@ -19,26 +19,32 @@ open Typedtree open Types open Format -val modtypes: - loc:Location.t -> Env.t -> - module_type -> module_type -> module_coercion +val modtypes : + loc:Location.t -> Env.t -> module_type -> module_type -> module_coercion -val signatures: Env.t -> signature -> signature -> module_coercion +val signatures : Env.t -> signature -> signature -> module_coercion -val compunit: - Env.t -> string -> signature -> string -> signature -> module_coercion +val compunit : + Env.t -> string -> signature -> string -> signature -> module_coercion -val type_declarations: - loc:Location.t -> Env.t -> - Ident.t -> type_declaration -> type_declaration -> unit +val type_declarations : + loc:Location.t -> + Env.t -> + Ident.t -> + type_declaration -> + type_declaration -> + unit -val print_coercion: formatter -> module_coercion -> unit +val print_coercion : formatter -> module_coercion -> unit type symptom = - Missing_field of Ident.t * Location.t * string (* kind *) + | Missing_field of Ident.t * Location.t * string (* kind *) | Value_descriptions of Ident.t * value_description * value_description - | Type_declarations of Ident.t * type_declaration - * type_declaration * Includecore.type_mismatch list + | Type_declarations of + Ident.t + * type_declaration + * type_declaration + * Includecore.type_mismatch list | Extension_constructors of Ident.t * extension_constructor * extension_constructor | Module_types of module_type * module_type @@ -50,10 +56,13 @@ type symptom = | Invalid_module_alias of Path.t type pos = - Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t + | Module of Ident.t + | Modtype of Ident.t + | Arg of Ident.t + | Body of Ident.t type error = pos list * Env.t * symptom exception Error of error list -val report_error: formatter -> error list -> unit -val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type +val report_error : formatter -> error list -> unit +val expand_module_alias : Env.t -> pos list -> Path.t -> Types.module_type diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 8b3a777e9d..fcd1dc86ca 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -13,88 +13,87 @@ (* *) (**************************************************************************) -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS +type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS -type record_repr = - | Record_regular - | Record_optional +type record_repr = Record_regular | Record_optional - -type tag_info = - | Blk_constructor of {name : string ; num_nonconst : int ; tag : int; attrs : Parsetree.attributes } - | Blk_record_inlined of { name : string ; num_nonconst : int; tag : int; optional_labels: string list; fields : string array; mutable_flag : Asttypes.mutable_flag; attrs : Parsetree.attributes } +type tag_info = + | Blk_constructor of { + name: string; + num_nonconst: int; + tag: int; + attrs: Parsetree.attributes; + } + | Blk_record_inlined of { + name: string; + num_nonconst: int; + tag: int; + optional_labels: string list; + fields: string array; + mutable_flag: Asttypes.mutable_flag; + attrs: Parsetree.attributes; + } | Blk_tuple - | Blk_poly_var of string - | Blk_record of {fields : string array; mutable_flag : Asttypes.mutable_flag; record_repr : record_repr} + | Blk_poly_var of string + | Blk_record of { + fields: string array; + mutable_flag: Asttypes.mutable_flag; + record_repr: record_repr; + } | Blk_module of string list | Blk_module_export of Ident.t list - - | Blk_extension + | Blk_extension | Blk_some - | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *) - | Blk_record_ext of { fields : string array; mutable_flag : Asttypes.mutable_flag} + | Blk_some_not_nested + (* ['a option] where ['a] can not inhabit a non-like value *) + | Blk_record_ext of { + fields: string array; + mutable_flag: Asttypes.mutable_flag; + } | Blk_lazy_general -let tag_of_tag_info (tag : tag_info ) = - match tag with - | Blk_constructor {tag} - | Blk_record_inlined {tag} -> tag - | Blk_tuple - | Blk_poly_var _ - | Blk_record _ - | Blk_module _ - | Blk_module_export _ - | Blk_extension - | Blk_some (* tag not make sense *) +let tag_of_tag_info (tag : tag_info) = + match tag with + | Blk_constructor {tag} | Blk_record_inlined {tag} -> tag + | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_module _ + | Blk_module_export _ | Blk_extension | Blk_some (* tag not make sense *) | Blk_some_not_nested (* tag not make sense *) | Blk_lazy_general (* tag not make sense 248 *) - | Blk_record_ext _ (* similar to Blk_extension*) - -> 0 + | Blk_record_ext _ (* similar to Blk_extension*) -> + 0 let mutable_flag_of_tag_info (tag : tag_info) = - match tag with + match tag with | Blk_record_inlined {mutable_flag} | Blk_record {mutable_flag} - | Blk_record_ext {mutable_flag} -> mutable_flag + | Blk_record_ext {mutable_flag} -> + mutable_flag | Blk_lazy_general -> Mutable - | Blk_tuple - | Blk_constructor _ - | Blk_poly_var _ - | Blk_module _ - | Blk_module_export _ - | Blk_extension - | Blk_some_not_nested - | Blk_some - -> Immutable + | Blk_tuple | Blk_constructor _ | Blk_poly_var _ | Blk_module _ + | Blk_module_export _ | Blk_extension | Blk_some_not_nested | Blk_some -> + Immutable type label = Types.label_description let find_name (attr : Parsetree.attribute) = match attr with - | ( { txt = "as" }, + | ( {txt = "as"}, PStr [ { pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _); + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _); }; ] ) -> - Some s + Some s | _ -> None - + let blk_record (fields : (label * _) array) mut record_repr = let all_labels_info = Ext_array.map fields (fun (lbl, _) -> Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) in - Blk_record - { fields = all_labels_info; mutable_flag = mut; record_repr } - + Blk_record {fields = all_labels_info; mutable_flag = mut; record_repr} let blk_record_ext fields mutable_flag = let all_labels_info = @@ -103,31 +102,38 @@ let blk_record_ext fields mutable_flag = Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) fields in - Blk_record_ext {fields = all_labels_info; mutable_flag } + Blk_record_ext {fields = all_labels_info; mutable_flag} -let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs mutable_flag = +let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs + mutable_flag = let fields = Array.map (fun ((lbl : label), _) -> Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) fields in - Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs } - -let ref_tag_info : tag_info = - Blk_record {fields = [| "contents" |]; mutable_flag = Mutable; record_repr = Record_regular} - -type field_dbg_info = - | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag} - | Fld_module of {name : string } - | Fld_record_inline of { name : string} - | Fld_record_extension of {name : string} - | Fld_tuple + Blk_record_inlined + {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs} + +let ref_tag_info : tag_info = + Blk_record + { + fields = [|"contents"|]; + mutable_flag = Mutable; + record_repr = Record_regular; + } + +type field_dbg_info = + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} + | Fld_module of {name: string} + | Fld_record_inline of {name: string} + | Fld_record_extension of {name: string} + | Fld_tuple | Fld_poly_var_tag | Fld_poly_var_content | Fld_extension | Fld_variant - | Fld_cons + | Fld_cons | Fld_array let fld_record (lbl : label) = @@ -139,25 +145,23 @@ let fld_record (lbl : label) = let fld_record_extension (lbl : label) = Fld_record_extension - { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name } + {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} -let ref_field_info : field_dbg_info = - Fld_record { name = "contents"; mutable_flag = Mutable} +let ref_field_info : field_dbg_info = + Fld_record {name = "contents"; mutable_flag = Mutable} +type set_field_dbg_info = + | Fld_record_set of string + | Fld_record_inline_set of string + | Fld_record_extension_set of string -type set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string - -let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" +let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" let fld_record_set (lbl : label) = - Fld_record_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + Fld_record_set (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) let fld_record_inline (lbl : label) = Fld_record_inline - { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name } + {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} let fld_record_inline_set (lbl : label) = Fld_record_inline_set @@ -167,13 +171,9 @@ let fld_record_extension_set (lbl : label) = Fld_record_extension_set (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) -type immediate_or_pointer = - | Immediate - | Pointer +type immediate_or_pointer = Immediate | Pointer -type is_safe = - | Safe - | Unsafe +type is_safe = Safe | Unsafe type primitive = | Pidentity @@ -185,13 +185,12 @@ type primitive = | Pfn_arity | Prevapply | Pdirapply - | Ploc of loc_kind - (* Globals *) + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t (* Operations on heap blocks *) - | Pmakeblock of tag_info + | Pmakeblock of tag_info | Pfield of int * field_dbg_info - | Psetfield of int * set_field_dbg_info + | Psetfield of int * set_field_dbg_info | Pduprecord (* Force lazy values *) | Plazyforce @@ -207,35 +206,71 @@ type primitive = | Pobjtag | Pobjsize (* Boolean operations *) - | Psequand | Psequor | Pnot + | Psequand + | Psequor + | Pnot | Pboolcomp of comparison - | Pboolorder | Pboolmin | Pboolmax + | Pboolorder + | Pboolmin + | Pboolmax (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pdivint of is_safe + | Pmodint of is_safe + | Pandint + | Porint + | Pxorint + | Plslint + | Plsrint + | Pasrint | Pintcomp of comparison - | Pintorder | Pintmin | Pintmax + | Pintorder + | Pintmin + | Pintmax | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat | Pmodfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Pmodfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat | Pfloatcomp of comparison - | Pfloatorder | Pfloatmin | Pfloatmax + | Pfloatorder + | Pfloatmin + | Pfloatmax (* BigInt operations *) - | Pnegbigint | Paddbigint | Psubbigint | Ppowbigint - | Pmulbigint | Pdivbigint | Pmodbigint - | Pandbigint | Porbigint | Pxorbigint - | Plslbigint | Pasrbigint + | Pnegbigint + | Paddbigint + | Psubbigint + | Ppowbigint + | Pmulbigint + | Pdivbigint + | Pmodbigint + | Pandbigint + | Porbigint + | Pxorbigint + | Plslbigint + | Pasrbigint | Pbigintcomp of comparison - | Pbigintorder | Pbigintmin | Pbigintmax + | Pbigintorder + | Pbigintmin + | Pbigintmax (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs + | Pstringlength + | Pstringrefu + | Pstringrefs | Pstringcomp of comparison - | Pstringorder | Pstringmin | Pstringmax + | Pstringorder + | Pstringmin + | Pstringmax | Pstringadd (* Array operations *) | Pmakearray of Asttypes.mutable_flag @@ -286,28 +321,26 @@ type primitive = | Pjs_fn_method | Pjs_unsafe_downgrade -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge +and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = - Pgenval +and value_kind = Pgenval -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace +and raise_kind = Raise_regular | Raise_reraise | Raise_notrace type pointer_info = - | Pt_constructor of {name: string; const: int; non_const: int; attrs: Parsetree.attributes} + | Pt_constructor of { + name: string; + const: int; + non_const: int; + attrs: Parsetree.attributes; + } | Pt_variant of {name: string} | Pt_module_alias | Pt_shape_none | Pt_assertfalse - - type structured_constant = - Const_base of Asttypes.constant + | Const_base of Asttypes.constant | Const_pointer of int * pointer_info | Const_block of tag_info * structured_constant list | Const_float_array of string list @@ -319,25 +352,19 @@ type inline_attribute = | Never_inline (* [@inline never] *) | Default_inline (* no [@inline] attribute *) - - - type let_kind = Strict | Alias | StrictOpt | Variable - - - type function_attribute = { - inline : inline_attribute; + inline: inline_attribute; is_a_functor: bool; - return_unit : bool; - async : bool; - directive : string option; - one_unit_arg : bool; + return_unit: bool; + async: bool; + directive: string option; + one_unit_arg: bool; } type lambda = - Lvar of Ident.t + | Lvar of Ident.t | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction @@ -357,54 +384,52 @@ type lambda = | Lassign of Ident.t * lambda | Lsend of string * lambda * Location.t -and lfunction = - { - params: Ident.t list; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc: Location.t; - } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_inlined : inline_attribute; - } - -and lambda_switch = - { sw_numconsts: int; - sw_consts: (int * lambda) list; - sw_numblocks: int; - sw_blocks: (int * lambda) list; - sw_failaction : lambda option; - sw_names: Ast_untagged_variants.switch_names option } - +and lfunction = { + params: Ident.t list; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; +} +and lambda_apply = { + ap_func: lambda; + ap_args: lambda list; + ap_loc: Location.t; + ap_inlined: inline_attribute; +} +and lambda_switch = { + sw_numconsts: int; + sw_consts: (int * lambda) list; + sw_numblocks: int; + sw_blocks: (int * lambda) list; + sw_failaction: lambda option; + sw_names: Ast_untagged_variants.switch_names option; +} -(* This is actually a dummy value - not necessary "()", it can be used as a place holder for module +(* This is actually a dummy value + not necessary "()", it can be used as a place holder for module alias etc. *) let const_unit = Const_pointer (0, Pt_constructor {name = "()"; const = 1; non_const = 0; attrs = []}) -let lambda_assert_false = Lconst (Const_pointer(0, Pt_assertfalse)) +let lambda_assert_false = Lconst (Const_pointer (0, Pt_assertfalse)) -let lambda_module_alias = Lconst (Const_pointer(0, Pt_module_alias)) +let lambda_module_alias = Lconst (Const_pointer (0, Pt_module_alias)) let lambda_unit = Lconst const_unit -let default_function_attribute = { - inline = Default_inline; - is_a_functor = false; - return_unit = false; - async = false; - one_unit_arg = false; - directive = None; -} +let default_function_attribute = + { + inline = Default_inline; + is_a_functor = false; + return_unit = false; + async = false; + one_unit_arg = false; + directive = None; + } (* Build sharing keys *) (* @@ -417,146 +442,141 @@ exception Not_simple let max_raw = 32 let make_key e = - let count = ref 0 (* Used for controling size *) + let count = ref 0 (* Used for controling size *) and make_key = Ident.make_key_generator () in (* make_key is used for normalizing let-bound variables *) let rec tr_rec env e = - incr count ; - if !count > max_raw then raise_notrace Not_simple ; (* Too big ! *) + incr count; + if !count > max_raw then raise_notrace Not_simple; + (* Too big ! *) match e with - | Lvar id -> - begin - try Ident.find_same id env - with Not_found -> e - end - | Lconst (Const_base (Const_string _)) -> - (* Mutable constants are not shared *) - raise_notrace Not_simple + | Lvar id -> ( try Ident.find_same id env with Not_found -> e) + | Lconst (Const_base (Const_string _)) -> + (* Mutable constants are not shared *) + raise_notrace Not_simple | Lconst _ -> e | Lapply ap -> - Lapply {ap with ap_func = tr_rec env ap.ap_func; - ap_args = tr_recs env ap.ap_args; - ap_loc = Location.none} - | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) - let ex = tr_rec env ex in - tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> - tr_rec env ex - | Llet (str,k,x,ex,e) -> - (* Because of side effects, keep other lets with normalized names *) - let ex = tr_rec env ex in - let y = make_key x in - Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p,es,_) -> - Lprim (p,tr_recs env es, Location.none) - | Lswitch (e,sw,loc) -> - Lswitch (tr_rec env e,tr_sw env sw,loc) - | Lstringswitch (e,sw,d,_) -> - Lstringswitch - (tr_rec env e, - List.map (fun (s,e) -> s,tr_rec env e) sw, - tr_opt env d, - Location.none) - | Lstaticraise (i,es) -> - Lstaticraise (i,tr_recs env es) - | Lstaticcatch (e1,xs,e2) -> - Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) - | Ltrywith (e1,x,e2) -> - Ltrywith (tr_rec env e1,x,tr_rec env e2) - | Lifthenelse (cond,ifso,ifnot) -> - Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) - | Lsequence (e1,e2) -> - Lsequence (tr_rec env e1,tr_rec env e2) - | Lassign (x,e) -> - Lassign (x,tr_rec env e) - | Lsend (m,e1,_loc) -> - Lsend (m,tr_rec env e1,Location.none) - | Lletrec _|Lfunction _ - | Lfor _ | Lwhile _ - -> - raise_notrace Not_simple - + Lapply + { + ap with + ap_func = tr_rec env ap.ap_func; + ap_args = tr_recs env ap.ap_args; + ap_loc = Location.none; + } + | Llet (Alias, _k, x, ex, e) -> + (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet ((Strict | StrictOpt), _k, x, ex, Lvar v) when Ident.same v x -> + tr_rec env ex + | Llet (str, k, x, ex, e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) + | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) + | Lstringswitch (e, sw, d, _) -> + Lstringswitch + ( tr_rec env e, + List.map (fun (s, e) -> (s, tr_rec env e)) sw, + tr_opt env d, + Location.none ) + | Lstaticraise (i, es) -> Lstaticraise (i, tr_recs env es) + | Lstaticcatch (e1, xs, e2) -> + Lstaticcatch (tr_rec env e1, xs, tr_rec env e2) + | Ltrywith (e1, x, e2) -> Ltrywith (tr_rec env e1, x, tr_rec env e2) + | Lifthenelse (cond, ifso, ifnot) -> + Lifthenelse (tr_rec env cond, tr_rec env ifso, tr_rec env ifnot) + | Lsequence (e1, e2) -> Lsequence (tr_rec env e1, tr_rec env e2) + | Lassign (x, e) -> Lassign (x, tr_rec env e) + | Lsend (m, e1, _loc) -> Lsend (m, tr_rec env e1, Location.none) + | Lletrec _ | Lfunction _ | Lfor _ | Lwhile _ -> raise_notrace Not_simple and tr_recs env es = List.map (tr_rec env) es - and tr_sw env sw = - { sw with - sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; - sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; - sw_failaction = tr_opt env sw.sw_failaction ; } - + { + sw with + sw_consts = List.map (fun (i, e) -> (i, tr_rec env e)) sw.sw_consts; + sw_blocks = List.map (fun (i, e) -> (i, tr_rec env e)) sw.sw_blocks; + sw_failaction = tr_opt env sw.sw_failaction; + } and tr_opt env = function | None -> None - | Some e -> Some (tr_rec env e) in + | Some e -> Some (tr_rec env e) + in - try - Some (tr_rec Ident.empty e) - with Not_simple -> None + try Some (tr_rec Ident.empty e) with Not_simple -> None (***************) let name_lambda strict arg fn = match arg with - Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id) + | Lvar id -> fn id + | _ -> + let id = Ident.create "let" in + Llet (strict, Pgenval, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function - [] -> fn (List.rev names) - | (Lvar _ as arg) :: rem -> - name_list (arg :: names) rem - | arg :: rem -> + | [] -> fn (List.rev names) + | (Lvar _ as arg) :: rem -> name_list (arg :: names) rem + | arg :: rem -> let id = Ident.create "let" in - Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in + Llet (Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) + in name_list [] args - let iter_opt f = function | None -> () | Some e -> f e let iter f = function - Lvar _ - | Lconst _ -> () - | Lapply{ap_func = fn; ap_args = args} -> - f fn; List.iter f args - | Lfunction{body} -> - f body - | Llet(_str, _k, _id, arg, body) -> - f arg; f body - | Lletrec(decl, body) -> - f body; - List.iter (fun (_id, exp) -> f exp) decl - | Lprim(_p, args, _loc) -> - List.iter f args - | Lswitch(arg, sw,_) -> - f arg; - List.iter (fun (_key, case) -> f case) sw.sw_consts; - List.iter (fun (_key, case) -> f case) sw.sw_blocks; - iter_opt f sw.sw_failaction - | Lstringswitch (arg,cases,default,_) -> - f arg ; - List.iter (fun (_,act) -> f act) cases ; - iter_opt f default - | Lstaticraise (_,args) -> - List.iter f args - | Lstaticcatch(e1, _, e2) -> - f e1; f e2 - | Ltrywith(e1, _, e2) -> - f e1; f e2 - | Lifthenelse(e1, e2, e3) -> - f e1; f e2; f e3 - | Lsequence(e1, e2) -> - f e1; f e2 - | Lwhile(e1, e2) -> - f e1; f e2 - | Lfor(_v, e1, e2, _dir, e3) -> - f e1; f e2; f e3 - | Lassign(_, e) -> - f e - | Lsend (_k, obj, _) -> - f obj - -module IdentSet = Set.Make(Ident) + | Lvar _ | Lconst _ -> () + | Lapply {ap_func = fn; ap_args = args} -> + f fn; + List.iter f args + | Lfunction {body} -> f body + | Llet (_str, _k, _id, arg, body) -> + f arg; + f body + | Lletrec (decl, body) -> + f body; + List.iter (fun (_id, exp) -> f exp) decl + | Lprim (_p, args, _loc) -> List.iter f args + | Lswitch (arg, sw, _) -> + f arg; + List.iter (fun (_key, case) -> f case) sw.sw_consts; + List.iter (fun (_key, case) -> f case) sw.sw_blocks; + iter_opt f sw.sw_failaction + | Lstringswitch (arg, cases, default, _) -> + f arg; + List.iter (fun (_, act) -> f act) cases; + iter_opt f default + | Lstaticraise (_, args) -> List.iter f args + | Lstaticcatch (e1, _, e2) -> + f e1; + f e2 + | Ltrywith (e1, _, e2) -> + f e1; + f e2 + | Lifthenelse (e1, e2, e3) -> + f e1; + f e2; + f e3 + | Lsequence (e1, e2) -> + f e1; + f e2 + | Lwhile (e1, e2) -> + f e1; + f e2 + | Lfor (_v, e1, e2, _dir, e3) -> + f e1; + f e2; + f e3 + | Lassign (_, e) -> f e + | Lsend (_k, obj, _) -> f obj + +module IdentSet = Set.Make (Ident) let free_ids get l = let fv = ref IdentSet.empty in @@ -564,90 +584,90 @@ let free_ids get l = iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with - Lfunction{params} -> - List.iter (fun param -> fv := IdentSet.remove param !fv) params - | Llet(_str, _k, id, _arg, _body) -> - fv := IdentSet.remove id !fv - | Lletrec(decl, _body) -> - List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl - | Lstaticcatch(_e1, (_,vars), _e2) -> - List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith(_e1, exn, _e2) -> - fv := IdentSet.remove exn !fv - | Lfor(v, _e1, _e2, _dir, _e3) -> - fv := IdentSet.remove v !fv - | Lassign(id, _e) -> - fv := IdentSet.add id !fv - | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ - | Lifthenelse _ | Lsequence _ | Lwhile _ - | Lsend _ - -> () - in free l; !fv + | Lfunction {params} -> + List.iter (fun param -> fv := IdentSet.remove param !fv) params + | Llet (_str, _k, id, _arg, _body) -> fv := IdentSet.remove id !fv + | Lletrec (decl, _body) -> + List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl + | Lstaticcatch (_e1, (_, vars), _e2) -> + List.iter (fun id -> fv := IdentSet.remove id !fv) vars + | Ltrywith (_e1, exn, _e2) -> fv := IdentSet.remove exn !fv + | Lfor (v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv + | Lassign (id, _e) -> fv := IdentSet.add id !fv + | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ + | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Lsend _ -> + () + in + free l; + !fv let free_variables l = - free_ids (function Lvar id -> [id] | _ -> []) l - + free_ids + (function + | Lvar id -> [id] + | _ -> []) + l (* Check if an action has a "when" guard *) let raise_count = ref 0 let next_raise_count () = - incr raise_count ; + incr raise_count; !raise_count let negative_raise_count = ref 0 let next_negative_raise_count () = - decr negative_raise_count ; + decr negative_raise_count; !negative_raise_count (* Anticipated staticraise, for guards *) -let staticfail = Lstaticraise (0,[]) +let staticfail = Lstaticraise (0, []) let rec is_guarded = function - | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true - | Llet(_str, _k, _id, _lam, body) -> is_guarded body + | Lifthenelse (_cond, _body, Lstaticraise (0, [])) -> true + | Llet (_str, _k, _id, _lam, body) -> is_guarded body | _ -> false let rec patch_guarded patch = function - | Lifthenelse (cond, body, Lstaticraise (0,[])) -> - Lifthenelse (cond, body, patch) - | Llet(str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) + | Lifthenelse (cond, body, Lstaticraise (0, [])) -> + Lifthenelse (cond, body, patch) + | Llet (str, k, id, lam, body) -> + Llet (str, k, id, lam, patch_guarded patch body) | _ -> assert false (* Translate an access path *) let rec transl_normal_path = function - Path.Pident id -> - if Ident.global id - then Lprim(Pgetglobal id, [], Location.none) - else Lvar id - | Pdot(p, s, pos) -> - Lprim(Pfield (pos, Fld_module {name = s}), [transl_normal_path p], Location.none) - | Papply _ -> - assert false + | Path.Pident id -> + if Ident.global id then Lprim (Pgetglobal id, [], Location.none) + else Lvar id + | Pdot (p, s, pos) -> + Lprim + ( Pfield (pos, Fld_module {name = s}), + [transl_normal_path p], + Location.none ) + | Papply _ -> assert false (* Translation of identifiers *) -let transl_module_path ?(loc=Location.none) env path = +let transl_module_path ?(loc = Location.none) env path = transl_normal_path (Env.normalize_path (Some loc) env path) -let transl_value_path ?(loc=Location.none) env path = +let transl_value_path ?(loc = Location.none) env path = transl_normal_path (Env.normalize_path_prefix (Some loc) env path) - let transl_extension_path = transl_value_path (* compatibility alias, deprecated in the .mli *) (* Compile a sequence of expressions *) let rec make_sequence fn = function - [] -> lambda_unit + | [] -> lambda_unit | [x] -> fn x - | x::rem -> - let lam = fn x in Lsequence(lam, make_sequence fn rem) + | x :: rem -> + let lam = fn x in + Lsequence (lam, make_sequence fn rem) (* Apply a substitution to a lambda-term. Assumes that the bound variables of the lambda-term do not @@ -657,99 +677,98 @@ let rec make_sequence fn = function let subst_lambda s lam = let rec subst = function - Lvar id as l -> - begin try Ident.find_same id s with Not_found -> l end - | Lconst _ as l -> l - | Lapply ap -> - Lapply{ap with ap_func = subst ap.ap_func; - ap_args = List.map subst ap.ap_args} - | Lfunction{ params; body; attr; loc} -> - Lfunction{ params; body = subst body; attr; loc} - | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body) - | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) - | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc) - | Lswitch(arg, sw, loc) -> - Lswitch(subst arg, - {sw with sw_consts = List.map subst_case sw.sw_consts; - sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = subst_opt sw.sw_failaction; }, - loc) - | Lstringswitch (arg,cases,default,loc) -> + | Lvar id as l -> ( try Ident.find_same id s with Not_found -> l) + | Lconst _ as l -> l + | Lapply ap -> + Lapply + { + ap with + ap_func = subst ap.ap_func; + ap_args = List.map subst ap.ap_args; + } + | Lfunction {params; body; attr; loc} -> + Lfunction {params; body = subst body; attr; loc} + | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) + | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) + | Lprim (p, args, loc) -> Lprim (p, List.map subst args, loc) + | Lswitch (arg, sw, loc) -> + Lswitch + ( subst arg, + { + sw with + sw_consts = List.map subst_case sw.sw_consts; + sw_blocks = List.map subst_case sw.sw_blocks; + sw_failaction = subst_opt sw.sw_failaction; + }, + loc ) + | Lstringswitch (arg, cases, default, loc) -> Lstringswitch - (subst arg,List.map subst_strcase cases,subst_opt default,loc) - | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) - | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) - | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) - | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3) - | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2) - | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2) - | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) - | Lassign(id, e) -> Lassign(id, subst e) - | Lsend (k, obj, loc) -> - Lsend (k,subst obj, loc) + (subst arg, List.map subst_strcase cases, subst_opt default, loc) + | Lstaticraise (i, args) -> Lstaticraise (i, List.map subst args) + | Lstaticcatch (e1, io, e2) -> Lstaticcatch (subst e1, io, subst e2) + | Ltrywith (e1, exn, e2) -> Ltrywith (subst e1, exn, subst e2) + | Lifthenelse (e1, e2, e3) -> Lifthenelse (subst e1, subst e2, subst e3) + | Lsequence (e1, e2) -> Lsequence (subst e1, subst e2) + | Lwhile (e1, e2) -> Lwhile (subst e1, subst e2) + | Lfor (v, e1, e2, dir, e3) -> Lfor (v, subst e1, subst e2, dir, subst e3) + | Lassign (id, e) -> Lassign (id, subst e) + | Lsend (k, obj, loc) -> Lsend (k, subst obj, loc) and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) and subst_strcase (key, case) = (key, subst case) and subst_opt = function | None -> None | Some e -> Some (subst e) - in subst lam + in + subst lam let rec map f lam = let lam = match lam with | Lvar _ -> lam | Lconst _ -> lam - | Lapply { ap_func; ap_args; ap_loc; - ap_inlined; } -> - Lapply { + | Lapply {ap_func; ap_args; ap_loc; ap_inlined} -> + Lapply + { ap_func = map f ap_func; ap_args = List.map (map f) ap_args; ap_loc; ap_inlined; } - | Lfunction { params; body; attr; loc; } -> - Lfunction { params; body = map f body; attr; loc; } - | Llet (str, k, v, e1, e2) -> - Llet (str, k, v, map f e1, map f e2) + | Lfunction {params; body; attr; loc} -> + Lfunction {params; body = map f body; attr; loc} + | Llet (str, k, v, e1, e2) -> Llet (str, k, v, map f e1, map f e2) | Lletrec (idel, e2) -> - Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2) - | Lprim (p, el, loc) -> - Lprim (p, List.map (map f) el, loc) + Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2) + | Lprim (p, el, loc) -> Lprim (p, List.map (map f) el, loc) | Lswitch (e, sw, loc) -> - Lswitch (map f e, - { sw_numconsts = sw.sw_numconsts; + Lswitch + ( map f e, + { + sw_numconsts = sw.sw_numconsts; sw_consts = List.map (fun (n, e) -> (n, map f e)) sw.sw_consts; sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks; sw_failaction = Misc.may_map (map f) sw.sw_failaction; - sw_names = sw.sw_names + sw_names = sw.sw_names; }, - loc) + loc ) | Lstringswitch (e, sw, default, loc) -> - Lstringswitch ( - map f e, + Lstringswitch + ( map f e, List.map (fun (s, e) -> (s, map f e)) sw, Misc.may_map (map f) default, - loc) - | Lstaticraise (i, args) -> - Lstaticraise (i, List.map (map f) args) + loc ) + | Lstaticraise (i, args) -> Lstaticraise (i, List.map (map f) args) | Lstaticcatch (body, id, handler) -> - Lstaticcatch (map f body, id, map f handler) - | Ltrywith (e1, v, e2) -> - Ltrywith (map f e1, v, map f e2) - | Lifthenelse (e1, e2, e3) -> - Lifthenelse (map f e1, map f e2, map f e3) - | Lsequence (e1, e2) -> - Lsequence (map f e1, map f e2) - | Lwhile (e1, e2) -> - Lwhile (map f e1, map f e2) - | Lfor (v, e1, e2, dir, e3) -> - Lfor (v, map f e1, map f e2, dir, map f e3) - | Lassign (v, e) -> - Lassign (v, map f e) - | Lsend (k, o, loc) -> - Lsend (k, map f o, loc) + Lstaticcatch (map f body, id, map f handler) + | Ltrywith (e1, v, e2) -> Ltrywith (map f e1, v, map f e2) + | Lifthenelse (e1, e2, e3) -> Lifthenelse (map f e1, map f e2, map f e3) + | Lsequence (e1, e2) -> Lsequence (map f e1, map f e2) + | Lwhile (e1, e2) -> Lwhile (map f e1, map f e2) + | Lfor (v, e1, e2, dir, e3) -> Lfor (v, map f e1, map f e2, dir, map f e3) + | Lassign (v, e) -> Lassign (v, map f e) + | Lsend (k, o, loc) -> Lsend (k, map f o, loc) in f lam @@ -757,18 +776,24 @@ let rec map f lam = let bind str var exp body = match exp with - Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, Pgenval, var, exp, body) + | Lvar var' when Ident.same var var' -> body + | _ -> Llet (str, Pgenval, var, exp, body) and commute_comparison = function -| Ceq -> Ceq| Cneq -> Cneq -| Clt -> Cgt | Cle -> Cge -| Cgt -> Clt | Cge -> Cle + | Ceq -> Ceq + | Cneq -> Cneq + | Clt -> Cgt + | Cle -> Cge + | Cgt -> Clt + | Cge -> Cle and negate_comparison = function -| Ceq -> Cneq| Cneq -> Ceq -| Clt -> Cge | Cle -> Cgt -| Cgt -> Cle | Cge -> Clt + | Ceq -> Cneq + | Cneq -> Ceq + | Clt -> Cge + | Cle -> Cgt + | Cgt -> Cle + | Cge -> Clt let raise_kind = function | Raise_regular -> "raise" @@ -777,30 +802,33 @@ let raise_kind = function let lam_of_loc kind loc = let loc_start = loc.Location.loc_start in - let (file, lnum, cnum) = Location.get_pos_info loc_start in - let file = Filename.basename file in - let enum = loc.Location.loc_end.Lexing.pos_cnum - - loc_start.Lexing.pos_cnum + cnum in + let file, lnum, cnum = Location.get_pos_info loc_start in + let file = Filename.basename file in + let enum = + loc.Location.loc_end.Lexing.pos_cnum - loc_start.Lexing.pos_cnum + cnum + in match kind with | Loc_POS -> - Lconst (Const_block (Blk_tuple, [ - Const_immstring file; - Const_base (Const_int lnum); - Const_base (Const_int cnum); - Const_base (Const_int enum); - ])) + Lconst + (Const_block + ( Blk_tuple, + [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ] )) | Loc_FILE -> Lconst (Const_immstring file) | Loc_MODULE -> let filename = Filename.basename file in let name = Env.get_unit_name () in - let module_name = if name = "" then "//"^filename^"//" else name in + let module_name = if name = "" then "//" ^ filename ^ "//" else name in Lconst (Const_immstring module_name) | Loc_LOC -> - let loc = Printf.sprintf "File %S, line %d, characters %d-%d" - file lnum cnum enum in + let loc = + Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum + in Lconst (Const_immstring loc) | Loc_LINE -> Lconst (Const_base (Const_int lnum)) - -let reset () = - raise_count := 0 +let reset () = raise_count := 0 diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 8ec0d24459..7f506ac62d 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -17,80 +17,83 @@ open Asttypes -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS - -type record_repr = - | Record_regular - | Record_optional - -type tag_info = - | Blk_constructor of { name : string ; num_nonconst : int; tag : int; attrs : Parsetree.attributes } - | Blk_record_inlined of { name : string ; num_nonconst : int ; tag : int; optional_labels: string list; fields : string array; mutable_flag : mutable_flag; attrs : Parsetree.attributes } +type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS + +type record_repr = Record_regular | Record_optional + +type tag_info = + | Blk_constructor of { + name: string; + num_nonconst: int; + tag: int; + attrs: Parsetree.attributes; + } + | Blk_record_inlined of { + name: string; + num_nonconst: int; + tag: int; + optional_labels: string list; + fields: string array; + mutable_flag: mutable_flag; + attrs: Parsetree.attributes; + } | Blk_tuple - | Blk_poly_var of string - | Blk_record of {fields : string array; mutable_flag : mutable_flag; record_repr : record_repr } + | Blk_poly_var of string + | Blk_record of { + fields: string array; + mutable_flag: mutable_flag; + record_repr: record_repr; + } | Blk_module of string list - | Blk_module_export of Ident.t list + | Blk_module_export of Ident.t list | Blk_extension (* underlying is the same as tuple, immutable block - {[ - exception A of int * int - ]} - is translated into - {[ - [A, x, y] - ]} - + {[ + exception A of int * int + ]} + is translated into + {[ + [A, x, y] + ]} *) - | Blk_some - | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *) - | Blk_record_ext of {fields : string array; mutable_flag : mutable_flag} - | Blk_lazy_general - -val find_name : - Parsetree.attribute -> Asttypes.label option - -val tag_of_tag_info : tag_info -> int -val mutable_flag_of_tag_info : tag_info -> mutable_flag -val blk_record : - (Types.label_description* Typedtree.record_label_definition) array -> - mutable_flag -> - record_repr -> + | Blk_some_not_nested + (* ['a option] where ['a] can not inhabit a non-like value *) + | Blk_record_ext of {fields: string array; mutable_flag: mutable_flag} + | Blk_lazy_general + +val find_name : Parsetree.attribute -> Asttypes.label option + +val tag_of_tag_info : tag_info -> int +val mutable_flag_of_tag_info : tag_info -> mutable_flag +val blk_record : + (Types.label_description * Typedtree.record_label_definition) array -> + mutable_flag -> + record_repr -> tag_info - val blk_record_ext : - (Types.label_description* Typedtree.record_label_definition) array -> - mutable_flag -> + (Types.label_description * Typedtree.record_label_definition) array -> + mutable_flag -> tag_info - -val blk_record_inlined : - (Types.label_description* Typedtree.record_label_definition) array -> +val blk_record_inlined : + (Types.label_description * Typedtree.record_label_definition) array -> string -> int -> string list -> tag:int -> attrs:Parsetree.attributes -> - mutable_flag -> + mutable_flag -> tag_info - - - val ref_tag_info : tag_info -type field_dbg_info = - | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag} - | Fld_module of {name : string} - | Fld_record_inline of {name : string} - | Fld_record_extension of {name : string} +type field_dbg_info = + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} + | Fld_module of {name: string} + | Fld_record_inline of {name: string} + | Fld_record_extension of {name: string} | Fld_tuple | Fld_poly_var_tag | Fld_poly_var_content @@ -98,51 +101,38 @@ type field_dbg_info = | Fld_variant | Fld_cons | Fld_array - -val fld_record : - Types.label_description -> - field_dbg_info - -val fld_record_inline : - Types.label_description -> - field_dbg_info -val fld_record_extension : - Types.label_description -> - field_dbg_info +val fld_record : Types.label_description -> field_dbg_info -val ref_field_info : field_dbg_info +val fld_record_inline : Types.label_description -> field_dbg_info +val fld_record_extension : Types.label_description -> field_dbg_info +val ref_field_info : field_dbg_info -type set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string +type set_field_dbg_info = + | Fld_record_set of string + | Fld_record_inline_set of string | Fld_record_extension_set of string -val ref_field_set_info : set_field_dbg_info +val ref_field_set_info : set_field_dbg_info -val fld_record_set : - Types.label_description -> - set_field_dbg_info +val fld_record_set : Types.label_description -> set_field_dbg_info -val fld_record_inline_set : - Types.label_description -> - set_field_dbg_info +val fld_record_inline_set : Types.label_description -> set_field_dbg_info -val fld_record_extension_set : - Types.label_description -> - set_field_dbg_info +val fld_record_extension_set : Types.label_description -> set_field_dbg_info -type immediate_or_pointer = - | Immediate - | Pointer -type is_safe = - | Safe - | Unsafe +type immediate_or_pointer = Immediate | Pointer +type is_safe = Safe | Unsafe type pointer_info = - | Pt_constructor of {name: string; const: int; non_const: int; attrs: Parsetree.attributes} + | Pt_constructor of { + name: string; + const: int; + non_const: int; + attrs: Parsetree.attributes; + } | Pt_variant of {name: string} | Pt_module_alias | Pt_shape_none @@ -158,15 +148,12 @@ type primitive = | Pfn_arity | Prevapply | Pdirapply - | Ploc of loc_kind - (* Globals *) + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info | Pfield of int * field_dbg_info | Psetfield of int * set_field_dbg_info - - | Pduprecord (* Force lazy values *) | Plazyforce @@ -182,43 +169,79 @@ type primitive = | Pobjtag | Pobjsize (* Boolean operations *) - | Psequand | Psequor | Pnot + | Psequand + | Psequor + | Pnot | Pboolcomp of comparison - | Pboolorder | Pboolmin | Pboolmax + | Pboolorder + | Pboolmin + | Pboolmax (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pdivint of is_safe + | Pmodint of is_safe + | Pandint + | Porint + | Pxorint + | Plslint + | Plsrint + | Pasrint | Pintcomp of comparison - | Pintorder | Pintmin | Pintmax + | Pintorder + | Pintmin + | Pintmax | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat | Pmodfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Pmodfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat | Pfloatcomp of comparison - | Pfloatorder | Pfloatmin | Pfloatmax + | Pfloatorder + | Pfloatmin + | Pfloatmax (* BigInt operations *) - | Pnegbigint | Paddbigint | Psubbigint | Ppowbigint - | Pmulbigint | Pdivbigint | Pmodbigint - | Pandbigint | Porbigint | Pxorbigint - | Plslbigint | Pasrbigint + | Pnegbigint + | Paddbigint + | Psubbigint + | Ppowbigint + | Pmulbigint + | Pdivbigint + | Pmodbigint + | Pandbigint + | Porbigint + | Pxorbigint + | Plslbigint + | Pasrbigint | Pbigintcomp of comparison - | Pbigintorder | Pbigintmin | Pbigintmax + | Pbigintorder + | Pbigintmin + | Pbigintmax (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs + | Pstringlength + | Pstringrefu + | Pstringrefs | Pstringcomp of comparison - | Pstringorder | Pstringmin | Pstringmax + | Pstringorder + | Pstringmin + | Pstringmax | Pstringadd (* Array operations *) | Pmakearray of mutable_flag - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets + | Parraylength + | Parrayrefu + | Parraysetu + | Parrayrefs + | Parraysets (* List primitives *) | Pmakelist of Asttypes.mutable_flag (* dict primitives *) @@ -261,34 +284,26 @@ type primitive = | Pjs_fn_method | Pjs_unsafe_downgrade -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge +and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = - Pgenval +and value_kind = Pgenval -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace +and raise_kind = Raise_regular | Raise_reraise | Raise_notrace type structured_constant = - Const_base of constant + | Const_base of constant | Const_pointer of int * pointer_info - | Const_block of tag_info * structured_constant list + | Const_block of tag_info * structured_constant list | Const_float_array of string list | Const_immstring of string | Const_false | Const_true - + type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) | Never_inline (* [@inline never] *) | Default_inline (* no [@inline] attribute *) - - - type let_kind = Strict | Alias | StrictOpt | Variable (* Meaning of kinds for let x = e in e': Strict: e may have side-effects; always evaluate e first @@ -299,23 +314,20 @@ type let_kind = Strict | Alias | StrictOpt | Variable StrictOpt: e does not have side-effects, but depend on the store; we can discard e if x does not appear in e' Variable: the variable x is assigned later in e' - *) - - - +*) (* [true] means yes, [false] may mean unknown *) type function_attribute = { - inline : inline_attribute; + inline: inline_attribute; is_a_functor: bool; - return_unit : bool; - async : bool; - directive : string option; - one_unit_arg : bool; + return_unit: bool; + async: bool; + directive: string option; + one_unit_arg: bool; } type lambda = - Lvar of Ident.t + | Lvar of Ident.t | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction @@ -323,8 +335,8 @@ type lambda = | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t -(* switch on strings, clauses are sorted by string order, - strings are pairwise distinct *) + (* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) | Lstringswitch of lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list @@ -335,31 +347,30 @@ type lambda = | Lwhile of lambda * lambda | Lfor of Ident.t * lambda * lambda * direction_flag * lambda | Lassign of Ident.t * lambda - | Lsend of string * lambda * Location.t - -and lfunction = - { - params: Ident.t list; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc : Location.t; } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) - } + | Lsend of string * lambda * Location.t -and lambda_switch = - { sw_numconsts: int; (* Number of integer cases *) - sw_consts: (int * lambda) list; (* Integer cases *) - sw_numblocks: int; (* Number of tag block cases *) - sw_blocks: (int * lambda) list; (* Tag block cases *) - sw_failaction : lambda option; (* Action to take if failure *) - sw_names: Ast_untagged_variants.switch_names option } +and lfunction = { + params: Ident.t list; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; +} +and lambda_apply = { + ap_func: lambda; + ap_args: lambda list; + ap_loc: Location.t; + ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) +} +and lambda_switch = { + sw_numconsts: int; (* Number of integer cases *) + sw_consts: (int * lambda) list; (* Integer cases *) + sw_numblocks: int; (* Number of tag block cases *) + sw_blocks: (int * lambda) list; (* Tag block cases *) + sw_failaction: lambda option; (* Action to take if failure *) + sw_names: Ast_untagged_variants.switch_names option; +} (* Lambda code for the middle-end. * In the closure case the code is a sequence of assignments to a @@ -374,29 +385,28 @@ and lambda_switch = *) (* Sharing key *) -val make_key: lambda -> lambda option +val make_key : lambda -> lambda option -val const_unit: structured_constant -val lambda_assert_false: lambda -val lambda_unit: lambda +val const_unit : structured_constant +val lambda_assert_false : lambda +val lambda_unit : lambda val lambda_module_alias : lambda -val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda -val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda - -val iter: (lambda -> unit) -> lambda -> unit -module IdentSet: Set.S with type elt = Ident.t -val free_variables: lambda -> IdentSet.t +val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda +val name_lambda_list : lambda list -> (lambda list -> lambda) -> lambda -val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) +val iter : (lambda -> unit) -> lambda -> unit +module IdentSet : Set.S with type elt = Ident.t +val free_variables : lambda -> IdentSet.t -val transl_module_path: ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_value_path: ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_extension_path: ?loc:Location.t -> Env.t -> Path.t -> lambda +val transl_normal_path : Path.t -> lambda (* Path.t is already normal *) +val transl_module_path : ?loc:Location.t -> Env.t -> Path.t -> lambda +val transl_value_path : ?loc:Location.t -> Env.t -> Path.t -> lambda +val transl_extension_path : ?loc:Location.t -> Env.t -> Path.t -> lambda -val make_sequence: ('a -> lambda) -> 'a list -> lambda +val make_sequence : ('a -> lambda) -> 'a list -> lambda -val subst_lambda: lambda Ident.tbl -> lambda -> lambda +val subst_lambda : lambda Ident.tbl -> lambda -> lambda val map : (lambda -> lambda) -> lambda -> lambda val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda @@ -412,19 +422,18 @@ val default_function_attribute : function_attribute (* Get a new static failure ident *) val next_raise_count : unit -> int val next_negative_raise_count : unit -> int - (* Negative raise counts are used to compile 'match ... with - exception x -> ...'. This disabled some simplifications - performed by the Simplif module that assume that static raises - are in tail position in their handler. *) +(* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) -val is_guarded: lambda -> bool +val is_guarded : lambda -> bool val patch_guarded : lambda -> lambda -> lambda -val raise_kind: raise_kind -> string +val raise_kind : raise_kind -> string val lam_of_loc : loc_kind -> Location.t -> lambda - -val reset: unit -> unit +val reset : unit -> unit diff --git a/compiler/ml/location.ml b/compiler/ml/location.ml index 4ca193cfd6..bbf80e8eee 100644 --- a/compiler/ml/location.ml +++ b/compiler/ml/location.ml @@ -16,71 +16,66 @@ open Lexing let absname = ref false - (* This reference should be in Clflags, but it would create an additional - dependency and make bootstrapping Camlp4 more difficult. *) +(* This reference should be in Clflags, but it would create an additional + dependency and make bootstrapping Camlp4 more difficult. *) -type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool };; +type t = Warnings.loc = { + loc_start: position; + loc_end: position; + loc_ghost: bool; +} let in_file name = - let loc = { - pos_fname = name; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = -1; - } in - { loc_start = loc; loc_end = loc; loc_ghost = true } -;; - -let none = in_file "_none_";; - -let curr lexbuf = { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.lex_curr_p; - loc_ghost = false -};; + let loc = {pos_fname = name; pos_lnum = 1; pos_bol = 0; pos_cnum = -1} in + {loc_start = loc; loc_end = loc; loc_ghost = true} + +let none = in_file "_none_" + +let curr lexbuf = + { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.lex_curr_p; + loc_ghost = false; + } let init lexbuf fname = - lexbuf.lex_curr_p <- { - pos_fname = fname; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0; + lexbuf.lex_curr_p <- + {pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0} + +let symbol_rloc () = + { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = false; + } + +let symbol_gloc () = + { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = true; + } + +let rhs_loc n = + { + loc_start = Parsing.rhs_start_pos n; + loc_end = Parsing.rhs_end_pos n; + loc_ghost = false; } -;; - -let symbol_rloc () = { - loc_start = Parsing.symbol_start_pos (); - loc_end = Parsing.symbol_end_pos (); - loc_ghost = false; -};; - -let symbol_gloc () = { - loc_start = Parsing.symbol_start_pos (); - loc_end = Parsing.symbol_end_pos (); - loc_ghost = true; -};; - -let rhs_loc n = { - loc_start = Parsing.rhs_start_pos n; - loc_end = Parsing.rhs_end_pos n; - loc_ghost = false; -};; let input_name = ref "_none_" let input_lexbuf = ref (None : lexbuf option) -let set_input_name name = - if name <> "" then input_name := name +let set_input_name name = if name <> "" then input_name := name (* Terminal info *) - - let num_loc_lines = ref 0 (* number of lines already printed after input *) (* Print the location in some way or another *) open Format -let absolute_path s = (* This function could go into Filename *) +let absolute_path s = + (* This function could go into Filename *) let open Filename in let s = if is_relative s then concat (Sys.getcwd ()) s else s in (* Now simplify . and .. components *) @@ -95,19 +90,15 @@ let absolute_path s = (* This function could go into Filename *) aux s let show_filename file = - let file = if file = "_none_" then !input_name else file in + let file = if file = "_none_" then !input_name else file in if !absname then absolute_path file else file -let print_filename ppf file = - Format.fprintf ppf "%s" (show_filename file) +let print_filename ppf file = Format.fprintf ppf "%s" (show_filename file) -let reset () = - num_loc_lines := 0 +let reset () = num_loc_lines := 0 (* return file, line, char from the given position *) -let get_pos_info pos = - (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) -;; +let get_pos_info pos = (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) let setup_colors () = Misc.Color.setup !Clflags.color; @@ -119,10 +110,10 @@ let setup_colors () = starting from the first erroring character?) *) let normalize_range loc = (* TODO: lots of the handlings here aren't needed anymore because the new - rescript syntax has much stronger invariants regarding positions, e.g. - no -1 *) - let (_, start_line, start_char) = get_pos_info loc.loc_start in - let (_, end_line, end_char) = get_pos_info loc.loc_end in + rescript syntax has much stronger invariants regarding positions, e.g. + no -1 *) + let _, start_line, start_char = get_pos_info loc.loc_start in + let _, end_line, end_char = get_pos_info loc.loc_end in (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) (* start_char is inclusive, end_char is exclusive *) if start_char == -1 || end_char == -1 then @@ -130,9 +121,9 @@ let normalize_range loc = None else if start_line = end_line && start_char >= end_char then (* in some errors, starting char and ending char can be the same. But - since ending char was supposed to be exclusive, here it might end up - smaller than the starting char if we naively did start_char + 1 to - just the starting char and forget ending char *) + since ending char was supposed to be exclusive, here it might end up + smaller than the starting char if we naively did start_char + 1 to + just the starting char and forget ending char *) let same_char = start_char + 1 in Some ((start_line, same_char), (end_line, same_char)) else @@ -144,36 +135,39 @@ let print_loc ppf (loc : t) = let normalized_range = normalize_range loc in let dim_loc ppf = function | None -> () - | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) -> + | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) + -> if start_line = end_line then if start_line_start_char = end_line_end_char then fprintf ppf ":@{%i:%i@}" start_line start_line_start_char else - fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char end_line_end_char + fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char + end_line_end_char else - fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char end_line end_line_end_char + fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char + end_line end_line_end_char in - fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalized_range -;; + fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname + dim_loc normalized_range let print ?(src = None) ~message_kind intro ppf (loc : t) = - begin match message_kind with - | `warning -> fprintf ppf "@[@{%s@}@]@," intro - | `warning_as_error -> fprintf ppf "@[@{%s@} (configured as error) @]@," intro - | `error -> fprintf ppf "@[@{%s@}@]@," intro - end; + (match message_kind with + | `warning -> fprintf ppf "@[@{%s@}@]@," intro + | `warning_as_error -> + fprintf ppf "@[@{%s@} (configured as error) @]@," intro + | `error -> fprintf ppf "@[@{%s@}@]@," intro); (* ocaml's reported line/col numbering is horrible and super error-prone when being handled programmatically (or humanly for that matter. If you're an ocaml contributor reading this: who the heck reads the character count starting from the first erroring character?) *) - let (file, start_line, start_char) = get_pos_info loc.loc_start in - let (_, end_line, end_char) = get_pos_info loc.loc_end in + let file, start_line, start_char = get_pos_info loc.loc_start in + let _, end_line, end_char = get_pos_info loc.loc_end in (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) (* start_char is inclusive, end_char is exclusive *) let normalized_range = (* TODO: lots of the handlings here aren't needed anymore because the new - rescript syntax has much stronger invariants regarding positions, e.g. - no -1 *) + rescript syntax has much stronger invariants regarding positions, e.g. + no -1 *) if start_char == -1 || end_char == -1 then (* happens sometimes. Syntax error for example *) None @@ -191,104 +185,85 @@ let print ?(src = None) ~message_kind intro ppf (loc : t) = fprintf ppf " @[%a@]@," print_loc loc; match normalized_range with | None -> () - | Some _ -> begin - try - (* Print a syntax error that is a list of Res_diagnostics.t. - Instead of reading file for every error, it uses the source that the parser already has. *) - let src = match src with + | Some _ -> ( + try + (* Print a syntax error that is a list of Res_diagnostics.t. + Instead of reading file for every error, it uses the source that the parser already has. *) + let src = + match src with | Some src -> src | None -> Ext_io.load_file file - in - (* we're putting the line break `@,` here rather than above, because this - branch might not be reached (aka no inline file content display) so - we don't wanna end up with two line breaks in the the consequent *) - fprintf ppf "@,%s" - (Code_frame.print - ~is_warning:(message_kind=`warning) - ~src - ~start_pos:loc.loc_start - ~end_pos:loc.loc_end - ) - with - (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. - we've already printed the location above, so nothing more to do here. *) - | Sys_error _ -> () - end -;; + in + (* we're putting the line break `@,` here rather than above, because this + branch might not be reached (aka no inline file content display) so + we don't wanna end up with two line breaks in the the consequent *) + fprintf ppf "@,%s" + (Code_frame.print ~is_warning:(message_kind = `warning) ~src + ~start_pos:loc.loc_start ~end_pos:loc.loc_end) + with + (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. + we've already printed the location above, so nothing more to do here. *) + | Sys_error _ -> + ()) let error_prefix = "Error" let print_error_prefix ppf = setup_colors (); - fprintf ppf "@{%s@}" error_prefix; -;; + fprintf ppf "@{%s@}" error_prefix let print_compact ppf loc = - begin - let (file, line, startchar) = get_pos_info loc.loc_start in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - fprintf ppf "%a:%i" print_filename file line; - if startchar >= 0 then fprintf ppf ",%i--%i" startchar endchar - end -;; + let file, line, startchar = get_pos_info loc.loc_start in + let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in + fprintf ppf "%a:%i" print_filename file line; + if startchar >= 0 then fprintf ppf ",%i--%i" startchar endchar let print_error intro ppf loc = - fprintf ppf "%a%t:" (print ~message_kind:`error intro) loc print_error_prefix; -;; + fprintf ppf "%a%t:" (print ~message_kind:`error intro) loc print_error_prefix let default_warning_printer loc ppf w = match Warnings.report w with | `Inactive -> () - | `Active { Warnings. number = _; message = _; is_error; sub_locs = _} -> + | `Active {Warnings.number = _; message = _; is_error; sub_locs = _} -> setup_colors (); let message_kind = if is_error then `warning_as_error else `warning in Format.fprintf ppf "@[@, %a@, %s@,@]@." - (print ~message_kind ("Warning number " ^ (Warnings.number w |> string_of_int))) - loc - (Warnings.message w); - (* at this point, you can display sub_locs too, from e.g. https://github.com/ocaml/ocaml/commit/f6d53cc38f87c67fbf49109f5fb79a0334bab17a - but we won't bother for now *) -;; + (print ~message_kind + ("Warning number " ^ (Warnings.number w |> string_of_int))) + loc (Warnings.message w) +(* at this point, you can display sub_locs too, from e.g. https://github.com/ocaml/ocaml/commit/f6d53cc38f87c67fbf49109f5fb79a0334bab17a + but we won't bother for now *) -let warning_printer = ref default_warning_printer ;; +let warning_printer = ref default_warning_printer -let print_warning loc ppf w = - !warning_printer loc ppf w -;; +let print_warning loc ppf w = !warning_printer loc ppf w -let formatter_for_warnings = ref err_formatter;; -let prerr_warning loc w = - print_warning loc !formatter_for_warnings w;; +let formatter_for_warnings = ref err_formatter +let prerr_warning loc w = print_warning loc !formatter_for_warnings w let echo_eof () = print_newline (); incr num_loc_lines -type 'a loc = { - txt : 'a; - loc : t; -} +type 'a loc = {txt: 'a; loc: t} -let mkloc txt loc = { txt ; loc } +let mkloc txt loc = {txt; loc} let mknoloc txt = mkloc txt none - -type error = - { - loc: t; - msg: string; - sub: error list; - if_highlight: string; (* alternative message if locations are highlighted *) - } +type error = { + loc: t; + msg: string; + sub: error list; + if_highlight: string; (* alternative message if locations are highlighted *) +} let pp_ksprintf ?before k fmt = let buf = Buffer.create 64 in let ppf = Format.formatter_of_buffer buf in Misc.Color.set_color_tag_handling ppf; - begin match before with - | None -> () - | Some f -> f ppf - end; + (match before with + | None -> () + | Some f -> f ppf); kfprintf (fun _ -> pp_print_flush ppf (); @@ -305,8 +280,7 @@ let print_phanton_error_prefix ppf = Format.pp_print_as ppf 2 "" let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt = - pp_ksprintf - ~before:print_phanton_error_prefix + pp_ksprintf ~before:print_phanton_error_prefix (fun msg -> {loc; msg; sub; if_highlight}) fmt @@ -323,60 +297,54 @@ let error_of_exn exn = match exn with | Already_displayed_error -> Some `Already_displayed | _ -> - let rec loop = function - | [] -> None - | f :: rest -> - match f exn with - | Some error -> Some (`Ok error) - | None -> loop rest - in - loop !error_of_exn + let rec loop = function + | [] -> None + | f :: rest -> ( + match f exn with + | Some error -> Some (`Ok error) + | None -> loop rest) + in + loop !error_of_exn (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) (* This is the error report entry point. We'll replace the default reporter with this one. *) -let rec default_error_reporter ?(src = None) ppf ({loc; msg; sub}) = +let rec default_error_reporter ?(src = None) ppf {loc; msg; sub} = setup_colors (); (* open a vertical box. Everything in our message is indented 2 spaces *) (* If src is given, it will display a syntax error after parsing. *) - let intro = match src with - | Some _ -> "Syntax error!" - | None -> "We've found a bug for you!" + let intro = + match src with + | Some _ -> "Syntax error!" + | None -> "We've found a bug for you!" in - Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~src ~message_kind:`error intro) loc msg; + Format.fprintf ppf "@[@, %a@, %s@,@]" + (print ~src ~message_kind:`error intro) + loc msg; List.iter (Format.fprintf ppf "@,@[%a@]" (default_error_reporter ~src)) sub (* no need to flush here; location's report_exception (which uses this ultimately) flushes *) - + let error_reporter = ref default_error_reporter -let report_error ?(src = None) ppf err = - !error_reporter ~src ppf err -;; +let report_error ?(src = None) ppf err = !error_reporter ~src ppf err -let error_of_printer loc print x = - errorf ~loc "%a@?" print x +let error_of_printer loc print x = errorf ~loc "%a@?" print x let error_of_printer_file print x = error_of_printer (in_file !input_name) print x let () = - register_error_of_exn - (function - | Sys_error msg -> - Some (errorf ~loc:(in_file !input_name) - "I/O error: %s" msg) - - | Misc.HookExnWrapper {error = e; hook_name; - hook_info={Misc.sourcefile}} -> - let sub = match error_of_exn e with - | None | Some `Already_displayed -> error (Printexc.to_string e) - | Some (`Ok err) -> err - in - Some - (errorf ~loc:(in_file sourcefile) - "In hook %S:" hook_name - ~sub:[sub]) - | _ -> None - ) + register_error_of_exn (function + | Sys_error msg -> + Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) + | Misc.HookExnWrapper {error = e; hook_name; hook_info = {Misc.sourcefile}} + -> + let sub = + match error_of_exn e with + | None | Some `Already_displayed -> error (Printexc.to_string e) + | Some (`Ok err) -> err + in + Some (errorf ~loc:(in_file sourcefile) "In hook %S:" hook_name ~sub:[sub]) + | _ -> None) external reraise : exn -> 'a = "%reraise" @@ -386,24 +354,20 @@ let rec report_exception_rec n ppf exn = | None -> reraise exn | Some `Already_displayed -> () | Some (`Ok err) -> fprintf ppf "@[%a@]@." (report_error ~src:None) err - with exn when n > 0 -> report_exception_rec (n-1) ppf exn + with exn when n > 0 -> report_exception_rec (n - 1) ppf exn let report_exception ppf exn = report_exception_rec 5 ppf exn - exception Error of error let () = - register_error_of_exn - (function - | Error e -> Some e - | _ -> None - ) + register_error_of_exn (function + | Error e -> Some e + | _ -> None) let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") = - pp_ksprintf - ~before:print_phanton_error_prefix - (fun msg -> raise (Error ({loc; msg; sub; if_highlight}))) + pp_ksprintf ~before:print_phanton_error_prefix (fun msg -> + raise (Error {loc; msg; sub; if_highlight})) let deprecated ?(def = none) ?(use = none) loc msg = prerr_warning loc (Warnings.Deprecated (msg, def, use)) diff --git a/compiler/ml/location.mli b/compiler/ml/location.mli index e0f91d4c52..db4aa270da 100644 --- a/compiler/ml/location.mli +++ b/compiler/ml/location.mli @@ -43,24 +43,24 @@ val init : Lexing.lexbuf -> string -> unit val curr : Lexing.lexbuf -> t (** Get the location of the current token from the [lexbuf]. *) -val symbol_rloc: unit -> t -val symbol_gloc: unit -> t +val symbol_rloc : unit -> t +val symbol_gloc : unit -> t +val rhs_loc : int -> t (** [rhs_loc n] returns the location of the symbol at position [n], starting at 1, in the current parser rule. *) -val rhs_loc: int -> t -val input_name: string ref -val set_input_name: string -> unit -val input_lexbuf: Lexing.lexbuf option ref +val input_name : string ref +val set_input_name : string -> unit +val input_lexbuf : Lexing.lexbuf option ref -val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) -val print_loc: formatter -> t -> unit -val print_error: tag -> formatter -> t -> unit +val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) +val print_loc : formatter -> t -> unit +val print_error : tag -> formatter -> t -> unit -val prerr_warning: t -> Warnings.t -> unit -val echo_eof: unit -> unit -val reset: unit -> unit +val prerr_warning : t -> Warnings.t -> unit +val echo_eof : unit -> unit +val reset : unit -> unit val warning_printer : (t -> formatter -> Warnings.t -> unit) ref (** Hook for intercepting warnings. *) @@ -70,60 +70,71 @@ val formatter_for_warnings : formatter ref val default_warning_printer : t -> formatter -> Warnings.t -> unit (** Original warning printer for use in hooks. *) -type 'a loc = { - txt : 'a; - loc : t; -} +type 'a loc = {txt: 'a; loc: t} val mknoloc : 'a -> 'a loc val mkloc : 'a -> t -> 'a loc -val print: ?src:string option -> message_kind:[< `error | `warning | `warning_as_error > `warning] -> string -> formatter -> t -> unit -val print_compact: formatter -> t -> unit -val print_filename: formatter -> string -> unit +val print : + ?src:string option -> + message_kind:[< `error | `warning | `warning_as_error > `warning] -> + string -> + formatter -> + t -> + unit +val print_compact : formatter -> t -> unit +val print_filename : formatter -> string -> unit -val absolute_path: string -> string +val absolute_path : string -> string -val show_filename: string -> string - (** In -absname mode, return the absolute path for this filename. +val show_filename : string -> string +(** In -absname mode, return the absolute path for this filename. Otherwise, returns the filename unchanged. *) - -val absname: bool ref +val absname : bool ref (** Support for located errors *) -type error = - { - loc: t; - msg: string; - sub: error list; - if_highlight: string; (* alternative message if locations are highlighted *) - } +type error = { + loc: t; + msg: string; + sub: error list; + if_highlight: string; (* alternative message if locations are highlighted *) +} exception Already_displayed_error exception Error of error -val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error - +val error : ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error val print_error_prefix : Format.formatter -> unit -val pp_ksprintf : ?before:(formatter -> unit) -> (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b - +val pp_ksprintf : + ?before:(formatter -> unit) -> + (string -> 'a) -> + ('b, formatter, unit, 'a) format4 -> + 'b -val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string - -> ('a, Format.formatter, unit, error) format4 -> 'a +val errorf : + ?loc:t -> + ?sub:error list -> + ?if_highlight:string -> + ('a, Format.formatter, unit, error) format4 -> + 'a -val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string - -> ('a, Format.formatter, unit, 'b) format4 -> 'a +val raise_errorf : + ?loc:t -> + ?sub:error list -> + ?if_highlight:string -> + ('a, Format.formatter, unit, 'b) format4 -> + 'a -val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error +val error_of_printer : t -> (formatter -> 'a -> unit) -> 'a -> error -val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error +val error_of_printer_file : (formatter -> 'a -> unit) -> 'a -> error -val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option +val error_of_exn : exn -> [`Ok of error | `Already_displayed] option -val register_error_of_exn: (exn -> error option) -> unit +val register_error_of_exn : (exn -> error option) -> unit (** Each compiler module which defines a custom type of exception which can surface as a user-visible error should register a "printer" for this exception using [register_error_of_exn]. @@ -131,7 +142,7 @@ val register_error_of_exn: (exn -> error option) -> unit a location, a message, and optionally sub-messages (each of them being located as well). *) -val report_error: ?src:string option -> formatter -> error -> unit +val report_error : ?src:string option -> formatter -> error -> unit val error_reporter : (?src:string option -> formatter -> error -> unit) ref (** Hook for intercepting error reports. *) @@ -139,7 +150,7 @@ val error_reporter : (?src:string option -> formatter -> error -> unit) ref val default_error_reporter : ?src:string option -> formatter -> error -> unit (** Original error reporter for use in hooks. *) -val report_exception: formatter -> exn -> unit +val report_exception : formatter -> exn -> unit (** Reraise the exception if it is unknown. *) -val deprecated: ?def:t -> ?use:t -> t -> string -> unit +val deprecated : ?def:t -> ?use:t -> t -> string -> unit diff --git a/compiler/ml/longident.ml b/compiler/ml/longident.ml index acae9a6d3a..721a131055 100644 --- a/compiler/ml/longident.ml +++ b/compiler/ml/longident.ml @@ -13,10 +13,7 @@ (* *) (**************************************************************************) -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t +type t = Lident of string | Ldot of t * string | Lapply of t * t let rec cmp : t -> t -> int = fun a b -> if a == b then 0 @@ -26,38 +23,43 @@ let rec cmp : t -> t -> int = | Lident _, _ -> -1 | _, Lident _ -> 1 | Ldot (a, b), Ldot (c, d) -> ( - match cmp a c with 0 -> compare b d | n -> n) + match cmp a c with + | 0 -> compare b d + | n -> n) | Ldot _, _ -> -1 | _, Ldot _ -> 1 | Lapply (a, b), Lapply (c, d) -> ( - match cmp a c with 0 -> cmp b d | n -> n) + match cmp a c with + | 0 -> cmp b d + | n -> n) let rec flat accu = function - Lident s -> s :: accu - | Ldot(lid, s) -> flat (s :: accu) lid - | Lapply(_, _) -> Misc.fatal_error "Longident.flat" + | Lident s -> s :: accu + | Ldot (lid, s) -> flat (s :: accu) lid + | Lapply (_, _) -> Misc.fatal_error "Longident.flat" let flatten lid = flat [] lid let last = function - Lident s -> s - | Ldot(_, s) -> s - | Lapply(_, _) -> Misc.fatal_error "Longident.last" + | Lident s -> s + | Ldot (_, s) -> s + | Lapply (_, _) -> Misc.fatal_error "Longident.last" let rec split_at_dots s pos = try let dot = String.index_from s pos '.' in String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) - with Not_found -> - [String.sub s pos (String.length s - pos)] + with Not_found -> [String.sub s pos (String.length s - pos)] let unflatten l = match l with | [] -> None - | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + | hd :: tl -> Some (List.fold_left (fun p s -> Ldot (p, s)) (Lident hd) tl) let parse s = match unflatten (split_at_dots s 0) with - | None -> Lident "" (* should not happen, but don't put assert false - so as not to crash the toplevel (see Genprintval) *) + | None -> + Lident "" + (* should not happen, but don't put assert false + so as not to crash the toplevel (see Genprintval) *) | Some v -> v diff --git a/compiler/ml/longident.mli b/compiler/ml/longident.mli index 4c65fa647d..26ed938e84 100644 --- a/compiler/ml/longident.mli +++ b/compiler/ml/longident.mli @@ -15,13 +15,10 @@ (** Long identifiers, used in parsetree. *) -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t +type t = Lident of string | Ldot of t * string | Lapply of t * t -val cmp : t -> t -> int -val flatten: t -> string list -val unflatten: string list -> t option -val last: t -> string -val parse: string -> t +val cmp : t -> t -> int +val flatten : t -> string list +val unflatten : string list -> t option +val last : t -> string +val parse : string -> t diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 2544cdb072..0b6b6f1f3e 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -23,11 +23,10 @@ open Lambda open Parmatch open Printf - let dbg = false -(* See Peyton-Jones, ``The Implementation of functional programming - languages'', chapter 5. *) +(* See Peyton-Jones, ``The Implementation of functional programming + languages'', chapter 5. *) (* Well, it was true at the beginning of the world. Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 @@ -41,9 +40,11 @@ let dbg = false returns true when they may have a common instance. *) -module MayCompat = - Parmatch.Compat (struct let equal = Types.may_equal_constr end) +module MayCompat = Parmatch.Compat (struct + let equal = Types.may_equal_constr +end) let may_compat = MayCompat.compat + and may_compats = MayCompat.compats (* @@ -55,214 +56,203 @@ and may_compats = MayCompat.compats - Jump summaries: mapping from exit numbers to contexts *) - let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; + Printlambda.lambda Format.str_formatter lam; Format.flush_str_formatter () type matrix = pattern list list -let add_omega_column pss = List.map (fun ps -> omega::ps) pss +let add_omega_column pss = List.map (fun ps -> omega :: ps) pss -type ctx = {left:pattern list ; right:pattern list} +type ctx = {left: pattern list; right: pattern list} let pretty_ctx ctx = List.iter - (fun {left=left ; right=right} -> - prerr_string "LEFT:" ; - pretty_line left ; - prerr_string " RIGHT:" ; - pretty_line right ; + (fun {left; right} -> + prerr_string "LEFT:"; + pretty_line left; + prerr_string " RIGHT:"; + pretty_line right; prerr_endline "") ctx -let le_ctx c1 c2 = - le_pats c1.left c2.left && - le_pats c1.right c2.right +let le_ctx c1 c2 = le_pats c1.left c2.left && le_pats c1.right c2.right -let lshift {left=left ; right=right} = match right with -| x::xs -> {left=x::left ; right=xs} -| _ -> assert false +let lshift {left; right} = + match right with + | x :: xs -> {left = x :: left; right = xs} + | _ -> assert false -let lforget {left=left ; right=right} = match right with -| _::xs -> {left=omega::left ; right=xs} -| _ -> assert false +let lforget {left; right} = + match right with + | _ :: xs -> {left = omega :: left; right = xs} + | _ -> assert false let rec small_enough n = function | [] -> true - | _::rem -> - if n <= 0 then false - else small_enough (n-1) rem + | _ :: rem -> if n <= 0 then false else small_enough (n - 1) rem let ctx_lshift ctx = - if small_enough 31 ctx then - List.map lshift ctx - else (* Context pruning *) begin - get_mins le_ctx (List.map lforget ctx) - end + if small_enough 31 ctx then List.map lshift ctx + else (* Context pruning *) get_mins le_ctx (List.map lforget ctx) -let rshift {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=p::right} -| _ -> assert false +let rshift {left; right} = + match left with + | p :: ps -> {left = ps; right = p :: right} + | _ -> assert false let ctx_rshift ctx = List.map rshift ctx let rec nchars n ps = - if n <= 0 then [],ps - else match ps with - | p::rem -> - let chars, cdrs = nchars (n-1) rem in - p::chars,cdrs - | _ -> assert false + if n <= 0 then ([], ps) + else + match ps with + | p :: rem -> + let chars, cdrs = nchars (n - 1) rem in + (p :: chars, cdrs) + | _ -> assert false -let rshift_num n {left=left ; right=right} = - let shifted,left = nchars n left in - {left=left ; right = shifted@right} +let rshift_num n {left; right} = + let shifted, left = nchars n left in + {left; right = shifted @ right} let ctx_rshift_num n ctx = List.map (rshift_num n) ctx (* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) - All mutable fields are replaced by '_', since side-effects in - guards can alter these fields *) + All mutable fields are replaced by '_', since side-effects in + guards can alter these fields *) -let combine {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=set_args_erase_mutable p right} -| _ -> assert false +let combine {left; right} = + match left with + | p :: ps -> {left = ps; right = set_args_erase_mutable p right} + | _ -> assert false let ctx_combine ctx = List.map combine ctx let ncols = function | [] -> 0 - | ps::_ -> List.length ps - + | ps :: _ -> List.length ps exception NoMatch exception OrPat let filter_matrix matcher pss = - let rec filter_rec = function - | (p::ps)::rem -> - begin match p.pat_desc with - | Tpat_alias (p,_,_) -> - filter_rec ((p::ps)::rem) - | Tpat_var _ -> - filter_rec ((omega::ps)::rem) - | _ -> - begin - let rem = filter_rec rem in - try - matcher p ps::rem - with - | NoMatch -> rem - | OrPat -> - match p.pat_desc with - | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem - | _ -> assert false - end - end + | (p :: ps) :: rem -> ( + match p.pat_desc with + | Tpat_alias (p, _, _) -> filter_rec ((p :: ps) :: rem) + | Tpat_var _ -> filter_rec ((omega :: ps) :: rem) + | _ -> ( + let rem = filter_rec rem in + try matcher p ps :: rem with + | NoMatch -> rem + | OrPat -> ( + match p.pat_desc with + | Tpat_or (p1, p2, _) -> filter_rec [p1 :: ps; p2 :: ps] @ rem + | _ -> assert false))) | [] -> [] | _ -> - pretty_matrix pss ; - fatal_error "Matching.filter_matrix" in + pretty_matrix pss; + fatal_error "Matching.filter_matrix" + in filter_rec pss let make_default matcher env = let rec make_rec = function | [] -> [] - | ([[]],i)::_ -> [[[]],i] - | (pss,i)::rem -> - let rem = make_rec rem in - match filter_matrix matcher pss with - | [] -> rem - | ([]::_) -> ([[]],i)::rem - | pss -> (pss,i)::rem in + | ([[]], i) :: _ -> [([[]], i)] + | (pss, i) :: rem -> ( + let rem = make_rec rem in + match filter_matrix matcher pss with + | [] -> rem + | [] :: _ -> ([[]], i) :: rem + | pss -> (pss, i) :: rem) + in make_rec env let ctx_matcher p = let p = normalize_pat p in match p.pat_desc with - | Tpat_construct (_, cstr,omegas) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args) -(* NB: may_constr_equal considers (potential) constructor rebinding *) + | Tpat_construct (_, cstr, omegas) -> ( + fun q rem -> + match q.pat_desc with + | Tpat_construct (_, cstr', args) + (* NB: may_constr_equal considers (potential) constructor rebinding *) when Types.may_equal_constr cstr cstr' -> - p,args@rem - | Tpat_any -> p,omegas @ rem + (p, args @ rem) + | Tpat_any -> (p, omegas @ rem) | _ -> raise NoMatch) - | Tpat_constant cst -> - (fun q rem -> match q.pat_desc with - | Tpat_constant cst' when const_compare cst cst' = 0 -> - p,rem - | Tpat_any -> p,rem + | Tpat_constant cst -> ( + fun q rem -> + match q.pat_desc with + | Tpat_constant cst' when const_compare cst cst' = 0 -> (p, rem) + | Tpat_any -> (p, rem) | _ -> raise NoMatch) - | Tpat_variant (lab,Some omega,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',Some arg,_) when lab=lab' -> - p,arg::rem - | Tpat_any -> p,omega::rem + | Tpat_variant (lab, Some omega, _) -> ( + fun q rem -> + match q.pat_desc with + | Tpat_variant (lab', Some arg, _) when lab = lab' -> (p, arg :: rem) + | Tpat_any -> (p, omega :: rem) | _ -> raise NoMatch) - | Tpat_variant (lab,None,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',None,_) when lab=lab' -> - p,rem - | Tpat_any -> p,rem + | Tpat_variant (lab, None, _) -> ( + fun q rem -> + match q.pat_desc with + | Tpat_variant (lab', None, _) when lab = lab' -> (p, rem) + | Tpat_any -> (p, rem) | _ -> raise NoMatch) - | Tpat_array omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_array args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem + | Tpat_array omegas -> ( + let len = List.length omegas in + fun q rem -> + match q.pat_desc with + | Tpat_array args when List.length args = len -> (p, args @ rem) + | Tpat_any -> (p, omegas @ rem) | _ -> raise NoMatch) - | Tpat_tuple omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_tuple args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem + | Tpat_tuple omegas -> ( + let len = List.length omegas in + fun q rem -> + match q.pat_desc with + | Tpat_tuple args when List.length args = len -> (p, args @ rem) + | Tpat_any -> (p, omegas @ rem) | _ -> raise NoMatch) - | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *) - let len = Array.length lbl.lbl_all in - (fun q rem -> match q.pat_desc with - | Tpat_record (((_, lbl', _) :: _) as l',_) + | Tpat_record (((_, lbl, _) :: _ as l), _) -> ( + (* Records are normalized *) + let len = Array.length lbl.lbl_all in + fun q rem -> + match q.pat_desc with + | Tpat_record (((_, lbl', _) :: _ as l'), _) when Array.length lbl'.lbl_all = len -> - let l' = all_record_args l' in - p, List.fold_right (fun (_, _,p) r -> p::r) l' rem - | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem + let l' = all_record_args l' in + (p, List.fold_right (fun (_, _, p) r -> p :: r) l' rem) + | Tpat_any -> (p, List.fold_right (fun (_, _, p) r -> p :: r) l rem) | _ -> raise NoMatch) - | Tpat_lazy omega -> - (fun q rem -> match q.pat_desc with - | Tpat_lazy arg -> p, (arg::rem) - | Tpat_any -> p, (omega::rem) - | _ -> raise NoMatch) - | _ -> fatal_error "Matching.ctx_matcher" - - - + | Tpat_lazy omega -> ( + fun q rem -> + match q.pat_desc with + | Tpat_lazy arg -> (p, arg :: rem) + | Tpat_any -> (p, omega :: rem) + | _ -> raise NoMatch) + | _ -> fatal_error "Matching.ctx_matcher" let filter_ctx q ctx = - let matcher = ctx_matcher q in let rec filter_rec = function - | ({right=p::ps} as l)::rem -> - begin match p.pat_desc with - | Tpat_or (p1,p2,_) -> - filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) - | Tpat_alias (p,_,_) -> - filter_rec ({l with right=p::ps}::rem) - | Tpat_var _ -> - filter_rec ({l with right=omega::ps}::rem) - | _ -> - begin let rem = filter_rec rem in - try - let to_left, right = matcher p ps in - {left=to_left::l.left ; right=right}::rem - with - | NoMatch -> rem - end - end + | ({right = p :: ps} as l) :: rem -> ( + match p.pat_desc with + | Tpat_or (p1, p2, _) -> + filter_rec + ({l with right = p1 :: ps} :: {l with right = p2 :: ps} :: rem) + | Tpat_alias (p, _, _) -> filter_rec ({l with right = p :: ps} :: rem) + | Tpat_var _ -> filter_rec ({l with right = omega :: ps} :: rem) + | _ -> ( + let rem = filter_rec rem in + try + let to_left, right = matcher p ps in + {left = to_left :: l.left; right} :: rem + with NoMatch -> rem)) | [] -> [] - | _ -> fatal_error "Matching.filter_ctx" in + | _ -> fatal_error "Matching.filter_ctx" + in filter_rec ctx @@ -271,144 +261,135 @@ let select_columns pss ctx = List.fold_right (fun ps r -> List.fold_right - (fun {left=left ; right=right} r -> + (fun {left; right} r -> let transfert, right = nchars n right in - try - {left = lubs transfert ps @ left ; right=right}::r - with - | Empty -> r) + try {left = lubs transfert ps @ left; right} :: r with Empty -> r) ctx r) pss [] let ctx_lub p ctx = List.fold_right - (fun {left=left ; right=right} r -> + (fun {left; right} r -> match right with - | q::rem -> - begin try - {left=left ; right = lub p q::rem}::r - with - | Empty -> r - end + | q :: rem -> ( try {left; right = lub p q :: rem} :: r with Empty -> r) | _ -> fatal_error "Matching.ctx_lub") ctx [] let ctx_match ctx pss = List.exists - (fun {right=qs} -> List.exists (fun ps -> may_compats qs ps) pss) + (fun {right = qs} -> List.exists (fun ps -> may_compats qs ps) pss) ctx type jumps = (int * ctx list) list -let pretty_jumps (env : jumps) = match env with -| [] -> () -| _ -> +let pretty_jumps (env : jumps) = + match env with + | [] -> () + | _ -> List.iter - (fun (i,ctx) -> - Printf.fprintf stderr "jump for %d\n" i ; + (fun (i, ctx) -> + Printf.fprintf stderr "jump for %d\n" i; pretty_ctx ctx) env - let rec jumps_extract (i : int) = function - | [] -> [],[] - | (j,pss) as x::rem as all -> - if i=j then pss,rem - else if j < i then [],all - else - let r,rem = jumps_extract i rem in - r,(x::rem) + | [] -> ([], []) + | ((j, pss) as x) :: rem as all -> + if i = j then (pss, rem) + else if j < i then ([], all) + else + let r, rem = jumps_extract i rem in + (r, x :: rem) -let rec jumps_remove (i:int) = function +let rec jumps_remove (i : int) = function | [] -> [] - | (j,_)::rem when i=j -> rem - | x::rem -> x::jumps_remove i rem + | (j, _) :: rem when i = j -> rem + | x :: rem -> x :: jumps_remove i rem let jumps_empty = [] + and jumps_is_empty = function - | [] -> true - | _ -> false + | [] -> true + | _ -> false let jumps_singleton i = function - | [] -> [] - | ctx -> [i,ctx] + | [] -> [] + | ctx -> [(i, ctx)] -let jumps_add i pss jumps = match pss with -| [] -> jumps -| _ -> +let jumps_add i pss jumps = + match pss with + | [] -> jumps + | _ -> let rec add = function - | [] -> [i,pss] - | (j,qss) as x::rem as all -> - if (j:int) > i then x::add rem - else if j < i then (i,pss)::all - else (i,(get_mins le_ctx (pss@qss)))::rem in + | [] -> [(i, pss)] + | ((j, qss) as x) :: rem as all -> + if (j : int) > i then x :: add rem + else if j < i then (i, pss) :: all + else (i, get_mins le_ctx (pss @ qss)) :: rem + in add jumps - -let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with -| [],_ -> env2 -| _,[] -> env1 -| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> - if i1=i2 then - (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 - else if i1 > i2 then - x1::jumps_union rem1 env2 - else - x2::jumps_union env1 rem2 - +let rec jumps_union (env1 : (int * ctx list) list) env2 = + match (env1, env2) with + | [], _ -> env2 + | _, [] -> env1 + | ((i1, pss1) as x1) :: rem1, ((i2, pss2) as x2) :: rem2 -> + if i1 = i2 then (i1, get_mins le_ctx (pss1 @ pss2)) :: jumps_union rem1 rem2 + else if i1 > i2 then x1 :: jumps_union rem1 env2 + else x2 :: jumps_union env1 rem2 let rec merge = function - | env1::env2::rem -> jumps_union env1 env2::merge rem + | env1 :: env2 :: rem -> jumps_union env1 env2 :: merge rem | envs -> envs -let rec jumps_unions envs = match envs with +let rec jumps_unions envs = + match envs with | [] -> [] | [env] -> env | _ -> jumps_unions (merge envs) -let jumps_map f env = - List.map - (fun (i,pss) -> i,f pss) - env +let jumps_map f env = List.map (fun (i, pss) -> (i, f pss)) env (* Pattern matching before any compilation *) -type pattern_matching = - { mutable cases : (pattern list * lambda) list; - args : (lambda * let_kind) list ; - default : (matrix * int) list} +type pattern_matching = { + mutable cases: (pattern list * lambda) list; + args: (lambda * let_kind) list; + default: (matrix * int) list; +} (* Pattern matching after application of both the or-pat rule and the mixture rule *) -type pm_or_compiled = - {body : pattern_matching ; - handlers : (matrix * int * Ident.t list * pattern_matching) list ; - or_matrix : matrix ; } +type pm_or_compiled = { + body: pattern_matching; + handlers: (matrix * int * Ident.t list * pattern_matching) list; + or_matrix: matrix; +} type pm_half_compiled = | PmOr of pm_or_compiled | PmVar of pm_var_compiled | Pm of pattern_matching -and pm_var_compiled = - {inside : pm_half_compiled ; var_arg : lambda ; } +and pm_var_compiled = {inside: pm_half_compiled; var_arg: lambda} -type pm_half_compiled_info = - {me : pm_half_compiled ; - matrix : matrix ; - top_default : (matrix * int) list ; } +type pm_half_compiled_info = { + me: pm_half_compiled; + matrix: matrix; + top_default: (matrix * int) list; +} let pretty_cases cases = List.iter - (fun (ps,_l) -> + (fun (ps, _l) -> List.iter (fun p -> - Parmatch.top_pretty Format.str_formatter p ; - prerr_string " " ; + Parmatch.top_pretty Format.str_formatter p; + prerr_string " "; prerr_string (Format.flush_str_formatter ())) - ps ; -(* + ps; + (* prerr_string " -> " ; Printlambda.lambda Format.str_formatter l ; prerr_string (Format.flush_str_formatter ()) ; @@ -417,47 +398,43 @@ let pretty_cases cases = cases let pretty_def def = - prerr_endline "+++++ Defaults +++++" ; + prerr_endline "+++++ Defaults +++++"; List.iter - (fun (pss,i) -> - Printf.fprintf stderr "Matrix for %d\n" i ; + (fun (pss, i) -> + Printf.fprintf stderr "Matrix for %d\n" i; pretty_matrix pss) - def ; + def; prerr_endline "+++++++++++++++++++++" let pretty_pm pm = - pretty_cases pm.cases ; - if pm.default <> [] then - pretty_def pm.default - + pretty_cases pm.cases; + if pm.default <> [] then pretty_def pm.default let rec pretty_precompiled = function | Pm pm -> - prerr_endline "++++ PM ++++" ; - pretty_pm pm + prerr_endline "++++ PM ++++"; + pretty_pm pm | PmVar x -> - prerr_endline "++++ VAR ++++" ; - pretty_precompiled x.inside + prerr_endline "++++ VAR ++++"; + pretty_precompiled x.inside | PmOr x -> - prerr_endline "++++ OR ++++" ; - pretty_pm x.body ; - pretty_matrix x.or_matrix ; - List.iter - (fun (_,i,_,pm) -> - eprintf "++ Handler %d ++\n" i ; - pretty_pm pm) - x.handlers + prerr_endline "++++ OR ++++"; + pretty_pm x.body; + pretty_matrix x.or_matrix; + List.iter + (fun (_, i, _, pm) -> + eprintf "++ Handler %d ++\n" i; + pretty_pm pm) + x.handlers let pretty_precompiled_res first nexts = - pretty_precompiled first ; + pretty_precompiled first; List.iter (fun (e, pmh) -> - eprintf "** DEFAULT %d **\n" e ; + eprintf "** DEFAULT %d **\n" e; pretty_precompiled pmh) nexts - - (* Identifying some semantically equivalent lambda-expressions, Our goal here is also to find alpha-equivalent (simple) terms *) @@ -469,87 +446,77 @@ let pretty_precompiled_res first nexts = in case action sharing is present. *) +module StoreExp = Switch.Store (struct + type t = lambda + type key = lambda + let compare_key = compare + let make_key = Lambda.make_key +end) -module StoreExp = - Switch.Store - (struct - type t = lambda - type key = lambda - let compare_key = compare - let make_key = Lambda.make_key - end) - - -let make_exit i = Lstaticraise (i,[]) +let make_exit i = Lstaticraise (i, []) (* Introduce a catch, if worth it *) -let make_catch d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> +let make_catch d k = + match d with + | Lstaticraise (_, []) -> k d + | _ -> let e = next_raise_count () in - Lstaticcatch (k (make_exit e),(e,[]),d) + Lstaticcatch (k (make_exit e), (e, []), d) (* Introduce a catch, if worth it, delayed version *) let rec as_simple_exit = function - | Lstaticraise (i,[]) -> Some i - | Llet (Alias,_k,_,_,e) -> as_simple_exit e + | Lstaticraise (i, []) -> Some i + | Llet (Alias, _k, _, _, e) -> as_simple_exit e | _ -> None - -let make_catch_delayed handler = match as_simple_exit handler with -| Some i -> i,(fun act -> act) -| None -> +let make_catch_delayed handler = + match as_simple_exit handler with + | Some i -> (i, fun act -> act) + | None -> ( let i = next_raise_count () in -(* + (* Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); *) - i, - (fun body -> match body with - | Lstaticraise (j,_) -> - if i=j then handler else body - | _ -> Lstaticcatch (body,(i,[]),handler)) - + ( i, + fun body -> + match body with + | Lstaticraise (j, _) -> if i = j then handler else body + | _ -> Lstaticcatch (body, (i, []), handler) )) let raw_action l = - match make_key l with | Some l -> l | None -> l + match make_key l with + | Some l -> l + | None -> l - -let tr_raw act = match make_key act with -| Some act -> act -| None -> raise Exit +let tr_raw act = + match make_key act with + | Some act -> act + | None -> raise Exit let same_actions = function | [] -> None - | [_,act] -> Some act - | (_,act0) :: rem -> - try - let raw_act0 = tr_raw act0 in - let rec s_rec = function - | [] -> Some act0 - | (_,act)::rem -> - if raw_act0 = tr_raw act then - s_rec rem - else - None in - s_rec rem - with - | Exit -> None - + | [(_, act)] -> Some act + | (_, act0) :: rem -> ( + try + let raw_act0 = tr_raw act0 in + let rec s_rec = function + | [] -> Some act0 + | (_, act) :: rem -> if raw_act0 = tr_raw act then s_rec rem else None + in + s_rec rem + with Exit -> None) (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = tr_raw act1 - and raw2 = tr_raw act2 in + let raw1 = tr_raw act1 and raw2 = tr_raw act2 in raw1 = raw2 - with - | Exit -> false + with Exit -> false -let up_ok (ps,act_p) l = +let up_ok (ps, act_p) l = List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || not (may_compats ps qs)) + (fun (qs, act_q) -> up_ok_action act_p act_q || not (may_compats ps qs)) l (* @@ -564,171 +531,149 @@ let up_ok (ps,act_p) l = exception Var of pattern let simplify_or p = - let rec simpl_rec p = match p with - | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) - | {pat_desc = Tpat_alias (q,id,s)} -> - begin try - {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} - with - | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) - end - | {pat_desc = Tpat_or (p1,p2,o)} -> - let q1 = simpl_rec p1 in - begin try - let q2 = simpl_rec p2 in - {p with pat_desc = Tpat_or (q1, q2, o)} - with - | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) - end - | {pat_desc = Tpat_record (lbls,closed)} -> - let all_lbls = all_record_args lbls in - {p with pat_desc=Tpat_record (all_lbls, closed)} - | _ -> p in - try - simpl_rec p - with - | Var p -> p + let rec simpl_rec p = + match p with + | {pat_desc = Tpat_any | Tpat_var _} -> raise (Var p) + | {pat_desc = Tpat_alias (q, id, s)} -> ( + try {p with pat_desc = Tpat_alias (simpl_rec q, id, s)} + with Var q -> raise (Var {p with pat_desc = Tpat_alias (q, id, s)})) + | {pat_desc = Tpat_or (p1, p2, o)} -> ( + let q1 = simpl_rec p1 in + try + let q2 = simpl_rec p2 in + {p with pat_desc = Tpat_or (q1, q2, o)} + with Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})) + | {pat_desc = Tpat_record (lbls, closed)} -> + let all_lbls = all_record_args lbls in + {p with pat_desc = Tpat_record (all_lbls, closed)} + | _ -> p + in + try simpl_rec p with Var p -> p -let simplify_cases args cls = match args with -| [] -> assert false -| (arg,_)::_ -> +let simplify_cases args cls = + match args with + | [] -> assert false + | (arg, _) :: _ -> let rec simplify = function | [] -> [] - | ((pat :: patl, action) as cl) :: rem -> - begin match pat.pat_desc with - | Tpat_var (id, _) -> - (omega :: patl, bind Alias id arg action) :: - simplify rem - | Tpat_any -> - cl :: simplify rem - | Tpat_alias(p, id,_) -> - simplify ((p :: patl, bind Alias id arg action) :: rem) - | Tpat_record ([],_) -> - (omega :: patl, action):: - simplify rem - | Tpat_record (lbls, closed) -> - let all_lbls = all_record_args lbls in - let full_pat = - {pat with pat_desc=Tpat_record (all_lbls, closed)} in - (full_pat::patl,action):: - simplify rem - | Tpat_or _ -> - let pat_simple = simplify_or pat in - begin match pat_simple.pat_desc with - | Tpat_or _ -> - (pat_simple :: patl, action) :: - simplify rem - | _ -> - simplify ((pat_simple::patl,action) :: rem) - end - | _ -> cl :: simplify rem - end - | _ -> assert false in + | ((pat :: patl, action) as cl) :: rem -> ( + match pat.pat_desc with + | Tpat_var (id, _) -> + (omega :: patl, bind Alias id arg action) :: simplify rem + | Tpat_any -> cl :: simplify rem + | Tpat_alias (p, id, _) -> + simplify ((p :: patl, bind Alias id arg action) :: rem) + | Tpat_record ([], _) -> (omega :: patl, action) :: simplify rem + | Tpat_record (lbls, closed) -> + let all_lbls = all_record_args lbls in + let full_pat = {pat with pat_desc = Tpat_record (all_lbls, closed)} in + (full_pat :: patl, action) :: simplify rem + | Tpat_or _ -> ( + let pat_simple = simplify_or pat in + match pat_simple.pat_desc with + | Tpat_or _ -> (pat_simple :: patl, action) :: simplify rem + | _ -> simplify ((pat_simple :: patl, action) :: rem)) + | _ -> cl :: simplify rem) + | _ -> assert false + in simplify cls - - (* Once matchings are simplified one can easily find their nature *) -let rec what_is_cases cases = match cases with -| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem -| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ - -> assert false (* applies to simplified matchings only *) -| (p::_,_)::_ -> p -| [] -> omega -| _ -> assert false - - +let rec what_is_cases cases = + match cases with + | ({pat_desc = Tpat_any} :: _, _) :: rem -> what_is_cases rem + | ({pat_desc = Tpat_var _ | Tpat_or (_, _, _) | Tpat_alias (_, _, _)} :: _, _) + :: _ -> + assert false (* applies to simplified matchings only *) + | (p :: _, _) :: _ -> p + | [] -> omega + | _ -> assert false (* A few operations on default environments *) -let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) +let as_matrix cases = get_mins le_pats (List.map (fun (ps, _) -> ps) cases) let cons_default matrix raise_num default = match matrix with | [] -> default - | _ -> (matrix,raise_num)::default + | _ -> (matrix, raise_num) :: default let default_compat p def = List.fold_right - (fun (pss,i) r -> + (fun (pss, i) r -> let qss = List.fold_right - (fun qs r -> match qs with - | q::rem when may_compat p q -> rem::r + (fun qs r -> + match qs with + | q :: rem when may_compat p q -> rem :: r | _ -> r) - pss [] in + pss [] + in match qss with | [] -> r - | _ -> (qss,i)::r) + | _ -> (qss, i) :: r) def [] (* Or-pattern expansion, variables are a complication w.r.t. the article *) -let rec extract_vars r p = match p.pat_desc with -| Tpat_var (id, _) -> IdentSet.add id r -| Tpat_alias (p, id,_ ) -> - extract_vars (IdentSet.add id r) p -| Tpat_tuple pats -> - List.fold_left extract_vars r pats -| Tpat_record (lpats,_) -> - List.fold_left - (fun r (_, _, p) -> extract_vars r p) - r lpats -| Tpat_construct (_, _, pats) -> - List.fold_left extract_vars r pats -| Tpat_array pats -> - List.fold_left extract_vars r pats -| Tpat_variant (_,Some p, _) -> extract_vars r p -| Tpat_lazy p -> extract_vars r p -| Tpat_or (p,_,_) -> extract_vars r p -| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r +let rec extract_vars r p = + match p.pat_desc with + | Tpat_var (id, _) -> IdentSet.add id r + | Tpat_alias (p, id, _) -> extract_vars (IdentSet.add id r) p + | Tpat_tuple pats -> List.fold_left extract_vars r pats + | Tpat_record (lpats, _) -> + List.fold_left (fun r (_, _, p) -> extract_vars r p) r lpats + | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats + | Tpat_array pats -> List.fold_left extract_vars r pats + | Tpat_variant (_, Some p, _) -> extract_vars r p + | Tpat_lazy p -> extract_vars r p + | Tpat_or (p, _, _) -> extract_vars r p + | Tpat_constant _ | Tpat_any | Tpat_variant (_, None, _) -> r exception Cannot_flatten let mk_alpha_env arg aliases ids = List.map - (fun id -> id, - if List.mem id aliases then - match arg with - | Some v -> v - | _ -> raise Cannot_flatten - else - Ident.create (Ident.name id)) + (fun id -> + ( id, + if List.mem id aliases then + match arg with + | Some v -> v + | _ -> raise Cannot_flatten + else Ident.create (Ident.name id) )) ids let rec explode_or_pat arg patl mk_action rem vars aliases = function - | {pat_desc = Tpat_or (p1,p2,_)} -> - explode_or_pat - arg patl mk_action - (explode_or_pat arg patl mk_action rem vars aliases p2) - vars aliases p1 - | {pat_desc = Tpat_alias (p,id, _)} -> - explode_or_pat arg patl mk_action rem vars (id::aliases) p + | {pat_desc = Tpat_or (p1, p2, _)} -> + explode_or_pat arg patl mk_action + (explode_or_pat arg patl mk_action rem vars aliases p2) + vars aliases p1 + | {pat_desc = Tpat_alias (p, id, _)} -> + explode_or_pat arg patl mk_action rem vars (id :: aliases) p | {pat_desc = Tpat_var (x, _)} -> - let env = mk_alpha_env arg (x::aliases) vars in - (omega::patl,mk_action (List.map snd env))::rem + let env = mk_alpha_env arg (x :: aliases) vars in + (omega :: patl, mk_action (List.map snd env)) :: rem | p -> - let env = mk_alpha_env arg aliases vars in - (alpha_pat env p::patl,mk_action (List.map snd env))::rem + let env = mk_alpha_env arg aliases vars in + (alpha_pat env p :: patl, mk_action (List.map snd env)) :: rem -let pm_free_variables {cases=cases} = +let pm_free_variables {cases} = List.fold_right - (fun (_,act) r -> IdentSet.union (free_variables act) r) + (fun (_, act) r -> IdentSet.union (free_variables act) r) cases IdentSet.empty - (* Basic grouping predicates *) let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr + | {pat_desc = Tpat_construct (_, cstr, _)} -> cstr | _ -> fatal_error "Matching.pat_as_constr" let group_constant = function - | {pat_desc= Tpat_constant _} -> true - | _ -> false + | {pat_desc = Tpat_constant _} -> true + | _ -> false and group_constructor = function - | {pat_desc = Tpat_construct (_,_,_)} -> true + | {pat_desc = Tpat_construct (_, _, _)} -> true | _ -> false and group_variant = function @@ -736,51 +681,51 @@ and group_variant = function | _ -> false and group_var = function - | {pat_desc=Tpat_any} -> true + | {pat_desc = Tpat_any} -> true | _ -> false and group_tuple = function - | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true + | {pat_desc = Tpat_tuple _ | Tpat_any} -> true | _ -> false and group_record = function - | {pat_desc = (Tpat_record _|Tpat_any)} -> true + | {pat_desc = Tpat_record _ | Tpat_any} -> true | _ -> false and group_array = function - | {pat_desc=Tpat_array _} -> true + | {pat_desc = Tpat_array _} -> true | _ -> false and group_lazy = function | {pat_desc = Tpat_lazy _} -> true | _ -> false -let get_group p = match p.pat_desc with -| Tpat_any -> group_var -| Tpat_constant _ -> group_constant -| Tpat_construct _ -> group_constructor -| Tpat_tuple _ -> group_tuple -| Tpat_record _ -> group_record -| Tpat_array _ -> group_array -| Tpat_variant (_,_,_) -> group_variant -| Tpat_lazy _ -> group_lazy -| _ -> fatal_error "Matching.get_group" - - - -let is_or p = match p.pat_desc with -| Tpat_or _ -> true -| _ -> false +let get_group p = + match p.pat_desc with + | Tpat_any -> group_var + | Tpat_constant _ -> group_constant + | Tpat_construct _ -> group_constructor + | Tpat_tuple _ -> group_tuple + | Tpat_record _ -> group_record + | Tpat_array _ -> group_array + | Tpat_variant (_, _, _) -> group_variant + | Tpat_lazy _ -> group_lazy + | _ -> fatal_error "Matching.get_group" + +let is_or p = + match p.pat_desc with + | Tpat_or _ -> true + | _ -> false (* Conditions for appending to the Or matrix *) let conda p q = not (may_compat p q) -and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps + +and condb act ps qs = (not (is_guarded act)) && Parmatch.le_pats qs ps let or_ok p ps l = List.for_all (function - | ({pat_desc=Tpat_or _} as q::qs,act) -> - conda p q || condb act ps qs + | ({pat_desc = Tpat_or _} as q) :: qs, act -> conda p q || condb act ps qs | _ -> true) l @@ -788,69 +733,76 @@ let or_ok p ps l = let equiv_pat p q = le_pat p q && le_pat q p -let rec get_equiv p l = match l with - | (q::_,_) as cl::rem -> - if equiv_pat p q then - let others,rem = get_equiv p rem in - cl::others,rem - else - [],l - | _ -> [],l - +let rec get_equiv p l = + match l with + | ((q :: _, _) as cl) :: rem -> + if equiv_pat p q then + let others, rem = get_equiv p rem in + (cl :: others, rem) + else ([], l) + | _ -> ([], l) let insert_or_append p ps act ors no = let rec attempt seen = function - | (q::qs,act_q) as cl::rem -> - if is_or q then begin - if may_compat p q then + | ((q :: qs, act_q) as cl) :: rem -> + if is_or q then + if may_compat p q then + if + IdentSet.is_empty (extract_vars IdentSet.empty p) + && IdentSet.is_empty (extract_vars IdentSet.empty q) + && equiv_pat p q + then + (* attempt insert, for equivalent orpats with no variables *) + let _, not_e = get_equiv q rem in if - IdentSet.is_empty (extract_vars IdentSet.empty p) && - IdentSet.is_empty (extract_vars IdentSet.empty q) && - equiv_pat p q - then (* attempt insert, for equivalent orpats with no variables *) - let _, not_e = get_equiv q rem in - if - or_ok p ps not_e && (* check append condition for head of O *) - List.for_all (* check insert condition for tail of O *) - (fun cl -> match cl with - | (q::_,_) -> not (may_compat p q) - | _ -> assert false) - seen - then (* insert *) - List.rev_append seen ((p::ps,act)::cl::rem), no - else (* fail to insert or append *) - ors,(p::ps,act)::no - else if condb act_q ps qs then (* check condition (b) for append *) - attempt (cl::seen) rem - else - ors,(p::ps,act)::no - else (* p # q, go on with append/insert *) - attempt (cl::seen) rem - end else (* q is not an or-pat, go on with append/insert *) - attempt (cl::seen) rem - | _ -> (* [] in fact *) - (p::ps,act)::ors,no in (* success in appending *) + or_ok p ps not_e + && (* check append condition for head of O *) + List.for_all (* check insert condition for tail of O *) + (fun cl -> + match cl with + | q :: _, _ -> not (may_compat p q) + | _ -> assert false) + seen + then + (* insert *) + (List.rev_append seen ((p :: ps, act) :: cl :: rem), no) + else (* fail to insert or append *) + (ors, (p :: ps, act) :: no) + else if condb act_q ps qs then + (* check condition (b) for append *) + attempt (cl :: seen) rem + else (ors, (p :: ps, act) :: no) + else (* p # q, go on with append/insert *) + attempt (cl :: seen) rem + else + (* q is not an or-pat, go on with append/insert *) + attempt (cl :: seen) rem + | _ -> + (* [] in fact *) + ((p :: ps, act) :: ors, no) + in + (* success in appending *) attempt [] ors (* Reconstruct default information from half_compiled pm list *) -let rec rebuild_matrix pmh = match pmh with +let rec rebuild_matrix pmh = + match pmh with | Pm pm -> as_matrix pm.cases - | PmOr {or_matrix=m} -> m - | PmVar x -> add_omega_column (rebuild_matrix x.inside) + | PmOr {or_matrix = m} -> m + | PmVar x -> add_omega_column (rebuild_matrix x.inside) -let rec rebuild_default nexts def = match nexts with -| [] -> def -| (e, pmh)::rem -> - (add_omega_column (rebuild_matrix pmh), e):: - rebuild_default rem def +let rec rebuild_default nexts def = + match nexts with + | [] -> def + | (e, pmh) :: rem -> + (add_omega_column (rebuild_matrix pmh), e) :: rebuild_default rem def let rebuild_nexts arg nexts k = List.fold_right - (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) + (fun (e, pm) k -> (e, PmVar {inside = pm; var_arg = arg}) :: k) nexts k - (* Split a matching. Splitting is first directed by or-patterns, then by @@ -871,43 +823,32 @@ let rebuild_nexts arg nexts k = *) - let rec split_or argo cls args def = - let cls = simplify_cases args cls in let rec do_split before ors no = function - | [] -> - cons_next - (List.rev before) (List.rev ors) (List.rev no) - | ((p::ps,act) as cl)::rem -> - if up_ok cl no then - if is_or p then - let ors, no = insert_or_append p ps act ors no in - do_split before ors no rem - else begin - if up_ok cl ors then - do_split (cl::before) ors no rem - else if or_ok p ps ors then - do_split before (cl::ors) no rem - else - do_split before ors (cl::no) rem - end - else - do_split before ors (cl::no) rem + | [] -> cons_next (List.rev before) (List.rev ors) (List.rev no) + | ((p :: ps, act) as cl) :: rem -> + if up_ok cl no then + if is_or p then + let ors, no = insert_or_append p ps act ors no in + do_split before ors no rem + else if up_ok cl ors then do_split (cl :: before) ors no rem + else if or_ok p ps ors then do_split before (cl :: ors) no rem + else do_split before ors (cl :: no) rem + else do_split before ors (cl :: no) rem | _ -> assert false - and cons_next yes yesor = function - | [] -> - precompile_or argo yes yesor args def [] + | [] -> precompile_or argo yes yesor args def [] | rem -> - let {me=next ; matrix=matrix ; top_default=def},nexts = - do_split [] [] [] rem in - let idef = next_raise_count () in - precompile_or - argo yes yesor args - (cons_default matrix idef def) - ((idef,next)::nexts) in + let {me = next; matrix; top_default = def}, nexts = + do_split [] [] [] rem + in + let idef = next_raise_count () in + precompile_or argo yes yesor args + (cons_default matrix idef def) + ((idef, next) :: nexts) + in do_split [] [] [] cls @@ -915,277 +856,290 @@ let rec split_or argo cls args def = as potential rebind prevents any kind of optimisation *) and split_naive cls args def k = - let rec split_exc cstr0 yes = function | [] -> - let yes = List.rev yes in - { me = Pm {cases=yes; args=args; default=def;} ; - matrix = as_matrix yes ; - top_default=def}, - k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let cstr = pat_as_constr p in - if cstr = cstr0 then split_exc cstr0 (cl::yes) rem - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_exc cstr [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts + let yes = List.rev yes in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + k ) + | ((p :: _, _) as cl) :: rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl :: yes) rem else let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noexc [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts + let {me = next; matrix; top_default = def}, nexts = + split_exc cstr [cl] rem + in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + (idef, next) :: nexts ) + else + let yes = List.rev yes in + let {me = next; matrix; top_default = def}, nexts = + split_noexc [cl] rem + in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + (idef, next) :: nexts ) | _ -> assert false - and split_noexc yes = function | [] -> precompile_var args (List.rev yes) def k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let yes= List.rev yes in - let {me=next; matrix=matrix; top_default=def;},nexts = - split_exc (pat_as_constr p) [cl] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - else split_noexc (cl::yes) rem - | _ -> assert false in + | ((p :: _, _) as cl) :: rem -> + if group_constructor p then + let yes = List.rev yes in + let {me = next; matrix; top_default = def}, nexts = + split_exc (pat_as_constr p) [cl] rem + in + let idef = next_raise_count () in + precompile_var args yes + (cons_default matrix idef def) + ((idef, next) :: nexts) + else split_noexc (cl :: yes) rem + | _ -> assert false + in match cls with | [] -> assert false - | (p::_,_ as cl)::rem -> - if group_constructor p then - split_exc (pat_as_constr p) [cl] rem - else - split_noexc [cl] rem + | ((p :: _, _) as cl) :: rem -> + if group_constructor p then split_exc (pat_as_constr p) [cl] rem + else split_noexc [cl] rem | _ -> assert false and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> - split_naive cls args def k - | _ -> + | Tpat_construct (_, {cstr_tag = Cstr_extension _}, _) -> + split_naive cls args def k + | _ -> ( + let group = get_group ex_pat in + + let rec split_ex yes no = function + | [] -> ( + let yes = List.rev yes and no = List.rev no in + match no with + | [] -> + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + k ) + | cl :: rem -> ( + match yes with + | [] -> + (* Could not success in raising up a constr matching up *) + split_noex [cl] [] rem + | _ -> + let {me = next; matrix; top_default = def}, nexts = + split_noex [cl] [] rem + in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + (idef, next) :: nexts ))) + | ((p :: _, _) as cl) :: rem -> + if group p && up_ok cl no then split_ex (cl :: yes) no rem + else split_ex yes (cl :: no) rem + | _ -> assert false + and split_noex yes no = function + | [] -> ( + let yes = List.rev yes and no = List.rev no in + match no with + | [] -> precompile_var args yes def k + | cl :: rem -> + let {me = next; matrix; top_default = def}, nexts = + split_ex [cl] [] rem + in + let idef = next_raise_count () in + precompile_var args yes + (cons_default matrix idef def) + ((idef, next) :: nexts)) + | [((ps, _) as cl)] when List.for_all group_var ps && yes <> [] -> + (* This enables an extra division in some frequent cases : + last row is made of variables only *) + split_noex yes (cl :: no) [] + | ((p :: _, _) as cl) :: rem -> + if (not (group p)) && up_ok cl no then split_noex (cl :: yes) no rem + else split_noex yes (cl :: no) rem + | _ -> assert false + in - let group = get_group ex_pat in + match cls with + | ((p :: _, _) as cl) :: rem -> + if group p then split_ex [cl] [] rem else split_noex [cl] [] rem + | _ -> assert false) - let rec split_ex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def}, - k - | cl::rem -> - begin match yes with - | [] -> - (* Could not success in raising up a constr matching up *) - split_noex [cl] [] rem - | _ -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noex [cl] [] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def }, - (idef, next)::nexts - end - end - | (p::_,_) as cl::rem -> - if group p && up_ok cl no then - split_ex (cl::yes) no rem - else - split_ex yes (cl::no) rem - | _ -> assert false - - and split_noex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> precompile_var args yes def k - | cl::rem -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_ex [cl] [] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - end - | [ps,_ as cl] - when List.for_all group_var ps && yes <> [] -> - (* This enables an extra division in some frequent cases : - last row is made of variables only *) - split_noex yes (cl::no) [] - | (p::_,_) as cl::rem -> - if not (group p) && up_ok cl no then - split_noex (cl::yes) no rem - else - split_noex yes (cl::no) rem - | _ -> assert false in - - match cls with - | ((p::_,_) as cl)::rem -> - if group p then split_ex [cl] [] rem - else split_noex [cl] [] rem - | _ -> assert false - -and precompile_var args cls def k = match args with -| [] -> assert false -| _::((Lvar v as av,_) as arg)::rargs -> - begin match cls with - | [_] -> (* as splitted as it can *) +and precompile_var args cls def k = + match args with + | [] -> assert false + | _ :: (((Lvar v as av), _) as arg) :: rargs -> ( + match cls with + | [_] -> + (* as splitted as it can *) + dont_precompile_var args cls def k + | _ -> ( + (* Precompile *) + let var_cls = + List.map + (fun (ps, act) -> + match ps with + | _ :: ps -> (ps, act) + | _ -> assert false) + cls + and var_def = make_default (fun _ rem -> rem) def in + let {me = first; matrix}, nexts = + split_or (Some v) var_cls (arg :: rargs) var_def + in + + (* Compute top information *) + match nexts with + | [] -> + (* If you need *) dont_precompile_var args cls def k - | _ -> -(* Precompile *) - let var_cls = - List.map - (fun (ps,act) -> match ps with - | _::ps -> ps,act | _ -> assert false) - cls - and var_def = make_default (fun _ rem -> rem) def in - let {me=first ; matrix=matrix}, nexts = - split_or (Some v) var_cls (arg::rargs) var_def in - -(* Compute top information *) - match nexts with - | [] -> (* If you need *) - dont_precompile_var args cls def k - | _ -> - let rfirst = - {me = PmVar {inside=first ; var_arg = av} ; - matrix = add_omega_column matrix ; - top_default = rebuild_default nexts def ; } - and rnexts = rebuild_nexts av nexts k in - rfirst, rnexts - end -| _ -> - dont_precompile_var args cls def k + | _ -> + let rfirst = + { + me = PmVar {inside = first; var_arg = av}; + matrix = add_omega_column matrix; + top_default = rebuild_default nexts def; + } + and rnexts = rebuild_nexts av nexts k in + (rfirst, rnexts))) + | _ -> dont_precompile_var args cls def k and dont_precompile_var args cls def k = - {me = Pm {cases = cls ; args = args ; default = def } ; - matrix=as_matrix cls ; - top_default=def},k - -and precompile_or argo cls ors args def k = match ors with -| [] -> split_constr cls args def k -| _ -> + ( { + me = Pm {cases = cls; args; default = def}; + matrix = as_matrix cls; + top_default = def; + }, + k ) + +and precompile_or argo cls ors args def k = + match ors with + | [] -> split_constr cls args def k + | _ -> let rec do_cases = function - | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in - let orpm = - {cases = - (patl, action):: - List.map - (function - | (_::ps,action) -> ps,action - | _ -> assert false) - others ; - args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in - let vars = - IdentSet.elements - (IdentSet.inter - (extract_vars IdentSet.empty orp) - (pm_free_variables orpm)) in - let or_num = next_raise_count () in - let new_patl = Parmatch.omega_list patl in - - let mk_new_action vs = - Lstaticraise - (or_num, List.map (fun v -> Lvar v) vs) in - - let body,handlers = do_cases rem in - explode_or_pat - argo new_patl mk_new_action body vars [] orp, + | (({pat_desc = Tpat_or _} as orp) :: patl, action) :: rem -> + let others, rem = get_equiv orp rem in + let orpm = + { + cases = + (patl, action) + :: List.map + (function + | _ :: ps, action -> (ps, action) + | _ -> assert false) + others; + args = + (match args with + | _ :: r -> r + | _ -> assert false); + default = default_compat orp def; + } + in + let vars = + IdentSet.elements + (IdentSet.inter + (extract_vars IdentSet.empty orp) + (pm_free_variables orpm)) + in + let or_num = next_raise_count () in + let new_patl = Parmatch.omega_list patl in + + let mk_new_action vs = + Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) + in + + let body, handlers = do_cases rem in + ( explode_or_pat argo new_patl mk_new_action body vars [] orp, let mat = [[orp]] in - ((mat, or_num, vars , orpm):: handlers) - | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in + (mat, or_num, vars, orpm) :: handlers ) + | cl :: rem -> + let new_ord, new_to_catch = do_cases rem in + (cl :: new_ord, new_to_catch) + | [] -> ([], []) + in let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) - and body = {cases=cls@end_body ; args=args ; default=def} in - {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; - matrix=matrix ; - top_default=def}, - k + let matrix = as_matrix (cls @ ors) + and body = {cases = cls @ end_body; args; default = def} in + ( {me = PmOr {body; handlers; or_matrix = matrix}; matrix; top_default = def}, + k ) let split_precompile argo pm = - let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in - if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) - then begin - prerr_endline "** SPLIT **" ; - pretty_pm pm ; - pretty_precompiled_res next nexts - end ; - next, nexts - + let {me = next}, nexts = split_or argo pm.cases pm.args pm.default in + if + dbg + && (nexts <> [] + || + match next with + | PmOr _ -> true + | _ -> false) + then ( + prerr_endline "** SPLIT **"; + pretty_pm pm; + pretty_precompiled_res next nexts); + (next, nexts) (* General divide functions *) -let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm +let add_line patl_action pm = + pm.cases <- patl_action :: pm.cases; + pm -type cell = - {pm : pattern_matching ; - ctx : ctx list ; - pat : pattern} +type cell = {pm: pattern_matching; ctx: ctx list; pat: pattern} let add make_matching_fun division eq_key key patl_action args = try - let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in + let _, cell = List.find (fun (k, _) -> eq_key key k) division in cell.pm.cases <- patl_action :: cell.pm.cases; division with Not_found -> let cell = make_matching_fun args in - cell.pm.cases <- [patl_action] ; + cell.pm.cases <- [patl_action]; (key, cell) :: division - let divide make eq_key get_key get_args ctx pm = - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add - (make p pm.default ctx) - this_match eq_key (get_key p) (get_args p patl,action) pm.args - | _ -> [] in + | (p :: patl, action) :: rem -> + let this_match = divide_rec rem in + add (make p pm.default ctx) this_match eq_key (get_key p) + (get_args p patl, action) + pm.args + | _ -> [] + in divide_rec pm.cases - let divide_line make_ctx make get_args pat ctx pm = let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add_line (get_args p patl, action) this_match - | _ -> make pm.default pm.args in - - {pm = divide_rec pm.cases ; - ctx=make_ctx ctx ; - pat=pat} - + | (p :: patl, action) :: rem -> + let this_match = divide_rec rem in + add_line (get_args p patl, action) this_match + | _ -> make pm.default pm.args + in + {pm = divide_rec pm.cases; ctx = make_ctx ctx; pat} (* Then come various functions, There is one set of functions per matching style @@ -1203,66 +1157,55 @@ let divide_line make_ctx make get_args pat ctx pm = new ``pattern_matching'' records. *) - - -let rec matcher_const cst p rem = match p.pat_desc with -| Tpat_or (p1,p2,_) -> - begin try - matcher_const cst p1 rem with - | NoMatch -> matcher_const cst p2 rem - end -| Tpat_constant c1 when const_compare c1 cst = 0 -> rem -| Tpat_any -> rem -| _ -> raise NoMatch +let rec matcher_const cst p rem = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> ( + try matcher_const cst p1 rem with NoMatch -> matcher_const cst p2 rem) + | Tpat_constant c1 when const_compare c1 cst = 0 -> rem + | Tpat_any -> rem + | _ -> raise NoMatch let get_key_constant caller = function - | {pat_desc= Tpat_constant cst} -> cst + | {pat_desc = Tpat_constant cst} -> cst | p -> - prerr_endline ("BAD: "^caller) ; - pretty_pat p ; - assert false + prerr_endline ("BAD: " ^ caller); + pretty_pat p; + assert false let get_args_constant _ rem = rem let make_constant_matching p def ctx = function - [] -> fatal_error "Matching.make_constant_matching" - | (_ :: argl) -> - let def = - make_default - (matcher_const (get_key_constant "make" p)) def - and ctx = - filter_ctx p ctx in - {pm = {cases = []; args = argl ; default = def} ; - ctx = ctx ; - pat = normalize_pat p} - - - + | [] -> fatal_error "Matching.make_constant_matching" + | _ :: argl -> + let def = make_default (matcher_const (get_key_constant "make" p)) def + and ctx = filter_ctx p ctx in + {pm = {cases = []; args = argl; default = def}; ctx; pat = normalize_pat p} let divide_constant ctx m = - divide - make_constant_matching - (fun c d -> const_compare c d = 0) (get_key_constant "divide") - get_args_constant - ctx m + divide make_constant_matching + (fun c d -> const_compare c d = 0) + (get_key_constant "divide") + get_args_constant ctx m (* Matching against a constructor *) - let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = - if pos > last_pos - then argl - else (Lprim(Pfield (pos, fld_info), [arg], loc), binding_kind) :: make_args (pos + 1) - in make_args first_pos + if pos > last_pos then argl + else + (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) + :: make_args (pos + 1) + in + make_args first_pos let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag + | {pat_desc = Tpat_construct (_, cstr, _)} -> cstr.cstr_tag | _ -> assert false -let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem -| _ -> assert false +let get_args_constr p rem = + match p with + | {pat_desc = Tpat_construct (_, _, args)} -> args @ rem + | _ -> assert false (* NB: matcher_constr applies to default matrices. @@ -1271,158 +1214,161 @@ let get_args_constr p rem = match p with This comparison is performed by Types.may_equal_constr. *) -let matcher_constr cstr = match cstr.cstr_arity with -| 0 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - begin - try matcher_rec p1 rem - with NoMatch -> matcher_rec p2 rem - end - | Tpat_construct (_, cstr',[]) - when Types.may_equal_constr cstr cstr' -> rem - | Tpat_any -> rem - | _ -> raise NoMatch in +let matcher_constr cstr = + match cstr.cstr_arity with + | 0 -> + let rec matcher_rec q rem = + match q.pat_desc with + | Tpat_or (p1, p2, _) -> ( + try matcher_rec p1 rem with NoMatch -> matcher_rec p2 rem) + | Tpat_construct (_, cstr', []) when Types.may_equal_constr cstr cstr' -> + rem + | Tpat_any -> rem + | _ -> raise NoMatch + in matcher_rec -| 1 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> + | 1 -> + let rec matcher_rec q rem = + match q.pat_desc with + | Tpat_or (p1, p2, _) -> ( let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in - begin match r1,r2 with + match (r1, r2) with | None, None -> raise NoMatch | Some r1, None -> r1 | None, Some r2 -> r2 - | Some (a1::_), Some (a2::_) -> - {a1 with - pat_loc = Location.none ; - pat_desc = Tpat_or (a1, a2, None)}:: - rem - | _, _ -> assert false - end - | Tpat_construct (_, cstr', [arg]) - when Types.may_equal_constr cstr cstr' -> arg::rem - | Tpat_any -> omega::rem - | _ -> raise NoMatch in + | Some (a1 :: _), Some (a2 :: _) -> + {a1 with pat_loc = Location.none; pat_desc = Tpat_or (a1, a2, None)} + :: rem + | _, _ -> assert false) + | Tpat_construct (_, cstr', [arg]) when Types.may_equal_constr cstr cstr' + -> + arg :: rem + | Tpat_any -> omega :: rem + | _ -> raise NoMatch + in matcher_rec -| _ -> - fun q rem -> match q.pat_desc with - | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_,cstr',args) - when Types.may_equal_constr cstr cstr' -> args @ rem - | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem - | _ -> raise NoMatch + | _ -> ( + fun q rem -> + match q.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_construct (_, cstr', args) when Types.may_equal_constr cstr cstr' + -> + args @ rem + | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem + | _ -> raise NoMatch) let make_constr_matching p def ctx = function - [] -> fatal_error "Matching.make_constr_matching" - | ((arg, _mut) :: argl) -> - let cstr = pat_as_constr p in - let untagged = Ast_untagged_variants.has_untagged cstr.cstr_attributes in - let newargs = - if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then - (arg, Alias) :: argl - else match cstr.cstr_tag with - | Cstr_block _ when - Datarepr.constructor_has_optional_shape cstr - -> - begin - let from_option = - match p.pat_desc with - | Tpat_construct(_, _, - [ { - pat_type ; pat_env - } ]) - when Typeopt.type_cannot_contain_undefined pat_type pat_env - -> Pval_from_option_not_nest - | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl - end - | Cstr_constant _ - | Cstr_block _ -> - make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + | [] -> fatal_error "Matching.make_constr_matching" + | (arg, _mut) :: argl -> + let cstr = pat_as_constr p in + let untagged = Ast_untagged_variants.has_untagged cstr.cstr_attributes in + let newargs = + if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then + (arg, Alias) :: argl + else + match cstr.cstr_tag with + | Cstr_block _ when Datarepr.constructor_has_optional_shape cstr -> + let from_option = + match p.pat_desc with + | Tpat_construct (_, _, [{pat_type; pat_env}]) + when Typeopt.type_cannot_contain_undefined pat_type pat_env -> + Pval_from_option_not_nest + | _ -> Pval_from_option + in + (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl + | Cstr_constant _ | Cstr_block _ -> + make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) | Cstr_unboxed -> (arg, Alias) :: argl | Cstr_extension _ -> - make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl ~fld_info:Fld_extension - in - {pm= - {cases = []; args = newargs; - default = make_default (matcher_constr cstr) def} ; - ctx = filter_ctx p ctx ; - pat=normalize_pat p} - + in + { + pm = + { + cases = []; + args = newargs; + default = make_default (matcher_constr cstr) def; + }; + ctx = filter_ctx p ctx; + pat = normalize_pat p; + } let divide_constructor ctx pm = - divide - make_constr_matching - Types.equal_tag get_key_constr get_args_constr - ctx pm + divide make_constr_matching Types.equal_tag get_key_constr get_args_constr ctx + pm (* Matching against a variant *) -let rec matcher_variant_const lab p rem = match p.pat_desc with -| Tpat_or (p1, p2, _) -> - begin - try - matcher_variant_const lab p1 rem - with - | NoMatch -> matcher_variant_const lab p2 rem - end -| Tpat_variant (lab1,_,_) when lab1=lab -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - +let rec matcher_variant_const lab p rem = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> ( + try matcher_variant_const lab p1 rem + with NoMatch -> matcher_variant_const lab p2 rem) + | Tpat_variant (lab1, _, _) when lab1 = lab -> rem + | Tpat_any -> rem + | _ -> raise NoMatch let make_variant_matching_constant p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_constant" - | (_ :: argl) -> - let def = make_default (matcher_variant_const lab) def - and ctx = filter_ctx p ctx in - {pm={ cases = []; args = argl ; default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let matcher_variant_nonconst lab p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem -| Tpat_any -> omega::rem -| _ -> raise NoMatch + | [] -> fatal_error "Matching.make_variant_matching_constant" + | _ :: argl -> + let def = make_default (matcher_variant_const lab) def + and ctx = filter_ctx p ctx in + {pm = {cases = []; args = argl; default = def}; ctx; pat = normalize_pat p} +let matcher_variant_nonconst lab p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_variant (lab1, Some arg, _) when lab1 = lab -> arg :: rem + | Tpat_any -> omega :: rem + | _ -> raise NoMatch let make_variant_matching_nonconst p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, _mut) :: argl) -> - let def = make_default (matcher_variant_nonconst lab) def - and ctx = filter_ctx p ctx in - {pm= - {cases = []; args = (Lprim(Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) :: argl; - default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_variant row ctx {cases = cl; args = al; default=def} = + | [] -> fatal_error "Matching.make_variant_matching_nonconst" + | (arg, _mut) :: argl -> + let def = make_default (matcher_variant_nonconst lab) def + and ctx = filter_ctx p ctx in + { + pm = + { + cases = []; + args = + (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) + :: argl; + default = def; + }; + ctx; + pat = normalize_pat p; + } + +let divide_variant row ctx {cases = cl; args = al; default = def} = let row = Btype.row_repr row in let rec divide = function - ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> - let variants = divide rem in - if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent + | (({pat_desc = Tpat_variant (lab, pato, _)} as p) :: patl, action) :: rem + -> ( + let variants = divide rem in + if + try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent with Not_found -> true - then - variants - else begin - let tag = Btype.hash_variant lab in - let (=) ((a:string),(b:Types.constructor_tag)) (c,d) = - a = c && Types.equal_tag b d - in - match pato with - None -> - add (make_variant_matching_constant p lab def ctx) variants - (=) (lab,Cstr_constant tag) (patl, action) al - | Some pat -> - add (make_variant_matching_nonconst p lab def ctx) variants - (=) (lab,Cstr_block tag) (pat :: patl, action) al - end + then variants + else + let tag = Btype.hash_variant lab in + let ( = ) ((a : string), (b : Types.constructor_tag)) (c, d) = + a = c && Types.equal_tag b d + in + match pato with + | None -> + add + (make_variant_matching_constant p lab def ctx) + variants ( = ) (lab, Cstr_constant tag) (patl, action) al + | Some pat -> + add + (make_variant_matching_nonconst p lab def ctx) + variants ( = ) (lab, Cstr_block tag) + (pat :: patl, action) + al) | _ -> [] in divide cl @@ -1435,59 +1381,55 @@ let divide_variant row ctx {cases = cl; args = al; default=def} = let get_args_var _ rem = rem - let make_var_matching def = function - | [] -> fatal_error "Matching.make_var_matching" - | _::argl -> - {cases=[] ; - args = argl ; - default= make_default get_args_var def} + | [] -> fatal_error "Matching.make_var_matching" + | _ :: argl -> + {cases = []; args = argl; default = make_default get_args_var def} let divide_var ctx pm = divide_line ctx_lshift make_var_matching get_args_var omega ctx pm (* Matching and forcing a lazy value *) -let get_arg_lazy p rem = match p with -| {pat_desc = Tpat_any} -> omega :: rem -| {pat_desc = Tpat_lazy arg} -> arg :: rem -| _ -> assert false +let get_arg_lazy p rem = + match p with + | {pat_desc = Tpat_any} -> omega :: rem + | {pat_desc = Tpat_lazy arg} -> arg :: rem + | _ -> assert false -let matcher_lazy p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omega :: rem -| Tpat_lazy arg -> arg :: rem -| _ -> raise NoMatch +let matcher_lazy p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_any | Tpat_var _ -> omega :: rem + | Tpat_lazy arg -> arg :: rem + | _ -> raise NoMatch (* Inlining the tag tests before calling the primitive that works on lazy blocks. This is also used in translcore.ml. No other call than Obj.tag when the value has been forced before. *) - let get_mod_field modname field = - lazy ( - try - let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial_safe_string in - let p = try - match Env.lookup_value (Longident.Lident field) env with - | (Path.Pdot(_,_,i), _) -> i - | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.") - with Not_found -> - fatal_error ("Primitive "^modname^"."^field^" not found.") - in - Lprim(Pfield (p, Fld_module {name = field}), - [Lprim(Pgetglobal mod_ident, [], Location.none)], - Location.none) - with Not_found -> fatal_error ("Module "^modname^" unavailable.") - ) - - -let code_force = - get_mod_field Primitive_modules.lazy_ "force" -;; + lazy + (try + let mod_ident = Ident.create_persistent modname in + let env = Env.open_pers_signature modname Env.initial_safe_string in + let p = + try + match Env.lookup_value (Longident.Lident field) env with + | Path.Pdot (_, _, i), _ -> i + | _ -> + fatal_error ("Primitive " ^ modname ^ "." ^ field ^ " not found.") + with Not_found -> + fatal_error ("Primitive " ^ modname ^ "." ^ field ^ " not found.") + in + Lprim + ( Pfield (p, Fld_module {name = field}), + [Lprim (Pgetglobal mod_ident, [], Location.none)], + Location.none ) + with Not_found -> fatal_error ("Module " ^ modname ^ " unavailable.")) + +let code_force = get_mod_field Primitive_modules.lazy_ "force" (* inline_lazy_force inlines the beginning of the code of Lazy.force. When the value argument is tagged as: @@ -1499,156 +1441,163 @@ let code_force = Forward(val_out_of_heap). *) - let inline_lazy_force arg loc = - Lapply { ap_func = Lazy.force code_force; ap_inlined = Default_inline; ap_args = [arg]; ap_loc = loc} + Lapply + { + ap_func = Lazy.force code_force; + ap_inlined = Default_inline; + ap_args = [arg]; + ap_loc = loc; + } let make_lazy_matching def = function - [] -> fatal_error "Matching.make_lazy_matching" - | (arg,_mut) :: argl -> - { cases = []; - args = - (inline_lazy_force arg Location.none, Strict) :: argl; - default = make_default matcher_lazy def } + | [] -> fatal_error "Matching.make_lazy_matching" + | (arg, _mut) :: argl -> + { + cases = []; + args = (inline_lazy_force arg Location.none, Strict) :: argl; + default = make_default matcher_lazy def; + } let divide_lazy p ctx pm = - divide_line - (filter_ctx p) - make_lazy_matching - get_arg_lazy - p ctx pm + divide_line (filter_ctx p) make_lazy_matching get_arg_lazy p ctx pm (* Matching against a tuple pattern *) +let get_args_tuple arity p rem = + match p with + | {pat_desc = Tpat_any} -> omegas arity @ rem + | {pat_desc = Tpat_tuple args} -> args @ rem + | _ -> assert false -let get_args_tuple arity p rem = match p with -| {pat_desc = Tpat_any} -> omegas arity @ rem -| {pat_desc = Tpat_tuple args} -> - args @ rem -| _ -> assert false - -let matcher_tuple arity p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omegas arity @ rem -| Tpat_tuple args when List.length args = arity -> args @ rem -| _ -> raise NoMatch +let matcher_tuple arity p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_any | Tpat_var _ -> omegas arity @ rem + | Tpat_tuple args when List.length args = arity -> args @ rem + | _ -> raise NoMatch let make_tuple_matching loc arity def = function - [] -> fatal_error "Matching.make_tuple_matching" + | [] -> fatal_error "Matching.make_tuple_matching" | (arg, _mut) :: argl -> - let rec make_args pos = - if pos >= arity - then argl - else (Lprim(Pfield (pos, Fld_tuple), [arg], loc), Alias) :: make_args (pos + 1) in - {cases = []; args = make_args 0 ; - default=make_default (matcher_tuple arity) def} - + let rec make_args pos = + if pos >= arity then argl + else + (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) + :: make_args (pos + 1) + in + { + cases = []; + args = make_args 0; + default = make_default (matcher_tuple arity) def; + } let divide_tuple arity p ctx pm = - divide_line - (filter_ctx p) + divide_line (filter_ctx p) (make_tuple_matching p.pat_loc arity) - (get_args_tuple arity) p ctx pm + (get_args_tuple arity) p ctx pm (* Matching against a record pattern *) - let record_matching_line num_fields lbl_pat_list = let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv -let get_args_record num_fields p rem = match p with -| {pat_desc=Tpat_any} -> - record_matching_line num_fields [] @ rem -| {pat_desc=Tpat_record (lbl_pat_list,_)} -> +let get_args_record num_fields p rem = + match p with + | {pat_desc = Tpat_any} -> record_matching_line num_fields [] @ rem + | {pat_desc = Tpat_record (lbl_pat_list, _)} -> record_matching_line num_fields lbl_pat_list @ rem -| _ -> assert false - -let matcher_record num_fields p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> - record_matching_line num_fields [] @ rem -| Tpat_record ([], _) when num_fields = 0 -> rem -| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _) - when Array.length lbl.lbl_all = num_fields -> + | _ -> assert false + +let matcher_record num_fields p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_any | Tpat_var _ -> record_matching_line num_fields [] @ rem + | Tpat_record ([], _) when num_fields = 0 -> rem + | Tpat_record (((_, lbl, _) :: _ as lbl_pat_list), _) + when Array.length lbl.lbl_all = num_fields -> record_matching_line num_fields lbl_pat_list @ rem -| _ -> raise NoMatch + | _ -> raise NoMatch let make_record_matching loc all_labels def = function - [] -> fatal_error "Matching.make_record_matching" - | ((arg, _mut) :: argl) -> - let rec make_args pos = - if pos >= Array.length all_labels then argl else begin - let lbl = all_labels.(pos) in - let access = - match lbl.lbl_repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) - | Record_inlined _ -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) - | Record_unboxed _ -> arg - | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc) - in - let str = - match lbl.lbl_mut with - Immutable -> Alias - | Mutable -> StrictOpt in - (access, str) :: make_args(pos + 1) - end in - let nfields = Array.length all_labels in - let def= make_default (matcher_record nfields) def in - {cases = []; args = make_args 0 ; default = def} - + | [] -> fatal_error "Matching.make_record_matching" + | (arg, _mut) :: argl -> + let rec make_args pos = + if pos >= Array.length all_labels then argl + else + let lbl = all_labels.(pos) in + let access = + match lbl.lbl_repres with + | Record_float_unused -> assert false + | Record_regular | Record_optional_labels _ -> + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) + | Record_inlined _ -> + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) + | Record_unboxed _ -> arg + | Record_extension -> + Lprim + ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), + [arg], + loc ) + in + let str = + match lbl.lbl_mut with + | Immutable -> Alias + | Mutable -> StrictOpt + in + (access, str) :: make_args (pos + 1) + in + let nfields = Array.length all_labels in + let def = make_default (matcher_record nfields) def in + {cases = []; args = make_args 0; default = def} let divide_record all_labels p ctx pm = let get_args = get_args_record (Array.length all_labels) in - divide_line - (filter_ctx p) + divide_line (filter_ctx p) (make_record_matching p.pat_loc all_labels) - get_args - p ctx pm + get_args p ctx pm (* Matching against an array pattern *) let get_key_array = function - | {pat_desc=Tpat_array patl} -> List.length patl + | {pat_desc = Tpat_array patl} -> List.length patl | _ -> assert false -let get_args_array p rem = match p with -| {pat_desc=Tpat_array patl} -> patl@rem -| _ -> assert false +let get_args_array p rem = + match p with + | {pat_desc = Tpat_array patl} -> patl @ rem + | _ -> assert false -let matcher_array len p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_array args when List.length args=len -> args @ rem -| Tpat_any -> Parmatch.omegas len @ rem -| _ -> raise NoMatch +let matcher_array len p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_array args when List.length args = len -> args @ rem + | Tpat_any -> Parmatch.omegas len @ rem + | _ -> raise NoMatch -let make_array_matching p def ctx = function +let make_array_matching p def ctx = function | [] -> fatal_error "Matching.make_array_matching" - | ((arg, _mut) :: argl) -> - let len = get_key_array p in - let rec make_args pos = - if pos >= len - then argl - else (Lprim(Parrayrefu , - [arg; Lconst(Const_base(Const_int pos))], - p.pat_loc), - StrictOpt) :: make_args (pos + 1) in - let def = make_default (matcher_array len) def - and ctx = filter_ctx p ctx in - {pm={cases = []; args = make_args 0 ; default = def} ; - ctx=ctx ; - pat = normalize_pat p} + | (arg, _mut) :: argl -> + let len = get_key_array p in + let rec make_args pos = + if pos >= len then argl + else + ( Lprim + (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc), + StrictOpt ) + :: make_args (pos + 1) + in + let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in + { + pm = {cases = []; args = make_args 0; default = def}; + ctx; + pat = normalize_pat p; + } let divide_array ctx pm = - divide - make_array_matching - (=) get_key_array get_args_array ctx pm - + divide make_array_matching ( = ) get_key_array get_args_array ctx pm (* Specific string test sequence @@ -1666,62 +1615,60 @@ let divide_array ctx pm = let strings_test_threshold = 8 -let bind_sw arg k = match arg with -| Lvar _ -> k arg -| _ -> +let bind_sw arg k = + match arg with + | Lvar _ -> k arg + | _ -> let id = Ident.create "switch" in - Llet (Strict,Pgenval,id,arg,k (Lvar id)) - + Llet (Strict, Pgenval, id, arg, k (Lvar id)) (* Sequential equality tests *) let make_string_test_sequence loc arg sw d = - let d,sw = match d with - | None -> - begin match sw with - | (_,d)::sw -> d,sw - | [] -> assert false - end - | Some d -> d,sw in - bind_sw arg - (fun arg -> + let d, sw = + match d with + | None -> ( + match sw with + | (_, d) :: sw -> (d, sw) + | [] -> assert false) + | Some d -> (d, sw) + in + bind_sw arg (fun arg -> List.fold_right - (fun (s,lam) k -> + (fun (s, lam) k -> Lifthenelse - (Lprim - (Pstringcomp Cneq, - [arg; Lconst (Const_immstring s)], loc), - k,lam)) + ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc), + k, + lam )) sw d) -let rec split k xs = match xs with -| [] -> assert false -| x0::xs -> - if k <= 1 then [],x0,xs +let rec split k xs = + match xs with + | [] -> assert false + | x0 :: xs -> + if k <= 1 then ([], x0, xs) else - let xs,y0,ys = split (k-2) xs in - x0::xs,y0,ys + let xs, y0, ys = split (k - 2) xs in + (x0 :: xs, y0, ys) -let zero_lam = Lconst (Const_base (Const_int 0)) +let zero_lam = Lconst (Const_base (Const_int 0)) let tree_way_test loc arg lt eq gt = Lifthenelse - (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, - Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) + ( Lprim (Pintcomp Clt, [arg; zero_lam], loc), + lt, + Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc), gt, eq) ) (* Dichotomic tree *) - let rec do_make_string_test_tree loc arg sw delta d = let len = List.length sw in - if len <= strings_test_threshold+delta then + if len <= strings_test_threshold + delta then make_string_test_sequence loc arg sw d else - let lt,(s,act),gt = split len sw in + let lt, (s, act), gt = split len sw in bind_sw - (Lprim - (Pstringcomp Ceq, - [arg; Lconst (Const_immstring s)], loc)) + (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc)) (fun r -> tree_way_test loc r (do_make_string_test_tree loc arg lt delta d) @@ -1729,15 +1676,12 @@ let rec do_make_string_test_tree loc arg sw delta d = (do_make_string_test_tree loc arg gt delta d)) (* Entry point *) -let expand_stringswitch loc arg sw d = match d with -| None -> - bind_sw arg - (fun arg -> do_make_string_test_tree loc arg sw 0 None) -| Some e -> - bind_sw arg - (fun arg -> - make_catch e - (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) +let expand_stringswitch loc arg sw d = + match d with + | None -> bind_sw arg (fun arg -> do_make_string_test_tree loc arg sw 0 None) + | Some e -> + bind_sw arg (fun arg -> + make_catch e (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) (**********************) (* Generic test trees *) @@ -1748,99 +1692,104 @@ let expand_stringswitch loc arg sw d = match d with (* Add handler, if shared *) let handle_shared () = let hs = ref (fun x -> x) in - let handle_shared act = match act with - | Switch.Single act -> act - | Switch.Shared act -> - let i,h = make_catch_delayed act in + let handle_shared act = + match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i, h = make_catch_delayed act in let ohs = !hs in - hs := (fun act -> h (ohs act)) ; - make_exit i in - hs,handle_shared - + (hs := fun act -> h (ohs act)); + make_exit i + in + (hs, handle_shared) let share_actions_tree sw d = let store = StoreExp.mk_store () in -(* Default action is always shared *) + (* Default action is always shared *) let d = match d with | None -> None - | Some d -> Some (store.Switch.act_store_shared d) in -(* Store all other actions *) - let sw = - List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + | Some d -> Some (store.Switch.act_store_shared d) + in + (* Store all other actions *) + let sw = List.map (fun (cst, act) -> (cst, store.Switch.act_store act)) sw in -(* Retrieve all actions, including potential default *) + (* Retrieve all actions, including potential default *) let acts = store.Switch.act_get_shared () in -(* Array of actual actions *) - let hs,handle_shared = handle_shared () in + (* Array of actual actions *) + let hs, handle_shared = handle_shared () in let acts = Array.map handle_shared acts in -(* Reconstruct default and switch list *) - let d = match d with - | None -> None - | Some d -> Some (acts.(d)) in - let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in - !hs,sw,d + (* Reconstruct default and switch list *) + let d = + match d with + | None -> None + | Some d -> Some acts.(d) + in + let sw = List.map (fun (cst, j) -> (cst, acts.(j))) sw in + (!hs, sw, d) (* Note: dichotomic search requires sorted input with no duplicates *) -let rec uniq_lambda_list sw = match sw with - | []|[_] -> sw - | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> - if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) - else p1::uniq_lambda_list sw1 +let rec uniq_lambda_list sw = + match sw with + | [] | [_] -> sw + | ((c1, _) as p1) :: ((c2, _) :: sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1 :: sw2) + else p1 :: uniq_lambda_list sw1 let sort_lambda_list l = - let l = - List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in + let l = List.stable_sort (fun (x, _) (y, _) -> const_compare x y) l in uniq_lambda_list l let rec cut n l = - if n = 0 then [],l - else match l with - [] -> raise (Invalid_argument "cut") - | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 + if n = 0 then ([], l) + else + match l with + | [] -> raise (Invalid_argument "cut") + | a :: l -> + let l1, l2 = cut (n - 1) l in + (a :: l1, l2) let rec do_tests_fail loc fail tst arg = function | [] -> fail - | (c, act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_fail loc fail tst arg rem, - act) + | (c, act) :: rem -> + Lifthenelse + ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + do_tests_fail loc fail tst arg rem, + act ) let rec do_tests_nofail loc tst arg = function | [] -> fatal_error "Matching.do_tests_nofail" - | [_,act] -> act - | (c,act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_nofail loc tst arg rem, - act) + | [(_, act)] -> act + | (c, act) :: rem -> + Lifthenelse + ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + do_tests_nofail loc tst arg rem, + act ) let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let const_lambda_list = sort_lambda_list const_lambda_list in - let hs,const_lambda_list,fail = - share_actions_tree const_lambda_list fail in + let hs, const_lambda_list, fail = share_actions_tree const_lambda_list fail in let rec make_test_sequence const_lambda_list = if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list - else match fail with - | None -> do_tests_nofail loc tst arg const_lambda_list - | Some fail -> do_tests_fail loc fail tst arg const_lambda_list - + else + match fail with + | None -> do_tests_nofail loc tst arg const_lambda_list + | Some fail -> do_tests_fail loc fail tst arg const_lambda_list and split_sequence const_lambda_list = let list1, list2 = - cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse(Lprim(lt_tst, - [arg; Lconst(Const_base (fst(List.hd list2)))], - loc), - make_test_sequence list1, make_test_sequence list2) + cut (List.length const_lambda_list / 2) const_lambda_list + in + Lifthenelse + ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc), + make_test_sequence list1, + make_test_sequence list2 ) in hs (make_test_sequence const_lambda_list) - module SArg = struct type primitive = Lambda.primitive @@ -1853,615 +1802,615 @@ module SArg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p,args,Location.none) - let make_offset arg n = match n with - | 0 -> arg - | _ -> Lprim (Poffsetint n,[arg],Location.none) + let make_prim p args = Lprim (p, args, Location.none) + let make_offset arg n = + match n with + | 0 -> arg + | _ -> Lprim (Poffsetint n, [arg], Location.none) let bind arg body = - let newvar,newarg = match arg with - | Lvar v -> v,arg - | _ -> + let newvar, newarg = + match arg with + | Lvar v -> (v, arg) + | _ -> let newvar = Ident.create "switcher" in - newvar,Lvar newvar in + (newvar, Lvar newvar) + in bind Alias newvar arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) - let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) + let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) + let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch loc arg cases acts ~offset sw_names = let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (offset + i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None; - sw_names}, loc) - let make_catch = make_catch_delayed + for i = Array.length cases - 1 downto 0 do + l := (offset + i, acts.(cases.(i))) :: !l + done; + Lswitch + ( arg, + { + sw_numconsts = Array.length cases; + sw_consts = !l; + sw_numblocks = 0; + sw_blocks = []; + sw_failaction = None; + sw_names; + }, + loc ) + let make_catch = make_catch_delayed let make_exit = make_exit - end (* Action sharing for Lswitch argument *) let share_actions_sw sw = -(* Attempt sharing on all actions *) + (* Attempt sharing on all actions *) let store = StoreExp.mk_store () in - let fail = match sw.sw_failaction with - | None -> None - | Some fail -> + let fail = + match sw.sw_failaction with + | None -> None + | Some fail -> (* Fail is translated to exit, whatever happens *) - Some (store.Switch.act_store_shared fail) in + Some (store.Switch.act_store_shared fail) + in let consts = - List.map - (fun (i,e) -> i,store.Switch.act_store e) - sw.sw_consts + List.map (fun (i, e) -> (i, store.Switch.act_store e)) sw.sw_consts and blocks = - List.map - (fun (i,e) -> i,store.Switch.act_store e) - sw.sw_blocks in + List.map (fun (i, e) -> (i, store.Switch.act_store e)) sw.sw_blocks + in let acts = store.Switch.act_get_shared () in - let hs,handle_shared = handle_shared () in + let hs, handle_shared = handle_shared () in let acts = Array.map handle_shared acts in - let fail = match fail with - | None -> None - | Some fail -> Some (acts.(fail)) in - !hs, - { sw with - sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; - sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; - sw_failaction = fail; } + let fail = + match fail with + | None -> None + | Some fail -> Some acts.(fail) + in + ( !hs, + { + sw with + sw_consts = List.map (fun (i, j) -> (i, acts.(j))) consts; + sw_blocks = List.map (fun (i, j) -> (i, acts.(j))) blocks; + sw_failaction = fail; + } ) (* Reintroduce fail action in switch argument, for the sake of avoiding carrying over huge switches *) -let reintroduce_fail sw = match sw.sw_failaction with -| None -> +let reintroduce_fail sw = + match sw.sw_failaction with + | None -> let t = Hashtbl.create 17 in - let seen (_,l) = match as_simple_exit l with - | Some i -> + let seen (_, l) = + match as_simple_exit l with + | Some i -> let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | None -> () in - List.iter seen sw.sw_consts ; - List.iter seen sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in + Hashtbl.replace t i (old + 1) + | None -> () + in + List.iter seen sw.sw_consts; + List.iter seen sw.sw_blocks; + let i_max = ref (-1) and max = ref (-1) in Hashtbl.iter (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; + if c > !max then ( + i_max := i; + max := c)) + t; if !max >= 3 then let default = !i_max in let remove ls = - Ext_list.filter ls - (fun (_,lam) -> match as_simple_exit lam with - | Some j -> j <> default - | None -> true) in - {sw with - sw_consts = remove sw.sw_consts ; - sw_blocks = remove sw.sw_blocks ; - sw_failaction = Some (make_exit default)} + Ext_list.filter ls (fun (_, lam) -> + match as_simple_exit lam with + | Some j -> j <> default + | None -> true) + in + { + sw with + sw_consts = remove sw.sw_consts; + sw_blocks = remove sw.sw_blocks; + sw_failaction = Some (make_exit default); + } else sw -| Some _ -> sw + | Some _ -> sw - -module Switcher = Switch.Make(SArg) +module Switcher = Switch.Make (SArg) open Switch let rec last def = function | [] -> def - | [x,_] -> x - | _::rem -> last def rem - -let get_edges low high l = match l with -| [] -> low, high -| (x,_)::_ -> x, last high l + | [(x, _)] -> x + | _ :: rem -> last def rem +let get_edges low high l = + match l with + | [] -> (low, high) + | (x, _) :: _ -> (x, last high l) let as_interval_canfail fail low high l = let store = StoreExp.mk_store () in let do_store _tag act = - - let i = store.act_store act in -(* + let i = store.act_store act in + (* eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; *) - i in + i + in let rec nofail_rec cur_low cur_high cur_act = function | [] -> - if cur_high = high then - [cur_low,cur_high,cur_act] - else - [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] - | ((i,act_i)::rem) as all -> - let act_index = do_store "NO" act_i in - if cur_high+1= i then - if act_index=cur_act then - nofail_rec cur_low i cur_act rem - else if act_index=0 then - (cur_low,i-1, cur_act)::fail_rec i i rem - else - (cur_low, i-1, cur_act)::nofail_rec i i act_index rem - else if act_index = 0 then - (cur_low, cur_high, cur_act):: - fail_rec (cur_high+1) (cur_high+1) all - else - (cur_low, cur_high, cur_act):: - (cur_high+1,i-1,0):: - nofail_rec i i act_index rem - + if cur_high = high then [(cur_low, cur_high, cur_act)] + else [(cur_low, cur_high, cur_act); (cur_high + 1, high, 0)] + | (i, act_i) :: rem as all -> + let act_index = do_store "NO" act_i in + if cur_high + 1 = i then + if act_index = cur_act then nofail_rec cur_low i cur_act rem + else if act_index = 0 then (cur_low, i - 1, cur_act) :: fail_rec i i rem + else (cur_low, i - 1, cur_act) :: nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act) + :: fail_rec (cur_high + 1) (cur_high + 1) all + else + (cur_low, cur_high, cur_act) + :: (cur_high + 1, i - 1, 0) + :: nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] - | (i,act_i)::rem -> - let index = do_store "YES" act_i in - if index=0 then fail_rec cur_low i rem - else - (cur_low,i-1,0):: - nofail_rec i i index rem in + | (i, act_i) :: rem -> + let index = do_store "YES" act_i in + if index = 0 then fail_rec cur_low i rem + else (cur_low, i - 1, 0) :: nofail_rec i i index rem + in let init_rec = function - | [] -> [low,high,0] - | (i,act_i)::rem -> - let index = do_store "INIT" act_i in - if index=0 then - fail_rec low i rem - else - if low < i then - (low,i-1,0)::nofail_rec i i index rem - else - nofail_rec i i index rem in + | [] -> [(low, high, 0)] + | (i, act_i) :: rem -> + let index = do_store "INIT" act_i in + if index = 0 then fail_rec low i rem + else if low < i then (low, i - 1, 0) :: nofail_rec i i index rem + else nofail_rec i i index rem + in - assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0); + (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store + (Array.of_list r, store) let as_interval_nofail l = let store = StoreExp.mk_store () in let rec some_hole = function - | []|[_] -> false - | (i,_)::((j,_)::_ as rem) -> - j > i+1 || some_hole rem in + | [] | [_] -> false + | (i, _) :: ((j, _) :: _ as rem) -> j > i + 1 || some_hole rem + in let rec i_rec cur_low cur_high cur_act = function - | [] -> - [cur_low, cur_high, cur_act] - | (i,act)::rem -> - let act_index = store.act_store act in - if act_index = cur_act then - i_rec cur_low i cur_act rem - else - (cur_low, cur_high, cur_act):: - i_rec i i act_index rem in - let inters = match l with - | (i,act)::rem -> + | [] -> [(cur_low, cur_high, cur_act)] + | (i, act) :: rem -> + let act_index = store.act_store act in + if act_index = cur_act then i_rec cur_low i cur_act rem + else (cur_low, cur_high, cur_act) :: i_rec i i act_index rem + in + let inters = + match l with + | (i, act) :: rem -> let act_index = (* In case there is some hole and that a switch is emitted, action 0 will be used as the action of unreachable cases (cf. switch.ml, make_switch). Hence, this action will be shared *) - if some_hole rem then - store.act_store_shared act - else - store.act_store act in - assert (act_index = 0) ; + if some_hole rem then store.act_store_shared act + else store.act_store act + in + assert (act_index = 0); i_rec i i act_index rem - | _ -> assert false in - - Array.of_list inters, store + | _ -> assert false + in + (Array.of_list inters, store) let sort_int_lambda_list l = List.sort - (fun (i1,_) (i2,_) -> - if i1 < i2 then -1 - else if i2 < i1 then 1 - else 0) + (fun (i1, _) (i2, _) -> if i1 < i2 then -1 else if i2 < i1 then 1 else 0) l let as_interval fail low high l = let l = sort_int_lambda_list l in - get_edges low high l, - (match fail with - | None -> as_interval_nofail l - | Some act -> as_interval_canfail act low high l) + ( get_edges low high l, + match fail with + | None -> as_interval_nofail l + | Some act -> as_interval_canfail act low high l ) let call_switcher loc fail arg low high int_lambda_list sw_names = - let edges, (cases, actions) = - as_interval fail low high int_lambda_list in + let edges, (cases, actions) = as_interval fail low high int_lambda_list in Switcher.zyva loc edges arg cases actions sw_names - let rec list_as_pat = function | [] -> fatal_error "Matching.list_as_pat" | [pat] -> pat - | pat::rem -> - {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} - + | pat :: rem -> {pat with pat_desc = Tpat_or (pat, list_as_pat rem, None)} let complete_pats_constrs = function - | p::_ as pats -> - List.map - (pat_of_constr p) - (complete_constrs p (List.map get_key_constr pats)) + | p :: _ as pats -> + List.map (pat_of_constr p) + (complete_constrs p (List.map get_key_constr pats)) | _ -> assert false - (* Following two ``failaction'' function compute n, the trap handler to jump to in case of failure of elementary tests *) -let mk_failaction_neg partial ctx def = match partial with -| Partial -> - begin match def with - | (_,idef)::_ -> - Some (Lstaticraise (idef,[])),jumps_singleton idef ctx +let mk_failaction_neg partial ctx def = + match partial with + | Partial -> ( + match def with + | (_, idef) :: _ -> + (Some (Lstaticraise (idef, [])), jumps_singleton idef ctx) | [] -> - (* Act as Total, this means - If no appropriate default matrix exists, - then this switch cannot fail *) - None, jumps_empty - end -| Total -> - None, jumps_empty - - + (* Act as Total, this means + If no appropriate default matrix exists, + then this switch cannot fail *) + (None, jumps_empty)) + | Total -> (None, jumps_empty) (* In line with the article and simpler than before *) -let mk_failaction_pos partial seen ctx defs = - if dbg then begin - prerr_endline "**POS**" ; - pretty_def defs ; - () - end ; - let rec scan_def env to_test defs = match to_test,defs with - | ([],_)|(_,[]) -> +let mk_failaction_pos partial seen ctx defs = + if dbg then ( + prerr_endline "**POS**"; + pretty_def defs; + ()); + let rec scan_def env to_test defs = + match (to_test, defs) with + | [], _ | _, [] -> List.fold_left - (fun (klist,jumps) (pats,i)-> - let action = Lstaticraise (i,[]) in + (fun (klist, jumps) (pats, i) -> + let action = Lstaticraise (i, []) in let klist = List.fold_right - (fun pat r -> (get_key_constr pat,action)::r) + (fun pat r -> (get_key_constr pat, action) :: r) pats klist - and jumps = - jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in - klist,jumps) - ([],jumps_empty) env - | _,(pss,idef)::rem -> + and jumps = jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in + (klist, jumps)) + ([], jumps_empty) env + | _, (pss, idef) :: rem -> ( let now, later = - List.partition - (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in + List.partition (fun (_p, p_ctx) -> ctx_match p_ctx pss) to_test + in match now with | [] -> scan_def env to_test rem - | _ -> scan_def ((List.map fst now,idef)::env) later rem in + | _ -> scan_def ((List.map fst now, idef) :: env) later rem) + in let fail_pats = complete_pats_constrs seen in - if List.length fail_pats < 32 then begin - let fail,jmps = - scan_def - [] - (List.map - (fun pat -> pat, ctx_lub pat ctx) - fail_pats) - defs in - if dbg then begin + if List.length fail_pats < 32 then ( + let fail, jmps = + scan_def [] (List.map (fun pat -> (pat, ctx_lub pat ctx)) fail_pats) defs + in + if dbg then ( eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); - pretty_jumps jmps - end ; - None,fail,jmps - end else begin (* Too many non-matched constructors -> reduced information *) - if dbg then eprintf "POS->NEG!!!\n%!" ; - let fail,jumps = mk_failaction_neg partial ctx defs in + pretty_jumps jmps); + (None, fail, jmps)) + else ( + (* Too many non-matched constructors -> reduced information *) + if dbg then eprintf "POS->NEG!!!\n%!"; + let fail, jumps = mk_failaction_neg partial ctx defs in if dbg then eprintf "FAIL: %s\n" (match fail with | None -> "" - | Some lam -> string_of_lam lam) ; - fail,[],jumps - end + | Some lam -> string_of_lam lam); + (fail, [], jumps)) let combine_constant names loc arg cst partial ctx def (const_lambda_list, total, _pats) = - let fail, local_jumps = - mk_failaction_neg partial ctx def in + let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = match cst with | Const_int _ -> - let int_lambda_list = - List.map (function Const_int n, l -> n,l | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list names + let int_lambda_list = + List.map + (function + | Const_int n, l -> (n, l) + | _ -> assert false) + const_lambda_list + in + call_switcher loc fail arg min_int max_int int_lambda_list names | Const_char _ -> - let int_lambda_list = - List.map (function Const_char c, l -> (c, l) + let int_lambda_list = + List.map + (function + | Const_char c, l -> (c, l) | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg 0 max_int int_lambda_list names + const_lambda_list + in + call_switcher loc fail arg 0 max_int int_lambda_list names | Const_string _ -> -(* Note as the bytecode compiler may resort to dichotomic search, - the clauses of stringswitch are sorted with duplicates removed. - This partly applies to the native code compiler, which requires - no duplicates *) - let const_lambda_list = sort_lambda_list const_lambda_list in - let sw = - List.map - (fun (c,act) -> match c with - | Const_string (s,_) -> s,act + (* Note as the bytecode compiler may resort to dichotomic search, + the clauses of stringswitch are sorted with duplicates removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c, act) -> + match c with + | Const_string (s, _) -> (s, act) | _ -> assert false) - const_lambda_list in - let hs,sw,fail = share_actions_tree sw fail in - hs (Lstringswitch (arg,sw,fail,loc)) + const_lambda_list + in + let hs, sw, fail = share_actions_tree sw fail in + hs (Lstringswitch (arg, sw, fail, loc)) | Const_float _ -> - make_test_sequence loc - fail - (Pfloatcomp Cneq) (Pfloatcomp Clt) - arg const_lambda_list + make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg + const_lambda_list | Const_int32 _ -> assert false | Const_int64 _ -> assert false | Const_bigint _ -> - make_test_sequence loc - fail - (Pbigintcomp Cneq) (Pbigintcomp Clt) - arg const_lambda_list - in lambda1,jumps_union local_jumps total - - + make_test_sequence loc fail (Pbigintcomp Cneq) (Pbigintcomp Clt) arg + const_lambda_list + in + (lambda1, jumps_union local_jumps total) let split_cases tag_lambda_list = let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_constant n -> ((n, act) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, act) :: nonconsts) - | Cstr_unboxed -> (consts, (0, act) :: nonconsts) - | Cstr_extension _ -> assert false in + | [] -> ([], []) + | (cstr, act) :: rem -> ( + let consts, nonconsts = split_rec rem in + match cstr with + | Cstr_constant n -> ((n, act) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, act) :: nonconsts) + | Cstr_unboxed -> (consts, (0, act) :: nonconsts) + | Cstr_extension _ -> assert false) + in let const, nonconst = split_rec tag_lambda_list in - sort_int_lambda_list const, - sort_int_lambda_list nonconst - + (sort_int_lambda_list const, sort_int_lambda_list nonconst) + (* refine [split_cases] and [split_variant_cases] *) let split_variant_cases tag_lambda_list = let rec split_rec = function - [] -> ([], []) - | ((name,cstr), act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_constant n -> ((n, (name, act)) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, (name, act)) :: nonconsts) - | Cstr_unboxed -> assert false - | Cstr_extension _ -> assert false in + | [] -> ([], []) + | ((name, cstr), act) :: rem -> ( + let consts, nonconsts = split_rec rem in + match cstr with + | Cstr_constant n -> ((n, (name, act)) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, (name, act)) :: nonconsts) + | Cstr_unboxed -> assert false + | Cstr_extension _ -> assert false) + in let const, nonconst = split_rec tag_lambda_list in - sort_int_lambda_list const, - sort_int_lambda_list nonconst + (sort_int_lambda_list const, sort_int_lambda_list nonconst) let get_extension_cases tag_lambda_list = let rec split_rec = function - [] -> [] - | (cstr, act) :: rem -> - let nonconsts = split_rec rem in - match cstr with - | Cstr_extension(path) -> ((path, act) :: nonconsts) - | _ -> assert false in + | [] -> [] + | (cstr, act) :: rem -> ( + let nonconsts = split_rec rem in + match cstr with + | Cstr_extension path -> (path, act) :: nonconsts + | _ -> assert false) + in split_rec tag_lambda_list - let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = - if cstr.cstr_consts < 0 then begin + if cstr.cstr_consts < 0 then (* Special cases for extensions *) - let fail, local_jumps = - mk_failaction_neg partial ctx def in + let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let extension_cases = get_extension_cases tag_lambda_list in let default, extension_cases = match fail with - | None -> - begin match extension_cases with - | (_, act)::rem -> act, rem - | _ -> assert false - end - | Some fail -> fail, extension_cases in + | None -> ( + match extension_cases with + | (_, act) :: rem -> (act, rem) + | _ -> assert false) + | Some fail -> (fail, extension_cases) + in match extension_cases with - | [] -> default - | _ -> - let tag = Ident.create "tag" in - let tests = - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse(Lprim(Pextension_slot_eq, [Lvar tag; ext], loc), - act, rem)) - extension_cases - default - in - Llet(Alias, Pgenval,tag, arg, tests) + | [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path ex_pat.pat_env path in + Lifthenelse + (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) + extension_cases default + in + Llet (Alias, Pgenval, tag, arg, tests) in - lambda1, jumps_union local_jumps total1 - end else begin + (lambda1, jumps_union local_jumps total1) + else (* Regular concrete type *) let ncases = List.length tag_lambda_list - and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in let sig_complete = ncases = nconstrs in - let fail_opt,fails,local_jumps = - if sig_complete then None,[],jumps_empty - else - mk_failaction_pos partial pats ctx def in + let fail_opt, fails, local_jumps = + if sig_complete then (None, [], jumps_empty) + else mk_failaction_pos partial pats ctx def + in let tag_lambda_list = fails @ tag_lambda_list in - let (consts, nonconsts) = split_cases tag_lambda_list in + let consts, nonconsts = split_cases tag_lambda_list in let lambda1 = - match fail_opt,same_actions tag_lambda_list with - | None,Some act -> act (* Identical actions, no failure *) - | _ -> - match - (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) - with - | (1, 1, [0, act1], [0, act2]) - when cstr.cstr_name = "::" || cstr.cstr_name = "[]" || Datarepr.constructor_has_optional_shape cstr - -> - (* Typically, match on lists, will avoid isint primitive in that - case *) - let arg = - if Datarepr.constructor_has_optional_shape cstr then - Lprim(Pis_not_none, [arg], loc) - else arg - in - Lifthenelse(arg, act2, act1) - | (2,0, [(i1,act1); (_,act2)],[]) when cstr.cstr_name = "true" || cstr.cstr_name = "false" -> - if i1 = 0 then Lifthenelse(arg, act2, act1) - else Lifthenelse (arg, act1, act2) - | (n,0,_,[]) when false (* relies on tag being an int *) -> (* The type defines constant constructors only *) - call_switcher loc fail_opt arg 0 (n-1) consts sw_names - | (n, _, _, _) -> - let act0 = - (* = Some act when all non-const constructors match to act *) - match fail_opt,nonconsts with - | Some a,[] -> Some a - | Some _,_ -> - if List.length nonconsts = cstr.cstr_nonconsts then - same_actions nonconsts - else None - | None,_ -> same_actions nonconsts in - match act0 with - | Some act when false (* relies on tag being an int *) -> - Lifthenelse - (Lprim (Pisint, [arg], loc), - call_switcher loc - fail_opt arg - 0 (n-1) consts sw_names, - act) -(* Emit a switch, as bytecode implements this sophisticated instruction *) - | _ -> - let sw = - {sw_numconsts = cstr.cstr_consts; sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; - sw_failaction = fail_opt; - sw_names} in - let hs,sw = share_actions_sw sw in - let sw = reintroduce_fail sw in - hs (Lswitch (arg,sw,loc)) in - lambda1, jumps_union local_jumps total1 - end + match (fail_opt, same_actions tag_lambda_list) with + | None, Some act -> act (* Identical actions, no failure *) + | _ -> ( + match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with + | 1, 1, [(0, act1)], [(0, act2)] + when cstr.cstr_name = "::" || cstr.cstr_name = "[]" + || Datarepr.constructor_has_optional_shape cstr -> + (* Typically, match on lists, will avoid isint primitive in that + case *) + let arg = + if Datarepr.constructor_has_optional_shape cstr then + Lprim (Pis_not_none, [arg], loc) + else arg + in + Lifthenelse (arg, act2, act1) + | 2, 0, [(i1, act1); (_, act2)], [] + when cstr.cstr_name = "true" || cstr.cstr_name = "false" -> + if i1 = 0 then Lifthenelse (arg, act2, act1) + else Lifthenelse (arg, act1, act2) + | n, 0, _, [] when false (* relies on tag being an int *) -> + (* The type defines constant constructors only *) + call_switcher loc fail_opt arg 0 (n - 1) consts sw_names + | n, _, _, _ -> ( + let act0 = + (* = Some act when all non-const constructors match to act *) + match (fail_opt, nonconsts) with + | Some a, [] -> Some a + | Some _, _ -> + if List.length nonconsts = cstr.cstr_nonconsts then + same_actions nonconsts + else None + | None, _ -> same_actions nonconsts + in + match act0 with + | Some act when false (* relies on tag being an int *) -> + Lifthenelse + ( Lprim (Pisint, [arg], loc), + call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, + act ) + (* Emit a switch, as bytecode implements this sophisticated instruction *) + | _ -> + let sw = + { + sw_numconsts = cstr.cstr_consts; + sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; + sw_blocks = nonconsts; + sw_failaction = fail_opt; + sw_names; + } + in + let hs, sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg, sw, loc)))) + in + (lambda1, jumps_union local_jumps total1) let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = - as_interval fail min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) in + as_interval fail min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) + in Switcher.test_sequence arg cases actions let call_switcher_variant_constant loc fail arg int_lambda_list names = - call_switcher loc fail arg min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) names - + call_switcher loc fail arg min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) + names let call_switcher_variant_constr loc fail arg int_lambda_list names = let v = Ident.create "variant" in - Llet(Alias, Pgenval, v, Lprim(Pfield (0, Fld_poly_var_tag), [arg], loc), - call_switcher loc - fail (Lvar v) min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) names) - -let call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref= ref call_switcher_variant_constant + Llet + ( Alias, + Pgenval, + v, + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + call_switcher loc fail (Lvar v) min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) + names ) + +let call_switcher_variant_constant : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref = + ref call_switcher_variant_constant let call_switcher_variant_constr : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref - = ref call_switcher_variant_constr + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref = + ref call_switcher_variant_constr let make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) - ref - = ref make_test_sequence_variant_constant + (Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.lambda) + ref = + ref make_test_sequence_variant_constant let combine_variant names loc row arg partial ctx def - (tag_lambda_list, total1, _pats) = + (tag_lambda_list, total1, _pats) = let row = Btype.row_repr row in let num_constr = ref 0 in if row.row_closed then List.iter (fun (_, f) -> match Btype.row_field_repr f with - Rabsent | Reither(true, _::_, _, _) -> () + | Rabsent | Reither (true, _ :: _, _, _) -> () | _ -> incr num_constr) row.row_fields - else - num_constr := max_int; + else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) in - let sig_complete = List.length tag_lambda_list = !num_constr - and one_action = same_actions tag_lambda_list in (* reduandant work under bs context *) + Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) + in + let sig_complete = List.length tag_lambda_list = !num_constr + and one_action = same_actions tag_lambda_list in + (* reduandant work under bs context *) let fail, local_jumps = if - sig_complete || (match partial with Total -> true | _ -> false) - then - None, jumps_empty - else - mk_failaction_neg partial ctx def in - let (consts, nonconsts) = split_variant_cases tag_lambda_list in - let lambda1 = match fail, one_action with - | None, Some act -> act - | _,_ -> + sig_complete + || + match partial with + | Total -> true + | _ -> false + then (None, jumps_empty) + else mk_failaction_neg partial ctx def + in + let consts, nonconsts = split_variant_cases tag_lambda_list in + let lambda1 = + match (fail, one_action) with + | None, Some act -> act + | _, _ -> ( match (consts, nonconsts) with - | ([_, (_,act1)], [_, (_,act2)]) when fail=None -> - test_int_or_block arg act1 act2 - | (_, []) -> (* One can compare integers and pointers *) - !make_test_sequence_variant_constant fail arg consts - | ([], _) -> - let lam = !call_switcher_variant_constr loc - fail arg nonconsts names in - (* One must not dereference integers *) - begin match fail with - | None -> lam - | Some fail -> test_int_or_block arg fail lam - end - | (_, _) -> - let lam_const = - !call_switcher_variant_constant loc - fail arg consts names - and lam_nonconst = - !call_switcher_variant_constr loc - fail arg nonconsts names in - test_int_or_block arg lam_const lam_nonconst + | [(_, (_, act1))], [(_, (_, act2))] when fail = None -> + test_int_or_block arg act1 act2 + | _, [] -> + (* One can compare integers and pointers *) + !make_test_sequence_variant_constant fail arg consts + | [], _ -> ( + let lam = !call_switcher_variant_constr loc fail arg nonconsts names in + (* One must not dereference integers *) + match fail with + | None -> lam + | Some fail -> test_int_or_block arg fail lam) + | _, _ -> + let lam_const = + !call_switcher_variant_constant loc fail arg consts names + and lam_nonconst = + !call_switcher_variant_constr loc fail arg nonconsts names + in + test_int_or_block arg lam_const lam_nonconst) in - lambda1, jumps_union local_jumps total1 - + (lambda1, jumps_union local_jumps total1) -let combine_array names loc arg partial ctx def - (len_lambda_list, total1, _pats) = - let fail, local_jumps = mk_failaction_neg partial ctx def in +let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) + = + let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in let switch = - call_switcher loc - fail (Lvar newvar) - 0 max_int len_lambda_list names in - bind - Alias newvar (Lprim(Parraylength , [arg], loc)) switch in - lambda1, jumps_union local_jumps total1 + call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names + in + bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch + in + (lambda1, jumps_union local_jumps total1) (* Insertion of debugging events *) -let [@inline] event_branch _repr lam = lam - +let[@inline] event_branch _repr lam = lam (* This exception is raised when the compiler cannot produce code @@ -2480,172 +2429,157 @@ let [@inline] event_branch _repr lam = lam exception Unused let compile_list compile_fun division = - let rec c_rec totals = function - | [] -> [], jumps_unions totals, [] - | (key, cell) :: rem -> - begin match cell.ctx with + | [] -> ([], jumps_unions totals, []) + | (key, cell) :: rem -> ( + match cell.ctx with | [] -> c_rec totals rem - | _ -> - try - let (lambda1, total1) = compile_fun cell.ctx cell.pm in - let c_rem, total, new_pats = - c_rec - (jumps_map ctx_combine total1::totals) rem in - ((key,lambda1)::c_rem), total, (cell.pat::new_pats) - with - | Unused -> c_rec totals rem - end in + | _ -> ( + try + let lambda1, total1 = compile_fun cell.ctx cell.pm in + let c_rem, total, new_pats = + c_rec (jumps_map ctx_combine total1 :: totals) rem + in + ((key, lambda1) :: c_rem, total, cell.pat :: new_pats) + with Unused -> c_rec totals rem)) + in c_rec [] division - let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = let rec do_rec r total_r = function - | [] -> r,total_r - | (mat,i,vars,pm)::rem -> - begin try - let ctx = select_columns mat ctx in - let handler_i, total_i = - compile_fun ctx pm in - match raw_action r with - | Lstaticraise (j,args) -> - if i=j then - List.fold_right2 (bind Alias) vars args handler_i, - jumps_map (ctx_rshift_num (ncols mat)) total_i - else - do_rec r total_r rem - | _ -> - do_rec - (Lstaticcatch (r,(i,vars), handler_i)) - (jumps_union - (jumps_remove i total_r) - (jumps_map (ctx_rshift_num (ncols mat)) total_i)) - rem - with - | Unused -> - do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem - end in + | [] -> (r, total_r) + | (mat, i, vars, pm) :: rem -> ( + try + let ctx = select_columns mat ctx in + let handler_i, total_i = compile_fun ctx pm in + match raw_action r with + | Lstaticraise (j, args) -> + if i = j then + ( List.fold_right2 (bind Alias) vars args handler_i, + jumps_map (ctx_rshift_num (ncols mat)) total_i ) + else do_rec r total_r rem + | _ -> + do_rec + (Lstaticcatch (r, (i, vars), handler_i)) + (jumps_union (jumps_remove i total_r) + (jumps_map (ctx_rshift_num (ncols mat)) total_i)) + rem + with Unused -> + do_rec (Lstaticcatch (r, (i, vars), lambda_unit)) total_r rem) + in do_rec lambda1 total1 to_catch - let compile_test compile_fun partial divide combine ctx to_match = let division = divide ctx to_match in let c_div = compile_list compile_fun division in match c_div with - | [],_,_ -> - begin match mk_failaction_neg partial ctx to_match.default with - | None,_ -> raise Unused - | Some l,total -> l,total - end - | _ -> - combine ctx to_match.default c_div + | [], _, _ -> ( + match mk_failaction_neg partial ctx to_match.default with + | None, _ -> raise Unused + | Some l, total -> (l, total)) + | _ -> combine ctx to_match.default c_div (* Attempt to avoid some useless bindings by lowering them *) (* Approximation of v present in lam *) let rec approx_present v = function | Lconst _ -> false - | Lstaticraise (_,args) -> - List.exists (fun lam -> approx_present v lam) args - | Lprim (_,args,_) -> - List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> - approx_present v l1 || approx_present v l2 + | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args + | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true -let rec lower_bind v arg lam = match lam with -| Lifthenelse (cond, ifso, ifnot) -> +let rec lower_bind v arg lam = + match lam with + | Lifthenelse (cond, ifso, ifnot) -> ( let pcond = approx_present v cond and pso = approx_present v ifso and pnot = approx_present v ifnot in - begin match pcond, pso, pnot with + match (pcond, pso, pnot) with | false, false, false -> lam - | false, true, false -> - Lifthenelse (cond, lower_bind v arg ifso, ifnot) - | false, false, true -> - Lifthenelse (cond, ifso, lower_bind v arg ifnot) - | _,_,_ -> bind Alias v arg lam - end -| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc) + | false, true, false -> Lifthenelse (cond, lower_bind v arg ifso, ifnot) + | false, false, true -> Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | _, _, _ -> bind Alias v arg lam) + | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw), loc) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc) -| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc) + Lswitch (ls, {sw with sw_consts = [(i, lower_bind v arg act)]}, loc) + | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw), loc) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc) -| Llet (Alias, k, vv, lv, l) -> - if approx_present v lv then - bind Alias v arg lam - else - Llet (Alias, k, vv, lv, lower_bind v arg l) -| Lvar u when Ident.same u v && Ident.name u = "*sth*" -> + Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}, loc) + | Llet (Alias, k, vv, lv, l) -> + if approx_present v lv then bind Alias v arg lam + else Llet (Alias, k, vv, lv, lower_bind v arg l) + | Lvar u when Ident.same u v && Ident.name u = "*sth*" -> arg (* eliminate let *sth* = from_option x in *sth* *) -| _ -> - bind Alias v arg lam - -let bind_check str v arg lam = match str,arg with -| _, Lvar _ ->bind str v arg lam -| Alias,_ -> lower_bind v arg lam -| _,_ -> bind str v arg lam - -let comp_exit ctx m = match m.default with -| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx -| _ -> fatal_error "Matching.comp_exit" + | _ -> bind Alias v arg lam +let bind_check str v arg lam = + match (str, arg) with + | _, Lvar _ -> bind str v arg lam + | Alias, _ -> lower_bind v arg lam + | _, _ -> bind str v arg lam +let comp_exit ctx m = + match m.default with + | (_, i) :: _ -> (Lstaticraise (i, []), jumps_singleton i ctx) + | _ -> fatal_error "Matching.comp_exit" let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with | [] -> comp_fun partial ctx arg first_match - | rem -> - let rec c_rec body total_body = function - | [] -> body, total_body - (* Hum, -1 means never taken - | (-1,pm)::rem -> c_rec body total_body rem *) - | (i,pm)::rem -> - let ctx_i,total_rem = jumps_extract i total_body in - begin match ctx_i with - | [] -> c_rec body total_body rem - | _ -> - try - let li,total_i = - comp_fun - (match rem with [] -> partial | _ -> Partial) - ctx_i arg pm in - c_rec - (Lstaticcatch (body,(i,[]),li)) - (jumps_union total_i total_rem) - rem - with - | Unused -> - c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) - total_rem rem - end in - try - let first_lam,total = comp_fun Partial ctx arg first_match in + | rem -> ( + let rec c_rec body total_body = function + | [] -> (body, total_body) + (* Hum, -1 means never taken + | (-1,pm)::rem -> c_rec body total_body rem *) + | (i, pm) :: rem -> ( + let ctx_i, total_rem = jumps_extract i total_body in + match ctx_i with + | [] -> c_rec body total_body rem + | _ -> ( + try + let li, total_i = + comp_fun + (match rem with + | [] -> partial + | _ -> Partial) + ctx_i arg pm + in + c_rec + (Lstaticcatch (body, (i, []), li)) + (jumps_union total_i total_rem) + rem + with Unused -> + c_rec (Lstaticcatch (body, (i, []), lambda_unit)) total_rem rem)) + in + try + let first_lam, total = comp_fun Partial ctx arg first_match in c_rec first_lam total rem - with Unused -> match next_matchs with - | [] -> raise Unused - | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs + with Unused -> ( + match next_matchs with + | [] -> raise Unused + | (_, x) :: xs -> comp_match_handlers comp_fun partial ctx arg x xs)) (* To find reasonable names for variables *) let rec name_pattern default = function - (pat :: _, _) :: rem -> - begin match Typecore.id_of_pattern pat with - | Some id -> id - | None -> name_pattern default rem - end + | (pat :: _, _) :: rem -> ( + match Typecore.id_of_pattern pat with + | Some id -> id + | None -> name_pattern default rem) | _ -> Ident.create default -let arg_to_var arg cls = match arg with -| Lvar v -> v,arg -| _ -> +let arg_to_var arg cls = + match arg with + | Lvar v -> (v, arg) + | _ -> let v = name_pattern "match" cls in - v,Lvar v + (v, Lvar v) (* To be set by Lam_compile *) -let names_from_construct_pattern : (pattern -> Ast_untagged_variants.switch_names option) ref = +let names_from_construct_pattern : + (pattern -> Ast_untagged_variants.switch_names option) ref = ref (fun _ -> None) (* @@ -2659,103 +2593,104 @@ let names_from_construct_pattern : (pattern -> Ast_untagged_variants.switch_name Output: a lambda term, a jump summary {..., exit number -> context, .. } *) -let rec compile_match repr partial ctx m = match m with -| { cases = []; args = [] } -> comp_exit ctx m -| { cases = ([], action) :: rem } -> - if is_guarded action then begin - let (lambda, total) = - compile_match None partial ctx { m with cases = rem } in - event_branch repr (patch_guarded lambda action), total - end else - (event_branch repr action, jumps_empty) -| { args = (arg, str)::argl } -> - let v,newarg = arg_to_var arg m.cases in - let first_match,rem = - split_precompile (Some v) - { m with args = (newarg, Alias) :: argl } in - let (lam, total) = +let rec compile_match repr partial ctx m = + match m with + | {cases = []; args = []} -> comp_exit ctx m + | {cases = ([], action) :: rem} -> + if is_guarded action then + let lambda, total = compile_match None partial ctx {m with cases = rem} in + (event_branch repr (patch_guarded lambda action), total) + else (event_branch repr action, jumps_empty) + | {args = (arg, str) :: argl} -> + let v, newarg = arg_to_var arg m.cases in + let first_match, rem = + split_precompile (Some v) {m with args = (newarg, Alias) :: argl} + in + let lam, total = comp_match_handlers ((if dbg then do_compile_matching_pr else do_compile_matching) repr) - partial ctx newarg first_match rem in - bind_check str v arg lam, total -| _ -> assert false - + partial ctx newarg first_match rem + in + (bind_check str v arg lam, total) + | _ -> assert false (* verbose version of do_compile_matching, for debug *) and do_compile_matching_pr repr partial ctx arg x = - prerr_string "COMPILE: " ; - prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ; - prerr_endline "MATCH" ; - pretty_precompiled x ; - prerr_endline "CTX" ; - pretty_ctx ctx ; - let (_, jumps) as r = do_compile_matching repr partial ctx arg x in - prerr_endline "JUMPS" ; - pretty_jumps jumps ; + prerr_string "COMPILE: "; + prerr_endline + (match partial with + | Partial -> "Partial" + | Total -> "Total"); + prerr_endline "MATCH"; + pretty_precompiled x; + prerr_endline "CTX"; + pretty_ctx ctx; + let ((_, jumps) as r) = do_compile_matching repr partial ctx arg x in + prerr_endline "JUMPS"; + pretty_jumps jumps; r -and do_compile_matching repr partial ctx arg pmh = match pmh with -| Pm pm -> - let pat = what_is_cases pm.cases in - begin match pat.pat_desc with - | Tpat_any -> +and do_compile_matching repr partial ctx arg pmh = + match pmh with + | Pm pm -> ( + let pat = what_is_cases pm.cases in + match pat.pat_desc with + | Tpat_any -> compile_no_test divide_var ctx_rshift repr partial ctx pm + | Tpat_tuple patl -> compile_no_test - divide_var ctx_rshift repr partial ctx pm - | Tpat_tuple patl -> - compile_no_test - (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine - repr partial ctx pm - | Tpat_record ((_, lbl,_)::_,_) -> + (divide_tuple (List.length patl) (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_record ((_, lbl, _) :: _, _) -> compile_no_test (divide_record lbl.lbl_all (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_constant cst -> - let names = None in + | Tpat_constant cst -> + let names = None in compile_test - (compile_match repr partial) partial - divide_constant + (compile_match repr partial) + partial divide_constant (combine_constant names pat.pat_loc arg cst partial) ctx pm - | Tpat_construct (_, cstr, _) -> - let sw_names = !names_from_construct_pattern pat in + | Tpat_construct (_, cstr, _) -> + let sw_names = !names_from_construct_pattern pat in compile_test - (compile_match repr partial) partial - divide_constructor + (compile_match repr partial) + partial divide_constructor (combine_constructor sw_names pat.pat_loc arg pat cstr partial) ctx pm - | Tpat_array _ -> - let names = None in - compile_test (compile_match repr partial) partial - divide_array (combine_array names pat.pat_loc arg partial) + | Tpat_array _ -> + let names = None in + compile_test + (compile_match repr partial) + partial divide_array + (combine_array names pat.pat_loc arg partial) ctx pm - | Tpat_lazy _ -> + | Tpat_lazy _ -> compile_no_test (divide_lazy (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_variant(_, _, row) -> - let names = None in - compile_test (compile_match repr partial) partial - (divide_variant !row) + | Tpat_variant (_, _, row) -> + let names = None in + compile_test + (compile_match repr partial) + partial (divide_variant !row) (combine_variant names pat.pat_loc !row arg partial) ctx pm - | _ -> assert false - end -| PmVar {inside=pmh ; var_arg=arg} -> + | _ -> assert false) + | PmVar {inside = pmh; var_arg = arg} -> let lam, total = - do_compile_matching repr partial (ctx_lshift ctx) arg pmh in - lam, jumps_map ctx_rshift total -| PmOr {body=body ; handlers=handlers} -> + do_compile_matching repr partial (ctx_lshift ctx) arg pmh + in + (lam, jumps_map ctx_rshift total) + | PmOr {body; handlers} -> let lam, total = compile_match repr partial ctx body in compile_orhandlers (compile_match repr partial) lam total ctx handlers and compile_no_test divide up_ctx repr partial ctx to_match = - let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in - let lambda,total = compile_match repr partial this_ctx this_match in - lambda, jumps_map up_ctx total - - - + let {pm = this_match; ctx = this_ctx} = divide ctx to_match in + let lambda, total = compile_match repr partial this_ctx this_match in + (lambda, jumps_map up_ctx total) (* The entry points *) @@ -2779,45 +2714,42 @@ LM: let find_in_pat pred = let rec find_rec p = - pred p.pat_desc || - begin match p.pat_desc with - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> - find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> - List.exists find_rec ps - | Tpat_record (lpats,_) -> - List.exists - (fun (_, _, p) -> find_rec p) - lpats - | Tpat_or (p,q,_) -> - find_rec p || find_rec q - | Tpat_constant _ | Tpat_var _ - | Tpat_any | Tpat_variant (_,None,_) -> false - end in + pred p.pat_desc + || + match p.pat_desc with + | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) | Tpat_lazy p -> + find_rec p + | Tpat_tuple ps | Tpat_construct (_, _, ps) | Tpat_array ps -> + List.exists find_rec ps + | Tpat_record (lpats, _) -> List.exists (fun (_, _, p) -> find_rec p) lpats + | Tpat_or (p, q, _) -> find_rec p || find_rec q + | Tpat_constant _ | Tpat_var _ | Tpat_any | Tpat_variant (_, None, _) -> + false + in find_rec let is_lazy_pat = function | Tpat_lazy _ -> true - | Tpat_alias _ | Tpat_variant _ | Tpat_record _ - | Tpat_tuple _|Tpat_construct _ | Tpat_array _ - | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any - -> false + | Tpat_alias _ | Tpat_variant _ | Tpat_record _ | Tpat_tuple _ + | Tpat_construct _ | Tpat_array _ | Tpat_or _ | Tpat_constant _ | Tpat_var _ + | Tpat_any -> + false let is_lazy p = find_in_pat is_lazy_pat p -let have_mutable_field p = match p with -| Tpat_record (lps,_) -> +let have_mutable_field p = + match p with + | Tpat_record (lps, _) -> List.exists - (fun (_,lbl,_) -> + (fun (_, lbl, _) -> match lbl.Types.lbl_mut with | Mutable -> true | Immutable -> false) lps -| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ -| Tpat_tuple _|Tpat_construct _ | Tpat_array _ -| Tpat_or _ -| Tpat_constant _ | Tpat_var _ | Tpat_any - -> false + | Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ | Tpat_tuple _ + | Tpat_construct _ | Tpat_array _ | Tpat_or _ | Tpat_constant _ | Tpat_var _ + | Tpat_any -> + false let is_mutable p = find_in_pat have_mutable_field p @@ -2829,14 +2761,14 @@ let is_mutable p = find_in_pat have_mutable_field p let check_partial is_mutable is_lazy pat_act_list = function | Partial -> Partial | Total -> - if - pat_act_list = [] || (* allow empty case list *) - List.exists - (fun (pats, lam) -> - is_mutable pats && (is_guarded lam || is_lazy pats)) - pat_act_list - then Partial - else Total + if + pat_act_list = [] + || (* allow empty case list *) + List.exists + (fun (pats, lam) -> is_mutable pats && (is_guarded lam || is_lazy pats)) + pat_act_list + then Partial + else Total let check_partial_list = check_partial (List.exists is_mutable) (List.exists is_lazy) @@ -2844,52 +2776,63 @@ let check_partial = check_partial is_mutable is_lazy (* have toplevel handler when appropriate *) -let start_ctx n = [{left=[] ; right = omegas n}] +let start_ctx n = [{left = []; right = omegas n}] let check_total total lambda i handler_fun = - if jumps_is_empty total then - lambda - else begin - Lstaticcatch(lambda, (i,[]), handler_fun()) - end + if jumps_is_empty total then lambda + else Lstaticcatch (lambda, (i, []), handler_fun ()) let compile_matching repr handler_fun arg pat_act_list partial = let partial = check_partial pat_act_list partial in match partial with - | Partial -> - let raise_num = next_raise_count () in - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = [[[omega]],raise_num]} in - begin try - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - check_total total lambda raise_num handler_fun - with - | Unused -> assert false (* ; handler_fun() *) - end + | Partial -> ( + let raise_num = next_raise_count () in + let pm = + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(arg, Strict)]; + default = [([[omega]], raise_num)]; + } + in + try + let lambda, total = compile_match repr partial (start_ctx 1) pm in + check_total total lambda raise_num handler_fun + with Unused -> assert false (* ; handler_fun() *)) | Total -> - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = []} in - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - assert (jumps_is_empty total) ; - lambda - + let pm = + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(arg, Strict)]; + default = []; + } + in + let lambda, total = compile_match repr partial (start_ctx 1) pm in + assert (jumps_is_empty total); + lambda let partial_function loc () = (* [Location.get_pos_info] is too expensive *) - let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - let fname = - Filename.basename fname - in - Lprim(Praise Raise_regular, [Lprim(Pmakeblock(Blk_extension), - [transl_normal_path Predef.path_match_failure; - Lconst(Const_block(Blk_tuple, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)]))], loc)], loc) + let fname, line, char = Location.get_pos_info loc.Location.loc_start in + let fname = Filename.basename fname in + Lprim + ( Praise Raise_regular, + [ + Lprim + ( Pmakeblock Blk_extension, + [ + transl_normal_path Predef.path_match_failure; + Lconst + (Const_block + ( Blk_tuple, + [ + Const_base (Const_string (fname, None)); + Const_base (Const_int line); + Const_base (Const_int char); + ] )); + ], + loc ); + ], + loc ) let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2897,12 +2840,11 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) + (fun () -> Lprim (Praise Raise_reraise, [param], Location.none)) param pat_act_list Partial let simple_for_let loc param pat body = - compile_matching None (partial_function loc) param [pat, body] Partial - + compile_matching None (partial_function loc) param [(pat, body)] Partial (* Optimize binding of immediate tuples @@ -2955,14 +2897,13 @@ let simple_for_let loc param pat body = let for_let loc param pat body = match pat.pat_desc with | Tpat_any -> - (* This eliminates a useless variable (and stack slot in bytecode) - for "let _ = ...". See #6865. *) - Lsequence(param, body) + (* This eliminates a useless variable (and stack slot in bytecode) + for "let _ = ...". See #6865. *) + Lsequence (param, body) | Tpat_var (id, _) -> - (* fast path, and keep track of simple bindings to unboxable numbers *) - Llet(Strict, Pgenval, id, param, body) - | _ -> - simple_for_let loc param pat body + (* fast path, and keep track of simple bindings to unboxable numbers *) + Llet (Strict, Pgenval, id, param, body) + | _ -> simple_for_let loc param pat body (* Handling of tupled functions and matchings *) @@ -2972,149 +2913,160 @@ let for_tupled_function loc paraml pats_act_list partial = let raise_num = next_raise_count () in let omegas = [List.map (fun _ -> omega) paraml] in let pm = - { cases = pats_act_list; - args = List.map (fun id -> (Lvar id, Strict)) paraml ; - default = [omegas,raise_num] - } in + { + cases = pats_act_list; + args = List.map (fun id -> (Lvar id, Strict)) paraml; + default = [(omegas, raise_num)]; + } + in try - let (lambda, total) = compile_match None partial - (start_ctx (List.length paraml)) pm in + let lambda, total = + compile_match None partial (start_ctx (List.length paraml)) pm + in check_total total lambda raise_num (partial_function loc) - with - | Unused -> partial_function loc () - - + with Unused -> partial_function loc () -let flatten_pattern size p = match p.pat_desc with -| Tpat_tuple args -> args -| Tpat_any -> omegas size -| _ -> raise Cannot_flatten +let flatten_pattern size p = + match p.pat_desc with + | Tpat_tuple args -> args + | Tpat_any -> omegas size + | _ -> raise Cannot_flatten -let rec flatten_pat_line size p k = match p.pat_desc with -| Tpat_any -> omegas size::k -| Tpat_tuple args -> args::k -| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) -| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a - useless binding, solves PR#3780 *) +let rec flatten_pat_line size p k = + match p.pat_desc with + | Tpat_any -> omegas size :: k + | Tpat_tuple args -> args :: k + | Tpat_or (p1, p2, _) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) + | Tpat_alias (p, _, _) -> + (* Note: if this 'as' pat is here, then this is a + useless binding, solves PR#3780 *) flatten_pat_line size p k -| _ -> fatal_error "Matching.flatten_pat_line" + | _ -> fatal_error "Matching.flatten_pat_line" let flatten_cases size cases = List.map - (fun (ps,action) -> match ps with - | [p] -> flatten_pattern size p,action - | _ -> fatal_error "Matching.flatten_case") + (fun (ps, action) -> + match ps with + | [p] -> (flatten_pattern size p, action) + | _ -> fatal_error "Matching.flatten_case") cases let flatten_matrix size pss = List.fold_right - (fun ps r -> match ps with - | [p] -> flatten_pat_line size p r - | _ -> fatal_error "Matching.flatten_matrix") + (fun ps r -> + match ps with + | [p] -> flatten_pat_line size p r + | _ -> fatal_error "Matching.flatten_matrix") pss [] let flatten_def size def = - List.map - (fun (pss,i) -> flatten_matrix size pss,i) - def + List.map (fun (pss, i) -> (flatten_matrix size pss, i)) def let flatten_pm size args pm = - {args = args ; cases = flatten_cases size pm.cases ; - default = flatten_def size pm.default} - - -let flatten_precompiled size args pmh = match pmh with -| Pm pm -> Pm (flatten_pm size args pm) -| PmOr {body=b ; handlers=hs ; or_matrix=m} -> + { + args; + cases = flatten_cases size pm.cases; + default = flatten_def size pm.default; + } + +let flatten_precompiled size args pmh = + match pmh with + | Pm pm -> Pm (flatten_pm size args pm) + | PmOr {body = b; handlers = hs; or_matrix = m} -> PmOr - {body=flatten_pm size args b ; - handlers= - List.map - (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) - hs ; - or_matrix=flatten_matrix size m ;} -| PmVar _ -> assert false + { + body = flatten_pm size args b; + handlers = + List.map + (fun (mat, i, vars, pm) -> (flatten_matrix size mat, i, vars, pm)) + hs; + or_matrix = flatten_matrix size m; + } + | PmVar _ -> assert false (* compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. Hence it needs a fourth argument, which it ignores *) -let compile_flattened repr partial ctx _ pmh = match pmh with -| Pm pm -> compile_match repr partial ctx pm -| PmOr {body=b ; handlers=hs} -> +let compile_flattened repr partial ctx _ pmh = + match pmh with + | Pm pm -> compile_match repr partial ctx pm + | PmOr {body = b; handlers = hs} -> let lam, total = compile_match repr partial ctx b in compile_orhandlers (compile_match repr partial) lam total ctx hs -| PmVar _ -> assert false + | PmVar _ -> assert false let do_for_multiple_match loc paraml pat_act_list partial = let repr = None in let partial = check_partial pat_act_list partial in - let raise_num,pm1 = + let raise_num, pm1 = match partial with | Partial -> - let raise_num = next_raise_count () in - raise_num, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock( Blk_tuple), paraml, loc), Strict]; - default = [[[omega]],raise_num] } + let raise_num = next_raise_count () in + ( raise_num, + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + default = [([[omega]], raise_num)]; + } ) | _ -> - -1, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock( Blk_tuple), paraml, loc), Strict]; - default = [] } in + ( -1, + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + default = []; + } ) + in try try -(* Once for checking that compilation is possible *) + (* Once for checking that compilation is possible *) let next, nexts = split_precompile None pm1 in let size = List.length paraml and idl = List.map (fun _ -> Ident.create "match") paraml in - let args = List.map (fun id -> Lvar id, Alias) idl in + let args = List.map (fun id -> (Lvar id, Alias)) idl in let flat_next = flatten_precompiled size args next and flat_nexts = - List.map - (fun (e,pm) -> e,flatten_precompiled size args pm) - nexts in + List.map (fun (e, pm) -> (e, flatten_precompiled size args pm)) nexts + in let lam, total = - comp_match_handlers - (compile_flattened repr) - partial (start_ctx size) () flat_next flat_nexts in + comp_match_handlers (compile_flattened repr) partial (start_ctx size) () + flat_next flat_nexts + in List.fold_right2 (bind Strict) idl paraml (match partial with - | Partial -> - check_total total lam raise_num (partial_function loc) + | Partial -> check_total total lam raise_num (partial_function loc) | Total -> - assert (jumps_is_empty total) ; - lam) - with Cannot_flatten -> - let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in - begin match partial with - | Partial -> - check_total total lambda raise_num (partial_function loc) + assert (jumps_is_empty total); + lam) + with Cannot_flatten -> ( + let lambda, total = compile_match None partial (start_ctx 1) pm1 in + match partial with + | Partial -> check_total total lambda raise_num (partial_function loc) | Total -> - assert (jumps_is_empty total) ; - lambda - end - with Unused -> - assert false (* ; partial_function loc () *) + assert (jumps_is_empty total); + lambda) + with Unused -> assert false (* ; partial_function loc () *) (* PR#4828: Believe it or not, the 'paraml' argument below may not be side effect free. *) -let param_to_var param = match param with -| Lvar v -> v,None -| _ -> Ident.create "match",Some param +let param_to_var param = + match param with + | Lvar v -> (v, None) + | _ -> (Ident.create "match", Some param) -let bind_opt (v,eo) k = match eo with -| None -> k -| Some e -> Lambda.bind Strict v e k +let bind_opt (v, eo) k = + match eo with + | None -> k + | Some e -> Lambda.bind Strict v e k let for_multiple_match loc paraml pat_act_list partial = let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in + let paraml = List.map (fun (v, _) -> Lvar v) v_paraml in List.fold_right bind_opt v_paraml (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli index 16fda89bf5..4f86b6b045 100644 --- a/compiler/ml/matching.mli +++ b/compiler/ml/matching.mli @@ -18,56 +18,61 @@ open Typedtree open Lambda -val call_switcher_variant_constant : +val call_switcher_variant_constant : (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref val call_switcher_variant_constr : (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref val make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) - ref - + (Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.lambda) + ref + (* Entry points to match compiler *) -val for_function: - Location.t -> int ref option -> lambda -> (pattern * lambda) list -> - partial -> lambda -val for_trywith: - lambda -> (pattern * lambda) list -> lambda -val for_let: - Location.t -> lambda -> pattern -> lambda -> lambda -val for_multiple_match: - Location.t -> lambda list -> (pattern * lambda) list -> partial -> - lambda +val for_function : + Location.t -> + int ref option -> + lambda -> + (pattern * lambda) list -> + partial -> + lambda +val for_trywith : lambda -> (pattern * lambda) list -> lambda +val for_let : Location.t -> lambda -> pattern -> lambda -> lambda +val for_multiple_match : + Location.t -> lambda list -> (pattern * lambda) list -> partial -> lambda -val for_tupled_function: - Location.t -> Ident.t list -> (pattern list * lambda) list -> - partial -> lambda +val for_tupled_function : + Location.t -> + Ident.t list -> + (pattern list * lambda) list -> + partial -> + lambda exception Cannot_flatten -val flatten_pattern: int -> pattern -> pattern list +val flatten_pattern : int -> pattern -> pattern list (* Expand stringswitch to string test tree *) -val expand_stringswitch: - Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda +val expand_stringswitch : + Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda (* To be set by Lam_compile *) -val names_from_construct_pattern : (pattern -> Ast_untagged_variants.switch_names option) ref +val names_from_construct_pattern : + (pattern -> Ast_untagged_variants.switch_names option) ref diff --git a/compiler/ml/mtype.ml b/compiler/ml/mtype.ml index 5f6b798bf6..449d89ae5a 100644 --- a/compiler/ml/mtype.ml +++ b/compiler/ml/mtype.ml @@ -19,90 +19,86 @@ open Asttypes open Path open Types - let rec scrape env mty = match mty with - Mty_ident p -> - begin try - scrape env (Env.find_modtype_expansion p env) - with Not_found -> - mty - end + | Mty_ident p -> ( + try scrape env (Env.find_modtype_expansion p env) with Not_found -> mty) | _ -> mty -let freshen mty = - Subst.modtype Subst.identity mty +let freshen mty = Subst.modtype Subst.identity mty let rec strengthen ~aliasable env mty p = match scrape env mty with - Mty_signature sg -> - Mty_signature(strengthen_sig ~aliasable env sg p 0) - | Mty_functor(param, arg, res) + | Mty_signature sg -> Mty_signature (strengthen_sig ~aliasable env sg p 0) + | Mty_functor (param, arg, res) when !Clflags.applicative_functors && Ident.name param <> "*" -> - Mty_functor(param, arg, - strengthen ~aliasable:false env res (Papply(p, Pident param))) - | mty -> - mty + Mty_functor + ( param, + arg, + strengthen ~aliasable:false env res (Papply (p, Pident param)) ) + | mty -> mty and strengthen_sig ~aliasable env sg p pos = match sg with - [] -> [] - | (Sig_value(_, desc) as sigelt) :: rem -> - let nextpos = - match desc.val_kind with - | Val_prim _ -> pos - | _ -> pos + 1 - in - sigelt :: strengthen_sig ~aliasable env rem p nextpos - | Sig_type(id, {type_kind=Type_abstract}, _) :: - (Sig_type(id', {type_private=Private}, _) :: _ as rem) + | [] -> [] + | (Sig_value (_, desc) as sigelt) :: rem -> + let nextpos = + match desc.val_kind with + | Val_prim _ -> pos + | _ -> pos + 1 + in + sigelt :: strengthen_sig ~aliasable env rem p nextpos + | Sig_type (id, {type_kind = Type_abstract}, _) + :: (Sig_type (id', {type_private = Private}, _) :: _ as rem) when Ident.name id = Ident.name id' ^ "#row" -> - strengthen_sig ~aliasable env rem p pos - | Sig_type(id, decl, rs) :: rem -> - let newdecl = - match decl.type_manifest, decl.type_private, decl.type_kind with - Some _, Public, _ -> decl - | Some _, Private, (Type_record _ | Type_variant _) -> decl - | _ -> - let manif = - Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), - decl.type_params, ref Mnil))) in - if decl.type_kind = Type_abstract then - { decl with type_private = Public; type_manifest = manif } - else - { decl with type_manifest = manif } - in - Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos + strengthen_sig ~aliasable env rem p pos + | Sig_type (id, decl, rs) :: rem -> + let newdecl = + match (decl.type_manifest, decl.type_private, decl.type_kind) with + | Some _, Public, _ -> decl + | Some _, Private, (Type_record _ | Type_variant _) -> decl + | _ -> + let manif = + Some + (Btype.newgenty + (Tconstr + (Pdot (p, Ident.name id, nopos), decl.type_params, ref Mnil))) + in + if decl.type_kind = Type_abstract then + {decl with type_private = Public; type_manifest = manif} + else {decl with type_manifest = manif} + in + Sig_type (id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos | (Sig_typext _ as sigelt) :: rem -> - sigelt :: strengthen_sig ~aliasable env rem p (pos+1) - | Sig_module(id, md, rs) :: rem -> - let str = - strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos)) - in - Sig_module(id, str, rs) - :: strengthen_sig ~aliasable - (Env.add_module_declaration ~check:false 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 = - match decl.mtd_type with - None -> - {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))} - | Some _ -> - decl - in - Sig_modtype(id, newdecl) :: - strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos - (* Need to add the module type in case it is manifest *) + sigelt :: strengthen_sig ~aliasable env rem p (pos + 1) + | Sig_module (id, md, rs) :: rem -> + let str = + strengthen_decl ~aliasable env md (Pdot (p, Ident.name id, pos)) + in + Sig_module (id, str, rs) + :: strengthen_sig ~aliasable + (Env.add_module_declaration ~check:false 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 = + match decl.mtd_type with + | None -> + {decl with mtd_type = Some (Mty_ident (Pdot (p, Ident.name id, nopos)))} + | Some _ -> decl + in + Sig_modtype (id, newdecl) + :: strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos + (* Need to add the module type in case it is manifest *) | (Sig_class _ as sigelt) :: rem -> - sigelt :: strengthen_sig ~aliasable env rem p (pos+1) + sigelt :: strengthen_sig ~aliasable env rem p (pos + 1) | (Sig_class_type _ as sigelt) :: rem -> - sigelt :: strengthen_sig ~aliasable env rem p pos + sigelt :: strengthen_sig ~aliasable env rem p pos and strengthen_decl ~aliasable env md p = match md.md_type with | Mty_alias _ -> md - | _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)} + | _ when aliasable -> {md with md_type = Mty_alias (Mta_present, p)} | mty -> {md with md_type = strengthen ~aliasable env mty p} let () = Env.strengthen := strengthen @@ -114,188 +110,190 @@ let () = Env.strengthen := strengthen type variance = Co | Contra | Strict let nondep_supertype env mid mty = - let rec nondep_mty env va mty = match mty with - Mty_ident p -> - if Path.isfree mid p then - nondep_mty env va (Env.find_modtype_expansion p env) - else mty - | Mty_alias(_, p) -> - if Path.isfree mid p then - nondep_mty env va (Env.find_module p env).md_type - else mty - | Mty_signature sg -> - Mty_signature(nondep_sig env va sg) - | Mty_functor(param, arg, res) -> - let var_inv = - match va with Co -> Contra | Contra -> Co | Strict -> Strict in - Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg, - nondep_mty - (Env.add_module ~arg:true param - (Btype.default_mty arg) env) va res) - + | Mty_ident p -> + if Path.isfree mid p then + nondep_mty env va (Env.find_modtype_expansion p env) + else mty + | Mty_alias (_, p) -> + if Path.isfree mid p then + nondep_mty env va (Env.find_module p env).md_type + else mty + | Mty_signature sg -> Mty_signature (nondep_sig env va sg) + | Mty_functor (param, arg, res) -> + let var_inv = + match va with + | Co -> Contra + | Contra -> Co + | Strict -> Strict + in + Mty_functor + ( param, + Misc.may_map (nondep_mty env var_inv) arg, + nondep_mty + (Env.add_module ~arg:true param (Btype.default_mty arg) env) + va res ) and nondep_sig env va = function - [] -> [] - | item :: rem -> + | [] -> [] + | item :: rem -> ( let rem' = nondep_sig env va rem in match item with - Sig_value(id, d) -> - Sig_value(id, - {d with val_type = Ctype.nondep_type env mid d.val_type}) - :: rem' - | Sig_type(id, d, rs) -> - Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) - :: rem' - | Sig_typext(id, ext, es) -> - Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es) - :: rem' - | Sig_module(id, md, rs) -> - Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs) - :: rem' - | Sig_modtype(id, d) -> - begin try - Sig_modtype(id, nondep_modtype_decl env d) :: rem' - with Not_found -> - match va with - Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none; - mtd_attributes=[]}) :: rem' - | _ -> raise Not_found - end + | Sig_value (id, d) -> + Sig_value (id, {d with val_type = Ctype.nondep_type env mid d.val_type}) + :: rem' + | Sig_type (id, d, rs) -> + Sig_type (id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' + | Sig_typext (id, ext, es) -> + Sig_typext (id, Ctype.nondep_extension_constructor env mid ext, es) + :: rem' + | Sig_module (id, md, rs) -> + Sig_module (id, {md with md_type = nondep_mty env va md.md_type}, rs) + :: rem' + | Sig_modtype (id, d) -> ( + try Sig_modtype (id, nondep_modtype_decl env d) :: rem' + with Not_found -> ( + match va with + | Co -> + Sig_modtype + ( id, + {mtd_type = None; mtd_loc = Location.none; mtd_attributes = []} + ) + :: rem' + | _ -> raise Not_found)) | Sig_class () -> assert false - | Sig_class_type () -> assert false - + | Sig_class_type () -> assert false) and nondep_modtype_decl env mtd = {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type} - in - nondep_mty env Co mty + + nondep_mty env Co mty let enrich_typedecl env p decl = match decl.type_manifest with - Some _ -> decl - | None -> - try - let orig_decl = Env.find_type p env in - if orig_decl.type_arity <> decl.type_arity - then decl - else {decl with type_manifest = - Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))} - with Not_found -> - decl + | Some _ -> decl + | None -> ( + try + let orig_decl = Env.find_type p env in + if orig_decl.type_arity <> decl.type_arity then decl + else + { + decl with + type_manifest = + Some (Btype.newgenty (Tconstr (p, decl.type_params, ref Mnil))); + } + with Not_found -> decl) let rec enrich_modtype env p mty = match mty with - Mty_signature sg -> - Mty_signature(List.map (enrich_item env p) sg) - | _ -> - mty + | Mty_signature sg -> Mty_signature (List.map (enrich_item env p) sg) + | _ -> mty and enrich_item env p = function - Sig_type(id, decl, rs) -> - Sig_type(id, - enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) - | Sig_module(id, md, rs) -> - Sig_module(id, - {md with - md_type = enrich_modtype env - (Pdot(p, Ident.name id, nopos)) md.md_type}, - rs) + | Sig_type (id, decl, rs) -> + Sig_type (id, enrich_typedecl env (Pdot (p, Ident.name id, nopos)) decl, rs) + | Sig_module (id, md, rs) -> + Sig_module + ( id, + { + md with + md_type = + enrich_modtype env (Pdot (p, Ident.name id, nopos)) md.md_type; + }, + rs ) | item -> item let rec type_paths env p mty = match scrape env mty with - Mty_ident _ -> [] + | Mty_ident _ -> [] | Mty_alias _ -> [] | Mty_signature sg -> type_paths_sig env p 0 sg | Mty_functor _ -> [] and type_paths_sig env p pos sg = match sg with - [] -> [] - | Sig_value(_id, decl) :: rem -> - let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in - type_paths_sig env p pos' rem - | Sig_type(id, _decl, _) :: rem -> - Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem - | Sig_module(id, md, _) :: rem -> - type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @ - type_paths_sig (Env.add_module_declaration ~check:false id md env) - p (pos+1) rem - | Sig_modtype(id, decl) :: rem -> - type_paths_sig (Env.add_modtype id decl env) p pos rem - | (Sig_typext _ | Sig_class _) :: rem -> - type_paths_sig env p (pos+1) rem - | (Sig_class_type _) :: rem -> - type_paths_sig env p pos rem + | [] -> [] + | Sig_value (_id, decl) :: rem -> + let pos' = + match decl.val_kind with + | Val_prim _ -> pos + | _ -> pos + 1 + in + type_paths_sig env p pos' rem + | Sig_type (id, _decl, _) :: rem -> + Pdot (p, Ident.name id, nopos) :: type_paths_sig env p pos rem + | Sig_module (id, md, _) :: rem -> + type_paths env (Pdot (p, Ident.name id, pos)) md.md_type + @ type_paths_sig + (Env.add_module_declaration ~check:false id md env) + p (pos + 1) rem + | Sig_modtype (id, decl) :: rem -> + type_paths_sig (Env.add_modtype id decl env) p pos rem + | (Sig_typext _ | Sig_class _) :: rem -> type_paths_sig env p (pos + 1) rem + | Sig_class_type _ :: rem -> type_paths_sig env p pos rem let rec no_code_needed env mty = match scrape env mty with - Mty_ident _ -> false + | Mty_ident _ -> false | Mty_signature sg -> no_code_needed_sig env sg - | Mty_functor(_, _, _) -> false - | Mty_alias(Mta_absent, _) -> true - | Mty_alias(Mta_present, _) -> false + | Mty_functor (_, _, _) -> false + | Mty_alias (Mta_absent, _) -> true + | Mty_alias (Mta_present, _) -> false and no_code_needed_sig env sg = match sg with - [] -> true - | Sig_value(_id, decl) :: rem -> - begin match decl.val_kind with - | Val_prim _ -> no_code_needed_sig env rem - | _ -> false - end - | Sig_module(id, md, _) :: rem -> - no_code_needed env md.md_type && - no_code_needed_sig - (Env.add_module_declaration ~check:false id md env) rem + | [] -> true + | Sig_value (_id, decl) :: rem -> ( + match decl.val_kind with + | Val_prim _ -> no_code_needed_sig env rem + | _ -> false) + | Sig_module (id, md, _) :: rem -> + no_code_needed env md.md_type + && no_code_needed_sig + (Env.add_module_declaration ~check:false id md env) + rem | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> - no_code_needed_sig env rem - | (Sig_typext _ | Sig_class _) :: _ -> - false - + no_code_needed_sig env rem + | (Sig_typext _ | Sig_class _) :: _ -> false (* Check whether a module type may return types *) let rec contains_type env = function - Mty_ident path -> - begin try match (Env.find_modtype path env).mtd_type with + | Mty_ident path -> ( + try + match (Env.find_modtype path env).mtd_type with | None -> raise Exit (* PR#6427 *) | Some mty -> contains_type env mty - with Not_found -> raise Exit - end - | Mty_signature sg -> - contains_type_sig env sg - | Mty_functor (_, _, body) -> - contains_type env body - | Mty_alias _ -> - () + with Not_found -> raise Exit) + | Mty_signature sg -> contains_type_sig env sg + | Mty_functor (_, _, body) -> contains_type env body + | Mty_alias _ -> () and contains_type_sig env = List.iter (contains_type_item env) and contains_type_item env = function - Sig_type (_,({type_manifest = None} | - {type_kind = Type_abstract; type_private = Private}),_) + | Sig_type + ( _, + ( {type_manifest = None} + | {type_kind = Type_abstract; type_private = Private} ), + _ ) | Sig_modtype _ | Sig_typext (_, {ext_args = Cstr_record _}, _) -> - (* We consider that extension constructors with an inlined - record create a type (the inlined record), even though - it would be technically safe to ignore that considering - the current constraints which guarantee that this type - is kept local to expressions. *) - raise Exit - | Sig_module (_, {md_type = mty}, _) -> - contains_type env mty - | Sig_value _ - | Sig_type _ - | Sig_typext _ - | Sig_class _ - | Sig_class_type _ -> - () + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) + raise Exit + | Sig_module (_, {md_type = mty}, _) -> contains_type env mty + | Sig_value _ | Sig_type _ | Sig_typext _ | Sig_class _ | Sig_class_type _ -> + () let contains_type env mty = - try contains_type env mty; false with Exit -> true - + try + contains_type env mty; + false + with Exit -> true (* Remove module aliases from a signature *) @@ -304,37 +302,35 @@ module PathMap = Map.Make (Path) module IdentSet = Set.Make (Ident) let rec get_prefixes = function - Pident _ -> PathSet.empty - | Pdot (p, _, _) - | Papply (p, _) -> PathSet.add p (get_prefixes p) + | Pident _ -> PathSet.empty + | Pdot (p, _, _) | Papply (p, _) -> PathSet.add p (get_prefixes p) let rec get_arg_paths = function - Pident _ -> PathSet.empty + | Pident _ -> PathSet.empty | Pdot (p, _, _) -> get_arg_paths p | Papply (p1, p2) -> - PathSet.add p2 - (PathSet.union (get_prefixes p2) - (PathSet.union (get_arg_paths p1) (get_arg_paths p2))) + PathSet.add p2 + (PathSet.union (get_prefixes p2) + (PathSet.union (get_arg_paths p1) (get_arg_paths p2))) let rec rollback_path subst p = try Pident (PathMap.find p subst) - with Not_found -> + with Not_found -> ( match p with - Pident _ | Papply _ -> p + | Pident _ | Papply _ -> p | Pdot (p1, s, n) -> - let p1' = rollback_path subst p1 in - if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n)) + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n))) let rec collect_ids subst bindings p = - begin match rollback_path subst p with - Pident id -> - let ids = - try collect_ids subst bindings (Ident.find_same id bindings) - with Not_found -> IdentSet.empty - in - IdentSet.add id ids - | _ -> IdentSet.empty - end + match rollback_path subst p with + | Pident id -> + let ids = + try collect_ids subst bindings (Ident.find_same id bindings) + with Not_found -> IdentSet.empty + in + IdentSet.add id ids + | _ -> IdentSet.empty let collect_arg_paths mty = let open Btype in @@ -347,60 +343,57 @@ let collect_arg_paths mty = and it_signature_item it si = type_iterators.it_signature_item it si; match si with - Sig_module (id, {md_type=Mty_alias(_, p)}, _) -> - bindings := Ident.add id p !bindings - | Sig_module (id, {md_type=Mty_signature sg}, _) -> - List.iter - (function Sig_module (id', _, _) -> - subst := - PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst - | _ -> ()) - sg + | Sig_module (id, {md_type = Mty_alias (_, p)}, _) -> + bindings := Ident.add id p !bindings + | Sig_module (id, {md_type = Mty_signature sg}, _) -> + List.iter + (function + | Sig_module (id', _, _) -> + subst := + PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst + | _ -> ()) + sg | _ -> () in let it = {type_iterators with it_path; it_signature_item} in it.it_module_type it mty; it.it_module_type unmark_iterators mty; - PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p)) + PathSet.fold + (fun p -> IdentSet.union (collect_ids !subst !bindings p)) !paths IdentSet.empty let rec remove_aliases env excl mty = match mty with - Mty_signature sg -> - Mty_signature (remove_aliases_sig env excl sg) + | Mty_signature sg -> Mty_signature (remove_aliases_sig env excl sg) | Mty_alias _ -> - let mty' = Env.scrape_alias env mty in - if mty' = mty then mty else (* nested polymorphic comparison *) + let mty' = Env.scrape_alias env mty in + if mty' = mty then mty + else (* nested polymorphic comparison *) remove_aliases env excl mty' - | mty -> - mty + | mty -> mty and remove_aliases_sig env excl sg = match sg with - [] -> [] - | Sig_module(id, md, rs) :: rem -> - let mty = - match md.md_type with - Mty_alias _ when IdentSet.mem id excl -> - md.md_type - | mty -> - remove_aliases env excl mty - in - Sig_module(id, {md with md_type = mty} , rs) :: - remove_aliases_sig (Env.add_module id mty env) excl rem - | Sig_modtype(id, mtd) :: rem -> - Sig_modtype(id, mtd) :: - remove_aliases_sig (Env.add_modtype id mtd env) excl rem - | it :: rem -> - it :: remove_aliases_sig env excl rem + | [] -> [] + | Sig_module (id, md, rs) :: rem -> + let mty = + match md.md_type with + | Mty_alias _ when IdentSet.mem id excl -> md.md_type + | mty -> remove_aliases env excl mty + in + Sig_module (id, {md with md_type = mty}, rs) + :: remove_aliases_sig (Env.add_module id mty env) excl rem + | Sig_modtype (id, mtd) :: rem -> + Sig_modtype (id, mtd) + :: remove_aliases_sig (Env.add_modtype id mtd env) excl rem + | it :: rem -> it :: remove_aliases_sig env excl rem let remove_aliases env sg = let excl = collect_arg_paths sg in (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl; - Format.eprintf "@."; *) + Format.eprintf "@."; *) remove_aliases env excl sg - (* Lower non-generalizable type variables *) let lower_nongen nglev mty = @@ -408,10 +401,9 @@ let lower_nongen nglev mty = let it_type_expr it ty = let ty = repr ty in match ty with - {desc=Tvar _; level} -> - if level < generic_level && level > nglev then set_level ty nglev - | _ -> - type_iterators.it_type_expr it ty + | {desc = Tvar _; level} -> + if level < generic_level && level > nglev then set_level ty nglev + | _ -> type_iterators.it_type_expr it ty in let it = {type_iterators with it_type_expr} in it.it_module_type it mty; diff --git a/compiler/ml/mtype.mli b/compiler/ml/mtype.mli index 84e870ac64..64198df4bd 100644 --- a/compiler/ml/mtype.mli +++ b/compiler/ml/mtype.mli @@ -17,29 +17,34 @@ open Types -val scrape: Env.t -> module_type -> module_type - (* Expand toplevel module type abbreviations - till hitting a "hard" module type (signature, functor, - or abstract module type ident. *) -val freshen: module_type -> module_type - (* Return an alpha-equivalent copy of the given module type - where bound identifiers are fresh. *) -val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type - (* Strengthen abstract type components relative to the - given path. *) -val strengthen_decl: +val scrape : Env.t -> module_type -> module_type +(* Expand toplevel module type abbreviations + till hitting a "hard" module type (signature, functor, + or abstract module type ident. *) + +val freshen : module_type -> module_type +(* Return an alpha-equivalent copy of the given module type + where bound identifiers are fresh. *) + +val strengthen : aliasable:bool -> Env.t -> module_type -> Path.t -> module_type +(* Strengthen abstract type components relative to the + given path. *) + +val strengthen_decl : aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration -val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type - (* Return the smallest supertype of the given type - in which the given ident does not appear. - Raise [Not_found] if no such type exists. *) -val no_code_needed: Env.t -> module_type -> bool -val no_code_needed_sig: Env.t -> signature -> bool - (* Determine whether a module needs no implementation code, - i.e. consists only of type definitions. *) -val enrich_modtype: Env.t -> Path.t -> module_type -> module_type -val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration -val type_paths: Env.t -> Path.t -> module_type -> Path.t list -val contains_type: Env.t -> module_type -> bool -val remove_aliases: Env.t -> module_type -> module_type -val lower_nongen: int -> module_type -> unit +val nondep_supertype : Env.t -> Ident.t -> module_type -> module_type +(* Return the smallest supertype of the given type + in which the given ident does not appear. + Raise [Not_found] if no such type exists. *) + +val no_code_needed : Env.t -> module_type -> bool +val no_code_needed_sig : Env.t -> signature -> bool +(* Determine whether a module needs no implementation code, + i.e. consists only of type definitions. *) + +val enrich_modtype : Env.t -> Path.t -> module_type -> module_type +val enrich_typedecl : Env.t -> Path.t -> type_declaration -> type_declaration +val type_paths : Env.t -> Path.t -> module_type -> Path.t list +val contains_type : Env.t -> module_type -> bool +val remove_aliases : Env.t -> module_type -> module_type +val lower_nongen : int -> module_type -> unit diff --git a/compiler/ml/oprint.ml b/compiler/ml/oprint.ml index 4b4c1bd6c9..93dd3afe4f 100644 --- a/compiler/ml/oprint.ml +++ b/compiler/ml/oprint.ml @@ -18,9 +18,7 @@ open Outcometree exception Ellipsis -let cautious f ppf arg = - try f ppf arg with - Ellipsis -> fprintf ppf "..." +let cautious f ppf arg = try f ppf arg with Ellipsis -> fprintf ppf "..." let out_ident = ref pp_print_string let map_primitive_name = ref (fun x -> x) @@ -29,52 +27,52 @@ let print_lident ppf = function | "::" -> !out_ident ppf "(::)" | s -> !out_ident ppf s -let rec print_ident ppf = - function - Oide_ident s -> print_lident ppf s +let rec print_ident ppf = function + | Oide_ident s -> print_lident ppf s | Oide_dot (id, s) -> - print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s + print_ident ppf id; + pp_print_char ppf '.'; + print_lident ppf s | Oide_apply (id1, id2) -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 + fprintf ppf "%a(%a)" print_ident id1 print_ident id2 let parenthesized_ident name = - (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) + List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] || - (match name.[0] with - 'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' -> - false - | _ -> true) + match name.[0] with + | 'a' .. 'z' | 'A' .. 'Z' | '\223' .. '\246' | '\248' .. '\255' | '_' -> false + | _ -> true let value_ident ppf name = - if parenthesized_ident name then - fprintf ppf "( %s )" name - else - pp_print_string ppf name + if parenthesized_ident name then fprintf ppf "( %s )" name + else pp_print_string ppf name (* Values *) let valid_float_lexeme s = let l = String.length s in let rec loop i = - if i >= l then s ^ "." else - match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in loop 0 + if i >= l then s ^ "." + else + match s.[i] with + | '0' .. '9' | '-' -> loop (i + 1) + | _ -> s + in + loop 0 let float_repres f = match classify_float f with - FP_nan -> "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" + | FP_nan -> "nan" + | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then s1 else + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 + else let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then s2 else - Printf.sprintf "%.18g" f - in valid_float_lexeme float_val + if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f + in + valid_float_lexeme float_val let parenthesize_if_neg ppf fmt v isneg = if isneg then pp_print_char ppf '('; @@ -83,71 +81,79 @@ let parenthesize_if_neg ppf fmt v isneg = let escape_string s = (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' and '"' *) - let n = ref 0 in + let n = ref 0 in for i = 0 to String.length s - 1 do - n := !n + - (match String.unsafe_get s i with - | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 - | '\x00' .. '\x1F' - | '\x7F' -> 4 - | _ -> 1) + n := + !n + + + match String.unsafe_get s i with + | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | '\x00' .. '\x1F' | '\x7F' -> 4 + | _ -> 1 done; - if !n = String.length s then s else begin + if !n = String.length s then s + else let s' = Bytes.create !n in n := 0; for i = 0 to String.length s - 1 do - begin match String.unsafe_get s i with + (match String.unsafe_get s i with | ('\"' | '\\') as c -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n c | '\n' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'n' | '\t' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 't' | '\r' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'r' | '\b' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' - | '\x00' .. '\x1F' | '\x7F' as c -> - let a = Char.code c in - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + a / 100)); - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10)); - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10)); - | c -> Bytes.unsafe_set s' !n c - end; + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'b' + | ('\x00' .. '\x1F' | '\x7F') as c -> + let a = Char.code c in + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 100))); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10 mod 10))); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a mod 10))) + | c -> Bytes.unsafe_set s' !n c); incr n done; Bytes.to_string s' - end - let print_out_string ppf s = let not_escaped = (* let the user dynamically choose if strings should be escaped: *) match Sys.getenv_opt "OCAMLTOP_UTF_8" with | None -> true - | Some x -> - match bool_of_string_opt x with - | None -> true - | Some f -> f in - if not_escaped then - fprintf ppf "\"%s\"" (escape_string s) - else - fprintf ppf "%S" s + | Some x -> ( + match bool_of_string_opt x with + | None -> true + | Some f -> f) + in + if not_escaped then fprintf ppf "\"%s\"" (escape_string s) + else fprintf ppf "%S" s let print_out_value ppf tree = - let rec print_tree_1 ppf = - function + let rec print_tree_1 ppf = function | Oval_constr (name, [param]) -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param + fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param | Oval_constr (name, (_ :: _ as params)) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name - (print_tree_list print_tree_1 ",") params + fprintf ppf "@[<1>%a@ (%a)@]" print_ident name + (print_tree_list print_tree_1 ",") + params | Oval_variant (name, Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param + fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param | tree -> print_simple_tree ppf tree and print_constr_param ppf = function | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) @@ -155,64 +161,57 @@ let print_out_value ppf tree = | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0) - | Oval_string (_,_, Ostr_bytes) as tree -> + | Oval_string (_, _, Ostr_bytes) as tree -> pp_print_char ppf '('; print_simple_tree ppf tree; - pp_print_char ppf ')'; + pp_print_char ppf ')' | tree -> print_simple_tree ppf tree - and print_simple_tree ppf = - function - Oval_int i -> fprintf ppf "%i" i + and print_simple_tree ppf = function + | Oval_int i -> fprintf ppf "%i" i | Oval_int32 i -> fprintf ppf "%lil" i | Oval_int64 i -> fprintf ppf "%LiL" i | Oval_nativeint i -> fprintf ppf "%nin" i | Oval_float f -> pp_print_string ppf (float_repres f) | Oval_char c -> fprintf ppf "%C" c - | Oval_string (s, maxlen, kind) -> - begin try - let len = String.length s in - let s = if len > maxlen then String.sub s 0 maxlen else s in - begin match kind with - | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s - | Ostr_string -> print_out_string ppf s - end; - (if len > maxlen then - fprintf ppf - "... (* string length %d; truncated *)" len - ) - with - Invalid_argument _ (* "String.create" *)-> fprintf ppf "" - end + | Oval_string (s, maxlen, kind) -> ( + try + let len = String.length s in + let s = if len > maxlen then String.sub s 0 maxlen else s in + (match kind with + | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s + | Ostr_string -> print_out_string ppf s); + if len > maxlen then + fprintf ppf "... (* string length %d; truncated *)" len + with Invalid_argument _ (* "String.create" *) -> + fprintf ppf "") | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl + fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl + fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl | Oval_constr (name, []) -> print_ident ppf name | Oval_variant (name, None) -> fprintf ppf "`%s" name | Oval_stuff s -> pp_print_string ppf s | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel + fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | Oval_tuple tree_list -> - fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree - and print_fields first ppf = - function - [] -> () + and print_fields first ppf = function + | [] -> () | (name, tree) :: fields -> - if not first then fprintf ppf ";@ "; - fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) - tree; - print_fields false ppf fields + if not first then fprintf ppf ";@ "; + fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) + tree; + print_fields false ppf fields and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - function - [] -> () + let rec print_list first ppf = function + | [] -> () | tree :: tree_list -> - if not first then fprintf ppf "%s@ " sep; - print_item ppf tree; - print_list false ppf tree_list + if not first then fprintf ppf "%s@ " sep; + print_item ppf tree; + print_list false ppf tree_list in cautious (print_list true) ppf tree_list in @@ -222,16 +221,20 @@ let out_value = ref print_out_value (* Types *) -let rec print_list_init pr sep ppf = - function - [] -> () - | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l +let rec print_list_init pr sep ppf = function + | [] -> () + | a :: l -> + sep ppf; + pr ppf a; + print_list_init pr sep ppf l -let rec print_list pr sep ppf = - function - [] -> () +let rec print_list pr sep ppf = function + | [] -> () | [a] -> pr ppf a - | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l + | a :: l -> + pr ppf a; + sep ppf; + print_list pr sep ppf l let pr_present = print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") @@ -239,159 +242,161 @@ let pr_present = let pr_vars = print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -let rec print_out_type ppf = - function - | Otyp_alias (ty, s) -> - fprintf ppf "@[%a@ as '%s@]" print_out_type ty s +let rec print_out_type ppf = function + | Otyp_alias (ty, s) -> fprintf ppf "@[%a@ as '%s@]" print_out_type ty s | Otyp_poly (sl, ty) -> - fprintf ppf "@[%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> - print_out_type_1 ppf ty - -and print_out_type_1 ppf = - function - Otyp_arrow (lab, ty1, ty2) -> - pp_open_box ppf 0; - if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':'); - print_out_type_2 ppf ty1; - pp_print_string ppf " ->"; - pp_print_space ppf (); - print_out_type_1 ppf ty2; - pp_close_box ppf () + fprintf ppf "@[%a.@ %a@]" pr_vars sl print_out_type ty + | ty -> print_out_type_1 ppf ty + +and print_out_type_1 ppf = function + | Otyp_arrow (lab, ty1, ty2) -> + pp_open_box ppf 0; + if lab <> "" then ( + pp_print_string ppf lab; + pp_print_char ppf ':'); + print_out_type_2 ppf ty1; + pp_print_string ppf " ->"; + pp_print_space ppf (); + print_out_type_1 ppf ty2; + pp_close_box ppf () | ty -> print_out_type_2 ppf ty -and print_out_type_2 ppf = - function - Otyp_tuple tyl -> - fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl + +and print_out_type_2 ppf = function + | Otyp_tuple tyl -> + fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl | ty -> print_simple_out_type ppf ty -and print_simple_out_type ppf = - function - Otyp_class (ng, id, tyl) -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), name ), - [tyl]) + +and print_simple_out_type ppf = function + | Otyp_class (ng, id, tyl) -> + fprintf ppf "@[%a%s#%a@]" print_typargs tyl + (if ng then "_" else "") + print_ident id + | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), name), [tyl]) -> + let res = + if name = "arity0" then + Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []), tyl) + else tyl + in + fprintf ppf "@[<0>(%a@ [@bs])@]" print_out_type_1 res + | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Meth"), name), [tyl]) + -> + let res = + if name = "arity0" then + Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []), tyl) + else tyl + in + fprintf ppf "@[<0>(%a@ [@meth])@]" print_out_type_1 res + | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Callback"), _), [tyl]) -> - let res = - if name = "arity0" then - Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),tyl) - else tyl - in - fprintf ppf "@[<0>(%a@ [@bs])@]" print_out_type_1 res - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Meth" ),name), - [tyl]) - -> - let res = - if name = "arity0" then - Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),tyl) - else tyl - in - fprintf ppf "@[<0>(%a@ [@meth])@]" print_out_type_1 res - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Callback" ), _), - [tyl]) - -> - fprintf ppf "@[<0>(%a@ [@this])@]" print_out_type_1 tyl + fprintf ppf "@[<0>(%a@ [@this])@]" print_out_type_1 tyl | Otyp_constr (id, tyl) -> - pp_open_box ppf 0; - print_typargs ppf tyl; - print_ident ppf id; - pp_close_box ppf () + pp_open_box ppf 0; + print_typargs ppf tyl; + print_ident ppf id; + pp_close_box ppf () | Otyp_object (fields, rest) -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields + fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields | Otyp_stuff s -> pp_print_string ppf s | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s | Otyp_variant (non_gen, row_fields, closed, tags) -> - let print_present ppf = - function - None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l - in - let print_fields ppf = - function - Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_typ typ -> - print_simple_out_type ppf typ - in - fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " else "? ") - print_fields row_fields - print_present tags - | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> - pp_open_box ppf 1; - pp_print_char ppf '('; - print_out_type ppf ty; - pp_print_char ppf ')'; - pp_close_box ppf () - | Otyp_abstract | Otyp_open - | Otyp_sum _ | Otyp_manifest (_, _) -> () + let print_present ppf = function + | None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l + in + let print_fields ppf = function + | Ovar_fields fields -> + print_list print_row_field + (fun ppf -> fprintf ppf "@;<1 -2>| ") + ppf fields + | Ovar_typ typ -> print_simple_out_type ppf typ + in + fprintf ppf "%s[%s@[@[%a@]%a ]@]" + (if non_gen then "_" else "") + (if closed then if tags = None then " " else "< " + else if tags = None then "> " + else "? ") + print_fields row_fields print_present tags + | (Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _) as ty -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_out_type ppf ty; + pp_print_char ppf ')'; + pp_close_box ppf () + | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ppf lbls | Otyp_module (p, n, tyl) -> - fprintf ppf "@[<1>(module %s" p; - let first = ref true in - List.iter2 - (fun s t -> - let sep = if !first then (first := false; "with") else "and" in - fprintf ppf " %s type %s = %a" sep s print_out_type t - ) - n tyl; - fprintf ppf ")@]" + fprintf ppf "@[<1>(module %s" p; + let first = ref true in + List.iter2 + (fun s t -> + let sep = + if !first then ( + first := false; + "with") + else "and" + in + fprintf ppf " %s type %s = %a" sep s print_out_type t) + n tyl; + fprintf ppf ")@]" | Otyp_attribute (t, attr) -> - fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name + fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name + and print_record_decl ppf lbls = fprintf ppf "{%a@;<1 -2>}" - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls -and print_fields rest ppf = - function - [] -> - begin match rest with - Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () - end - | [s, t] -> - fprintf ppf "%s : %a" s print_out_type t; - begin match rest with - Some _ -> fprintf ppf ";@ " - | None -> () - end; - print_fields rest ppf [] + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) + lbls + +and print_fields rest ppf = function + | [] -> ( + match rest with + | Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") + | None -> ()) + | [(s, t)] -> + fprintf ppf "%s : %a" s print_out_type t; + (match rest with + | Some _ -> fprintf ppf ";@ " + | None -> ()); + print_fields rest ppf [] | (s, t) :: l -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l + and print_row_field ppf (l, opt_amp, tyl) = let pr_of ppf = if opt_amp then fprintf ppf " of@ &@ " else if tyl <> [] then fprintf ppf " of@ " else fprintf ppf "" in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") + fprintf ppf "@[`%s%t%a@]" l pr_of + (print_typlist print_out_type " &") tyl -and print_typlist print_elem sep ppf = - function - [] -> () + +and print_typlist print_elem sep ppf = function + | [] -> () | [ty] -> print_elem ppf ty | ty :: tyl -> - print_elem ppf ty; - pp_print_string ppf sep; - pp_print_space ppf (); - print_typlist print_elem sep ppf tyl -and print_typargs ppf = - function - [] -> () - | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf () + print_elem ppf ty; + pp_print_string ppf sep; + pp_print_space ppf (); + print_typlist print_elem sep ppf tyl + +and print_typargs ppf = function + | [] -> () + | [ty1] -> + print_simple_out_type ppf ty1; + pp_print_space ppf () | tyl -> - pp_open_box ppf 1; - pp_print_char ppf '('; - print_typlist print_out_type "," ppf tyl; - pp_print_char ppf ')'; - pp_close_box ppf (); - pp_print_space ppf () + pp_open_box ppf 1; + pp_print_char ppf '('; + print_typlist print_out_type "," ppf tyl; + pp_print_char ppf ')'; + pp_close_box ppf (); + pp_print_space ppf () + and print_out_label ppf (name, mut, opt, arg) = - fprintf ppf "@[<2>%s%s%s :@ %a@];" (if opt then "@optional " else "") (if mut then "mutable " else "") name - print_out_type arg + fprintf ppf "@[<2>%s%s%s :@ %a@];" + (if opt then "@optional " else "") + (if mut then "mutable " else "") + name print_out_type arg let out_type = ref print_out_type @@ -400,52 +405,48 @@ let out_type = ref print_out_type let type_parameter ppf (ty, (co, cn)) = fprintf ppf "%s%s" (if not cn then "+" else if not co then "-" else "") - (if ty = "_" then ty else "'"^ty) + (if ty = "_" then ty else "'" ^ ty) -let print_out_class_params ppf = - function - [] -> () +let print_out_class_params ppf = function + | [] -> () | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list type_parameter (fun ppf -> fprintf ppf ", ")) - tyl - -let rec print_out_class_type ppf = - function - Octy_constr (id, tyl) -> - let pr_tyl ppf = - function - [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id + fprintf ppf "@[<1>[%a]@]@ " + (print_list type_parameter (fun ppf -> fprintf ppf ", ")) + tyl + +let rec print_out_class_type ppf = function + | Octy_constr (id, tyl) -> + let pr_tyl ppf = function + | [] -> () + | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl + in + fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id | Octy_arrow (lab, ty, cty) -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty + fprintf ppf "@[%s%a ->@ %a@]" + (if lab <> "" then lab ^ ":" else "") + print_out_type_2 ty print_out_class_type cty | Octy_signature (self_ty, csil) -> - let pr_param ppf = - function - Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty - | None -> () - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil -and print_out_class_sig_item ppf = - function - Ocsg_constraint (ty1, ty2) -> - fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 - !out_type ty2 + let pr_param ppf = function + | Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty + | None -> () + in + fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty + (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) + csil + +and print_out_class_sig_item ppf = function + | Ocsg_constraint (ty1, ty2) -> + fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2 | Ocsg_method (name, priv, virt, ty) -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name !out_type ty + fprintf ppf "@[<2>method %s%s%s :@ %a@]" + (if priv then "private " else "") + (if virt then "virtual " else "") + name !out_type ty | Ocsg_value (name, mut, vr, ty) -> - fprintf ppf "@[<2>val %s%s%s :@ %a@]" - (if mut then "mutable " else "") - (if vr then "virtual " else "") - name !out_type ty + fprintf ppf "@[<2>val %s%s%s :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") + name !out_type ty let out_class_type = ref print_out_class_type @@ -456,144 +457,139 @@ let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") let out_signature = ref (fun _ -> failwith "Oprint.out_signature") let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") -let rec print_out_functor funct ppf = - function - Omty_functor (_, None, mty_res) -> - if funct then fprintf ppf "() %a" (print_out_functor true) mty_res - else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res - | Omty_functor (name, Some mty_arg, mty_res) -> begin - match name, funct with - | "_", true -> - fprintf ppf "->@ %a ->@ %a" - print_out_module_type mty_arg (print_out_functor false) mty_res - | "_", false -> - fprintf ppf "%a ->@ %a" - print_out_module_type mty_arg (print_out_functor false) mty_res - | name, true -> - fprintf ppf "(%s : %a) %a" name - print_out_module_type mty_arg (print_out_functor true) mty_res - | name, false -> - fprintf ppf "functor@ (%s : %a) %a" name - print_out_module_type mty_arg (print_out_functor true) mty_res - end +let rec print_out_functor funct ppf = function + | Omty_functor (_, None, mty_res) -> + if funct then fprintf ppf "() %a" (print_out_functor true) mty_res + else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res + | Omty_functor (name, Some mty_arg, mty_res) -> ( + match (name, funct) with + | "_", true -> + fprintf ppf "->@ %a ->@ %a" print_out_module_type mty_arg + (print_out_functor false) mty_res + | "_", false -> + fprintf ppf "%a ->@ %a" print_out_module_type mty_arg + (print_out_functor false) mty_res + | name, true -> + fprintf ppf "(%s : %a) %a" name print_out_module_type mty_arg + (print_out_functor true) mty_res + | name, false -> + fprintf ppf "functor@ (%s : %a) %a" name print_out_module_type mty_arg + (print_out_functor true) mty_res) | m -> - if funct then fprintf ppf "->@ %a" print_out_module_type m - else print_out_module_type ppf m - -and print_out_module_type ppf = - function - Omty_abstract -> () - | Omty_functor _ as t -> - fprintf ppf "@[<2>%a@]" (print_out_functor false) t + if funct then fprintf ppf "->@ %a" print_out_module_type m + else print_out_module_type ppf m + +and print_out_module_type ppf = function + | Omty_abstract -> () + | Omty_functor _ as t -> fprintf ppf "@[<2>%a@]" (print_out_functor false) t | Omty_ident id -> fprintf ppf "%a" print_ident id | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" !out_signature sg + fprintf ppf "@[sig@ %a@;<1 -2>end@]" !out_signature sg | Omty_alias id -> fprintf ppf "(module %a)" print_ident id -and print_out_signature ppf = - function - [] -> () + +and print_out_signature ppf = function + | [] -> () | [item] -> !out_sig_item ppf item - | Osig_typext(ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - Osig_typext(ext, Oext_next) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = + | Osig_typext (ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Osig_typext (ext, Oext_next) :: items -> gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + :: acc) items - in - let te = - { otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + items + in + let te = + { + otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items | item :: items -> - fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items -and print_out_sig_item ppf = - function - Osig_class (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" - (if rs = Orec_next then "and" else "class") - (if vir_flag then " virtual" else "") print_out_class_params params - name !out_class_type clt + fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items + +and print_out_sig_item ppf = function + | Osig_class (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") + print_out_class_params params name !out_class_type clt | Osig_class_type (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" - (if rs = Orec_next then "and" else "class type") - (if vir_flag then " virtual" else "") print_out_class_params params - name !out_class_type clt + fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") + print_out_class_params params name !out_class_type clt | Osig_typext (ext, Oext_exception) -> - fprintf ppf "@[<2>exception %a@]" - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - | Osig_typext (ext, _es) -> - print_out_extension_constructor ppf ext + fprintf ppf "@[<2>exception %a@]" print_out_constr + (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + | Osig_typext (ext, _es) -> print_out_extension_constructor ppf ext | Osig_modtype (name, Omty_abstract) -> - fprintf ppf "@[<2>module type %s@]" name + fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> - fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty + fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty | Osig_module (name, Omty_alias id, _) -> - fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id + fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id | Osig_module (name, mty, rs) -> - fprintf ppf "@[<2>%s %s :@ %a@]" - (match rs with Orec_not -> "module" - | Orec_first -> "module rec" - | Orec_next -> "and") - name !out_module_type mty - | Osig_type(td, rs) -> - print_out_type_decl - (match rs with - | Orec_not -> "type nonrec" - | Orec_first -> "type" - | Orec_next -> "and") - ppf td + fprintf ppf "@[<2>%s %s :@ %a@]" + (match rs with + | Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and") + name !out_module_type mty + | Osig_type (td, rs) -> + print_out_type_decl + (match rs with + | Orec_not -> "type nonrec" + | Orec_first -> "type" + | Orec_next -> "and") + ppf td | Osig_value vd -> - let kwd = if vd.oval_prims = [] then "val" else "external" in - let pr_prims ppf = - function - [] -> () - | s :: sl -> - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> -(* TODO: in general, we should print bs attributes, some attributes like - variadic do need it *) - fprintf ppf "@ \"%s\"" (!map_primitive_name s) - ) sl - in - fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name - !out_type vd.oval_type pr_prims vd.oval_prims - (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) - vd.oval_attributes - | Osig_ellipsis -> - fprintf ppf "..." + let kwd = if vd.oval_prims = [] then "val" else "external" in + let pr_prims ppf = function + | [] -> () + | s :: sl -> + fprintf ppf "@ = \"%s\"" s; + List.iter + (fun s -> + (* TODO: in general, we should print bs attributes, some attributes like + variadic do need it *) + fprintf ppf "@ \"%s\"" (!map_primitive_name s)) + sl + in + fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name !out_type + vd.oval_type pr_prims vd.oval_prims + (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) + vd.oval_attributes + | Osig_ellipsis -> fprintf ppf "..." and print_out_type_decl kwd ppf td = let print_constraints ppf = List.iter (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 - !out_type ty2) + fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2) td.otype_cstrs in let type_defined ppf = match td.otype_params with - [] -> pp_print_string ppf td.otype_name + | [] -> pp_print_string ppf td.otype_name | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) - td.otype_params - td.otype_name + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params td.otype_name in - let print_manifest ppf = - function - Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty + let print_manifest ppf = function + | Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty | _ -> () in let print_name_params ppf = @@ -601,12 +597,12 @@ and print_out_type_decl kwd ppf td = in let ty = match td.otype_type with - Otyp_manifest (_, ty) -> ty + | Otyp_manifest (_, ty) -> ty | _ -> td.otype_type in let print_private ppf = function - Asttypes.Private -> fprintf ppf " private" - | Asttypes.Public -> () + | Asttypes.Private -> fprintf ppf " private" + | Asttypes.Public -> () in let print_immediate ppf = if td.otype_immediate then fprintf ppf " [%@%@immediate]" else () @@ -615,102 +611,82 @@ and print_out_type_decl kwd ppf td = if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else () in let print_out_tkind ppf = function - | Otyp_abstract -> () - | Otyp_record lbls -> - fprintf ppf " =%a %a" - print_private td.otype_private - print_record_decl lbls - | Otyp_sum constrs -> - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_open -> - fprintf ppf " =%a .." - print_private td.otype_private - | ty -> - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - !out_type ty + | Otyp_abstract -> () + | Otyp_record lbls -> + fprintf ppf " =%a %a" print_private td.otype_private print_record_decl + lbls + | Otyp_sum constrs -> + fprintf ppf " =%a@;<1 2>%a" print_private td.otype_private + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + constrs + | Otyp_open -> fprintf ppf " =%a .." print_private td.otype_private + | ty -> + fprintf ppf " =%a@;<1 2>%a" print_private td.otype_private !out_type ty in - fprintf ppf "@[<2>@[%t%a@]%t%t%t@]" - print_name_params - print_out_tkind ty - print_constraints - print_immediate - print_unboxed + fprintf ppf "@[<2>@[%t%a@]%t%t%t@]" print_name_params print_out_tkind ty + print_constraints print_immediate print_unboxed and print_out_constr ppf (name, tyl, ret_type_opt, repr) = - let () = match repr with + let () = + match repr with | None -> () - | Some s -> pp_print_string ppf s in + | Some s -> pp_print_string ppf s + in let name = match name with - | "::" -> "(::)" (* #7200 *) + | "::" -> "(::)" (* #7200 *) | s -> s in match ret_type_opt with - | None -> - begin match tyl with - | [] -> - pp_print_string ppf name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl - end - | Some ret_type -> - begin match tyl with - | [] -> - fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type - | _ -> - fprintf ppf "@[<2>%s :@ %a -> %a@]" name - (print_typlist print_simple_out_type " *") - tyl print_simple_out_type ret_type - end + | None -> ( + match tyl with + | [] -> pp_print_string ppf name + | _ -> + fprintf ppf "@[<2>%s of@ %a@]" name + (print_typlist print_simple_out_type " *") + tyl) + | Some ret_type -> ( + match tyl with + | [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type + | _ -> + fprintf ppf "@[<2>%s :@ %a -> %a@]" name + (print_typlist print_simple_out_type " *") + tyl print_simple_out_type ret_type) and print_out_extension_constructor ppf ext = let print_extended_type ppf = let print_type_parameter ppf ty = - fprintf ppf "%s" - (if ty = "_" then ty else "'"^ty) + fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty) in - match ext.oext_type_params with - [] -> fprintf ppf "%s" ext.oext_type_name - | [ty_param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter - ty_param - ext.oext_type_name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) - ext.oext_type_params - ext.oext_type_name + match ext.oext_type_params with + | [] -> fprintf ppf "%s" ext.oext_type_name + | [ty_param] -> + fprintf ppf "@[%a@ %s@]" print_type_parameter ty_param ext.oext_type_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params ext.oext_type_name in - fprintf ppf "@[type %t +=%s@;<1 2>%a@]" - print_extended_type + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type (if ext.oext_private = Asttypes.Private then " private" else "") - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + print_out_constr + (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) and print_out_type_extension ppf te = let print_extended_type ppf = let print_type_parameter ppf ty = - fprintf ppf "%s" - (if ty = "_" then ty else "'"^ty) + fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty) in match te.otyext_params with - [] -> fprintf ppf "%s" te.otyext_name + | [] -> fprintf ppf "%s" te.otyext_name | [param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter param - te.otyext_name + fprintf ppf "@[%a@ %s@]" print_type_parameter param te.otyext_name | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) - te.otyext_params - te.otyext_name + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params te.otyext_name in - fprintf ppf "@[type %t +=%s@;<1 2>%a@]" - print_extended_type + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type (if te.otyext_private = Asttypes.Private then " private" else "") (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) te.otyext_constructors @@ -724,51 +700,49 @@ let _ = out_type_extension := print_out_type_extension let print_out_exception ppf exn outv = match exn with - Sys.Break -> fprintf ppf "Interrupted.@." + | Sys.Break -> fprintf ppf "Interrupted.@." | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." + fprintf ppf "Stack overflow during evaluation (looping recursion?).@." | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv -let rec print_items ppf = - function - [] -> () - | (Osig_typext(ext, Oext_first), None) :: items -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - (Osig_typext(ext, Oext_next), None) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = +let rec print_items ppf = function + | [] -> () + | (Osig_typext (ext, Oext_first), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Osig_typext (ext, Oext_next), None) :: items -> gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + :: acc) items - in - let te = - { otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - fprintf ppf "@[%a@]" !out_type_extension te; - if items <> [] then fprintf ppf "@ %a" print_items items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + items + in + let te = + { + otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + fprintf ppf "@[%a@]" !out_type_extension te; + if items <> [] then fprintf ppf "@ %a" print_items items | (tree, valopt) :: items -> - begin match valopt with - Some v -> - fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree - !out_value v - | None -> fprintf ppf "@[%a@]" !out_sig_item tree - end; - if items <> [] then fprintf ppf "@ %a" print_items items - -let print_out_phrase ppf = - function - Ophr_eval (outv, ty) -> - fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv + (match valopt with + | Some v -> fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree !out_value v + | None -> fprintf ppf "@[%a@]" !out_sig_item tree); + if items <> [] then fprintf ppf "@ %a" print_items items + +let print_out_phrase ppf = function + | Ophr_eval (outv, ty) -> + fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv | Ophr_signature [] -> () | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv diff --git a/compiler/ml/oprint.mli b/compiler/ml/oprint.mli index 7c53634f71..4bdd95ad7e 100644 --- a/compiler/ml/oprint.mli +++ b/compiler/ml/oprint.mli @@ -16,7 +16,6 @@ open Format open Outcometree - val out_ident : (formatter -> string -> unit) ref val map_primitive_name : (string -> string) ref diff --git a/compiler/ml/outcometree.ml b/compiler/ml/outcometree.ml index 2bad441a29..dcd620b5e6 100644 --- a/compiler/ml/outcometree.ml +++ b/compiler/ml/outcometree.ml @@ -27,12 +27,9 @@ type out_ident = | Oide_dot of out_ident * string | Oide_ident of string -type out_string = - | Ostr_string - | Ostr_bytes +type out_string = Ostr_string | Ostr_bytes -type out_attribute = - { oattr_name: string } +type out_attribute = {oattr_name: string} type out_value = | Oval_array of out_value list @@ -66,8 +63,7 @@ type out_type = | Otyp_sum of (string * out_type list * out_type option * string option) list | Otyp_tuple of out_type list | Otyp_var of bool * string - | Otyp_variant of - bool * out_variant * bool * (string list) option + | Otyp_variant of bool * out_variant * bool * string list option | Otyp_poly of string list * out_type | Otyp_module of string * string list * out_type list | Otyp_attribute of out_type * out_attribute @@ -93,51 +89,56 @@ type out_module_type = | Omty_alias of out_ident and out_sig_item = | Osig_class of - bool * string * (string * (bool * bool)) list * out_class_type * - out_rec_status + bool + * string + * (string * (bool * bool)) list + * out_class_type + * out_rec_status | Osig_class_type of - bool * string * (string * (bool * bool)) list * out_class_type * - out_rec_status + bool + * string + * (string * (bool * bool)) 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 = - { otype_name: string; - otype_params: (string * (bool * bool)) list; - otype_type: out_type; - otype_private: Asttypes.private_flag; - otype_immediate: bool; - otype_unboxed: bool; - otype_cstrs: (out_type * out_type) list } -and 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_repr: string option; - oext_private: Asttypes.private_flag } -and out_type_extension = - { otyext_name: string; - otyext_params: string list; - otyext_constructors: (string * out_type list * out_type option * string option) list; - otyext_private: Asttypes.private_flag } -and out_val_decl = - { oval_name: string; - oval_type: out_type; - oval_prims: string list; - oval_attributes: out_attribute list } -and out_rec_status = - | Orec_not - | Orec_first - | Orec_next -and out_ext_status = - | Oext_first - | Oext_next - | Oext_exception +and out_type_decl = { + otype_name: string; + otype_params: (string * (bool * bool)) list; + otype_type: out_type; + otype_private: Asttypes.private_flag; + otype_immediate: bool; + otype_unboxed: bool; + otype_cstrs: (out_type * out_type) list; +} +and 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_repr: string option; + oext_private: Asttypes.private_flag; +} +and out_type_extension = { + otyext_name: string; + otyext_params: string list; + otyext_constructors: + (string * out_type list * out_type option * string option) list; + otyext_private: Asttypes.private_flag; +} +and out_val_decl = { + oval_name: string; + oval_type: out_type; + oval_prims: string list; + oval_attributes: out_attribute list; +} +and out_rec_status = Orec_not | Orec_first | Orec_next +and out_ext_status = Oext_first | Oext_next | Oext_exception type out_phrase = | Ophr_eval of out_value * out_type diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index aac887c7e9..346ac58c61 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -25,20 +25,21 @@ open Typedtree (*************************************) let make_pat desc ty tenv = - {pat_desc = desc; pat_loc = Location.none; pat_extra = []; - pat_type = ty ; pat_env = tenv; - pat_attributes = []; + { + pat_desc = desc; + pat_loc = Location.none; + pat_extra = []; + pat_type = ty; + pat_env = tenv; + pat_attributes = []; } let omega = make_pat Tpat_any Ctype.none Env.empty let extra_pat = - make_pat - (Tpat_var (Ident.create "+", mknoloc "+")) - Ctype.none Env.empty + make_pat (Tpat_var (Ident.create "+", mknoloc "+")) Ctype.none Env.empty -let rec omegas i = - if i <= 0 then [] else omega :: omegas (i-1) +let rec omegas i = if i <= 0 then [] else omega :: omegas (i - 1) let omega_list l = List.map (fun _ -> omega) l @@ -115,21 +116,20 @@ let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty when an "incoherence" is not detected by this check. *) - let simplify_head_pat p k = let rec simplify_head_pat p k = match p.pat_desc with - | Tpat_alias (p,_,_) -> simplify_head_pat p k - | Tpat_var (_,_) -> omega :: k - | Tpat_or (p1,p2,_) -> simplify_head_pat p1 (simplify_head_pat p2 k) + | Tpat_alias (p, _, _) -> simplify_head_pat p k + | Tpat_var (_, _) -> omega :: k + | Tpat_or (p1, p2, _) -> simplify_head_pat p1 (simplify_head_pat p2 k) | _ -> p :: k - in simplify_head_pat p k + in + simplify_head_pat p k let rec simplified_first_col = function | [] -> [] | [] :: _ -> assert false (* the rows are non-empty! *) - | (p::_) :: rows -> - simplify_head_pat p (simplified_first_col rows) + | (p :: _) :: rows -> simplify_head_pat p (simplified_first_col rows) (* Given the simplified first column of a matrix, this function first looks for a "discriminating" pattern on that column (i.e. a non-omega one) and then @@ -137,30 +137,26 @@ let rec simplified_first_col = function *) let all_coherent column = let coherent_heads hp1 hp2 = - match hp1.pat_desc, hp2.pat_desc with + match (hp1.pat_desc, hp2.pat_desc) with | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _ | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) -> assert false | Tpat_construct (_, c, _), Tpat_construct (_, c', _) -> - c.cstr_consts = c'.cstr_consts - && c.cstr_nonconsts = c'.cstr_nonconsts - | Tpat_constant c1, Tpat_constant c2 -> begin - match c1, c2 with - | Const_char _, Const_char _ - | Const_int _, Const_int _ - | Const_int32 _, Const_int32 _ - | Const_int64 _, Const_int64 _ - | Const_bigint _, Const_bigint _ - | Const_float _, Const_float _ - | Const_string _, Const_string _ -> true - | ( Const_char _ - | Const_int _ - | Const_int32 _ - | Const_int64 _ - | Const_bigint _ - | Const_float _ - | Const_string _), _ -> false - end + c.cstr_consts = c'.cstr_consts && c.cstr_nonconsts = c'.cstr_nonconsts + | Tpat_constant c1, Tpat_constant c2 -> ( + match (c1, c2) with + | Const_char _, Const_char _ + | Const_int _, Const_int _ + | Const_int32 _, Const_int32 _ + | Const_int64 _, Const_int64 _ + | Const_bigint _, Const_bigint _ + | Const_float _, Const_float _ + | Const_string _, Const_string _ -> + true + | ( ( Const_char _ | Const_int _ | Const_int32 _ | Const_int64 _ + | Const_bigint _ | Const_float _ | Const_string _ ), + _ ) -> + false) | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) -> Array.length lbl1.lbl_all = Array.length lbl2.lbl_all @@ -170,179 +166,170 @@ let all_coherent column = | Tpat_record (_, _), Tpat_record ([], _) | Tpat_variant _, Tpat_variant _ | Tpat_array _, Tpat_array _ - | Tpat_lazy _, Tpat_lazy _ -> true + | Tpat_lazy _, Tpat_lazy _ -> + true | _, _ -> false in match - List.find (fun head_pat -> - match head_pat.pat_desc with - | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false - | Tpat_any -> false - | _ -> true - ) column + List.find + (fun head_pat -> + match head_pat.pat_desc with + | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false + | Tpat_any -> false + | _ -> true) + column with | exception Not_found -> (* only omegas on the column: the column is coherent. *) true - | discr_pat -> - List.for_all (coherent_heads discr_pat) column + | discr_pat -> List.for_all (coherent_heads discr_pat) column -let first_column simplified_matrix = - List.map fst simplified_matrix +let first_column simplified_matrix = List.map fst simplified_matrix (***********************) (* Compatibility check *) (***********************) (* Patterns p and q compatible means: - there exists value V that matches both, However.... - - The case of extension types is dubious, as constructor rebind permits - that different constructors are the same (and are thus compatible). + there exists value V that matches both, However.... - Compilation must take this into account, consider: + The case of extension types is dubious, as constructor rebind permits + that different constructors are the same (and are thus compatible). - type t = .. - type t += A|B - type t += C=A + Compilation must take this into account, consider: - let f x y = match x,y with - | true,A -> '1' - | _,C -> '2' - | false,A -> '3' - | _,_ -> '_' + type t = .. + type t += A|B + type t += C=A - As C is bound to A the value of f false A is '2' (and not '3' as it would - be in the absence of rebinding). + let f x y = match x,y with + | true,A -> '1' + | _,C -> '2' + | false,A -> '3' + | _,_ -> '_' - Not considering rebinding, patterns "false,A" and "_,C" are incompatible - and the compiler can swap the second and third clause, resulting in the - (more efficiently compiled) matching + As C is bound to A the value of f false A is '2' (and not '3' as it would + be in the absence of rebinding). - match x,y with - | true,A -> '1' - | false,A -> '3' - | _,C -> '2' - | _,_ -> '_' + Not considering rebinding, patterns "false,A" and "_,C" are incompatible + and the compiler can swap the second and third clause, resulting in the + (more efficiently compiled) matching - This is not correct: when C is bound to A, "f false A" returns '2' (not '3') + match x,y with + | true,A -> '1' + | false,A -> '3' + | _,C -> '2' + | _,_ -> '_' + This is not correct: when C is bound to A, "f false A" returns '2' (not '3') - However, diagnostics do not take constructor rebinding into account. - Notice, that due to module abstraction constructor rebinding is hidden. - module X : sig type t = .. type t += A|B end = struct - type t = .. - type t += A - type t += B=A - end + However, diagnostics do not take constructor rebinding into account. + Notice, that due to module abstraction constructor rebinding is hidden. - open X + module X : sig type t = .. type t += A|B end = struct + type t = .. + type t += A + type t += B=A + end - let f x = match x with - | A -> '1' - | B -> '2' - | _ -> '_' + open X - The second clause above will NOT (and cannot) be flagged as useless. + let f x = match x with + | A -> '1' + | B -> '2' + | _ -> '_' - Finally, there are two compatibility fonction - compat p q ---> 'syntactic compatibility, used for diagnostics. - may_compat p q ---> a safe approximation of possible compat, - for compilation + The second clause above will NOT (and cannot) be flagged as useless. + Finally, there are two compatibility fonction + compat p q ---> 'syntactic compatibility, used for diagnostics. + may_compat p q ---> a safe approximation of possible compat, + for compilation *) - let is_absent tag row = Btype.row_field tag !row = Rabsent -let is_absent_pat p = match p.pat_desc with -| Tpat_variant (tag, _, row) -> is_absent tag row -| _ -> false +let is_absent_pat p = + match p.pat_desc with + | Tpat_variant (tag, _, row) -> is_absent tag row + | _ -> false let const_compare x y = - match x,y with + match (x, y) with | Const_float f1, Const_float f2 -> - compare (float_of_string f1) (float_of_string f2) + compare (float_of_string f1) (float_of_string f2) | Const_bigint (s1, b1), Const_bigint (s2, b2) -> - Bigint_utils.compare (s1, b1) (s2, b2) - | Const_string (s1, _), Const_string (s2, _) -> - String.compare s1 s2 + Bigint_utils.compare (s1, b1) (s2, b2) + | Const_string (s1, _), Const_string (s2, _) -> String.compare s1 s2 | _, _ -> compare x y let records_args l1 l2 = (* Invariant: fields are already sorted by Typecore.type_label_a_list *) - let rec combine r1 r2 l1 l2 = match l1,l2 with - | [],[] -> List.rev r1, List.rev r2 - | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 - | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] - | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 -> + let rec combine r1 r2 l1 l2 = + match (l1, l2) with + | [], [] -> (List.rev r1, List.rev r2) + | [], (_, _, p2) :: rem2 -> combine (omega :: r1) (p2 :: r2) [] rem2 + | (_, _, p1) :: rem1, [] -> combine (p1 :: r1) (omega :: r2) rem1 [] + | (_, lbl1, p1) :: rem1, (_, lbl2, p2) :: rem2 -> if lbl1.lbl_pos < lbl2.lbl_pos then - combine (p1::r1) (omega::r2) rem1 l2 + combine (p1 :: r1) (omega :: r2) rem1 l2 else if lbl1.lbl_pos > lbl2.lbl_pos then - combine (omega::r1) (p2::r2) l1 rem2 + combine (omega :: r1) (p2 :: r2) l1 rem2 else (* same label on both sides *) - combine (p1::r1) (p2::r2) rem1 rem2 in + combine (p1 :: r1) (p2 :: r2) rem1 rem2 + in combine [] [] l1 l2 - - -module Compat - (Constr:sig - val equal : - Types.constructor_description -> - Types.constructor_description -> - bool - end) = struct - - let rec compat p q = match p.pat_desc,q.pat_desc with -(* Variables match any value *) - | ((Tpat_any|Tpat_var _),_) - | (_,(Tpat_any|Tpat_var _)) -> true -(* Structural induction *) - | Tpat_alias (p,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_) -> compat p q - | Tpat_or (p1,p2,_),_ -> - (compat p1 q || compat p2 q) - | _,Tpat_or (q1,q2,_) -> - (compat p q1 || compat p q2) -(* Constructors, with special case for extension *) - | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) -> +module Compat (Constr : sig + val equal : + Types.constructor_description -> Types.constructor_description -> bool +end) = +struct + let rec compat p q = + match (p.pat_desc, q.pat_desc) with + (* Variables match any value *) + | (Tpat_any | Tpat_var _), _ | _, (Tpat_any | Tpat_var _) -> true + (* Structural induction *) + | Tpat_alias (p, _, _), _ -> compat p q + | _, Tpat_alias (q, _, _) -> compat p q + | Tpat_or (p1, p2, _), _ -> compat p1 q || compat p2 q + | _, Tpat_or (q1, q2, _) -> compat p q1 || compat p q2 + (* Constructors, with special case for extension *) + | Tpat_construct (_, c1, ps1), Tpat_construct (_, c2, ps2) -> Constr.equal c1 c2 && compats ps1 ps2 -(* More standard stuff *) - | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> - l1=l2 && ocompat op1 op2 - | Tpat_constant c1, Tpat_constant c2 -> - const_compare c1 c2 = 0 - | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs - | Tpat_lazy p, Tpat_lazy q -> compat p q - | Tpat_record (l1,_),Tpat_record (l2,_) -> - let ps,qs = records_args l1 l2 in + (* More standard stuff *) + | Tpat_variant (l1, op1, _), Tpat_variant (l2, op2, _) -> + l1 = l2 && ocompat op1 op2 + | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 + | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs + | Tpat_lazy p, Tpat_lazy q -> compat p q + | Tpat_record (l1, _), Tpat_record (l2, _) -> + let ps, qs = records_args l1 l2 in compats ps qs - | Tpat_array ps, Tpat_array qs -> - List.length ps = List.length qs && - compats ps qs - | _,_ -> false - - and ocompat op oq = match op,oq with - | None,None -> true - | Some p,Some q -> compat p q - | (None,Some _)|(Some _,None) -> false + | Tpat_array ps, Tpat_array qs -> + List.length ps = List.length qs && compats ps qs + | _, _ -> false - and compats ps qs = match ps,qs with - | [], [] -> true - | p::ps, q::qs -> compat p q && compats ps qs - | _,_ -> false + and ocompat op oq = + match (op, oq) with + | None, None -> true + | Some p, Some q -> compat p q + | None, Some _ | Some _, None -> false + and compats ps qs = + match (ps, qs) with + | [], [] -> true + | p :: ps, q :: qs -> compat p q && compats ps qs + | _, _ -> false end -module SyntacticCompat = - Compat - (struct - let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag - end) +module SyntacticCompat = Compat (struct + let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag +end) + +let compat = SyntacticCompat.compat -let compat = SyntacticCompat.compat and compats = SyntacticCompat.compats (* Due to (potential) rebinding, two extension constructors @@ -362,131 +349,116 @@ let clean_copy ty = let get_type_path ty tenv = let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in match ty.desc with - | Tconstr (path,_,_) -> path + | Tconstr (path, _, _) -> path | _ -> fatal_error "Parmatch.get_type_path" (*************************************) (* Values as patterns pretty printer *) (*************************************) -let print_res_pat: (Typedtree.pattern -> string) ref = +let print_res_pat : (Typedtree.pattern -> string) ref = ref (fun _ -> assert false) open Format -;; let is_cons = function -| {cstr_name = "::"} -> true -| _ -> false - -let pretty_const c = match c with -| Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) -| Const_string (s, _) -> Printf.sprintf "%S" s -| Const_float f -> Printf.sprintf "%s" f -| Const_int32 i -> Printf.sprintf "%ldl" i -| Const_int64 i -> Printf.sprintf "%LdL" i -| Const_bigint (sign, i) -> Printf.sprintf "%s" (Bigint_utils.to_string sign i) + | {cstr_name = "::"} -> true + | _ -> false + +let pretty_const c = + match c with + | Const_int i -> Printf.sprintf "%d" i + | Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) + | Const_string (s, _) -> Printf.sprintf "%S" s + | Const_float f -> Printf.sprintf "%s" f + | Const_int32 i -> Printf.sprintf "%ldl" i + | Const_int64 i -> Printf.sprintf "%LdL" i + | Const_bigint (sign, i) -> + Printf.sprintf "%s" (Bigint_utils.to_string sign i) let rec pretty_val ppf v = match v.pat_extra with - (cstr, _loc, _attrs) :: rem -> - begin match cstr with - | Tpat_unpack -> - fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_constraint _ -> - fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } - | Tpat_type _ -> - fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_open _ -> - fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } - end - | [] -> - match v.pat_desc with - | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) - | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) - | Tpat_tuple vs -> - fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct (_, cstr, []) -> - fprintf ppf "%s" cstr.cstr_name - | Tpat_construct (_, cstr, [w]) -> + | (cstr, _loc, _attrs) :: rem -> ( + match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_val {v with pat_extra = rem} + | Tpat_constraint _ -> + fprintf ppf "@[(%a : _)@]" pretty_val {v with pat_extra = rem} + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_val {v with pat_extra = rem} + | Tpat_open _ -> + fprintf ppf "@[(# %a)@]" pretty_val {v with pat_extra = rem}) + | [] -> ( + match v.pat_desc with + | Tpat_any -> fprintf ppf "_" + | Tpat_var (x, _) -> fprintf ppf "%s" (Ident.name x) + | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) + | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs + | Tpat_construct (_, cstr, []) -> fprintf ppf "%s" cstr.cstr_name + | Tpat_construct (_, cstr, [w]) -> fprintf ppf "@[<2>%s(%a)@]" cstr.cstr_name pretty_arg w - | Tpat_construct (_, cstr, vs) -> + | Tpat_construct (_, cstr, vs) -> ( let name = cstr.cstr_name in - begin match (name, vs) with - ("::", [v1;v2]) -> - fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 - | _ -> - fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs - end - | Tpat_variant (l, None, _) -> - fprintf ppf "#%s" l - | Tpat_variant (l, Some w, _) -> - fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w - | Tpat_record (lvs,_) -> - let filtered_lvs = Ext_list.filter lvs - (function - | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) - | _ -> true) in - begin match filtered_lvs with + match (name, vs) with + | "::", [v1; v2] -> fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 + | _ -> fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs) + | Tpat_variant (l, None, _) -> fprintf ppf "#%s" l + | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w + | Tpat_record (lvs, _) -> ( + let filtered_lvs = + Ext_list.filter lvs (function + | _, _, {pat_desc = Tpat_any} -> false (* do not show lbl=_ *) + | _ -> true) + in + match filtered_lvs with | [] -> fprintf ppf "_" | (_, _lbl, _) :: _q -> - let elision_mark _ = () in - fprintf ppf "@[{%a%t}@]" - pretty_lvals filtered_lvs elision_mark - end - | Tpat_array vs -> - fprintf ppf "@[[%a]@]" (pretty_vals ",") vs - | Tpat_lazy v -> - fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x,_) -> + let elision_mark _ = () in + fprintf ppf "@[{%a%t}@]" pretty_lvals filtered_lvs elision_mark) + | Tpat_array vs -> fprintf ppf "@[[%a]@]" (pretty_vals ",") vs + | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v + | Tpat_alias (v, x, _) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x - | Tpat_or (v,w,_) -> - fprintf ppf "@[%a | @,%a@]" pretty_or v pretty_or w - -and pretty_car ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [_ ; _]) - when is_cons cstr -> - fprintf ppf "(%a)" pretty_val v -| _ -> pretty_val ppf v - -and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [v1 ; v2]) - when is_cons cstr -> - fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 -| _ -> pretty_val ppf v - -and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_,_::_) -| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v -| _ -> pretty_val ppf v - -and pretty_or ppf v = match v.pat_desc with -| Tpat_or (v,w,_) -> - fprintf ppf "%a | @,%a" pretty_or v pretty_or w -| _ -> pretty_val ppf v + | Tpat_or (v, w, _) -> fprintf ppf "@[%a | @,%a@]" pretty_or v pretty_or w) + +and pretty_car ppf v = + match v.pat_desc with + | Tpat_construct (_, cstr, [_; _]) when is_cons cstr -> + fprintf ppf "(%a)" pretty_val v + | _ -> pretty_val ppf v + +and pretty_cdr ppf v = + match v.pat_desc with + | Tpat_construct (_, cstr, [v1; v2]) when is_cons cstr -> + fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 + | _ -> pretty_val ppf v + +and pretty_arg ppf v = + match v.pat_desc with + | Tpat_construct (_, _, _ :: _) | Tpat_variant (_, Some _, _) -> + fprintf ppf "(%a)" pretty_val v + | _ -> pretty_val ppf v + +and pretty_or ppf v = + match v.pat_desc with + | Tpat_or (v, w, _) -> fprintf ppf "%a | @,%a" pretty_or v pretty_or w + | _ -> pretty_val ppf v and pretty_vals sep ppf = function | [] -> () | [v] -> pretty_val ppf v - | v::vs -> - fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs + | v :: vs -> fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs and pretty_lvals ppf = function | [] -> () - | [_,lbl,v] -> - fprintf ppf "%s: %a" lbl.lbl_name pretty_val v - | (_, lbl,v)::rest -> - fprintf ppf "%s: %a,@ %a" - lbl.lbl_name pretty_val v pretty_lvals rest - -let top_pretty ppf v = - fprintf ppf "@[%a@]@?" pretty_val v + | [(_, lbl, v)] -> fprintf ppf "%s: %a" lbl.lbl_name pretty_val v + | (_, lbl, v) :: rest -> + fprintf ppf "%s: %a,@ %a" lbl.lbl_name pretty_val v pretty_lvals rest +let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v let pretty_pat p = - top_pretty Format.str_formatter p ; + top_pretty Format.str_formatter p; prerr_string (Format.flush_str_formatter ()) type matrix = pattern list list @@ -494,125 +466,115 @@ type matrix = pattern list list let pretty_line ps = List.iter (fun p -> - top_pretty Format.str_formatter p ; - prerr_string " <" ; - prerr_string (Format.flush_str_formatter ()) ; + top_pretty Format.str_formatter p; + prerr_string " <"; + prerr_string (Format.flush_str_formatter ()); prerr_string ">") ps let pretty_matrix (pss : matrix) = - prerr_endline "begin matrix" ; + prerr_endline "begin matrix"; List.iter (fun ps -> - pretty_line ps ; + pretty_line ps; prerr_endline "") - pss ; + pss; prerr_endline "end matrix" - (****************************) (* Utilities for matching *) (****************************) (* Check top matching *) let simple_match p1 p2 = - match p1.pat_desc, p2.pat_desc with - | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag - | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) -> - l1 = l2 - | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 + match (p1.pat_desc, p2.pat_desc) with + | Tpat_construct (_, c1, _), Tpat_construct (_, c2, _) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag + | Tpat_variant (l1, _, _), Tpat_variant (l2, _, _) -> l1 = l2 + | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 | Tpat_lazy _, Tpat_lazy _ -> true - | Tpat_record _ , Tpat_record _ -> true - | Tpat_tuple p1s, Tpat_tuple p2s - | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s - | _, (Tpat_any | Tpat_var(_)) -> true + | Tpat_record _, Tpat_record _ -> true + | Tpat_tuple p1s, Tpat_tuple p2s | Tpat_array p1s, Tpat_array p2s -> + List.length p1s = List.length p2s + | _, (Tpat_any | Tpat_var _) -> true | _, _ -> false - - - (* extract record fields as a whole *) -let record_arg p = match p.pat_desc with -| Tpat_any -> [] -| Tpat_record (args,_) -> args -| _ -> fatal_error "Parmatch.as_record" - +let record_arg p = + match p.pat_desc with + | Tpat_any -> [] + | Tpat_record (args, _) -> args + | _ -> fatal_error "Parmatch.as_record" (* Raise Not_found when pos is not present in arg *) let get_field pos arg = - let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in + let _, _, p = List.find (fun (_, lbl, _) -> pos = lbl.lbl_pos) arg in p let extract_fields omegas arg = List.map - (fun (_,lbl,_) -> - try - get_field lbl.lbl_pos arg - with Not_found -> omega) + (fun (_, lbl, _) -> try get_field lbl.lbl_pos arg with Not_found -> omega) omegas -let all_record_args lbls = match lbls with -| (_,{lbl_all=lbl_all},_)::_ -> +let all_record_args lbls = + match lbls with + | (_, {lbl_all}, _) :: _ -> let t = Array.map - (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega) - lbl_all in - List.iter - (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) - lbls ; + (fun lbl -> (mknoloc (Longident.Lident "?temp?"), lbl, omega)) + lbl_all + in + List.iter (fun ((_, lbl, _) as x) -> t.(lbl.lbl_pos) <- x) lbls; Array.to_list t -| _ -> fatal_error "Parmatch.all_record_args" - + | _ -> fatal_error "Parmatch.all_record_args" (* Build argument list when p2 >= p1, where p1 is a simple pattern *) -let rec simple_match_args p1 p2 = match p2.pat_desc with -| Tpat_alias (p2,_,_) -> simple_match_args p1 p2 -| Tpat_construct(_, _, args) -> args -| Tpat_variant(_, Some arg, _) -> [arg] -| Tpat_tuple(args) -> args -| Tpat_record(args,_) -> extract_fields (record_arg p1) args -| Tpat_array(args) -> args -| Tpat_lazy arg -> [arg] -| (Tpat_any | Tpat_var(_)) -> - begin match p1.pat_desc with - Tpat_construct(_, _,args) -> omega_list args - | Tpat_variant(_, Some _, _) -> [omega] - | Tpat_tuple(args) -> omega_list args - | Tpat_record(args,_) -> omega_list args - | Tpat_array(args) -> omega_list args +let rec simple_match_args p1 p2 = + match p2.pat_desc with + | Tpat_alias (p2, _, _) -> simple_match_args p1 p2 + | Tpat_construct (_, _, args) -> args + | Tpat_variant (_, Some arg, _) -> [arg] + | Tpat_tuple args -> args + | Tpat_record (args, _) -> extract_fields (record_arg p1) args + | Tpat_array args -> args + | Tpat_lazy arg -> [arg] + | Tpat_any | Tpat_var _ -> ( + match p1.pat_desc with + | Tpat_construct (_, _, args) -> omega_list args + | Tpat_variant (_, Some _, _) -> [omega] + | Tpat_tuple args -> omega_list args + | Tpat_record (args, _) -> omega_list args + | Tpat_array args -> omega_list args | Tpat_lazy _ -> [omega] - | _ -> [] - end -| _ -> [] + | _ -> []) + | _ -> [] (* Normalize a pattern -> all arguments are omega (simple pattern) and no more variables *) -let rec normalize_pat q = match q.pat_desc with +let rec normalize_pat q = + match q.pat_desc with | Tpat_any | Tpat_constant _ -> q | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env - | Tpat_alias (p,_,_) -> normalize_pat p - | Tpat_tuple (args) -> - make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env - | Tpat_construct (lid, c,args) -> - make_pat - (Tpat_construct (lid, c,omega_list args)) - q.pat_type q.pat_env + | Tpat_alias (p, _, _) -> normalize_pat p + | Tpat_tuple args -> + make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env + | Tpat_construct (lid, c, args) -> + make_pat (Tpat_construct (lid, c, omega_list args)) q.pat_type q.pat_env | Tpat_variant (l, arg, row) -> - make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row)) - q.pat_type q.pat_env - | Tpat_array (args) -> - make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env + make_pat + (Tpat_variant (l, may_map (fun _ -> omega) arg, row)) + q.pat_type q.pat_env + | Tpat_array args -> + make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env | Tpat_record (largs, closed) -> - make_pat - (Tpat_record (List.map (fun (lid,lbl,_) -> - lid, lbl,omega) largs, closed)) - q.pat_type q.pat_env - | Tpat_lazy _ -> - make_pat (Tpat_lazy omega) q.pat_type q.pat_env + make_pat + (Tpat_record + (List.map (fun (lid, lbl, _) -> (lid, lbl, omega)) largs, closed)) + q.pat_type q.pat_env + | Tpat_lazy _ -> make_pat (Tpat_lazy omega) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" (* @@ -621,34 +583,33 @@ let rec normalize_pat q = match q.pat_desc with *) let discr_pat q pss = - - let rec acc_pat acc pss = match pss with - ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss -> - acc_pat acc ((p::ps)::pss) - | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss -> - acc_pat acc ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss -> - acc_pat acc pss - | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p - | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p - | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss -> + let rec acc_pat acc pss = + match pss with + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + acc_pat acc ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + acc_pat acc ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> acc_pat acc pss + | (({pat_desc = Tpat_tuple _} as p) :: _) :: _ -> normalize_pat p + | (({pat_desc = Tpat_lazy _} as p) :: _) :: _ -> normalize_pat p + | (({pat_desc = Tpat_record (largs, closed)} as p) :: _) :: pss -> let new_omegas = List.fold_right - (fun (lid, lbl,_) r -> + (fun (lid, lbl, _) r -> try let _ = get_field lbl.lbl_pos r in r - with Not_found -> - (lid, lbl,omega)::r) + with Not_found -> (lid, lbl, omega) :: r) largs (record_arg acc) in acc_pat (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) pss - | _ -> acc in + | _ -> acc + in match normalize_pat q with - | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss + | {pat_desc = Tpat_any | Tpat_record _} as q -> acc_pat q pss | q -> q (* @@ -656,80 +617,75 @@ let discr_pat q pss = of the matching pattern. *) -let rec read_args xs r = match xs,r with -| [],_ -> [],r -| _::xs, arg::rest -> - let args,rest = read_args xs rest in - arg::args,rest -| _,_ -> - fatal_error "Parmatch.read_args" - -let do_set_args erase_mutable q r = match q with -| {pat_desc = Tpat_tuple omegas} -> - let args,rest = read_args omegas r in - make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest -| {pat_desc = Tpat_record (omegas,closed)} -> - let args,rest = read_args omegas r in +let rec read_args xs r = + match (xs, r) with + | [], _ -> ([], r) + | _ :: xs, arg :: rest -> + let args, rest = read_args xs rest in + (arg :: args, rest) + | _, _ -> fatal_error "Parmatch.read_args" + +let do_set_args erase_mutable q r = + match q with + | {pat_desc = Tpat_tuple omegas} -> + let args, rest = read_args omegas r in + make_pat (Tpat_tuple args) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_record (omegas, closed)} -> + let args, rest = read_args omegas r in make_pat (Tpat_record - (List.map2 (fun (lid, lbl,_) arg -> - if - erase_mutable && - (match lbl.lbl_mut with - | Mutable -> true | Immutable -> false) - then - lid, lbl, omega - else - lid, lbl, arg) - omegas args, closed)) - q.pat_type q.pat_env:: - rest -| {pat_desc = Tpat_construct (lid, c,omegas)} -> - let args,rest = read_args omegas r in - make_pat - (Tpat_construct (lid, c,args)) - q.pat_type q.pat_env:: - rest -| {pat_desc = Tpat_variant (l, omega, row)} -> + ( List.map2 + (fun (lid, lbl, _) arg -> + if + erase_mutable + && + match lbl.lbl_mut with + | Mutable -> true + | Immutable -> false + then (lid, lbl, omega) + else (lid, lbl, arg)) + omegas args, + closed )) + q.pat_type q.pat_env + :: rest + | {pat_desc = Tpat_construct (lid, c, omegas)} -> + let args, rest = read_args omegas r in + make_pat (Tpat_construct (lid, c, args)) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_variant (l, omega, row)} -> let arg, rest = - match omega, r with - Some _, a::r -> Some a, r - | None, r -> None, r + match (omega, r) with + | Some _, a :: r -> (Some a, r) + | None, r -> (None, r) | _ -> assert false in - make_pat - (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: - rest -| {pat_desc = Tpat_lazy _omega} -> - begin match r with - arg::rest -> - make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest - | _ -> fatal_error "Parmatch.do_set_args (lazy)" - end -| {pat_desc = Tpat_array omegas} -> - let args,rest = read_args omegas r in - make_pat - (Tpat_array args) q.pat_type q.pat_env:: - rest -| {pat_desc=Tpat_constant _|Tpat_any} -> - q::r (* case any is used in matching.ml *) -| _ -> fatal_error "Parmatch.set_args" + make_pat (Tpat_variant (l, arg, row)) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_lazy _omega} -> ( + match r with + | arg :: rest -> make_pat (Tpat_lazy arg) q.pat_type q.pat_env :: rest + | _ -> fatal_error "Parmatch.do_set_args (lazy)") + | {pat_desc = Tpat_array omegas} -> + let args, rest = read_args omegas r in + make_pat (Tpat_array args) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_constant _ | Tpat_any} -> + q :: r (* case any is used in matching.ml *) + | _ -> fatal_error "Parmatch.set_args" let set_args q r = do_set_args false q r + and set_args_erase_mutable q r = do_set_args true q r (* filter pss according to pattern q *) let filter_one q pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_rec ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_rec ((p1::ps)::(p2::ps)::pss) - | (p::ps)::pss -> - if simple_match q p - then (simple_match_args q p @ ps) :: filter_rec pss - else filter_rec pss - | _ -> [] in + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_rec ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_rec ((p1 :: ps) :: (p2 :: ps) :: pss) + | (p :: ps) :: pss -> + if simple_match q p then (simple_match_args q p @ ps) :: filter_rec pss + else filter_rec pss + | _ -> [] + in filter_rec pss (* @@ -739,14 +695,14 @@ let filter_one q pss = *) let filter_extra pss = let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_rec ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_rec ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss -> - qs :: filter_rec pss - | _::pss -> filter_rec pss - | [] -> [] in + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_rec ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_rec ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: qs) :: pss -> qs :: filter_rec pss + | _ :: pss -> filter_rec pss + | [] -> [] + in filter_rec pss (* @@ -762,91 +718,95 @@ let filter_extra pss = *) let filter_all pat0 pss = - let rec insert q qs env = match env with - [] -> - let q0 = normalize_pat q in - [q0, [simple_match_args q0 q @ qs]] - | ((q0,pss) as c)::env -> - if simple_match q0 q - then (q0, ((simple_match_args q0 q @ qs) :: pss)) :: env - else c :: insert q qs env in + | [] -> + let q0 = normalize_pat q in + [(q0, [simple_match_args q0 q @ qs])] + | ((q0, pss) as c) :: env -> + if simple_match q0 q then + (q0, (simple_match_args q0 q @ qs) :: pss) :: env + else c :: insert q qs env + in let rec filter_rec env = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_rec env ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_rec env ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss -> - filter_rec env pss - | (p::ps)::pss -> - filter_rec (insert p ps env) pss - | _ -> env - + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_rec env ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_rec env ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> filter_rec env pss + | (p :: ps) :: pss -> filter_rec (insert p ps env) pss + | _ -> env and filter_omega env = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_omega env ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_omega env ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss -> + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_omega env ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_omega env ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: ps) :: pss -> filter_omega - (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) + (List.map + (fun (q, qss) -> (q, (simple_match_args q omega @ ps) :: qss)) env) pss - | _::pss -> filter_omega env pss - | [] -> env in + | _ :: pss -> filter_omega env pss + | [] -> env + in filter_omega (filter_rec - (match pat0.pat_desc with - (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]] - | _ -> []) - pss) + (match pat0.pat_desc with + | Tpat_record _ | Tpat_tuple _ | Tpat_lazy _ -> [(pat0, [])] + | _ -> []) + pss) pss (* Variant related functions *) let rec set_last a = function - [] -> [] + | [] -> [] | [_] -> [a] - | x::l -> x :: set_last a l + | x :: l -> x :: set_last a l (* mark constructor lines for failure when they are incomplete *) let rec mark_partial = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - mark_partial ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - mark_partial ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))} :: _ as ps) :: pss -> - ps :: mark_partial pss - | ps::pss -> - (set_last zero ps) :: mark_partial pss + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + mark_partial ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + mark_partial ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: _ as ps) :: pss -> + ps :: mark_partial pss + | ps :: pss -> set_last zero ps :: mark_partial pss | [] -> [] let close_variant env row = let row = Btype.row_repr row in let nm = List.fold_left - (fun nm (_tag,f) -> + (fun nm (_tag, f) -> match Btype.row_field_repr f with - | Reither(_, _, false, e) -> - (* m=false means that this tag is not explicitly matched *) - Btype.set_row_field e Rabsent; - None + | Reither (_, _, false, e) -> + (* m=false means that this tag is not explicitly matched *) + Btype.set_row_field e Rabsent; + None | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) - row.row_name row.row_fields in - if not row.row_closed || nm != row.row_name then begin + row.row_name row.row_fields + in + if (not row.row_closed) || nm != row.row_name then (* this unification cannot fail *) Ctype.unify env row.row_more (Btype.newgenty - (Tvariant {row with row_fields = []; row_more = Btype.newgenvar(); - row_closed = true; row_name = nm})) - end + (Tvariant + { + row with + row_fields = []; + row_more = Btype.newgenvar (); + row_closed = true; + row_name = nm; + })) let row_of_pat pat = match Ctype.expand_head pat.pat_env pat.pat_type with - {desc = Tvariant row} -> Btype.row_repr row + | {desc = Tvariant row} -> Btype.row_repr row | _ -> assert false (* @@ -854,14 +814,16 @@ let row_of_pat pat = not. *) -let full_match closing env = match env with -| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ -> +let full_match closing env = + match env with + | ({pat_desc = Tpat_construct (_, c, _)}, _) :: _ -> if c.cstr_consts < 0 then false (* extensions *) else List.length env = c.cstr_consts + c.cstr_nonconsts -| ({pat_desc = Tpat_variant _} as p,_) :: _ -> + | (({pat_desc = Tpat_variant _} as p), _) :: _ -> let fields = List.map - (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag + (function + | {pat_desc = Tpat_variant (tag, _, _)}, _ -> tag | _ -> assert false) env in @@ -869,57 +831,53 @@ let full_match closing env = match env with if closing && not (Btype.row_fixed row) then (* closing=true, we are considering the variant as closed *) List.for_all - (fun (tag,f) -> + (fun (tag, f) -> match Btype.row_field_repr f with - Rabsent | Reither(_, _, false, _) -> true + | Rabsent | Reither (_, _, false, _) -> true | Reither (_, _, true, _) - (* m=true, do not discard matched tags, rather warn *) - | Rpresent _ -> List.mem tag fields) + (* m=true, do not discard matched tags, rather warn *) + | Rpresent _ -> + List.mem tag fields) row.row_fields else - row.row_closed && - List.for_all - (fun (tag,f) -> - Btype.row_field_repr f = Rabsent || List.mem tag fields) - row.row_fields -| ({pat_desc = Tpat_constant(_)},_) :: _ -> false -| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true -| ({pat_desc = Tpat_record(_)},_) :: _ -> true -| ({pat_desc = Tpat_array(_)},_) :: _ -> false -| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true -| ({pat_desc = (Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _)},_) :: _ -| [] - -> + row.row_closed + && List.for_all + (fun (tag, f) -> + Btype.row_field_repr f = Rabsent || List.mem tag fields) + row.row_fields + | ({pat_desc = Tpat_constant _}, _) :: _ -> false + | ({pat_desc = Tpat_tuple _}, _) :: _ -> true + | ({pat_desc = Tpat_record _}, _) :: _ -> true + | ({pat_desc = Tpat_array _}, _) :: _ -> false + | ({pat_desc = Tpat_lazy _}, _) :: _ -> true + | ({pat_desc = Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _}, _) :: _ | [] + -> assert false (* Written as a non-fragile matching, PR#7451 originated from a fragile matching below. *) -let should_extend ext env = match ext with -| None -> false -| Some ext -> begin match env with - | [] -> assert false - | (p,_)::_ -> - begin match p.pat_desc with - | Tpat_construct - (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) -> - let path = get_type_path p.pat_type p.pat_env in - Path.same path ext +let should_extend ext env = + match ext with + | None -> false + | Some ext -> ( + match env with + | [] -> assert false + | (p, _) :: _ -> ( + match p.pat_desc with | Tpat_construct - (_, {cstr_tag=(Cstr_extension _)},_) -> false - | Tpat_constant _|Tpat_tuple _|Tpat_variant _ - | Tpat_record _|Tpat_array _ | Tpat_lazy _ - -> false - | Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _ - -> assert false - end -end - -module ConstructorTagHashtbl = Hashtbl.Make( - struct - type t = Types.constructor_tag - let hash = Hashtbl.hash - let equal = Types.equal_tag - end -) + (_, {cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed}, _) -> + let path = get_type_path p.pat_type p.pat_env in + Path.same path ext + | Tpat_construct (_, {cstr_tag = Cstr_extension _}, _) -> false + | Tpat_constant _ | Tpat_tuple _ | Tpat_variant _ | Tpat_record _ + | Tpat_array _ | Tpat_lazy _ -> + false + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false)) + +module ConstructorTagHashtbl = Hashtbl.Make (struct + type t = Types.constructor_tag + let hash = Hashtbl.hash + let equal = Types.equal_tag +end) (* complement constructor tags *) let complete_tags nconsts nconstrs tags = @@ -929,97 +887,104 @@ let complete_tags nconsts nconstrs tags = (function | Cstr_constant i -> seen_const.(i) <- true | Cstr_block i -> seen_constr.(i) <- true - | _ -> assert false) - tags ; - let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in - for i = 0 to nconsts-1 do - if not seen_const.(i) then - ConstructorTagHashtbl.add r (Cstr_constant i) () - done ; - for i = 0 to nconstrs-1 do - if not seen_constr.(i) then - ConstructorTagHashtbl.add r (Cstr_block i) () - done ; + | _ -> assert false) + tags; + let r = ConstructorTagHashtbl.create (nconsts + nconstrs) in + for i = 0 to nconsts - 1 do + if not seen_const.(i) then ConstructorTagHashtbl.add r (Cstr_constant i) () + done; + for i = 0 to nconstrs - 1 do + if not seen_constr.(i) then ConstructorTagHashtbl.add r (Cstr_block i) () + done; r (* build a pattern from a constructor list *) let pat_of_constr ex_pat cstr = - {ex_pat with pat_desc = - Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"), - cstr, omegas cstr.cstr_arity)} + { + ex_pat with + pat_desc = + Tpat_construct + ( mknoloc (Longident.Lident "?pat_of_constr?"), + cstr, + omegas cstr.cstr_arity ); + } let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env let rec orify_many = function -| [] -> assert false -| [x] -> x -| x :: xs -> orify x (orify_many xs) + | [] -> assert false + | [x] -> x + | x :: xs -> orify x (orify_many xs) let pat_of_constrs ex_pat cstrs = - if cstrs = [] then raise Empty else - orify_many (List.map (pat_of_constr ex_pat) cstrs) + if cstrs = [] then raise Empty + else orify_many (List.map (pat_of_constr ex_pat) cstrs) -let pats_of_type ?(always=false) env ty = +let pats_of_type ?(always = false) env ty = let ty' = Ctype.expand_head env ty in match ty'.desc with - | Tconstr (path, _, _) -> - begin try match (Env.find_type path env).type_kind with - | Type_variant cl when always || List.length cl = 1 || - List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> - let cstrs = fst (Env.find_type_descrs path env) in - List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs + | Tconstr (path, _, _) -> ( + try + match (Env.find_type path env).type_kind with + | Type_variant cl + when always + || List.length cl = 1 + || List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> + let cstrs = fst (Env.find_type_descrs path env) in + List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs | Type_record _ -> - let labels = snd (Env.find_type_descrs path env) in - let fields = - List.map (fun ld -> - mknoloc (Longident.Lident "?pat_of_label?"), ld, omega) - labels - in - [make_pat (Tpat_record (fields, Closed)) ty env] + let labels = snd (Env.find_type_descrs path env) in + let fields = + List.map + (fun ld -> (mknoloc (Longident.Lident "?pat_of_label?"), ld, omega)) + labels + in + [make_pat (Tpat_record (fields, Closed)) ty env] | _ -> [omega] - with Not_found -> [omega] - end - | Ttuple tl -> - [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + with Not_found -> [omega]) + | Ttuple tl -> [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] | _ -> [omega] let rec get_variant_constructors env ty = match (Ctype.repr ty).desc with - | Tconstr (path,_,_) -> begin - try match Env.find_type path env with - | {type_kind=Type_variant _} -> - fst (Env.find_type_descrs path env) + | Tconstr (path, _, _) -> ( + try + match Env.find_type path env with + | {type_kind = Type_variant _} -> fst (Env.find_type_descrs path env) | {type_manifest = Some _} -> - get_variant_constructors env - (Ctype.expand_head_once env (clean_copy ty)) + get_variant_constructors env + (Ctype.expand_head_once env (clean_copy ty)) | _ -> fatal_error "Parmatch.get_variant_constructors" - with Not_found -> - fatal_error "Parmatch.get_variant_constructors" - end + with Not_found -> fatal_error "Parmatch.get_variant_constructors") | _ -> fatal_error "Parmatch.get_variant_constructors" (* Sends back a pattern that complements constructor tags all_tag *) let complete_constrs p all_tags = let c = - match p.pat_desc with Tpat_construct (_, c, _) -> c | _ -> assert false in + match p.pat_desc with + | Tpat_construct (_, c, _) -> c + | _ -> assert false + in let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in let constrs = get_variant_constructors p.pat_env c.cstr_res in let others = - Ext_list.filter constrs - (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) + Ext_list.filter constrs (fun cnstr -> + ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) in let const, nonconst = - List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in + List.partition (fun cnstr -> cnstr.cstr_arity = 0) others + in const @ nonconst let build_other_constrs env p = match p.pat_desc with - Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) -> - let get_tag = function - | {pat_desc = Tpat_construct (_,c,_)} -> c.cstr_tag - | _ -> fatal_error "Parmatch.get_tag" in - let all_tags = List.map (fun (p,_) -> get_tag p) env in - pat_of_constrs p (complete_constrs p all_tags) + | Tpat_construct (_, {cstr_tag = Cstr_constant _ | Cstr_block _}, _) -> + let get_tag = function + | {pat_desc = Tpat_construct (_, c, _)} -> c.cstr_tag + | _ -> fatal_error "Parmatch.get_tag" + in + let all_tags = List.map (fun (p, _) -> get_tag p) env in + pat_of_constrs p (complete_constrs p all_tags) | _ -> extra_pat (* Auxiliary for build_other *) @@ -1027,10 +992,10 @@ let build_other_constrs env p = let build_other_constant proj make first next p env = let all = List.map (fun (p, _) -> proj p.pat_desc) env in let rec try_const i = - if List.mem i all - then try_const (next i) + if List.mem i all then try_const (next i) else make_pat (make i) p.pat_type p.pat_env - in try_const first + in + try_const first (* Builds a pattern that is incompatible with all patterns in @@ -1039,105 +1004,126 @@ let build_other_constant proj make first next p env = let some_other_tag = "" -let build_other ext env : Typedtree.pattern = match env with -| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ -> - (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) - make_pat (Tpat_var (Ident.create "*extension*", - {lid with txt="*extension*"})) Ctype.none Env.empty -| ({pat_desc = Tpat_construct _} as p,_) :: _ -> - begin match ext with +let build_other ext env : Typedtree.pattern = + match env with + | ({pat_desc = Tpat_construct (lid, {cstr_tag = Cstr_extension _}, _)}, _) + :: _ -> + (* let c = {c with cstr_name = "*extension*"} in *) + (* PR#7330 *) + make_pat + (Tpat_var (Ident.create "*extension*", {lid with txt = "*extension*"})) + Ctype.none Env.empty + | (({pat_desc = Tpat_construct _} as p), _) :: _ -> ( + match ext with | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> - extra_pat - | _ -> - build_other_constrs env p - end -| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ -> + extra_pat + | _ -> build_other_constrs env p) + | (({pat_desc = Tpat_variant (_, _, r)} as p), _) :: _ -> ( let tags = List.map - (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag - | _ -> assert false) + (function + | {pat_desc = Tpat_variant (tag, _, _)}, _ -> tag + | _ -> assert false) env in let row = row_of_pat p in let make_other_pat tag const = let arg = if const then None else Some omega in - make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in - begin match + make_pat (Tpat_variant (tag, arg, r)) p.pat_type p.pat_env + in + match List.fold_left - (fun others (tag,f) -> - if List.mem tag tags then others else - match Btype.row_field_repr f with - Rabsent (* | Reither _ *) -> others - (* This one is called after erasing pattern info *) - | Reither (c, _, _, _) -> make_other_pat tag c :: others - | Rpresent arg -> make_other_pat tag (arg = None) :: others) + (fun others (tag, f) -> + if List.mem tag tags then others + else + match Btype.row_field_repr f with + | Rabsent (* | Reither _ *) -> others + (* This one is called after erasing pattern info *) + | Reither (c, _, _, _) -> make_other_pat tag c :: others + | Rpresent arg -> make_other_pat tag (arg = None) :: others) [] row.row_fields with - [] -> - make_other_pat some_other_tag true - | pat::other_pats -> - List.fold_left - (fun p_res pat -> - make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) - pat other_pats - end -| ({pat_desc=(Tpat_constant (Const_int _ ))} as p,_) :: _ -> + | [] -> make_other_pat some_other_tag true + | pat :: other_pats -> + List.fold_left + (fun p_res pat -> + make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) + pat other_pats) + | (({pat_desc = Tpat_constant (Const_int _)} as p), _) :: _ -> build_other_constant - (function Tpat_constant(Const_int i) -> i - | _ -> assert false) - (function i -> Tpat_constant(Const_int i)) + (function + | Tpat_constant (Const_int i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_int i)) 0 succ p env -| ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> - build_other_constant - (function - | Tpat_constant (Const_char i) -> i - | _ -> assert false) - (function i -> Tpat_constant(Const_char i)) - 0 succ p env -| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> + | (({pat_desc = Tpat_constant (Const_char _)} as p), _) :: _ -> build_other_constant - (function Tpat_constant(Const_int32 i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_int32 i)) + (function + | Tpat_constant (Const_char i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_char i)) + 0 succ p env + | (({pat_desc = Tpat_constant (Const_int32 _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_int32 i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_int32 i)) 0l Int32.succ p env -| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ -> + | (({pat_desc = Tpat_constant (Const_int64 _)} as p), _) :: _ -> build_other_constant - (function Tpat_constant(Const_int64 i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_int64 i)) + (function + | Tpat_constant (Const_int64 i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_int64 i)) 0L Int64.succ p env -| ({pat_desc=(Tpat_constant (Const_bigint _))} as p,_) :: _ -> + | (({pat_desc = Tpat_constant (Const_bigint _)} as p), _) :: _ -> build_other_constant - (function Tpat_constant(Const_bigint (sign, i)) -> String.length (Bigint_utils.to_string sign i) | _ -> assert false) - (function i -> Tpat_constant(Const_bigint (true, (string_of_int i)))) + (function + | Tpat_constant (Const_bigint (sign, i)) -> + String.length (Bigint_utils.to_string sign i) + | _ -> assert false) + (function + | i -> Tpat_constant (Const_bigint (true, string_of_int i))) 0 succ p env -| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ -> + | (({pat_desc = Tpat_constant (Const_string _)} as p), _) :: _ -> build_other_constant - (function Tpat_constant(Const_string (s, _)) -> String.length s - | _ -> assert false) - (function i -> Tpat_constant(Const_string(String.make i '*', None))) + (function + | Tpat_constant (Const_string (s, _)) -> String.length s + | _ -> assert false) + (function + | i -> Tpat_constant (Const_string (String.make i '*', None))) 0 succ p env -| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ -> + | (({pat_desc = Tpat_constant (Const_float _)} as p), _) :: _ -> build_other_constant - (function Tpat_constant(Const_float f) -> float_of_string f - | _ -> assert false) - (function f -> Tpat_constant(Const_float (string_of_float f))) - 0.0 (fun f -> f +. 1.0) p env - -| ({pat_desc = Tpat_array _} as p,_)::_ -> + (function + | Tpat_constant (Const_float f) -> float_of_string f + | _ -> assert false) + (function + | f -> Tpat_constant (Const_float (string_of_float f))) + 0.0 + (fun f -> f +. 1.0) + p env + | (({pat_desc = Tpat_array _} as p), _) :: _ -> let all_lengths = List.map - (fun (p,_) -> match p.pat_desc with - | Tpat_array args -> List.length args - | _ -> assert false) - env in + (fun (p, _) -> + match p.pat_desc with + | Tpat_array args -> List.length args + | _ -> assert false) + env + in let rec try_arrays l = - if List.mem l all_lengths then try_arrays (l+1) - else - make_pat - (Tpat_array (omegas l)) - p.pat_type p.pat_env in + if List.mem l all_lengths then try_arrays (l + 1) + else make_pat (Tpat_array (omegas l)) p.pat_type p.pat_env + in try_arrays 0 -| [] -> omega -| _ -> omega + | [] -> omega + | _ -> omega (* Core function : @@ -1148,21 +1134,20 @@ let build_other ext env : Typedtree.pattern = match env with 2- qs <= es (es matches qs) *) -let rec has_instance p = match p.pat_desc with - | Tpat_variant (l,_,r) when is_absent l r -> false - | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p - | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 - | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps -> - has_instances ps - | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) - | Tpat_lazy p - -> has_instance p - +let rec has_instance p = + match p.pat_desc with + | Tpat_variant (l, _, r) when is_absent l r -> false + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> true + | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> has_instance p + | Tpat_or (p1, p2, _) -> has_instance p1 || has_instance p2 + | Tpat_construct (_, _, ps) | Tpat_tuple ps | Tpat_array ps -> + has_instances ps + | Tpat_record (lps, _) -> has_instances (List.map (fun (_, _, x) -> x) lps) + | Tpat_lazy p -> has_instance p and has_instances = function | [] -> true - | q::rem -> has_instance q && has_instances rem + | q :: rem -> has_instance q && has_instances rem (* In two places in the following function, we check the coherence of the first @@ -1178,93 +1163,85 @@ and has_instances = function it is not. This is sad but not the end of the world, we're just allowing dead code to survive. *) -let rec satisfiable pss qs = match pss with -| [] -> has_instances qs -| _ -> +let rec satisfiable pss qs = + match pss with + | [] -> has_instances qs + | _ -> ( match qs with | [] -> false - | {pat_desc = Tpat_or(q1,q2,_)}::qs -> - satisfiable pss (q1::qs) || satisfiable pss (q2::qs) - | {pat_desc = Tpat_alias(q,_,_)}::qs -> - satisfiable pss (q::qs) - | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> - if not (all_coherent (simplified_first_col pss)) then - false - else begin - let q0 = discr_pat omega pss in - match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> satisfiable (filter_extra pss) qs - | constrs -> - if full_match false constrs then - List.exists - (fun (p,pss) -> - not (is_absent_pat p) && - satisfiable pss (simple_match_args p omega @ qs)) - constrs - else - satisfiable (filter_extra pss) qs - end - | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false - | q::qs -> - if not (all_coherent (q :: simplified_first_col pss)) then - false - else begin - let q0 = discr_pat q pss in - satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs) - end + | {pat_desc = Tpat_or (q1, q2, _)} :: qs -> + satisfiable pss (q1 :: qs) || satisfiable pss (q2 :: qs) + | {pat_desc = Tpat_alias (q, _, _)} :: qs -> satisfiable pss (q :: qs) + | {pat_desc = Tpat_any | Tpat_var _} :: qs -> ( + if not (all_coherent (simplified_first_col pss)) then false + else + let q0 = discr_pat omega pss in + match filter_all q0 pss with + (* first column of pss is made of variables only *) + | [] -> satisfiable (filter_extra pss) qs + | constrs -> + if full_match false constrs then + List.exists + (fun (p, pss) -> + (not (is_absent_pat p)) + && satisfiable pss (simple_match_args p omega @ qs)) + constrs + else satisfiable (filter_extra pss) qs) + | {pat_desc = Tpat_variant (l, _, r)} :: _ when is_absent l r -> false + | q :: qs -> + if not (all_coherent (q :: simplified_first_col pss)) then false + else + let q0 = discr_pat q pss in + satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)) (* Also return the remaining cases, to enable GADT handling For considerations regarding the coherence check, see the comment on - [satisfiable] above. *) -let rec satisfiables pss qs = match pss with -| [] -> if has_instances qs then [qs] else [] -| _ -> + [satisfiable] above. *) +let rec satisfiables pss qs = + match pss with + | [] -> if has_instances qs then [qs] else [] + | _ -> ( match qs with | [] -> [] - | {pat_desc = Tpat_or(q1,q2,_)}::qs -> - satisfiables pss (q1::qs) @ satisfiables pss (q2::qs) - | {pat_desc = Tpat_alias(q,_,_)}::qs -> - satisfiables pss (q::qs) - | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> - if not (all_coherent (simplified_first_col pss)) then - [] - else begin - let q0 = discr_pat omega pss in - let wild p = - List.map (fun qs -> p::qs) (satisfiables (filter_extra pss) qs) in - match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> - wild omega - | (p,_)::_ as constrs -> - let for_constrs () = - List.flatten ( - List.map - (fun (p,pss) -> - if is_absent_pat p then [] else - List.map (set_args p) - (satisfiables pss (simple_match_args p omega @ qs))) - constrs ) - in - if full_match false constrs then for_constrs () else - match p.pat_desc with - Tpat_construct _ -> - (* activate this code for checking non-gadt constructors *) - wild (build_other_constrs constrs p) @ for_constrs () - | _ -> - wild omega - end - | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> [] - | q::qs -> - if not (all_coherent (q :: simplified_first_col pss)) then - [] - else begin - let q0 = discr_pat q pss in - List.map (set_args q0) - (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs)) - end + | {pat_desc = Tpat_or (q1, q2, _)} :: qs -> + satisfiables pss (q1 :: qs) @ satisfiables pss (q2 :: qs) + | {pat_desc = Tpat_alias (q, _, _)} :: qs -> satisfiables pss (q :: qs) + | {pat_desc = Tpat_any | Tpat_var _} :: qs -> ( + if not (all_coherent (simplified_first_col pss)) then [] + else + let q0 = discr_pat omega pss in + let wild p = + List.map (fun qs -> p :: qs) (satisfiables (filter_extra pss) qs) + in + match filter_all q0 pss with + (* first column of pss is made of variables only *) + | [] -> wild omega + | (p, _) :: _ as constrs -> ( + let for_constrs () = + List.flatten + (List.map + (fun (p, pss) -> + if is_absent_pat p then [] + else + List.map (set_args p) + (satisfiables pss (simple_match_args p omega @ qs))) + constrs) + in + if full_match false constrs then for_constrs () + else + match p.pat_desc with + | Tpat_construct _ -> + (* activate this code for checking non-gadt constructors *) + wild (build_other_constrs constrs p) @ for_constrs () + | _ -> wild omega)) + | {pat_desc = Tpat_variant (l, _, r)} :: _ when is_absent l r -> [] + | q :: qs -> + if not (all_coherent (q :: simplified_first_col pss)) then [] + else + let q0 = discr_pat q pss in + List.map (set_args q0) + (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs))) (* Now another satisfiable function that additionally @@ -1274,8 +1251,8 @@ let rec satisfiables pss qs = match pss with *) type 'a result = - | Rnone (* No matching value *) - | Rsome of 'a (* This matching value *) + | Rnone (* No matching value *) + | Rsome of 'a (* This matching value *) (* let rec try_many f = function @@ -1287,15 +1264,14 @@ let rec try_many f = function *) let rappend r1 r2 = - match r1, r2 with + match (r1, r2) with | Rnone, _ -> r2 | _, Rnone -> r1 | Rsome l1, Rsome l2 -> Rsome (l1 @ l2) -let rec try_many_gadt f = function +let rec try_many_gadt f = function | [] -> Rnone - | (p,pss)::rest -> - rappend (f (p, pss)) (try_many_gadt f rest) + | (p, pss) :: rest -> rappend (f (p, pss)) (try_many_gadt f rest) (* let rec exhaust ext pss n = match pss with @@ -1384,15 +1360,16 @@ let print_pat pat = (* strictly more powerful than exhaust; however, exhaust was kept for backwards compatibility *) -let rec exhaust_gadt (ext:Path.t option) pss n = match pss with -| [] -> Rsome [omegas n] -| []::_ -> Rnone -| pss -> +let rec exhaust_gadt (ext : Path.t option) pss n = + match pss with + | [] -> Rsome [omegas n] + | [] :: _ -> Rnone + | pss -> ( if not (all_coherent (simplified_first_col pss)) then (* We're considering an ill-typed branch, we won't actually be able to produce a well typed value taking that branch. *) Rnone - else begin + else (* Assuming the first column is ill-typed but considered coherent, we might end up producing an ill-typed witness of non-exhaustivity corresponding to the current branch. @@ -1405,30 +1382,27 @@ let rec exhaust_gadt (ext:Path.t option) pss n = match pss with example testsuite/tests/warnings/w04_failure.ml. *) let q0 = discr_pat omega pss in match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> - begin match exhaust_gadt ext (filter_extra pss) (n-1) with - | Rsome r -> Rsome (List.map (fun row -> q0::row) r) - | r -> r - end - | constrs -> - let try_non_omega (p,pss) = - if is_absent_pat p then - Rnone - else - match - exhaust_gadt - ext pss (List.length (simple_match_args p omega) + n - 1) - with - | Rsome r -> Rsome (List.map (fun row -> (set_args p row)) r) - | r -> r in - let before = try_many_gadt try_non_omega constrs in - if - full_match false constrs && not (should_extend ext constrs) - then - before + (* first column of pss is made of variables only *) + | [] -> ( + match exhaust_gadt ext (filter_extra pss) (n - 1) with + | Rsome r -> Rsome (List.map (fun row -> q0 :: row) r) + | r -> r) + | constrs -> ( + let try_non_omega (p, pss) = + if is_absent_pat p then Rnone else - (* + match + exhaust_gadt ext pss + (List.length (simple_match_args p omega) + n - 1) + with + | Rsome r -> Rsome (List.map (fun row -> set_args p row) r) + | r -> r + in + let before = try_many_gadt try_non_omega constrs in + if full_match false constrs && not (should_extend ext constrs) then + before + else + (* D = filter_extra pss is the default matrix as it is included in pss, one can avoid recursive calls on specialized matrices, @@ -1436,32 +1410,33 @@ let rec exhaust_gadt (ext:Path.t option) pss n = match pss with * D exhaustive => pss exhaustive * D non-exhaustive => we have a non-filtered value *) - let r = exhaust_gadt ext (filter_extra pss) (n-1) in - match r with - | Rnone -> before - | Rsome r -> - try - let p = build_other ext constrs in - let dug = List.map (fun tail -> p :: tail) r in - match before with - | Rnone -> Rsome dug - | Rsome x -> Rsome (x @ dug) - with - (* cannot occur, since constructors don't make a full signature *) - | Empty -> fatal_error "Parmatch.exhaust" - end + let r = exhaust_gadt ext (filter_extra pss) (n - 1) in + match r with + | Rnone -> before + | Rsome r -> ( + try + let p = build_other ext constrs in + let dug = List.map (fun tail -> p :: tail) r in + match before with + | Rnone -> Rsome dug + | Rsome x -> Rsome (x @ dug) + with + (* cannot occur, since constructors don't make a full signature *) + | Empty -> + fatal_error "Parmatch.exhaust"))) let exhaust_gadt ext pss n = let ret = exhaust_gadt ext pss n in match ret with - Rnone -> Rnone + | Rnone -> Rnone | Rsome lst -> - (* The following line is needed to compile stdlib/printf.ml *) - if lst = [] then Rsome (omegas n) else + (* The following line is needed to compile stdlib/printf.ml *) + if lst = [] then Rsome (omegas n) + else let singletons = List.map (function - [x] -> x + | [x] -> x | _ -> assert false) lst in @@ -1480,43 +1455,37 @@ let exhaust_gadt ext pss n = *) let rec pressure_variants tdefs = function - | [] -> false - | []::_ -> true - | pss -> - if not (all_coherent (simplified_first_col pss)) then - true - else begin - let q0 = discr_pat omega pss in - match filter_all q0 pss with - [] -> pressure_variants tdefs (filter_extra pss) - | constrs -> - let rec try_non_omega = function - (_p,pss) :: rem -> - let ok = pressure_variants tdefs pss in - try_non_omega rem && ok - | [] -> true - in - if full_match (tdefs=None) constrs then - try_non_omega constrs - else if tdefs = None then - pressure_variants None (filter_extra pss) - else - let full = full_match true constrs in - let ok = - if full then try_non_omega constrs - else try_non_omega (filter_all q0 (mark_partial pss)) - in - begin match constrs, tdefs with - ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> - let row = row_of_pat p in - if Btype.row_fixed row - || pressure_variants None (filter_extra pss) then () - else close_variant env row - | _ -> () - end; - ok - end - + | [] -> false + | [] :: _ -> true + | pss -> ( + if not (all_coherent (simplified_first_col pss)) then true + else + let q0 = discr_pat omega pss in + match filter_all q0 pss with + | [] -> pressure_variants tdefs (filter_extra pss) + | constrs -> + let rec try_non_omega = function + | (_p, pss) :: rem -> + let ok = pressure_variants tdefs pss in + try_non_omega rem && ok + | [] -> true + in + if full_match (tdefs = None) constrs then try_non_omega constrs + else if tdefs = None then pressure_variants None (filter_extra pss) + else + let full = full_match true constrs in + let ok = + if full then try_non_omega constrs + else try_non_omega (filter_all q0 (mark_partial pss)) + in + (match (constrs, tdefs) with + | (({pat_desc = Tpat_variant _} as p), _) :: _, Some env -> + let row = row_of_pat p in + if Btype.row_fixed row || pressure_variants None (filter_extra pss) + then () + else close_variant env row + | _ -> ()); + ok) (* Yet another satisfiable function *) @@ -1527,18 +1496,15 @@ let rec pressure_variants tdefs = function *) type answer = - | Used (* Useful pattern *) - | Unused (* Useless pattern *) - | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) - - + | Used (* Useful pattern *) + | Unused (* Useless pattern *) + | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) (* this row type enable column processing inside the matrix - left -> elements not to be processed, - right -> elements to be processed *) -type 'a row = {no_ors : 'a list ; ors : 'a list ; active : 'a list} - +type 'a row = {no_ors: 'a list; ors: 'a list; active: 'a list} (* let pretty_row {ors=ors ; no_ors=no_ors; active=active} = @@ -1557,120 +1523,121 @@ let pretty_rows rs = *) (* Initial build *) -let make_row ps = {ors=[] ; no_ors=[]; active=ps} +let make_row ps = {ors = []; no_ors = []; active = ps} let make_rows pss = List.map make_row pss - (* Useful to detect and expand or pats inside as pats *) -let rec unalias p = match p.pat_desc with -| Tpat_alias (p,_,_) -> unalias p -| _ -> p - +let rec unalias p = + match p.pat_desc with + | Tpat_alias (p, _, _) -> unalias p + | _ -> p -let is_var p = match (unalias p).pat_desc with -| Tpat_any|Tpat_var _ -> true -| _ -> false +let is_var p = + match (unalias p).pat_desc with + | Tpat_any | Tpat_var _ -> true + | _ -> false let is_var_column rs = List.for_all - (fun r -> match r.active with - | p::_ -> is_var p - | [] -> assert false) + (fun r -> + match r.active with + | p :: _ -> is_var p + | [] -> assert false) rs (* Standard or-args for left-to-right matching *) -let rec or_args p = match p.pat_desc with -| Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_,_) -> or_args p -| _ -> assert false +let rec or_args p = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> (p1, p2) + | Tpat_alias (p, _, _) -> or_args p + | _ -> assert false (* Just remove current column *) -let remove r = match r.active with -| _::rem -> {r with active=rem} -| [] -> assert false +let remove r = + match r.active with + | _ :: rem -> {r with active = rem} + | [] -> assert false let remove_column rs = List.map remove rs (* Current column has been processed *) -let push_no_or r = match r.active with -| p::rem -> { r with no_ors = p::r.no_ors ; active=rem} -| [] -> assert false +let push_no_or r = + match r.active with + | p :: rem -> {r with no_ors = p :: r.no_ors; active = rem} + | [] -> assert false -let push_or r = match r.active with -| p::rem -> { r with ors = p::r.ors ; active=rem} -| [] -> assert false +let push_or r = + match r.active with + | p :: rem -> {r with ors = p :: r.ors; active = rem} + | [] -> assert false let push_or_column rs = List.map push_or rs + and push_no_or_column rs = List.map push_no_or rs (* Those are adaptations of the previous homonymous functions that work on the current column, instead of the first column *) -let discr_pat q rs = - discr_pat q (List.map (fun r -> r.active) rs) +let discr_pat q rs = discr_pat q (List.map (fun r -> r.active) rs) let filter_one q rs = - let rec filter_rec rs = match rs with - | [] -> [] - | r::rem -> + let rec filter_rec rs = + match rs with + | [] -> [] + | r :: rem -> ( match r.active with | [] -> assert false - | {pat_desc = Tpat_alias(p,_,_)}::ps -> - filter_rec ({r with active = p::ps}::rem) - | {pat_desc = Tpat_or(p1,p2,_)}::ps -> - filter_rec - ({r with active = p1::ps}:: - {r with active = p2::ps}:: - rem) - | p::ps -> - if simple_match q p then - {r with active=simple_match_args q p @ ps} :: filter_rec rem - else - filter_rec rem in + | {pat_desc = Tpat_alias (p, _, _)} :: ps -> + filter_rec ({r with active = p :: ps} :: rem) + | {pat_desc = Tpat_or (p1, p2, _)} :: ps -> + filter_rec + ({r with active = p1 :: ps} :: {r with active = p2 :: ps} :: rem) + | p :: ps -> + if simple_match q p then + {r with active = simple_match_args q p @ ps} :: filter_rec rem + else filter_rec rem) + in filter_rec rs - (* Back to normal matrices *) let make_vector r = List.rev r.no_ors let make_matrix rs = List.map make_vector rs - (* Standard union on answers *) -let union_res r1 r2 = match r1, r2 with -| (Unused,_) -| (_, Unused) -> Unused -| Used,_ -> r2 -| _, Used -> r1 -| Upartial u1, Upartial u2 -> Upartial (u1@u2) +let union_res r1 r2 = + match (r1, r2) with + | Unused, _ | _, Unused -> Unused + | Used, _ -> r2 + | _, Used -> r1 + | Upartial u1, Upartial u2 -> Upartial (u1 @ u2) (* propose or pats for expansion *) let extract_elements qs = let rec do_rec seen = function | [] -> [] - | q::rem -> - {no_ors= List.rev_append seen rem @ qs.no_ors ; - ors=[] ; - active = [q]}:: - do_rec (q::seen) rem in + | q :: rem -> + {no_ors = List.rev_append seen rem @ qs.no_ors; ors = []; active = [q]} + :: do_rec (q :: seen) rem + in do_rec [] qs.ors (* idem for matrices *) -let transpose rs = match rs with -| [] -> assert false -| r::rem -> +let transpose rs = + match rs with + | [] -> assert false + | r :: rem -> let i = List.map (fun x -> [x]) r in - List.fold_left - (List.map2 (fun r x -> x::r)) - i rem + List.fold_left (List.map2 (fun r x -> x :: r)) i rem -let extract_columns pss qs = match pss with -| [] -> List.map (fun _ -> []) qs.ors -| _ -> - let rows = List.map extract_elements pss in - transpose rows +let extract_columns pss qs = + match pss with + | [] -> List.map (fun _ -> []) qs.ors + | _ -> + let rows = List.map extract_elements pss in + transpose rows (* Core function The idea is to first look for or patterns (recursive case), then @@ -1678,69 +1645,63 @@ let extract_columns pss qs = match pss with *) let rec simplified_first_usefulness_col = function | [] -> [] - | row :: rows -> + | row :: rows -> ( match row.active with | [] -> assert false (* the rows are non-empty! *) - | p :: _ -> simplify_head_pat p (simplified_first_usefulness_col rows) + | p :: _ -> simplify_head_pat p (simplified_first_usefulness_col rows)) -let rec every_satisfiables pss qs = match qs.active with -| [] -> +let rec every_satisfiables pss qs = + match qs.active with + | [] -> ( (* qs is now partitionned, check usefulness *) - begin match qs.ors with - | [] -> (* no or-patterns *) - if satisfiable (make_matrix pss) (make_vector qs) then - Used - else - Unused - | _ -> (* n or-patterns -> 2n expansions *) - List.fold_right2 - (fun pss qs r -> match r with + match qs.ors with + | [] -> + (* no or-patterns *) + if satisfiable (make_matrix pss) (make_vector qs) then Used else Unused + | _ -> + (* n or-patterns -> 2n expansions *) + List.fold_right2 + (fun pss qs r -> + match r with | Unused -> Unused - | _ -> - match qs.active with - | [q] -> - let q1,q2 = or_args q in - let r_loc = every_both pss qs q1 q2 in - union_res r r_loc - | _ -> assert false) - (extract_columns pss qs) (extract_elements qs) - Used - end -| q::rem -> + | _ -> ( + match qs.active with + | [q] -> + let q1, q2 = or_args q in + let r_loc = every_both pss qs q1 q2 in + union_res r r_loc + | _ -> assert false)) + (extract_columns pss qs) (extract_elements qs) Used) + | q :: rem -> ( let uq = unalias q in - begin match uq.pat_desc with + match uq.pat_desc with | Tpat_any | Tpat_var _ -> - if is_var_column pss then -(* forget about ``all-variable'' columns now *) - every_satisfiables (remove_column pss) (remove qs) - else -(* otherwise this is direct food for satisfiable *) - every_satisfiables (push_no_or_column pss) (push_no_or qs) - | Tpat_or (q1,q2,_) -> - if - q1.pat_loc.Location.loc_ghost && - q2.pat_loc.Location.loc_ghost - then -(* syntactically generated or-pats should not be expanded *) - every_satisfiables (push_no_or_column pss) (push_no_or qs) - else -(* this is a real or-pattern *) - every_satisfiables (push_or_column pss) (push_or qs) - | Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *) - Unused + if is_var_column pss then + (* forget about ``all-variable'' columns now *) + every_satisfiables (remove_column pss) (remove qs) + else + (* otherwise this is direct food for satisfiable *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + | Tpat_or (q1, q2, _) -> + if q1.pat_loc.Location.loc_ghost && q2.pat_loc.Location.loc_ghost then + (* syntactically generated or-pats should not be expanded *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + else + (* this is a real or-pattern *) + every_satisfiables (push_or_column pss) (push_or qs) + | Tpat_variant (l, _, r) when is_absent l r -> + (* Ah Jacques... *) + Unused | _ -> -(* standard case, filter matrix *) - (* The handling of incoherent matrices is kept in line with - [satisfiable] *) - if not (all_coherent (uq :: simplified_first_usefulness_col pss)) then - Unused - else begin - let q0 = discr_pat q pss in - every_satisfiables - (filter_one q0 pss) - {qs with active=simple_match_args q0 q @ rem} - end - end + (* standard case, filter matrix *) + (* The handling of incoherent matrices is kept in line with + [satisfiable] *) + if not (all_coherent (uq :: simplified_first_usefulness_col pss)) then + Unused + else + let q0 = discr_pat q pss in + every_satisfiables (filter_one q0 pss) + {qs with active = simple_match_args q0 q @ rem}) (* This function ``every_both'' performs the usefulness check @@ -1752,68 +1713,59 @@ let rec every_satisfiables pss qs = match qs.active with - all matching work performed on qs.no_ors is not performed again. *) and every_both pss qs q1 q2 = - let qs1 = {qs with active=[q1]} - and qs2 = {qs with active=[q2]} in + let qs1 = {qs with active = [q1]} and qs2 = {qs with active = [q2]} in let r1 = every_satisfiables pss qs1 - and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in + and r2 = every_satisfiables (if compat q1 q2 then qs1 :: pss else pss) qs2 in match r1 with - | Unused -> - begin match r2 with - | Unused -> Unused - | Used -> Upartial [q1] - | Upartial u2 -> Upartial (q1::u2) - end - | Used -> - begin match r2 with - | Unused -> Upartial [q2] - | _ -> r2 - end - | Upartial u1 -> - begin match r2 with - | Unused -> Upartial (u1@[q2]) - | Used -> r1 - | Upartial u2 -> Upartial (u1 @ u2) - end - - - + | Unused -> ( + match r2 with + | Unused -> Unused + | Used -> Upartial [q1] + | Upartial u2 -> Upartial (q1 :: u2)) + | Used -> ( + match r2 with + | Unused -> Upartial [q2] + | _ -> r2) + | Upartial u1 -> ( + match r2 with + | Unused -> Upartial (u1 @ [q2]) + | Used -> r1 + | Upartial u2 -> Upartial (u1 @ u2)) (* le_pat p q means, forall V, V matches q implies V matches p *) let rec le_pat p q = match (p.pat_desc, q.pat_desc) with - | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_,_), _ -> le_pat p q - | _, Tpat_alias(q,_,_) -> le_pat p q - | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 - | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs - | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> - (l1 = l2 && le_pat p1 p2) - | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) -> - l1 = l2 - | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false - | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs + | (Tpat_var _ | Tpat_any), _ -> true + | Tpat_alias (p, _, _), _ -> le_pat p q + | _, Tpat_alias (q, _, _) -> le_pat p q + | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 + | Tpat_construct (_, c1, ps), Tpat_construct (_, c2, qs) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs + | Tpat_variant (l1, Some p1, _), Tpat_variant (l2, Some p2, _) -> + l1 = l2 && le_pat p1 p2 + | Tpat_variant (l1, None, _r1), Tpat_variant (l2, None, _) -> l1 = l2 + | Tpat_variant (_, _, _), Tpat_variant (_, _, _) -> false + | Tpat_tuple ps, Tpat_tuple qs -> le_pats ps qs | Tpat_lazy p, Tpat_lazy q -> le_pat p q - | Tpat_record (l1,_), Tpat_record (l2,_) -> - let ps,qs = records_args l1 l2 in - le_pats ps qs - | Tpat_array(ps), Tpat_array(qs) -> - Ext_list.same_length ps qs && le_pats ps qs -(* In all other cases, enumeration is performed *) - | _,_ -> not (satisfiable [[p]] [q]) + | Tpat_record (l1, _), Tpat_record (l2, _) -> + let ps, qs = records_args l1 l2 in + le_pats ps qs + | Tpat_array ps, Tpat_array qs -> Ext_list.same_length ps qs && le_pats ps qs + (* In all other cases, enumeration is performed *) + | _, _ -> not (satisfiable [[p]] [q]) and le_pats ps qs = - match ps,qs with - p::ps, q::qs -> le_pat p q && le_pats ps qs - | _, _ -> true + match (ps, qs) with + | p :: ps, q :: qs -> le_pat p q && le_pats ps qs + | _, _ -> true let get_mins le ps = let rec select_rec r = function - [] -> r - | p::ps -> - if List.exists (fun p0 -> le p0 p) ps - then select_rec r ps - else select_rec (p::r) ps in + | [] -> r + | p :: ps -> + if List.exists (fun p0 -> le p0 p) ps then select_rec r ps + else select_rec (p :: r) ps + in select_rec [] (select_rec [] ps) (* @@ -1821,68 +1773,61 @@ let get_mins le ps = may raise Empty, when p and q are not compatible *) -let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_,_),_ -> lub p q -| _,Tpat_alias (q,_,_) -> lub p q -| (Tpat_any|Tpat_var _),_ -> q -| _,(Tpat_any|Tpat_var _) -> p -| Tpat_or (p1,p2,_),_ -> orlub p1 p2 q -| _,Tpat_or (q1,q2,_) -> orlub q1 q2 p (* Thanks god, lub is commutative *) -| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p -| Tpat_tuple ps, Tpat_tuple qs -> +let rec lub p q = + match (p.pat_desc, q.pat_desc) with + | Tpat_alias (p, _, _), _ -> lub p q + | _, Tpat_alias (q, _, _) -> lub p q + | (Tpat_any | Tpat_var _), _ -> q + | _, (Tpat_any | Tpat_var _) -> p + | Tpat_or (p1, p2, _), _ -> orlub p1 p2 q + | _, Tpat_or (q1, q2, _) -> orlub q1 q2 p (* Thanks god, lub is commutative *) + | Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p + | Tpat_tuple ps, Tpat_tuple qs -> let rs = lubs ps qs in make_pat (Tpat_tuple rs) p.pat_type p.pat_env -| Tpat_lazy p, Tpat_lazy q -> + | Tpat_lazy p, Tpat_lazy q -> let r = lub p q in make_pat (Tpat_lazy r) p.pat_type p.pat_env -| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2) - when Types.equal_tag c1.cstr_tag c2.cstr_tag -> - let rs = lubs ps1 ps2 in - make_pat (Tpat_construct (lid, c1,rs)) - p.pat_type p.pat_env -| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) - when l1=l2 -> - let r=lub p1 p2 in - make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env -| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_) - when l1 = l2 -> p -| Tpat_record (l1,closed),Tpat_record (l2,_) -> + | Tpat_construct (lid, c1, ps1), Tpat_construct (_, c2, ps2) + when Types.equal_tag c1.cstr_tag c2.cstr_tag -> + let rs = lubs ps1 ps2 in + make_pat (Tpat_construct (lid, c1, rs)) p.pat_type p.pat_env + | Tpat_variant (l1, Some p1, row), Tpat_variant (l2, Some p2, _) when l1 = l2 + -> + let r = lub p1 p2 in + make_pat (Tpat_variant (l1, Some r, row)) p.pat_type p.pat_env + | Tpat_variant (l1, None, _row), Tpat_variant (l2, None, _) when l1 = l2 -> p + | Tpat_record (l1, closed), Tpat_record (l2, _) -> let rs = record_lubs l1 l2 in make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env -| Tpat_array ps, Tpat_array qs - when List.length ps = List.length qs -> - let rs = lubs ps qs in - make_pat (Tpat_array rs) p.pat_type p.pat_env -| _,_ -> - raise Empty + | Tpat_array ps, Tpat_array qs when List.length ps = List.length qs -> + let rs = lubs ps qs in + make_pat (Tpat_array rs) p.pat_type p.pat_env + | _, _ -> raise Empty and orlub p1 p2 q = try let r1 = lub p1 q in - try - {q with pat_desc=(Tpat_or (r1,lub p2 q,None))} - with - | Empty -> r1 -with -| Empty -> lub p2 q + try {q with pat_desc = Tpat_or (r1, lub p2 q, None)} with Empty -> r1 + with Empty -> lub p2 q and record_lubs l1 l2 = - let rec lub_rec l1 l2 = match l1,l2 with - | [],_ -> l2 - | _,[] -> l1 - | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 -> - if lbl1.lbl_pos < lbl2.lbl_pos then - (lid1, lbl1,p1)::lub_rec rem1 l2 - else if lbl2.lbl_pos < lbl1.lbl_pos then - (lid2, lbl2,p2)::lub_rec l1 rem2 - else - (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in + let rec lub_rec l1 l2 = + match (l1, l2) with + | [], _ -> l2 + | _, [] -> l1 + | (lid1, lbl1, p1) :: rem1, (lid2, lbl2, p2) :: rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then (lid1, lbl1, p1) :: lub_rec rem1 l2 + else if lbl2.lbl_pos < lbl1.lbl_pos then + (lid2, lbl2, p2) :: lub_rec l1 rem2 + else (lid1, lbl1, lub p1 p2) :: lub_rec rem1 rem2 + in lub_rec l1 l2 -and lubs ps qs = match ps,qs with -| p::ps, q::qs -> lub p q :: lubs ps qs -| _,_ -> [] - +and lubs ps qs = + match (ps, qs) with + | p :: ps, q :: qs -> lub p q :: lubs ps qs + | _, _ -> [] (******************************) (* Exported variant closing *) @@ -1891,7 +1836,7 @@ and lubs ps qs = match ps,qs with (* Apply pressure to variants *) let pressure_variants tdefs patl = - let pss = List.map (fun p -> [p;omega]) patl in + let pss = List.map (fun p -> [p; omega]) patl in ignore (pressure_variants (Some tdefs) pss) (*****************************) @@ -1904,9 +1849,9 @@ let pressure_variants tdefs patl = *) let rec initial_matrix = function - [] -> [] - | {c_guard=Some _} :: rem -> initial_matrix rem - | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem + | [] -> [] + | {c_guard = Some _} :: rem -> initial_matrix rem + | {c_guard = None; c_lhs = p} :: rem -> [p] :: initial_matrix rem (******************************************) (* Look for a row that matches some value *) @@ -1918,64 +1863,55 @@ let rec initial_matrix = function (by a guarded clause) *) - - exception NoGuard let rec initial_all no_guard = function - | [] -> - if no_guard then - raise NoGuard - else - [] - | {c_lhs=pat; c_guard; _} :: rem -> - ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem - + | [] -> if no_guard then raise NoGuard else [] + | {c_lhs = pat; c_guard; _} :: rem -> + ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem let rec do_filter_var = function - | (_::ps,loc)::rem -> (ps,loc)::do_filter_var rem + | (_ :: ps, loc) :: rem -> (ps, loc) :: do_filter_var rem | _ -> [] let do_filter_one q pss = let rec filter_rec = function - | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss -> - filter_rec ((p::ps,loc)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss -> - filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss) - | (p::ps,loc)::pss -> - if simple_match q p - then (simple_match_args q p @ ps, loc) :: filter_rec pss - else filter_rec pss - | _ -> [] in + | ({pat_desc = Tpat_alias (p, _, _)} :: ps, loc) :: pss -> + filter_rec ((p :: ps, loc) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps, loc) :: pss -> + filter_rec ((p1 :: ps, loc) :: (p2 :: ps, loc) :: pss) + | (p :: ps, loc) :: pss -> + if simple_match q p then + (simple_match_args q p @ ps, loc) :: filter_rec pss + else filter_rec pss + | _ -> [] + in filter_rec pss -let rec do_match pss qs = match qs with -| [] -> - begin match pss with - | ([],loc)::_ -> Some loc - | _ -> None - end -| q::qs -> match q with - | {pat_desc = Tpat_or (q1,q2,_)} -> - begin match do_match pss (q1::qs) with - | None -> do_match pss (q2::qs) - | r -> r - end - | {pat_desc = Tpat_any} -> - do_match (do_filter_var pss) qs - | _ -> +let rec do_match pss qs = + match qs with + | [] -> ( + match pss with + | ([], loc) :: _ -> Some loc + | _ -> None) + | q :: qs -> ( + match q with + | {pat_desc = Tpat_or (q1, q2, _)} -> ( + match do_match pss (q1 :: qs) with + | None -> do_match pss (q2 :: qs) + | r -> r) + | {pat_desc = Tpat_any} -> do_match (do_filter_var pss) qs + | _ -> let q0 = normalize_pat q in (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of - its first column. *) - do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs) - + its first column. *) + do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs)) let check_partial_all v casel = try let pss = initial_all true casel in do_match pss [v] - with - | NoGuard -> None + with NoGuard -> None (************************) (* Exhaustiveness check *) @@ -1997,72 +1933,66 @@ module Conv = struct let labels = Hashtbl.create 7 in let rec loop pat = match pat.pat_desc with - Tpat_or (pa,pb,_) -> - mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *) - mkpat (Ppat_var nm) - | Tpat_any - | Tpat_var _ -> - mkpat Ppat_any - | Tpat_constant c -> - mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p,_,_) -> loop p - | Tpat_tuple lst -> - mkpat (Ppat_tuple (List.map loop lst)) + | Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb)) + | Tpat_var (_, ({txt = "*extension*"} as nm)) -> + (* PR#7330 *) + mkpat (Ppat_var nm) + | Tpat_any | Tpat_var _ -> mkpat Ppat_any + | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) + | Tpat_alias (p, _, _) -> loop p + | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) | Tpat_construct (cstr_lid, cstr, lst) -> - let id = fresh cstr.cstr_name in - let lid = { cstr_lid with txt = Longident.Lident id } in - Hashtbl.add constrs id cstr; - let arg = - match List.map loop lst with - | [] -> None - | [p] -> Some p - | lst -> Some (mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct(lid, arg)) - | Tpat_variant(label,p_opt,_row_desc) -> - let arg = Misc.may_map loop p_opt in - mkpat (Ppat_variant(label, arg)) + let id = fresh cstr.cstr_name in + let lid = {cstr_lid with txt = Longident.Lident id} in + Hashtbl.add constrs id cstr; + let arg = + match List.map loop lst with + | [] -> None + | [p] -> Some p + | lst -> Some (mkpat (Ppat_tuple lst)) + in + mkpat (Ppat_construct (lid, arg)) + | Tpat_variant (label, p_opt, _row_desc) -> + let arg = Misc.may_map loop p_opt in + mkpat (Ppat_variant (label, arg)) | Tpat_record (subpatterns, _closed_flag) -> - let fields = - List.map - (fun (_, lbl, p) -> - let id = fresh lbl.lbl_name in - Hashtbl.add labels id lbl; - (mknoloc (Longident.Lident id), loop p)) - subpatterns - in - mkpat (Ppat_record (fields, Open)) - | Tpat_array lst -> - mkpat (Ppat_array (List.map loop lst)) - | Tpat_lazy p -> - mkpat (Ppat_lazy (loop p)) + let fields = + List.map + (fun (_, lbl, p) -> + let id = fresh lbl.lbl_name in + Hashtbl.add labels id lbl; + (mknoloc (Longident.Lident id), loop p)) + subpatterns + in + mkpat (Ppat_record (fields, Open)) + | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) + | Tpat_lazy p -> mkpat (Ppat_lazy (loop p)) in let ps = loop typed in (ps, constrs, labels) end - (* Whether the counter-example contains an extension pattern *) let contains_extension pat = let r = ref false in let rec loop = function - {pat_desc=Tpat_var (_, {txt="*extension*"})} -> - r := true + | {pat_desc = Tpat_var (_, {txt = "*extension*"})} -> r := true | p -> Typedtree.iter_pattern_desc loop p.pat_desc - in loop pat; !r + in + loop pat; + !r (* Build an untyped or-pattern from its expected type *) let ppat_of_type env ty = match pats_of_type env ty with - [{pat_desc = Tpat_any}] -> - (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0) - | pats -> - Conv.conv (orify_many pats) - -let do_check_partial ?pred exhaust loc casel pss = match pss with -| [] -> - (* + | [{pat_desc = Tpat_any}] -> + (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0) + | pats -> Conv.conv (orify_many pats) + +let do_check_partial ?pred exhaust loc casel pss = + match pss with + | [] -> + (* This can occur - For empty matches generated by ocamlp4 (no warning) - when all patterns have guards (then, casel <> []) @@ -2070,66 +2000,59 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with Then match MUST be considered non-exhaustive, otherwise compilation of PM is broken. *) - begin match casel with + (match casel with | [] -> () - | _ -> + | _ -> if Warnings.is_active Warnings.All_clauses_guarded then - Location.prerr_warning loc Warnings.All_clauses_guarded - end ; + Location.prerr_warning loc Warnings.All_clauses_guarded); Partial -| ps::_ -> - begin match exhaust None pss (List.length ps) with + | ps :: _ -> ( + match exhaust None pss (List.length ps) with | Rnone -> Total - | Rsome [u] -> - let v = - match pred with - | Some pred -> - let (pattern,constrs,labels) = Conv.conv u in - let u' = pred constrs labels pattern in - (* pretty_pat u; - begin match u' with - None -> prerr_endline ": impossible" - | Some _ -> prerr_endline ": possible" - end; *) - u' - | None -> Some u - in - begin match v with - None -> Total - | Some v -> - if Warnings.is_active (Warnings.Partial_match "") then begin - let errmsg = - try - let buf = Buffer.create 16 in - Buffer.add_string buf "| "; - Buffer.add_string buf (!print_res_pat v); - begin match check_partial_all v casel with - | None -> () - | Some _ -> - (* This is 'Some loc', where loc is the location of - a possibly matching clause. - Forget about loc, because printing two locations - is a pain in the top-level *) - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)" - end; - if contains_extension v then - Buffer.add_string buf - "\nMatching over values of extensible variant types \ - (the *extension* above)\n\ - must include a wild card pattern in order to be exhaustive." - ; - Buffer.contents buf - with _ -> - "" - in - Location.prerr_warning loc (Warnings.Partial_match errmsg) - end; - Partial - end - | _ -> - fatal_error "Parmatch.check_partial" - end + | Rsome [u] -> ( + let v = + match pred with + | Some pred -> + let pattern, constrs, labels = Conv.conv u in + let u' = pred constrs labels pattern in + (* pretty_pat u; + begin match u' with + None -> prerr_endline ": impossible" + | Some _ -> prerr_endline ": possible" + end; *) + u' + | None -> Some u + in + match v with + | None -> Total + | Some v -> + (if Warnings.is_active (Warnings.Partial_match "") then + let errmsg = + try + let buf = Buffer.create 16 in + Buffer.add_string buf "| "; + Buffer.add_string buf (!print_res_pat v); + (match check_partial_all v casel with + | None -> () + | Some _ -> + (* This is 'Some loc', where loc is the location of + a possibly matching clause. + Forget about loc, because printing two locations + is a pain in the top-level *) + Buffer.add_string buf + "\n(However, some guarded clause may match this value.)"); + if contains_extension v then + Buffer.add_string buf + "\n\ + Matching over values of extensible variant types (the \ + *extension* above)\n\ + must include a wild card pattern in order to be exhaustive."; + Buffer.contents buf + with _ -> "" + in + Location.prerr_warning loc (Warnings.Partial_match errmsg)); + Partial) + | _ -> fatal_error "Parmatch.check_partial") (* let do_check_partial_normal loc casel pss = @@ -2139,8 +2062,6 @@ let do_check_partial_normal loc casel pss = let do_check_partial_gadt pred loc casel pss = do_check_partial ~pred exhaust_gadt loc casel pss - - (*****************) (* Fragile check *) (*****************) @@ -2149,40 +2070,36 @@ let do_check_partial_gadt pred loc casel pss = let rec add_path path = function | [] -> [path] - | x::rem as paths -> - if Path.same path x then paths - else x::add_path path rem + | x :: rem as paths -> + if Path.same path x then paths else x :: add_path path rem let extendable_path path = not - (Path.same path Predef.path_bool || - Path.same path Predef.path_list || - Path.same path Predef.path_unit || - Path.same path Predef.path_option) - -let rec collect_paths_from_pat r p = match p.pat_desc with -| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps) - -> - let path = get_type_path p.pat_type p.pat_env in - List.fold_left - collect_paths_from_pat + (Path.same path Predef.path_bool + || Path.same path Predef.path_list + || Path.same path Predef.path_unit + || Path.same path Predef.path_option) + +let rec collect_paths_from_pat r p = + match p.pat_desc with + | Tpat_construct + (_, {cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed}, ps) -> + let path = get_type_path p.pat_type p.pat_env in + List.fold_left collect_paths_from_pat (if extendable_path path then add_path path r else r) ps -| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r -| Tpat_tuple ps | Tpat_array ps -| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)-> + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> r + | Tpat_tuple ps + | Tpat_array ps + | Tpat_construct (_, {cstr_tag = Cstr_extension _}, ps) -> List.fold_left collect_paths_from_pat r ps -| Tpat_record (lps,_) -> - List.fold_left - (fun r (_, _, p) -> collect_paths_from_pat r p) - r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p -| Tpat_or (p1,p2,_) -> - collect_paths_from_pat (collect_paths_from_pat r p1) p2 -| Tpat_lazy p - -> + | Tpat_record (lps, _) -> + List.fold_left (fun r (_, _, p) -> collect_paths_from_pat r p) r lps + | Tpat_variant (_, Some p, _) | Tpat_alias (p, _, _) -> collect_paths_from_pat r p - + | Tpat_or (p1, p2, _) -> + collect_paths_from_pat (collect_paths_from_pat r p1) p2 + | Tpat_lazy p -> collect_paths_from_pat r p (* Actual fragile check @@ -2193,23 +2110,21 @@ let rec collect_paths_from_pat r p = match p.pat_desc with let do_check_fragile_param exhaust loc casel pss = let exts = - List.fold_left - (fun r c -> collect_paths_from_pat r c.c_lhs) - [] casel in + List.fold_left (fun r c -> collect_paths_from_pat r c.c_lhs) [] casel + in match exts with | [] -> () - | _ -> match pss with + | _ -> ( + match pss with | [] -> () - | ps::_ -> - List.iter - (fun ext -> - match exhaust (Some ext) pss (List.length ps) with - | Rnone -> - Location.prerr_warning - loc - (Warnings.Fragile_match (Path.name ext)) - | Rsome _ -> ()) - exts + | ps :: _ -> + List.iter + (fun ext -> + match exhaust (Some ext) pss (List.length ps) with + | Rnone -> + Location.prerr_warning loc (Warnings.Fragile_match (Path.name ext)) + | Rsome _ -> ()) + exts) (*let do_check_fragile_normal = do_check_fragile_param exhaust*) let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt @@ -2219,61 +2134,68 @@ let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt (********************************) let check_unused pred casel = - if Warnings.is_active Warnings.Unused_match - || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then + if + Warnings.is_active Warnings.Unused_match + || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel + then let rec do_rec pref = function | [] -> () - | {c_lhs=q; c_guard; c_rhs} :: rem -> - let qs = [q] in - begin try - let pss = - get_mins le_pats (Ext_list.filter pref (compats qs)) in - (* First look for redundant or partially redundant patterns *) - let r = every_satisfiables (make_rows pss) (make_row qs) in - let refute = (c_rhs.exp_desc = Texp_unreachable) in - (* Do not warn for unused [pat -> .] *) - if r = Unused && refute then () else - let r = - (* Do not refine if there are no other lines *) - let skip = - r = Unused || (not refute && pref = []) || - not(refute || Warnings.is_active Warnings.Unreachable_case) in - if skip then r else - (* Then look for empty patterns *) - let sfs = satisfiables pss qs in - if sfs = [] then Unused else - let sfs = - List.map (function [u] -> u | _ -> assert false) sfs in - let u = orify_many sfs in - (*Format.eprintf "%a@." pretty_val u;*) - let (pattern,constrs,labels) = Conv.conv u in - let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in - match pred refute constrs labels pattern with - None when not refute -> - Location.prerr_warning q.pat_loc Warnings.Unreachable_case; - Used - | _ -> r - in - match r with - | Unused -> - Location.prerr_warning - q.pat_loc Warnings.Unused_match - | Upartial ps -> - ps - |> List.filter (fun p -> - not (Variant_type_spread.is_pat_from_variant_spread_attr p)) - |> List.iter - (fun p -> - Location.prerr_warning - p.pat_loc Warnings.Unused_pat) - | Used -> () - with Empty | Not_found | NoGuard -> assert false - end ; - - if c_guard <> None then - do_rec pref rem - else - do_rec ([q]::pref) rem in + | {c_lhs = q; c_guard; c_rhs} :: rem -> + let qs = [q] in + (try + let pss = get_mins le_pats (Ext_list.filter pref (compats qs)) in + (* First look for redundant or partially redundant patterns *) + let r = every_satisfiables (make_rows pss) (make_row qs) in + let refute = c_rhs.exp_desc = Texp_unreachable in + (* Do not warn for unused [pat -> .] *) + if r = Unused && refute then () + else + let r = + (* Do not refine if there are no other lines *) + let skip = + r = Unused + || ((not refute) && pref = []) + || not (refute || Warnings.is_active Warnings.Unreachable_case) + in + if skip then r + else + (* Then look for empty patterns *) + let sfs = satisfiables pss qs in + if sfs = [] then Unused + else + let sfs = + List.map + (function + | [u] -> u + | _ -> assert false) + sfs + in + let u = orify_many sfs in + (*Format.eprintf "%a@." pretty_val u;*) + let pattern, constrs, labels = Conv.conv u in + let pattern = + {pattern with Parsetree.ppat_loc = q.pat_loc} + in + match pred refute constrs labels pattern with + | None when not refute -> + Location.prerr_warning q.pat_loc Warnings.Unreachable_case; + Used + | _ -> r + in + match r with + | Unused -> Location.prerr_warning q.pat_loc Warnings.Unused_match + | Upartial ps -> + ps + |> List.filter (fun p -> + not + (Variant_type_spread.is_pat_from_variant_spread_attr p)) + |> List.iter (fun p -> + Location.prerr_warning p.pat_loc Warnings.Unused_pat) + | Used -> () + with Empty | Not_found | NoGuard -> assert false); + + if c_guard <> None then do_rec pref rem else do_rec ([q] :: pref) rem + in do_rec [] casel @@ -2286,38 +2208,25 @@ let irrefutable pat = le_pat pat omega let inactive ~partial pat = match partial with | Partial -> false - | Total -> begin - let rec loop pat = - match pat.pat_desc with - | Tpat_lazy _ | Tpat_array _ -> - false - | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) -> - true - | Tpat_constant c -> begin - match c with - | Const_string _ -> true (*Config.safe_string*) - | Const_int _ | Const_char _ | Const_float _ - | Const_int32 _ | Const_int64 _ | Const_bigint _ -> true - end - | Tpat_tuple ps | Tpat_construct (_, _, ps) -> - List.for_all (fun p -> loop p) ps - | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> - loop p - | Tpat_record (ldps,_) -> - List.for_all - (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) - ldps - | Tpat_or (p,q,_) -> - loop p && loop q - in - loop pat - end - - - - - - + | Total -> + let rec loop pat = + match pat.pat_desc with + | Tpat_lazy _ | Tpat_array _ -> false + | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) -> true + | Tpat_constant c -> ( + match c with + | Const_string _ -> true (*Config.safe_string*) + | Const_int _ | Const_char _ | Const_float _ | Const_int32 _ + | Const_int64 _ | Const_bigint _ -> + true) + | Tpat_tuple ps | Tpat_construct (_, _, ps) -> + List.for_all (fun p -> loop p) ps + | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> loop p + | Tpat_record (ldps, _) -> + List.for_all (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) ldps + | Tpat_or (p, q, _) -> loop p && loop q + in + loop pat (*********************************) (* Exported exhaustiveness check *) @@ -2329,15 +2238,12 @@ let inactive ~partial pat = *) let check_partial_param do_check_partial do_check_fragile loc casel = - let pss = initial_matrix casel in - let pss = get_mins le_pats pss in - let total = do_check_partial loc casel pss in - if - total = Total && Warnings.is_active (Warnings.Fragile_match "") - then begin - do_check_fragile loc casel pss - end ; - total + let pss = initial_matrix casel in + let pss = get_mins le_pats pss in + let total = do_check_partial loc casel pss in + if total = Total && Warnings.is_active (Warnings.Fragile_match "") then + do_check_fragile loc casel pss; + total (*let check_partial = check_partial_param @@ -2345,10 +2251,10 @@ let check_partial_param do_check_partial do_check_fragile loc casel = do_check_fragile_normal*) let check_partial_gadt pred loc casel = - check_partial_param (do_check_partial_gadt pred) + check_partial_param + (do_check_partial_gadt pred) do_check_fragile_gadt loc casel - (*************************************) (* Ambiguous variable in or-patterns *) (*************************************) @@ -2395,7 +2301,7 @@ let check_partial_gadt pred loc casel = to a specific guard. *) -module IdSet = Set.Make(Ident) +module IdSet = Set.Make (Ident) let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p) @@ -2403,37 +2309,34 @@ let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p) unseen is the traditional pattern row, seen is a list of position bindings *) -type amb_row = { unseen : pattern list ; seen : IdSet.t list; } - +type amb_row = {unseen: pattern list; seen: IdSet.t list} (* Push binding variables now *) -let rec do_push r p ps seen k = match p.pat_desc with -| Tpat_alias (p,x,_) -> do_push (IdSet.add x r) p ps seen k -| Tpat_var (x,_) -> - (omega,{ unseen = ps; seen=IdSet.add x r::seen; })::k -| Tpat_or (p1,p2,_) -> - do_push r p1 ps seen (do_push r p2 ps seen k) -| _ -> - (p,{ unseen = ps; seen = r::seen; })::k +let rec do_push r p ps seen k = + match p.pat_desc with + | Tpat_alias (p, x, _) -> do_push (IdSet.add x r) p ps seen k + | Tpat_var (x, _) -> (omega, {unseen = ps; seen = IdSet.add x r :: seen}) :: k + | Tpat_or (p1, p2, _) -> do_push r p1 ps seen (do_push r p2 ps seen k) + | _ -> (p, {unseen = ps; seen = r :: seen}) :: k let rec push_vars = function | [] -> [] - | { unseen = [] }::_ -> assert false - | { unseen = p::ps; seen; }::rem -> - do_push IdSet.empty p ps seen (push_vars rem) + | {unseen = []} :: _ -> assert false + | {unseen = p :: ps; seen} :: rem -> + do_push IdSet.empty p ps seen (push_vars rem) let collect_stable = function | [] -> assert false - | { seen=xss; _}::rem -> - let rec c_rec xss = function - | [] -> xss - | {seen=yss; _}::rem -> - let xss = List.map2 IdSet.inter xss yss in - c_rec xss rem in - let inters = c_rec xss rem in - List.fold_left IdSet.union IdSet.empty inters - + | {seen = xss; _} :: rem -> + let rec c_rec xss = function + | [] -> xss + | {seen = yss; _} :: rem -> + let xss = List.map2 IdSet.inter xss yss in + c_rec xss rem + in + let inters = c_rec xss rem in + List.fold_left IdSet.union IdSet.empty inters (*********************************************) (* Filtering utilities for our specific rows *) @@ -2465,49 +2368,53 @@ let filter_all = let discr_head pat = match pat.pat_desc with | Tpat_record (lbls, closed) -> - (* a partial record pattern { f1 = p1; f2 = p2; _ } - needs to be expanded, otherwise matching against this head - would drop the pattern arguments for non-mentioned fields *) - let lbls = all_record_args lbls in - normalize_pat { pat with pat_desc = Tpat_record (lbls, closed) } + (* a partial record pattern { f1 = p1; f2 = p2; _ } + needs to be expanded, otherwise matching against this head + would drop the pattern arguments for non-mentioned fields *) + let lbls = all_record_args lbls in + normalize_pat {pat with pat_desc = Tpat_record (lbls, closed)} | _ -> normalize_pat pat in (* insert a row of head [p] and rest [r] into the right group *) - let rec insert p r env = match env with - | [] -> + let rec insert p r env = + match env with + | [] -> (* if no group matched this row, it has a head constructor that was never seen before; add a new sub-matrix for this head *) let p0 = discr_head p in - [p0,[{ r with unseen = simple_match_args p0 p @ r.unseen }]] - | (q0,rs) as bd::env -> - if simple_match q0 p then begin - let r = { r with unseen = simple_match_args q0 p@r.unseen; } in - (q0,r::rs)::env - end - else bd::insert p r env in + [(p0, [{r with unseen = simple_match_args p0 p @ r.unseen}])] + | ((q0, rs) as bd) :: env -> + if simple_match q0 p then + let r = {r with unseen = simple_match_args q0 p @ r.unseen} in + (q0, r :: rs) :: env + else bd :: insert p r env + in (* insert a row of head omega into all groups *) let insert_omega r env = List.map - (fun (q0,rs) -> - let r = - { r with unseen = simple_match_args q0 omega @ r.unseen; } in - (q0,r::rs)) + (fun (q0, rs) -> + let r = {r with unseen = simple_match_args q0 omega @ r.unseen} in + (q0, r :: rs)) env in let rec filter_rec env = function | [] -> env - | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false - | ({pat_desc=Tpat_any}, _)::rs -> filter_rec env rs - | (p,r)::rs -> filter_rec (insert p r env) rs in + | ({pat_desc = Tpat_var _ | Tpat_alias _ | Tpat_or _}, _) :: _ -> + assert false + | ({pat_desc = Tpat_any}, _) :: rs -> filter_rec env rs + | (p, r) :: rs -> filter_rec (insert p r env) rs + in let rec filter_omega env = function | [] -> env - | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false - | ({pat_desc=Tpat_any},r)::rs -> filter_omega (insert_omega r env) rs - | _::rs -> filter_omega env rs in + | ({pat_desc = Tpat_var _ | Tpat_alias _ | Tpat_or _}, _) :: _ -> + assert false + | ({pat_desc = Tpat_any}, r) :: rs -> filter_omega (insert_omega r env) rs + | _ :: rs -> filter_omega env rs + in fun rs -> (* first insert the rows with head constructors, @@ -2518,83 +2425,80 @@ let filter_all = (* Compute stable bindings *) -let rec do_stable rs = match rs with -| [] -> assert false (* No empty matrix *) -| { unseen=[]; _ }::_ -> - collect_stable rs -| _ -> +let rec do_stable rs = + match rs with + | [] -> assert false (* No empty matrix *) + | {unseen = []; _} :: _ -> collect_stable rs + | _ -> ( let rs = push_vars rs in - if not (all_coherent (first_column rs)) then begin + if not (all_coherent (first_column rs)) then (* If the first column is incoherent, then all the variables of this matrix are stable. *) - List.fold_left (fun acc (_, { seen; _ }) -> - List.fold_left IdSet.union acc seen - ) IdSet.empty rs - end else begin + List.fold_left + (fun acc (_, {seen; _}) -> List.fold_left IdSet.union acc seen) + IdSet.empty rs + else (* If the column is ill-typed but deemed coherent, we might spuriously warn about some variables being unstable. As sad as that might be, the warning can be silenced by splitting the - or-pattern... *) + or-pattern... *) match filter_all rs with - | [] -> - do_stable (List.map snd rs) - | (_,rs)::env -> - List.fold_left - (fun xs (_,rs) -> IdSet.inter xs (do_stable rs)) - (do_stable rs) env - end - -let stable p = do_stable [{unseen=[p]; seen=[];}] + | [] -> do_stable (List.map snd rs) + | (_, rs) :: env -> + List.fold_left + (fun xs (_, rs) -> IdSet.inter xs (do_stable rs)) + (do_stable rs) env) +let stable p = do_stable [{unseen = [p]; seen = []}] (* All identifier paths that appear in an expression that occurs - as a clause right hand side or guard. + as a clause right hand side or guard. - The function is rather complex due to the compilation of - unpack patterns by introducing code in rhs expressions - and **guards**. + The function is rather complex due to the compilation of + unpack patterns by introducing code in rhs expressions + and **guards**. - For pattern (module M:S) -> e the code is - let module M_mod = unpack M .. in e + For pattern (module M:S) -> e the code is + let module M_mod = unpack M .. in e - Hence M is "free" in e iff M_mod is free in e. + Hence M is "free" in e iff M_mod is free in e. - Not doing so will yield excessive warning in - (module (M:S) } ...) when true -> .... - as M is always present in - let module M_mod = unpack M .. in true + Not doing so will yield excessive warning in + (module (M:S) } ...) when true -> .... + as M is always present in + let module M_mod = unpack M .. in true *) let all_rhs_idents exp = let ids = ref IdSet.empty in - let module Iterator = TypedtreeIter.MakeIterator(struct + let module Iterator = TypedtreeIter.MakeIterator (struct include TypedtreeIter.DefaultIteratorArgument - let enter_expression exp = match exp.exp_desc with + let enter_expression exp = + match exp.exp_desc with | Texp_ident (path, _lid, _descr) -> - List.iter - (fun id -> ids := IdSet.add id !ids) - (Path.heads path) + List.iter (fun id -> ids := IdSet.add id !ids) (Path.heads path) | _ -> () -(* Very hackish, detect unpack pattern compilation - and perform "indirect check for them" *) + (* Very hackish, detect unpack pattern compilation + and perform "indirect check for them" *) let is_unpack exp = - List.exists - (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes + List.exists (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes let leave_expression exp = - if is_unpack exp then begin match exp.exp_desc with - | Texp_letmodule - (id_mod,_, - {mod_desc= - Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, - _) -> - assert (IdSet.mem id_exp !ids) ; - if not (IdSet.mem id_mod !ids) then begin - ids := IdSet.remove id_exp !ids - end - | _ -> assert false - end + if is_unpack exp then + match exp.exp_desc with + | Texp_letmodule + ( id_mod, + _, + { + mod_desc = + Tmod_unpack + ({exp_desc = Texp_ident (Path.Pident id_exp, _, _)}, _); + }, + _ ) -> + assert (IdSet.mem id_exp !ids); + if not (IdSet.mem id_mod !ids) then ids := IdSet.remove id_exp !ids + | _ -> assert false end) in Iterator.iter_expression exp; !ids @@ -2605,18 +2509,16 @@ let check_ambiguous_bindings = fun cases -> if is_active warn0 then List.iter - (fun case -> match case with - | { c_guard=None ; _} -> () - | { c_lhs=p; c_guard=Some g; _} -> - let all = - IdSet.inter (pattern_vars p) (all_rhs_idents g) in - if not (IdSet.is_empty all) then begin + (fun case -> + match case with + | {c_guard = None; _} -> () + | {c_lhs = p; c_guard = Some g; _} -> + let all = IdSet.inter (pattern_vars p) (all_rhs_idents g) in + if not (IdSet.is_empty all) then let st = stable p in let ambiguous = IdSet.diff all st in - if not (IdSet.is_empty ambiguous) then begin + if not (IdSet.is_empty ambiguous) then let pps = IdSet.elements ambiguous |> List.map Ident.name in let warn = Ambiguous_pattern pps in - Location.prerr_warning p.pat_loc warn - end - end) + Location.prerr_warning p.pat_loc warn) cases diff --git a/compiler/ml/parmatch.mli b/compiler/ml/parmatch.mli index e44fb78a70..1213d47831 100644 --- a/compiler/ml/parmatch.mli +++ b/compiler/ml/parmatch.mli @@ -24,32 +24,31 @@ val pretty_pat : pattern -> unit val pretty_line : pattern list -> unit val pretty_matrix : pattern list list -> unit -val print_res_pat: (Typedtree.pattern -> string) ref +val print_res_pat : (Typedtree.pattern -> string) ref val omega : pattern val omegas : int -> pattern list val omega_list : 'a list -> pattern list val normalize_pat : pattern -> pattern val all_record_args : - (Longident.t loc * label_description * pattern) list -> - (Longident.t loc * label_description * pattern) list + (Longident.t loc * label_description * pattern) list -> + (Longident.t loc * label_description * pattern) list val const_compare : constant -> constant -> int val le_pat : pattern -> pattern -> bool val le_pats : pattern list -> pattern list -> bool (* Exported compatibility functor, abstracted over constructor equality *) -module [@warning "-67"] Compat : - functor - (Constr: sig - val equal : - Types.constructor_description -> - Types.constructor_description -> - bool - end) -> sig - val compat : pattern -> pattern -> bool - val compats : pattern list -> pattern list -> bool - end +module Compat : functor + (Constr : sig + val equal : + Types.constructor_description -> Types.constructor_description -> bool + end) + -> sig + val compat : pattern -> pattern -> bool + val compats : pattern list -> pattern list -> bool +end +[@@warning "-67"] exception Empty val lub : pattern -> pattern -> pattern @@ -67,33 +66,39 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list val pat_of_constr : pattern -> constructor_description -> pattern val complete_constrs : - pattern -> constructor_tag list -> constructor_description list + pattern -> constructor_tag list -> constructor_description list val ppat_of_type : - Env.t -> type_expr -> - Parsetree.pattern * - (string, constructor_description) Hashtbl.t * - (string, label_description) Hashtbl.t + Env.t -> + type_expr -> + Parsetree.pattern + * (string, constructor_description) Hashtbl.t + * (string, label_description) Hashtbl.t -val pressure_variants: Env.t -> pattern list -> unit -val check_partial_gadt: - ((string, constructor_description) Hashtbl.t -> - (string, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> - Location.t -> case list -> partial -val check_unused: - (bool -> - (string, constructor_description) Hashtbl.t -> - (string, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> - case list -> unit +val pressure_variants : Env.t -> pattern list -> unit +val check_partial_gadt : + ((string, constructor_description) Hashtbl.t -> + (string, label_description) Hashtbl.t -> + Parsetree.pattern -> + pattern option) -> + Location.t -> + case list -> + partial +val check_unused : + (bool -> + (string, constructor_description) Hashtbl.t -> + (string, label_description) Hashtbl.t -> + Parsetree.pattern -> + pattern option) -> + case list -> + unit (* Irrefutability tests *) val irrefutable : pattern -> bool +val inactive : partial:partial -> pattern -> bool (** An inactive pattern is a pattern, matching against which can be duplicated, erased or delayed without change in observable behavior of the program. Patterns containing (lazy _) subpatterns or reads of mutable fields are active. *) -val inactive : partial:partial -> pattern -> bool (* Ambiguous bindings *) val check_ambiguous_bindings : case list -> unit diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index cb2a274d54..279ef1a365 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -18,7 +18,7 @@ open Asttypes type constant = - Pconst_integer of string * char option + | Pconst_integer of string * char option (* 3 3l 3L 3n Suffixes [g-z][G-Z] are accepted by the parser. @@ -31,343 +31,305 @@ type constant = {delim|other constant|delim} *) | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 +(* 3.4 2e5 1.4e-4 - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. +*) (** {1 Extension points} *) type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] +(* [@id ARG] + [@@id ARG] - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. +*) and extension = string loc * payload - (* [%id ARG] - [%%id ARG] +(* [%id ARG] + [%%id ARG] - Sub-language placeholder -- rejected by the typechecker. - *) + Sub-language placeholder -- rejected by the typechecker. +*) and attributes = attribute list and payload = | PStr of structure | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - -(** {1 Core language} *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option +(* ? P or ? P when E *) (* Type expressions *) -and core_type = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } +(** {1 Core language} *) + +and core_type = { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) +} and core_type_desc = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) + | Ptyp_any (* _ *) + | Ptyp_var of string (* 'a *) | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) | Ptyp_tuple of core_type list - (* T1 * ... * Tn + (* T1 * ... * Tn - Invariant: n >= 2 - *) + Invariant: n >= 2 + *) | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of unit - (* dummy AST node *) - | Ptyp_alias of core_type * string - (* T as 'a *) + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of unit (* dummy AST node *) + | Ptyp_alias of core_type * string (* T as 'a *) | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T + (* 'a1 ... 'an. T - Can only appear in the following context: + Can only appear in the following context: - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... - - Under Cfk_virtual for methods (not values). + - Under Cfk_virtual for methods (not values). - - As the core_type of a Pctf_method node. + - As the core_type of a Pctf_method node. - - As the core_type of a Pexp_poly node. + - As the core_type of a Pexp_poly node. - - As the pld_type field of a label_declaration. + - As the pld_type field of a label_declaration. - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) + - As a core_type of a Ptyp_object node. + *) + | Ptyp_package of package_type (* (module S) *) | Ptyp_extension of extension - (* [%id] *) +(* [%id] *) and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* +(* (module S) (module S with type t1 = T1 and ... and tn = Tn) *) and row_field = | Rtag of label loc * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + + - TODO: switch to a record representation, and keep location + *) | Rinherit of core_type - (* [ T ] *) +(* [ T ] *) and object_field = | Otag of label loc * attributes * core_type | Oinherit of core_type (* Patterns *) - -and pattern = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } +and pattern = { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) +} and pattern_desc = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_any (* _ *) + | Ppat_var of string loc (* x *) + | Ppat_alias of pattern * string loc (* P as 'a *) + | Ppat_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Ppat_interval of constant * constant - (* 'a'..'z' + (* 'a'..'z' - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) | Ppat_tuple of pattern list - (* (P1, ..., Pn) + (* (P1, ..., Pn) - Invariant: n >= 2 - *) + Invariant: n >= 2 + *) | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) + (* `A (None) + `A P (Some P) + *) | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern (* P1 | P2 *) + | Ppat_constraint of pattern * core_type (* (P : T) *) + | Ppat_type of Longident.t loc (* #tconst *) + | Ppat_lazy of pattern (* lazy P *) | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern (* exception P *) + | Ppat_extension of extension (* [%id] *) | Ppat_open of Longident.t loc * pattern - (* M.(P) *) +(* M.(P) *) (* Value expressions *) -and expression = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } +and expression = { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) +} and expression_desc = | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (* x + M.x + *) + | Pexp_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list (* function P1 -> E1 | ... | Pn -> En *) | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). - Invariant: n > 0 - *) + Invariant: n > 0 + *) | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) + (* match E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) + (* try E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_tuple of expression list - (* (E1, ..., En) + (* (E1, ..., En) - Invariant: n >= 2 - *) + Invariant: n >= 2 + *) | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) + (* `A (None) + `A E (Some E) + *) | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 + *) + | Pexp_field of expression * Longident.t loc (* E.l *) + | Pexp_setfield of expression * Longident.t loc * expression (* E1.l <- E2 *) + | Pexp_array of expression list (* [| E1; ...; En |] *) | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) + (* if E1 then E2 else E3 *) + | Pexp_sequence of expression * expression (* E1; E2 *) + | Pexp_while of expression * expression (* while E1 do E2 done *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type (* (E : T) *) | Pexp_coerce of expression * unit * core_type - (* (E :> T) (None, T) + (* (E :> T) (None, T) *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) + | Pexp_send of expression * label loc (* E # m *) + | Pexp_new of Longident.t loc (* new M.c *) + | Pexp_setinstvar of label loc * expression (* x <- 2 *) | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) + (* {< x1 = E1; ...; Xn = En >} *) | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) + (* let module M = ME in E *) | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) + (* let exception C in E *) | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) + (* assert E + Note: "assert false" is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (* lazy E *) | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of unit - (* dummy AST node *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) + (* Used for method bodies. + + Can only be used as the expression under Cfk_concrete + for methods (not values). *) + | Pexp_object of unit (* dummy AST node *) + | Pexp_newtype of string loc * expression (* fun (type t) -> E *) | Pexp_pack of module_expr - (* (module ME) + (* (module ME) - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) | Pexp_open of override_flag * Longident.t loc * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_extension of extension - (* [%id] *) + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension (* [%id] *) | Pexp_unreachable - (* . *) +(* . *) -and case = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } +and case = { + (* (P -> E) or (P when E0 -> E) *) + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; +} (* Value descriptions *) - -and value_description = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } +and value_description = { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_loc: Location.t; +} (* val x: T (prim = []) @@ -375,20 +337,18 @@ and value_description = *) (* Type declarations *) - -and type_declaration = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } +and type_declaration = { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; +} (* type t (abstract, no manifest) @@ -399,38 +359,33 @@ and type_declaration = type t = T0 = {l : T; ...} (record, manifest=T0) type t = .. (open, no manifest) *) - and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) + (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (* Invariant: non-empty list *) | Ptype_open -and label_declaration = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } +and label_declaration = { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (* l : T [@id1] [@id2] *) +} -(* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) - Note: T can be a Ptyp_poly. + Note: T can be a Ptyp_poly. *) - -and constructor_declaration = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } +and constructor_declaration = { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) +} and constructor_arguments = | Pcstr_tuple of core_type list @@ -444,145 +399,119 @@ and constructor_arguments = | C: {...} -> T0 (res = Some T0, args = Pcstr_record) | C of {...} as t (res = None, args = Pcstr_record) *) - -and type_extension = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +and type_extension = { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) +} (* type t += ... *) -and extension_constructor = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } +and extension_constructor = { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (* C of ... [@id1] [@id2] *) +} and extension_constructor_kind = - Pext_decl of constructor_arguments * core_type option - (* + | Pext_decl of constructor_arguments * core_type option + (* | C of T1 * ... * Tn ([T1; ...; Tn], None) | C: T0 ([], Some T0) | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) *) | Pext_rebind of Longident.t loc - (* +(* | C = D *) +(* Type expressions for the module language *) (** {1 Module language} *) -(* Type expressions for the module language *) - -and module_type = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } +and module_type = { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (* ... [@id1] [@id2] *) +} and module_type_desc = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) + | Pmty_ident of Longident.t loc (* S *) + | Pmty_signature of signature (* sig ... end *) | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) + (* functor(X : MT1) -> MT2 *) + | Pmty_with of module_type * with_constraint list (* MT with ... *) + | Pmty_typeof of module_expr (* module type of ME *) + | Pmty_extension of extension (* [%id] *) | Pmty_alias of Longident.t loc - (* (module M) *) +(* (module M) *) and signature = signature_item list -and signature_item = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } +and signature_item = {psig_desc: signature_item_desc; psig_loc: Location.t} and signature_item_desc = | Psig_value of value_description - (* + (* val x: T external x: T = "s1" ... "sn" *) | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) + (* type t1 = ... and ... and tn = ... *) + | Psig_typext of type_extension (* type t1 += ... *) + | Psig_exception of extension_constructor (* exception C of T *) + | Psig_module of module_declaration (* module X : MT *) | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) + (* module rec X1 : MT1 and ... and Xn : MTn *) | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of unit - (* Dummy AST node *) - | Psig_class_type of unit - (* Dummy AST node *) - | Psig_attribute of attribute - (* [@@@id] *) + (* module type S = MT + module type S *) + | Psig_open of open_description (* open X *) + | Psig_include of include_description (* include MT *) + | Psig_class of unit (* Dummy AST node *) + | Psig_class_type of unit (* Dummy AST node *) + | Psig_attribute of attribute (* [@@@id] *) | Psig_extension of extension * attributes - (* [%%id] *) - -and module_declaration = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } +(* [%%id] *) + +and module_declaration = { + pmd_name: string loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; +} (* S : MT *) -and module_type_declaration = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } +and module_type_declaration = { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_loc: Location.t; +} (* S = MT S (abstract module type declaration, pmtd_type = None) *) -and open_description = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } +and open_description = { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; +} (* open! X - popen_override = Override (silences the 'used identifier shadowing' warning) open X - popen_override = Fresh - *) +*) -and 'a include_infos = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } +and 'a include_infos = { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; +} and include_description = module_type include_infos (* include MT *) @@ -592,100 +521,77 @@ and include_declaration = module_expr include_infos and with_constraint = | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... + (* with type X.t = ... - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc (* with module X.Y = Z *) | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) + (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) +(* with module X.Y := Z *) (* Value expressions for the module language *) -and module_expr = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } +and module_expr = { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (* ... [@id1] [@id2] *) +} and module_expr_desc = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) + | Pmod_ident of Longident.t loc (* X *) + | Pmod_structure of structure (* struct ... end *) | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr (* ME1(ME2) *) + | Pmod_constraint of module_expr * module_type (* (ME : MT) *) + | Pmod_unpack of expression (* (val E) *) | Pmod_extension of extension - (* [%id] *) +(* [%id] *) and structure = structure_item list -and structure_item = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } +and structure_item = {pstr_desc: structure_item_desc; pstr_loc: Location.t} and structure_item_desc = - | Pstr_eval of expression * attributes - (* E *) + | Pstr_eval of expression * attributes (* E *) | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) + (* val x: T + external x: T = "s1" ... "sn" *) | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension (* type t1 += ... *) | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) + (* exception C of T + exception C = M.X *) + | Pstr_module of module_binding (* module X = ME *) | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of unit - (* Dummy AST node *) - | Pstr_class_type of unit - (* Dummy AST node *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) + (* module rec X1 = ME1 and ... and Xn = MEn *) + | Pstr_modtype of module_type_declaration (* module type S = MT *) + | Pstr_open of open_description (* open X *) + | Pstr_class of unit (* Dummy AST node *) + | Pstr_class_type of unit (* Dummy AST node *) + | Pstr_include of include_declaration (* include ME *) + | Pstr_attribute of attribute (* [@@@id] *) | Pstr_extension of extension * attributes - (* [%%id] *) - -and value_binding = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - -and module_binding = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } +(* [%%id] *) + +and value_binding = { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; +} + +and module_binding = { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; +} (* X = ME *) - diff --git a/compiler/ml/path.ml b/compiler/ml/path.ml index 5189386514..d3c78a3b13 100644 --- a/compiler/ml/path.ml +++ b/compiler/ml/path.ml @@ -13,54 +13,51 @@ (* *) (**************************************************************************) -type t = - Pident of Ident.t - | Pdot of t * string * int - | Papply of t * t +type t = Pident of Ident.t | Pdot of t * string * int | Papply of t * t let nopos = -1 let rec same p1 p2 = match (p1, p2) with - (Pident id1, Pident id2) -> Ident.same id1 id2 - | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2 - | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - same fun1 fun2 && same arg1 arg2 - | (_, _) -> false + | Pident id1, Pident id2 -> Ident.same id1 id2 + | Pdot (p1, s1, _pos1), Pdot (p2, s2, _pos2) -> s1 = s2 && same p1 p2 + | Papply (fun1, arg1), Papply (fun2, arg2) -> same fun1 fun2 && same arg1 arg2 + | _, _ -> false let rec compare p1 p2 = match (p1, p2) with - (Pident id1, Pident id2) -> Ident.compare id1 id2 - | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> - let h = compare p1 p2 in - if h <> 0 then h else String.compare s1 s2 - | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - let h = compare fun1 fun2 in - if h <> 0 then h else compare arg1 arg2 - | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1 - | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1 + | Pident id1, Pident id2 -> Ident.compare id1 id2 + | Pdot (p1, s1, _pos1), Pdot (p2, s2, _pos2) -> + let h = compare p1 p2 in + if h <> 0 then h else String.compare s1 s2 + | Papply (fun1, arg1), Papply (fun2, arg2) -> + let h = compare fun1 fun2 in + if h <> 0 then h else compare arg1 arg2 + | (Pident _ | Pdot _), (Pdot _ | Papply _) -> -1 + | (Pdot _ | Papply _), (Pident _ | Pdot _) -> 1 let rec isfree id = function - Pident id' -> Ident.same id id' - | Pdot(p, _s, _pos) -> isfree id p - | Papply(p1, p2) -> isfree id p1 || isfree id p2 + | Pident id' -> Ident.same id id' + | Pdot (p, _s, _pos) -> isfree id p + | Papply (p1, p2) -> isfree id p1 || isfree id p2 let rec binding_time = function - Pident id -> Ident.binding_time id - | Pdot(p, _s, _pos) -> binding_time p - | Papply(p1, p2) -> Ext_pervasives.max_int (binding_time p1) (binding_time p2) + | Pident id -> Ident.binding_time id + | Pdot (p, _s, _pos) -> binding_time p + | Papply (p1, p2) -> + Ext_pervasives.max_int (binding_time p1) (binding_time p2) let kfalse _ = false -let rec name ?(paren=kfalse) = function - Pident id -> Ident.name id - | Pdot(p, s, _pos) -> - name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s - | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" +let rec name ?(paren = kfalse) = function + | Pident id -> Ident.name id + | Pdot (p, s, _pos) -> + name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s + | Papply (p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" let rec head = function - Pident id -> id - | Pdot(p, _s, _pos) -> head p + | Pident id -> id + | Pdot (p, _s, _pos) -> head p | Papply _ -> assert false let flatten = @@ -72,22 +69,23 @@ let flatten = fun t -> flatten [] t let heads p = - let rec heads p acc = match p with + let rec heads p acc = + match p with | Pident id -> id :: acc | Pdot (p, _s, _pos) -> heads p acc - | Papply(p1, p2) -> - heads p1 (heads p2 acc) - in heads p [] + | Papply (p1, p2) -> heads p1 (heads p2 acc) + in + heads p [] let rec last = function | Pident id -> Ident.name id - | Pdot(_, s, _) -> s - | Papply(_, p) -> last p + | Pdot (_, s, _) -> s + | Papply (_, p) -> last p let is_uident s = assert (s <> ""); match s.[0] with - | 'A'..'Z' -> true + | 'A' .. 'Z' -> true | _ -> false type typath = @@ -98,9 +96,8 @@ type typath = let constructor_typath = function | Pident id when is_uident (Ident.name id) -> LocalExt id - | Pdot(ty_path, s, _) when is_uident s -> - if is_uident (last ty_path) then Ext (ty_path, s) - else Cstr (ty_path, s) + | Pdot (ty_path, s, _) when is_uident s -> + if is_uident (last ty_path) then Ext (ty_path, s) else Cstr (ty_path, s) | p -> Regular p let is_constructor_typath p = diff --git a/compiler/ml/path.mli b/compiler/ml/path.mli index 18491462e8..0c24ae12f3 100644 --- a/compiler/ml/path.mli +++ b/compiler/ml/path.mli @@ -15,26 +15,24 @@ (* Access paths *) -type t = - Pident of Ident.t - | Pdot of t * string * int - | Papply of t * t +type t = Pident of Ident.t | Pdot of t * string * int | Papply of t * t -val same: t -> t -> bool -val compare: t -> t -> int -val isfree: Ident.t -> t -> bool -val binding_time: t -> int -val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] +val same : t -> t -> bool +val compare : t -> t -> int +val isfree : Ident.t -> t -> bool +val binding_time : t -> int +val flatten : t -> [`Contains_apply | `Ok of Ident.t * string list] -val nopos: int +val nopos : int -val name: ?paren:(string -> bool) -> t -> string - (* [paren] tells whether a path suffix needs parentheses *) -val head: t -> Ident.t +val name : ?paren:(string -> bool) -> t -> string +(* [paren] tells whether a path suffix needs parentheses *) -val heads: t -> Ident.t list +val head : t -> Ident.t -val last: t -> string +val heads : t -> Ident.t list + +val last : t -> string type typath = | Regular of t @@ -42,5 +40,5 @@ type typath = | LocalExt of Ident.t | Cstr of t * string -val constructor_typath: t -> typath -val is_constructor_typath: t -> bool +val constructor_typath : t -> typath +val is_constructor_typath : t -> bool diff --git a/compiler/ml/pprintast.mli b/compiler/ml/pprintast.mli index 7da9ee0d12..fb26664584 100644 --- a/compiler/ml/pprintast.mli +++ b/compiler/ml/pprintast.mli @@ -15,13 +15,12 @@ type space_formatter = (unit, Format.formatter, unit) format - val expression : Format.formatter -> Parsetree.expression -> unit val string_of_expression : Parsetree.expression -> string -val core_type: Format.formatter -> Parsetree.core_type -> unit -val pattern: Format.formatter -> Parsetree.pattern -> unit -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string -val string_of_int_as_char: int -> string +val core_type : Format.formatter -> Parsetree.core_type -> unit +val pattern : Format.formatter -> Parsetree.pattern -> unit +val signature : Format.formatter -> Parsetree.signature -> unit +val structure : Format.formatter -> Parsetree.structure -> unit +val string_of_structure : Parsetree.structure -> string +val string_of_int_as_char : int -> string diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 38760e67d8..155cd6ddb6 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -30,129 +30,179 @@ let ident_create = wrap Ident.create let ident_create_predef_exn = wrap Ident.create_predef_exn let ident_int = ident_create "int" + and ident_char = ident_create "char" + and ident_float = ident_create "float" + and ident_bool = ident_create "bool" + and ident_unit = ident_create "unit" + and ident_exn = ident_create "exn" + and ident_array = ident_create "array" + and ident_list = ident_create "list" + and ident_option = ident_create "option" + and ident_result = ident_create "result" + and ident_dict = ident_create "dict" + and ident_bigint = ident_create "bigint" + and ident_lazy_t = ident_create "lazy_t" + and ident_string = ident_create "string" + and ident_extension_constructor = ident_create "extension_constructor" + and ident_unknown = ident_create "unknown" + and ident_promise = ident_create "promise" + and ident_uncurried = ident_create "function$" -type test = - | For_sure_yes - | For_sure_no - | NA +type test = For_sure_yes | For_sure_no | NA let type_is_builtin_path_but_option (p : Path.t) : test = match p with + | Pident {stamp} when stamp = ident_option.stamp -> For_sure_no + | Pident {stamp} when stamp = ident_unit.stamp -> For_sure_no | Pident {stamp} - when stamp = ident_option.stamp - -> For_sure_no - | Pident {stamp} - when stamp = ident_unit.stamp - -> For_sure_no - | Pident {stamp} - when stamp >= ident_int.stamp && stamp <= ident_uncurried.stamp - -> For_sure_yes + when stamp >= ident_int.stamp && stamp <= ident_uncurried.stamp -> + For_sure_yes | _ -> NA let path_int = Pident ident_int + and path_char = Pident ident_char + and path_float = Pident ident_float + and path_bool = Pident ident_bool + and path_unit = Pident ident_unit + and path_exn = Pident ident_exn + and path_array = Pident ident_array + and path_list = Pident ident_list + and path_option = Pident ident_option + and path_result = Pident ident_result + and path_dict = Pident ident_dict + and path_bigint = Pident ident_bigint + and path_lazy_t = Pident ident_lazy_t + and path_string = Pident ident_string + and path_unkonwn = Pident ident_unknown + and path_extension_constructor = Pident ident_extension_constructor + and path_promise = Pident ident_promise + and path_uncurried = Pident ident_uncurried -let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) -and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) -and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) -and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) -and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) -and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) -and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) -and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) -and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) -and type_result t1 t2 = newgenty (Tconstr(path_result, [t1; t2], ref Mnil)) -and type_dict t = newgenty (Tconstr(path_dict, [t], ref Mnil)) - -and type_bigint = newgenty (Tconstr(path_bigint, [], ref Mnil)) -and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) -and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) - -and type_unknown = newgenty (Tconstr(path_unkonwn, [], ref Mnil)) +let type_int = newgenty (Tconstr (path_int, [], ref Mnil)) + +and type_char = newgenty (Tconstr (path_char, [], ref Mnil)) + +and type_float = newgenty (Tconstr (path_float, [], ref Mnil)) + +and type_bool = newgenty (Tconstr (path_bool, [], ref Mnil)) + +and type_unit = newgenty (Tconstr (path_unit, [], ref Mnil)) + +and type_exn = newgenty (Tconstr (path_exn, [], ref Mnil)) + +and type_array t = newgenty (Tconstr (path_array, [t], ref Mnil)) + +and type_list t = newgenty (Tconstr (path_list, [t], ref Mnil)) + +and type_option t = newgenty (Tconstr (path_option, [t], ref Mnil)) + +and type_result t1 t2 = newgenty (Tconstr (path_result, [t1; t2], ref Mnil)) + +and type_dict t = newgenty (Tconstr (path_dict, [t], ref Mnil)) + +and type_bigint = newgenty (Tconstr (path_bigint, [], ref Mnil)) + +and type_lazy_t t = newgenty (Tconstr (path_lazy_t, [t], ref Mnil)) + +and type_string = newgenty (Tconstr (path_string, [], ref Mnil)) + +and type_unknown = newgenty (Tconstr (path_unkonwn, [], ref Mnil)) + and type_extension_constructor = - newgenty (Tconstr(path_extension_constructor, [], ref Mnil)) + newgenty (Tconstr (path_extension_constructor, [], ref Mnil)) let ident_match_failure = ident_create_predef_exn "Match_failure" and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" + and ident_failure = ident_create_predef_exn "Failure" + and ident_ok = ident_create_predef_exn "Ok" + and ident_error = ident_create_predef_exn "Error" -and ident_dict_magic_field_name = ident_create Dict_type_helpers.dict_magic_field_name +and ident_dict_magic_field_name = + ident_create Dict_type_helpers.dict_magic_field_name and ident_js_error = ident_create_predef_exn "JsError" + and ident_not_found = ident_create_predef_exn "Not_found" and ident_end_of_file = ident_create_predef_exn "End_of_file" -and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" +and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" and ident_assert_failure = ident_create_predef_exn "Assert_failure" + and ident_undefined_recursive_module = - ident_create_predef_exn "Undefined_recursive_module" - -let all_predef_exns = [ - ident_match_failure; - ident_invalid_argument; - ident_failure; - ident_js_error; - ident_not_found; - ident_end_of_file; - ident_division_by_zero; - ident_assert_failure; - ident_undefined_recursive_module; -] + ident_create_predef_exn "Undefined_recursive_module" + +let all_predef_exns = + [ + ident_match_failure; + ident_invalid_argument; + ident_failure; + ident_js_error; + ident_not_found; + ident_end_of_file; + ident_division_by_zero; + ident_assert_failure; + ident_undefined_recursive_module; + ] let path_match_failure = Pident ident_match_failure + and path_assert_failure = Pident ident_assert_failure + and path_undefined_recursive_module = Pident ident_undefined_recursive_module let decl_abstr = - {type_params = []; - type_arity = 0; - type_kind = Type_abstract; - type_loc = Location.none; - type_private = Asttypes.Public; - type_manifest = None; - type_variance = []; - type_newtype_level = None; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = []; + type_newtype_level = None; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; } let decl_abstr_imm = {decl_abstr with type_immediate = true} @@ -167,179 +217,248 @@ let cstr id args = } let ident_false = ident_create "false" + and ident_true = ident_create "true" + and ident_void = ident_create "()" + and ident_nil = ident_create "[]" + and ident_cons = ident_create "::" + and ident_none = ident_create "None" + and ident_some = ident_create "Some" + and ident_ctor_unknown = ident_create "Unknown" + and ident_ctor_uncurried = ident_create "Function$" let common_initial_env add_type add_extension empty_env = let decl_bool = - {decl_abstr with - type_kind = Type_variant([cstr ident_false []; cstr ident_true []]); - type_immediate = true} + { + decl_abstr with + type_kind = Type_variant [cstr ident_false []; cstr ident_true []]; + type_immediate = true; + } and decl_unit = - {decl_abstr with - type_kind = Type_variant([cstr ident_void []]); - type_immediate = true} - and decl_exn = - {decl_abstr with - type_kind = Type_open} + { + decl_abstr with + type_kind = Type_variant [cstr ident_void []]; + type_immediate = true; + } + and decl_exn = {decl_abstr with type_kind = Type_open} and decl_array = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.full]} + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.full]; + } and decl_list = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_kind = - Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]); - type_variance = [Variance.covariant]} + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_kind = + Type_variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]; + type_variance = [Variance.covariant]; + } and decl_option = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]); - type_variance = [Variance.covariant]} + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_kind = Type_variant [cstr ident_none []; cstr ident_some [tvar]]; + type_variance = [Variance.covariant]; + } and decl_result = - let tvar1, tvar2 = newgenvar(), newgenvar() in - {decl_abstr with - type_params = [tvar1; tvar2]; - type_arity = 2; - type_kind = - Type_variant([cstr ident_ok [tvar1]; - cstr ident_error [tvar2]]); - type_variance = [Variance.covariant; Variance.covariant]} + let tvar1, tvar2 = (newgenvar (), newgenvar ()) in + { + decl_abstr with + type_params = [tvar1; tvar2]; + type_arity = 2; + type_kind = Type_variant [cstr ident_ok [tvar1]; cstr ident_error [tvar2]]; + type_variance = [Variance.covariant; Variance.covariant]; + } and decl_dict = - let tvar = newgenvar() in + let tvar = newgenvar () in (* Dicts are implemented as a single "magic" field record. This magic field is the medium through which we can piggy back on the existing record pattern matching mechanism. We do this by letting the compiler route any label lookup for the dict record type to the magic field, which has the type of the values of the dict. - So, this definition is important for the dict pattern matching functionality, - but not something intended to be exposed to the user. *) - {decl_abstr with - type_attributes = [Dict_type_helpers.dict_attr; (Location.mknoloc "live", Parsetree.PStr [])]; + So, this definition is important for the dict pattern matching functionality, + but not something intended to be exposed to the user. *) + { + decl_abstr with + type_attributes = + [ + Dict_type_helpers.dict_attr; + (Location.mknoloc "live", Parsetree.PStr []); + ]; type_params = [tvar]; type_arity = 1; type_variance = [Variance.full]; - type_kind = Type_record ([{ - ld_id = ident_dict_magic_field_name; - ld_attributes = [(Location.mknoloc "res.optional", Parsetree.PStr []); Dict_type_helpers.dict_magic_field_attr]; - ld_loc = Location.none; - ld_mutable = Immutable; - ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil)); - }], - Record_optional_labels [Ident.name ident_dict_magic_field_name]); + type_kind = + Type_record + ( [ + { + ld_id = ident_dict_magic_field_name; + ld_attributes = + [ + (Location.mknoloc "res.optional", Parsetree.PStr []); + Dict_type_helpers.dict_magic_field_attr; + ]; + ld_loc = Location.none; + ld_mutable = Immutable; + ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil)); + }; + ], + Record_optional_labels [Ident.name ident_dict_magic_field_name] ); } and decl_uncurried = - let tvar1, tvar2 = newgenvar(), newgenvar() in - {decl_abstr with - type_params = [tvar1; tvar2]; - type_arity = 2; - type_kind = Type_variant([cstr ident_ctor_uncurried [tvar1]]); - type_variance = [Variance.covariant; Variance.covariant]; - type_unboxed = Types.unboxed_true_default_false; - } - and decl_unknown = - let tvar = newgenvar () in - {decl_abstr with + let tvar1, tvar2 = (newgenvar (), newgenvar ()) in + { + decl_abstr with + type_params = [tvar1; tvar2]; + type_arity = 2; + type_kind = Type_variant [cstr ident_ctor_uncurried [tvar1]]; + type_variance = [Variance.covariant; Variance.covariant]; + type_unboxed = Types.unboxed_true_default_false; + } + and decl_unknown = + let tvar = newgenvar () in + { + decl_abstr with type_params = []; type_arity = 0; - type_kind = Type_variant ([ { - cd_id = ident_ctor_unknown; - cd_args = Cstr_tuple [tvar]; - cd_res = Some type_unknown; - cd_loc = Location.none; - cd_attributes = [] - }]); - type_unboxed = Types.unboxed_true_default_false - } + type_kind = + Type_variant + [ + { + cd_id = ident_ctor_unknown; + cd_args = Cstr_tuple [tvar]; + cd_res = Some type_unknown; + cd_loc = Location.none; + cd_attributes = []; + }; + ]; + type_unboxed = Types.unboxed_true_default_false; + } and decl_lazy_t = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.covariant]} + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.covariant]; + } and decl_promise = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.covariant]} + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.covariant]; + } in let add_exception id l = add_extension id - { ext_type_path = path_exn; + { + ext_type_path = path_exn; ext_type_params = []; ext_args = Cstr_tuple l; ext_ret_type = None; ext_private = Asttypes.Public; ext_loc = Location.none; - ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern"; - loc=Location.none}, - Parsetree.PStr[]]; - ext_is_exception = true } + ext_attributes = + [ + ( { + Asttypes.txt = "ocaml.warn_on_literal_pattern"; + loc = Location.none; + }, + Parsetree.PStr [] ); + ]; + ext_is_exception = true; + } in add_exception ident_match_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_exception ident_invalid_argument [type_string] ( - add_exception ident_js_error [type_unknown] ( - add_exception ident_failure [type_string] ( - add_exception ident_not_found [] ( - add_exception ident_end_of_file [] ( - add_exception ident_division_by_zero [] ( - add_exception ident_assert_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_exception ident_undefined_recursive_module - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_type ident_bigint decl_abstr ( - - add_type ident_lazy_t decl_lazy_t ( - add_type ident_option decl_option ( - add_type ident_result decl_result ( - add_type ident_dict decl_dict ( - add_type ident_list decl_list ( - add_type ident_array decl_array ( - add_type ident_exn decl_exn ( - add_type ident_unit decl_unit ( - add_type ident_bool decl_bool ( - add_type ident_float decl_abstr ( - add_type ident_unknown decl_unknown ( - add_type ident_uncurried decl_uncurried ( - add_type ident_string decl_abstr ( - add_type ident_int decl_abstr_imm ( - add_type ident_extension_constructor decl_abstr ( - add_type ident_promise decl_promise ( - empty_env)))))))))))))))))))))))))) + [newgenty (Ttuple [type_string; type_int; type_int])] + (add_exception ident_invalid_argument [type_string] + (add_exception ident_js_error [type_unknown] + (add_exception ident_failure [type_string] + (add_exception ident_not_found [] + (add_exception ident_end_of_file [] + (add_exception ident_division_by_zero [] + (add_exception ident_assert_failure + [newgenty (Ttuple [type_string; type_int; type_int])] + (add_exception ident_undefined_recursive_module + [ + newgenty (Ttuple [type_string; type_int; type_int]); + ] + (add_type ident_bigint decl_abstr + (add_type ident_lazy_t decl_lazy_t + (add_type ident_option decl_option + (add_type ident_result decl_result + (add_type ident_dict decl_dict + (add_type ident_list decl_list + (add_type ident_array decl_array + (add_type ident_exn decl_exn + (add_type ident_unit + decl_unit + (add_type ident_bool + decl_bool + (add_type ident_float + decl_abstr + (add_type + ident_unknown + decl_unknown + (add_type + ident_uncurried + decl_uncurried + (add_type + ident_string + decl_abstr + (add_type + ident_int + decl_abstr_imm + (add_type + ident_extension_constructor + decl_abstr + (add_type + ident_promise + decl_promise + empty_env))))))))))))))))))))))))) let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in - let decl_type_char = - {decl_abstr with - type_manifest = Some type_int; - type_private = Private} in - add_type ident_char decl_type_char common - - + let decl_type_char = + {decl_abstr with type_manifest = Some type_int; type_private = Private} + in + add_type ident_char decl_type_char common + let builtin_values = - List.map (fun id -> Ident.make_global id; (Ident.name id, id)) - [ident_match_failure; - ident_invalid_argument; - ident_failure; ident_js_error; ident_not_found; ident_end_of_file; - ident_division_by_zero; - ident_assert_failure; ident_undefined_recursive_module ] + List.map + (fun id -> + Ident.make_global id; + (Ident.name id, id)) + [ + ident_match_failure; + ident_invalid_argument; + ident_failure; + ident_js_error; + ident_not_found; + ident_end_of_file; + ident_division_by_zero; + ident_assert_failure; + ident_undefined_recursive_module; + ] (* Start non-predef identifiers at 1000. This way, more predefs can be defined in this file (above!) without breaking .cmi diff --git a/compiler/ml/predef.mli b/compiler/ml/predef.mli index 8de1073fe1..7919b802ee 100644 --- a/compiler/ml/predef.mli +++ b/compiler/ml/predef.mli @@ -17,43 +17,43 @@ open Types -val type_int: type_expr -val type_char: type_expr -val type_string: type_expr -val type_float: type_expr -val type_bool: type_expr -val type_unit: type_expr -val type_exn: type_expr -val type_array: type_expr -> type_expr -val type_list: type_expr -> type_expr -val type_option: type_expr -> type_expr -val type_result: type_expr -> type_expr -> type_expr -val type_dict: type_expr -> type_expr +val type_int : type_expr +val type_char : type_expr +val type_string : type_expr +val type_float : type_expr +val type_bool : type_expr +val type_unit : type_expr +val type_exn : type_expr +val type_array : type_expr -> type_expr +val type_list : type_expr -> type_expr +val type_option : type_expr -> type_expr +val type_result : type_expr -> type_expr -> type_expr +val type_dict : type_expr -> type_expr -val type_bigint: type_expr -val type_lazy_t: type_expr -> type_expr -val type_extension_constructor:type_expr +val type_bigint : type_expr +val type_lazy_t : type_expr -> type_expr +val type_extension_constructor : type_expr -val path_int: Path.t -val path_char: Path.t -val path_string: Path.t -val path_float: Path.t -val path_bool: Path.t -val path_unit: Path.t -val path_exn: Path.t -val path_array: Path.t -val path_list: Path.t -val path_option: Path.t -val path_result: Path.t -val path_dict: Path.t +val path_int : Path.t +val path_char : Path.t +val path_string : Path.t +val path_float : Path.t +val path_bool : Path.t +val path_unit : Path.t +val path_exn : Path.t +val path_array : Path.t +val path_list : Path.t +val path_option : Path.t +val path_result : Path.t +val path_dict : Path.t -val path_bigint: Path.t -val path_lazy_t: Path.t -val path_extension_constructor: Path.t -val path_promise: Path.t -val path_uncurried: Path.t +val path_bigint : Path.t +val path_lazy_t : Path.t +val path_extension_constructor : Path.t +val path_promise : Path.t +val path_uncurried : Path.t -val path_match_failure: Path.t +val path_match_failure : Path.t val path_assert_failure : Path.t val path_undefined_recursive_module : Path.t @@ -61,27 +61,25 @@ val path_undefined_recursive_module : Path.t recursion between predef and env, we break it by parameterizing over Env.t, Env.add_type and Env.add_extension. *) -val build_initial_env: +val build_initial_env : (Ident.t -> type_declaration -> 'a -> 'a) -> (Ident.t -> extension_constructor -> 'a -> 'a) -> - 'a -> 'a + 'a -> + 'a (* To initialize linker tables *) -val builtin_values: (string * Ident.t) list -val builtin_idents: (string * Ident.t) list +val builtin_values : (string * Ident.t) list +val builtin_idents : (string * Ident.t) list +val ident_division_by_zero : Ident.t (** All predefined exceptions, exposed as [Ident.t] for flambda (for building value approximations). The [Ident.t] for division by zero is also exported explicitly so flambda can generate code to raise it. *) -val ident_division_by_zero: Ident.t + val all_predef_exns : Ident.t list -type test = - | For_sure_yes - | For_sure_no - | NA +type test = For_sure_yes | For_sure_no | NA -val type_is_builtin_path_but_option : - Path.t -> test +val type_is_builtin_path_but_option : Path.t -> test diff --git a/compiler/ml/primitive.ml b/compiler/ml/primitive.ml index d7ff04ac06..f776eb29df 100644 --- a/compiler/ml/primitive.ml +++ b/compiler/ml/primitive.ml @@ -20,66 +20,61 @@ open Parsetree type boxed_integer = Pbigint | Pint32 | Pint64 -type description = - { prim_name: string; (* Name of primitive or C function *) - prim_arity: int; (* Number of arguments *) - prim_alloc: bool; (* Does it allocates or raise? *) - prim_native_name: string; (* Name of C function for the nat. code gen. *) - prim_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *) - } +type description = { + prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_from_constructor: bool; + (* Is it from a type constructor instead of a concrete function type? *) +} -let coerce : (description -> description -> bool) ref = - ref (fun - (p1 : description) (p2 : description) -> - p1 = p2 - ) +let coerce : (description -> description -> bool) ref = + ref (fun (p1 : description) (p2 : description) -> p1 = p2) let simple ~name ~arity ~alloc = - {prim_name = name; - prim_arity = arity; - prim_alloc = alloc; - prim_native_name = ""; - prim_from_constructor = false;} + { + prim_name = name; + prim_arity = arity; + prim_alloc = alloc; + prim_native_name = ""; + prim_from_constructor = false; + } let make ~name ~alloc ~native_name ~arity = - {prim_name = name; - prim_arity = arity; - prim_alloc = alloc; - prim_native_name = native_name; - prim_from_constructor = false;} + { + prim_name = name; + prim_arity = arity; + prim_alloc = alloc; + prim_native_name = native_name; + prim_from_constructor = false; + } let parse_declaration valdecl ~arity ~from_constructor = let name, native_name = match valdecl.pval_prim with | name :: name2 :: _ -> (name, name2) | name :: _ -> (name, "") - | [] -> - fatal_error "Primitive.parse_declaration" + | [] -> fatal_error "Primitive.parse_declaration" in - {prim_name = name; - prim_arity = arity; - prim_alloc = true; - prim_native_name = native_name; - prim_from_constructor = from_constructor} + { + prim_name = name; + prim_arity = arity; + prim_alloc = true; + prim_native_name = native_name; + prim_from_constructor = from_constructor; + } open Outcometree let print p osig_val_decl = let prims = - if p.prim_native_name <> "" then - [p.prim_name; p.prim_native_name] - else - [p.prim_name] + if p.prim_native_name <> "" then [p.prim_name; p.prim_native_name] + else [p.prim_name] in - { osig_val_decl with - oval_prims = prims; - oval_attributes = [] } + {osig_val_decl with oval_prims = prims; oval_attributes = []} let native_name p = - if p.prim_native_name <> "" - then p.prim_native_name - else p.prim_name - -let byte_name p = - p.prim_name + if p.prim_native_name <> "" then p.prim_native_name else p.prim_name +let byte_name p = p.prim_name diff --git a/compiler/ml/primitive.mli b/compiler/ml/primitive.mli index ff53c71170..dbd4cc310c 100644 --- a/compiler/ml/primitive.mli +++ b/compiler/ml/primitive.mli @@ -17,43 +17,31 @@ type boxed_integer = Pbigint | Pint32 | Pint64 -type description = private - { prim_name: string; (* Name of primitive or C function *) - prim_arity: int; (* Number of arguments *) - prim_alloc: bool; (* Does it allocates or raise? *) - prim_native_name: string; (* Name of C function for the nat. code gen. *) - prim_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *) - } +type description = private { + prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_from_constructor: bool; + (* Is it from a type constructor instead of a concrete function type? *) +} (* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) -val simple - : name:string - -> arity:int - -> alloc:bool - -> description +val simple : name:string -> arity:int -> alloc:bool -> description -val make - : name:string - -> alloc:bool - -> native_name:string - -> arity: int - -> description +val make : + name:string -> alloc:bool -> native_name:string -> arity:int -> description -val parse_declaration - : Parsetree.value_description - -> arity: int - -> from_constructor: bool - -> description +val parse_declaration : + Parsetree.value_description -> + arity:int -> + from_constructor:bool -> + description -val print - : description - -> Outcometree.out_val_decl - -> Outcometree.out_val_decl +val print : description -> Outcometree.out_val_decl -> Outcometree.out_val_decl -val native_name: description -> string -val byte_name: description -> string +val native_name : description -> string +val byte_name : description -> string - -val coerce : - (description -> description -> bool ) ref +val coerce : (description -> description -> bool) ref diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index d181935b84..5984b35c6a 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -13,45 +13,37 @@ (* *) (**************************************************************************) -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Parsetree;; +open Asttypes +open Format +open Lexing +open Location +open Parsetree let fmt_position with_name f l = let fname = if with_name then l.pos_fname else "" in - if l.pos_lnum = -1 - then fprintf f "%s[%d]" fname l.pos_cnum - else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol - (l.pos_cnum - l.pos_bol) -;; + if l.pos_lnum = -1 then fprintf f "%s[%d]" fname l.pos_cnum + else + fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol (l.pos_cnum - l.pos_bol) let fmt_location f loc = if !Clflags.dump_location then ( - let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in - fprintf f "(%a..%a)" (fmt_position true) loc.loc_start - (fmt_position p_2nd_name) loc.loc_end; - if loc.loc_ghost then fprintf f " ghost"; - ) -;; + let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in + fprintf f "(%a..%a)" (fmt_position true) loc.loc_start + (fmt_position p_2nd_name) loc.loc_end; + if loc.loc_ghost then fprintf f " ghost") let rec fmt_longident_aux f x = match x with - | Longident.Lident (s) -> fprintf f "%s" s; - | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lident s -> fprintf f "%s" s + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; -;; - + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z let fmt_longident_loc f (x : Longident.t loc) = - fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc; -;; + fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc let fmt_string_loc f (x : string loc) = - fprintf f "\"%s\" %a" x.txt fmt_location x.loc; -;; + fprintf f "\"%s\" %a" x.txt fmt_location x.loc let fmt_char_option f = function | None -> fprintf f "None" @@ -59,25 +51,22 @@ let fmt_char_option f = function let fmt_constant f x = match x with - | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | Pconst_char (c) -> fprintf f "PConst_char %02x" c; - | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; + | Pconst_integer (i, m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m + | Pconst_char c -> fprintf f "PConst_char %02x" c + | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s | Pconst_string (s, Some delim) -> - fprintf f "PConst_string (%S,Some %S)" s delim; - | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; -;; + fprintf f "PConst_string (%S,Some %S)" s delim + | Pconst_float (s, m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m let fmt_mutable_flag f x = match x with - | Immutable -> fprintf f "Immutable"; - | Mutable -> fprintf f "Mutable"; -;; + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" let fmt_override_flag f x = match x with - | Override -> fprintf f "Override"; - | Fresh -> fprintf f "Fresh"; -;; + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" let fmt_closed_flag f x = match x with @@ -86,102 +75,96 @@ let fmt_closed_flag f x = let fmt_rec_flag f x = match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" let fmt_direction_flag f x = match x with - | Upto -> fprintf f "Up"; - | Downto -> fprintf f "Down"; -;; + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" let fmt_private_flag f x = match x with - | Public -> fprintf f "Public"; - | Private -> fprintf f "Private"; -;; + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" let line i f s (*...*) = - fprintf f "%s" (String.make ((2*i) mod 72) ' '); + fprintf f "%s" (String.make (2 * i mod 72) ' '); fprintf f s (*...*) -;; let list i f ppf l = match l with - | [] -> line i ppf "[]\n"; + | [] -> line i ppf "[]\n" | _ :: _ -> - line i ppf "[\n"; - List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; + line i ppf "[\n"; + List.iter (f (i + 1) ppf) l; + line i ppf "]\n" let option i f ppf x = match x with - | None -> line i ppf "None\n"; + | None -> line i ppf "None\n" | Some x -> - line i ppf "Some\n"; - f (i+1) ppf x; -;; + line i ppf "Some\n"; + f (i + 1) ppf x -let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;; -let string i ppf s = line i ppf "\"%s\"\n" s;; -let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; +let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li +let string i ppf s = line i ppf "\"%s\"\n" s +let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s let arg_label i ppf = function | Nolabel -> line i ppf "Nolabel\n" | Optional s -> line i ppf "Optional \"%s\"\n" s | Labelled s -> line i ppf "Labelled \"%s\"\n" s -;; let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; attributes i ppf x.ptyp_attributes; - let i = i+1 in + let i = i + 1 in match x.ptyp_desc with - | Ptyp_any -> line i ppf "Ptyp_any\n"; - | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_any -> line i ppf "Ptyp_any\n" + | Ptyp_var s -> line i ppf "Ptyp_var %s\n" s | Ptyp_arrow (l, ct1, ct2) -> - line i ppf "Ptyp_arrow\n"; - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2; + line i ppf "Ptyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2 | Ptyp_tuple l -> - line i ppf "Ptyp_tuple\n"; - list i core_type ppf l; + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l | Ptyp_constr (li, l) -> - line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; + line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; + list i core_type ppf l | Ptyp_variant (l, closed, low) -> - line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; - list i label_x_bool_x_core_type_list ppf l; - option i (fun i -> list i string) ppf low + line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low | Ptyp_object (l, c) -> - line i ppf "Ptyp_object %a\n" fmt_closed_flag c; - let i = i + 1 in - List.iter ( - function - | Otag (l, attrs, t) -> - line i ppf "method %s\n" l.txt; - attributes i ppf attrs; - core_type (i + 1) ppf t - | Oinherit ct -> - line i ppf "Oinherit\n"; - core_type (i + 1) ppf ct - ) l + line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter + (function + | Otag (l, attrs, t) -> + line i ppf "method %s\n" l.txt; + attributes i ppf attrs; + core_type (i + 1) ppf t + | Oinherit ct -> + line i ppf "Oinherit\n"; + core_type (i + 1) ppf ct) + l | Ptyp_class () -> () | Ptyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%s\"\n" s; - core_type i ppf ct; + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct | Ptyp_poly (sl, ct) -> - line i ppf "Ptyp_poly%a\n" - (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl; - core_type i ppf ct; + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) + sl; + core_type i ppf ct | Ptyp_package (s, l) -> - line i ppf "Ptyp_package %a\n" fmt_longident_loc s; - list i package_with ppf l; + line i ppf "Ptyp_package %a\n" fmt_longident_loc s; + list i package_with ppf l | Ptyp_extension (s, arg) -> - line i ppf "Ptyp_extension \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Ptyp_extension \"%s\"\n" s.txt; + payload i ppf arg and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident_loc s; @@ -190,217 +173,214 @@ and package_with i ppf (s, t) = and pattern i ppf x = line i ppf "pattern %a\n" fmt_location x.ppat_loc; attributes i ppf x.ppat_attributes; - let i = i+1 in + let i = i + 1 in match x.ppat_desc with - | Ppat_any -> line i ppf "Ppat_any\n"; - | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; + | Ppat_any -> line i ppf "Ppat_any\n" + | Ppat_var s -> line i ppf "Ppat_var %a\n" fmt_string_loc s | Ppat_alias (p, s) -> - line i ppf "Ppat_alias %a\n" fmt_string_loc s; - pattern i ppf p; - | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p + | Ppat_constant c -> line i ppf "Ppat_constant %a\n" fmt_constant c | Ppat_interval (c1, c2) -> - line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; - | Ppat_tuple (l) -> - line i ppf "Ppat_tuple\n"; - list i pattern ppf l; + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2 + | Ppat_tuple l -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l | Ppat_construct (li, po) -> - line i ppf "Ppat_construct %a\n" fmt_longident_loc li; - option i pattern ppf po; + line i ppf "Ppat_construct %a\n" fmt_longident_loc li; + option i pattern ppf po | Ppat_variant (l, po) -> - line i ppf "Ppat_variant \"%s\"\n" l; - option i pattern ppf po; + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po | Ppat_record (l, c) -> - line i ppf "Ppat_record %a\n" fmt_closed_flag c; - list i longident_x_pattern ppf l; - | Ppat_array (l) -> - line i ppf "Ppat_array\n"; - list i pattern ppf l; + line i ppf "Ppat_record %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l + | Ppat_array l -> + line i ppf "Ppat_array\n"; + list i pattern ppf l | Ppat_or (p1, p2) -> - line i ppf "Ppat_or\n"; - pattern i ppf p1; - pattern i ppf p2; + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2 | Ppat_lazy p -> - line i ppf "Ppat_lazy\n"; - pattern i ppf p; + line i ppf "Ppat_lazy\n"; + pattern i ppf p | Ppat_constraint (p, ct) -> - line i ppf "Ppat_constraint\n"; - pattern i ppf p; - core_type i ppf ct; - | Ppat_type (li) -> - line i ppf "Ppat_type\n"; - longident_loc i ppf li - | Ppat_unpack s -> - line i ppf "Ppat_unpack %a\n" fmt_string_loc s; + line i ppf "Ppat_constraint\n"; + pattern i ppf p; + core_type i ppf ct + | Ppat_type li -> + line i ppf "Ppat_type\n"; + longident_loc i ppf li + | Ppat_unpack s -> line i ppf "Ppat_unpack %a\n" fmt_string_loc s | Ppat_exception p -> - line i ppf "Ppat_exception\n"; - pattern i ppf p - | Ppat_open (m,p) -> - line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; - pattern i ppf p + line i ppf "Ppat_exception\n"; + pattern i ppf p + | Ppat_open (m, p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p | Ppat_extension (s, arg) -> - line i ppf "Ppat_extension \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Ppat_extension \"%s\"\n" s.txt; + payload i ppf arg and expression i ppf x = line i ppf "expression %a\n" fmt_location x.pexp_loc; attributes i ppf x.pexp_attributes; - let i = i+1 in + let i = i + 1 in match x.pexp_desc with - | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; - | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_ident li -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li + | Pexp_constant c -> line i ppf "Pexp_constant %a\n" fmt_constant c | Pexp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - expression i ppf e; + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e | Pexp_function l -> - line i ppf "Pexp_function\n"; - list i case ppf l; + line i ppf "Pexp_function\n"; + list i case ppf l | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; + line i ppf "Pexp_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + expression i ppf e | Pexp_apply (e, l) -> - line i ppf "Pexp_apply\n"; - expression i ppf e; - list i label_x_expression ppf l; + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l | Pexp_match (e, l) -> - line i ppf "Pexp_match\n"; - expression i ppf e; - list i case ppf l; + line i ppf "Pexp_match\n"; + expression i ppf e; + list i case ppf l | Pexp_try (e, l) -> - line i ppf "Pexp_try\n"; - expression i ppf e; - list i case ppf l; - | Pexp_tuple (l) -> - line i ppf "Pexp_tuple\n"; - list i expression ppf l; + line i ppf "Pexp_try\n"; + expression i ppf e; + list i case ppf l + | Pexp_tuple l -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l | Pexp_construct (li, eo) -> - line i ppf "Pexp_construct %a\n" fmt_longident_loc li; - option i expression ppf eo; + line i ppf "Pexp_construct %a\n" fmt_longident_loc li; + option i expression ppf eo | Pexp_variant (l, eo) -> - line i ppf "Pexp_variant \"%s\"\n" l; - option i expression ppf eo; + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo | Pexp_record (l, eo) -> - line i ppf "Pexp_record\n"; - list i longident_x_expression ppf l; - option i expression ppf eo; + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo | Pexp_field (e, li) -> - line i ppf "Pexp_field\n"; - expression i ppf e; - longident_loc i ppf li; + line i ppf "Pexp_field\n"; + expression i ppf e; + longident_loc i ppf li | Pexp_setfield (e1, li, e2) -> - line i ppf "Pexp_setfield\n"; - expression i ppf e1; - longident_loc i ppf li; - expression i ppf e2; - | Pexp_array (l) -> - line i ppf "Pexp_array\n"; - list i expression ppf l; + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident_loc i ppf li; + expression i ppf e2 + | Pexp_array l -> + line i ppf "Pexp_array\n"; + list i expression ppf l | Pexp_ifthenelse (e1, e2, eo) -> - line i ppf "Pexp_ifthenelse\n"; - expression i ppf e1; - expression i ppf e2; - option i expression ppf eo; + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo | Pexp_sequence (e1, e2) -> - line i ppf "Pexp_sequence\n"; - expression i ppf e1; - expression i ppf e2; + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2 | Pexp_while (e1, e2) -> - line i ppf "Pexp_while\n"; - expression i ppf e1; - expression i ppf e2; + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2 | Pexp_for (p, e1, e2, df, e3) -> - line i ppf "Pexp_for %a\n" fmt_direction_flag df; - pattern i ppf p; - expression i ppf e1; - expression i ppf e2; - expression i ppf e3; + line i ppf "Pexp_for %a\n" fmt_direction_flag df; + pattern i ppf p; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3 | Pexp_constraint (e, ct) -> - line i ppf "Pexp_constraint\n"; - expression i ppf e; - core_type i ppf ct; + line i ppf "Pexp_constraint\n"; + expression i ppf e; + core_type i ppf ct | Pexp_coerce (e, (), cto2) -> - line i ppf "Pexp_coerce\n"; - expression i ppf e; - core_type i ppf cto2; + line i ppf "Pexp_coerce\n"; + expression i ppf e; + core_type i ppf cto2 | Pexp_send (e, s) -> - line i ppf "Pexp_send \"%s\"\n" s.txt; - expression i ppf e; - | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; + line i ppf "Pexp_send \"%s\"\n" s.txt; + expression i ppf e + | Pexp_new li -> line i ppf "Pexp_new %a\n" fmt_longident_loc li | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; - expression i ppf e; - | Pexp_override (l) -> - line i ppf "Pexp_override\n"; - list i string_x_expression ppf l; + line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + expression i ppf e + | Pexp_override l -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l | Pexp_letmodule (s, me, e) -> - line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; - module_expr i ppf me; - expression i ppf e; + line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; + module_expr i ppf me; + expression i ppf e | Pexp_letexception (cd, e) -> - line i ppf "Pexp_letexception\n"; - extension_constructor i ppf cd; - expression i ppf e; - | Pexp_assert (e) -> - line i ppf "Pexp_assert\n"; - expression i ppf e; - | Pexp_lazy (e) -> - line i ppf "Pexp_lazy\n"; - expression i ppf e; + line i ppf "Pexp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e + | Pexp_assert e -> + line i ppf "Pexp_assert\n"; + expression i ppf e + | Pexp_lazy e -> + line i ppf "Pexp_lazy\n"; + expression i ppf e | Pexp_poly (e, cto) -> - line i ppf "Pexp_poly\n"; - expression i ppf e; - option i core_type ppf cto; + line i ppf "Pexp_poly\n"; + expression i ppf e; + option i core_type ppf cto | Pexp_object () -> () | Pexp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s.txt; - expression i ppf e + line i ppf "Pexp_newtype \"%s\"\n" s.txt; + expression i ppf e | Pexp_pack me -> - line i ppf "Pexp_pack\n"; - module_expr i ppf me + line i ppf "Pexp_pack\n"; + module_expr i ppf me | Pexp_open (ovf, m, e) -> - line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; - expression i ppf e + line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_longident_loc m; + expression i ppf e | Pexp_extension (s, arg) -> - line i ppf "Pexp_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pexp_unreachable -> - line i ppf "Pexp_unreachable" + line i ppf "Pexp_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pexp_unreachable -> line i ppf "Pexp_unreachable" and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc - x.pval_name fmt_location x.pval_loc; + line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location + x.pval_loc; attributes i ppf x.pval_attributes; - core_type (i+1) ppf x.pval_type; - list (i+1) string ppf x.pval_prim + core_type (i + 1) ppf x.pval_type; + list (i + 1) string ppf x.pval_prim and type_parameter i ppf (x, _variance) = core_type i ppf x and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name - fmt_location x.ptype_loc; + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name fmt_location + x.ptype_loc; attributes i ppf x.ptype_attributes; - let i = i+1 in + let i = i + 1 in line i ppf "ptype_params =\n"; - list (i+1) type_parameter ppf x.ptype_params; + list (i + 1) type_parameter ppf x.ptype_params; line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + list (i + 1) core_type_x_core_type_x_location ppf x.ptype_cstrs; line i ppf "ptype_kind =\n"; - type_kind (i+1) ppf x.ptype_kind; + type_kind (i + 1) ppf x.ptype_kind; line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; - option (i+1) core_type ppf x.ptype_manifest + option (i + 1) core_type ppf x.ptype_manifest and attributes i ppf l = let i = i + 1 in List.iter (fun (s, arg) -> - line i ppf "attribute %a \"%s\"\n" fmt_location (s: _ Asttypes.loc).loc s.txt; - payload (i + 1) ppf arg; - ) + line i ppf "attribute %a \"%s\"\n" fmt_location (s : _ Asttypes.loc).loc + s.txt; + payload (i + 1) ppf arg) l and payload i ppf = function @@ -413,30 +393,27 @@ and payload i ppf = function line i ppf "\n"; expression (i + 1) ppf g - and type_kind i ppf x = match x with - | Ptype_abstract -> - line i ppf "Ptype_abstract\n" + | Ptype_abstract -> line i ppf "Ptype_abstract\n" | Ptype_variant l -> - line i ppf "Ptype_variant\n"; - list (i+1) constructor_decl ppf l; + line i ppf "Ptype_variant\n"; + list (i + 1) constructor_decl ppf l | Ptype_record l -> - line i ppf "Ptype_record\n"; - list (i+1) label_decl ppf l; - | Ptype_open -> - line i ppf "Ptype_open\n"; + line i ppf "Ptype_record\n"; + list (i + 1) label_decl ppf l + | Ptype_open -> line i ppf "Ptype_open\n" and type_extension i ppf x = line i ppf "type_extension\n"; attributes i ppf x.ptyext_attributes; - let i = i+1 in + let i = i + 1 in line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; line i ppf "ptyext_params =\n"; - list (i+1) type_parameter ppf x.ptyext_params; + list (i + 1) type_parameter ppf x.ptyext_params; line i ppf "ptyext_constructors =\n"; - list (i+1) extension_constructor ppf x.ptyext_constructors; - line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; + list (i + 1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private and extension_constructor i ppf x = line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; @@ -444,274 +421,268 @@ and extension_constructor i ppf x = let i = i + 1 in line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; line i ppf "pext_kind =\n"; - extension_constructor_kind (i + 1) ppf x.pext_kind; + extension_constructor_kind (i + 1) ppf x.pext_kind and extension_constructor_kind i ppf x = match x with - Pext_decl(a, r) -> - line i ppf "Pext_decl\n"; - constructor_arguments (i+1) ppf a; - option (i+1) core_type ppf r; - | Pext_rebind li -> - line i ppf "Pext_rebind\n"; - line (i+1) ppf "%a\n" fmt_longident_loc li; - + | Pext_decl (a, r) -> + line i ppf "Pext_decl\n"; + constructor_arguments (i + 1) ppf a; + option (i + 1) core_type ppf r + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i + 1) ppf "%a\n" fmt_longident_loc li and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.pmty_loc; attributes i ppf x.pmty_attributes; - let i = i+1 in + let i = i + 1 in match x.pmty_desc with - | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; - | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; - | Pmty_signature (s) -> - line i ppf "Pmty_signature\n"; - signature i ppf s; + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li + | Pmty_signature s -> + line i ppf "Pmty_signature\n"; + signature i ppf s | Pmty_functor (s, mt1, mt2) -> - line i ppf "Pmty_functor %a\n" fmt_string_loc s; - Misc.may (module_type i ppf) mt1; - module_type i ppf mt2; + line i ppf "Pmty_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt1; + module_type i ppf mt2 | Pmty_with (mt, l) -> - line i ppf "Pmty_with\n"; - module_type i ppf mt; - list i with_constraint ppf l; + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i with_constraint ppf l | Pmty_typeof m -> - line i ppf "Pmty_typeof\n"; - module_expr i ppf m; + line i ppf "Pmty_typeof\n"; + module_expr i ppf m | Pmty_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg and signature i ppf x = list i signature_item ppf x and signature_item i ppf x = line i ppf "signature_item %a\n" fmt_location x.psig_loc; - let i = i+1 in + let i = i + 1 in match x.psig_desc with | Psig_value vd -> - line i ppf "Psig_value\n"; - value_description i ppf vd; + line i ppf "Psig_value\n"; + value_description i ppf vd | Psig_type (rf, l) -> - line i ppf "Psig_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; + line i ppf "Psig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l | Psig_typext te -> - line i ppf "Psig_typext\n"; - type_extension i ppf te + line i ppf "Psig_typext\n"; + type_extension i ppf te | Psig_exception ext -> - line i ppf "Psig_exception\n"; - extension_constructor i ppf ext; + line i ppf "Psig_exception\n"; + extension_constructor i ppf ext | Psig_module pmd -> - line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type i ppf pmd.pmd_type + line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type i ppf pmd.pmd_type | Psig_recmodule decls -> - line i ppf "Psig_recmodule\n"; - list i module_declaration ppf decls; + line i ppf "Psig_recmodule\n"; + list i module_declaration ppf decls | Psig_modtype x -> - line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type + line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type | Psig_open od -> - line i ppf "Psig_open %a %a\n" - fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; - attributes i ppf od.popen_attributes + line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes | Psig_include incl -> - line i ppf "Psig_include\n"; - module_type i ppf incl.pincl_mod; - attributes i ppf incl.pincl_attributes - | Psig_class () -> () + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_class () -> () | Psig_class_type () -> () | Psig_extension ((s, arg), attrs) -> - line i ppf "Psig_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg + line i ppf "Psig_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg | Psig_attribute (s, arg) -> - line i ppf "Psig_attribute \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Psig_attribute \"%s\"\n" s.txt; + payload i ppf arg and modtype_declaration i ppf = function | None -> line i ppf "#abstract" - | Some mt -> module_type (i+1) ppf mt + | Some mt -> module_type (i + 1) ppf mt and with_constraint i ppf x = match x with | Pwith_type (lid, td) -> - line i ppf "Pwith_type %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; + line i ppf "Pwith_type %a\n" fmt_longident_loc lid; + type_declaration (i + 1) ppf td | Pwith_typesubst (lid, td) -> - line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; + line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; + type_declaration (i + 1) ppf td | Pwith_module (lid1, lid2) -> - line i ppf "Pwith_module %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; + line i ppf "Pwith_module %a = %a\n" fmt_longident_loc lid1 fmt_longident_loc + lid2 | Pwith_modsubst (lid1, lid2) -> - line i ppf "Pwith_modsubst %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; + line i ppf "Pwith_modsubst %a = %a\n" fmt_longident_loc lid1 + fmt_longident_loc lid2 and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.pmod_loc; attributes i ppf x.pmod_attributes; - let i = i+1 in + let i = i + 1 in match x.pmod_desc with - | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; - | Pmod_structure (s) -> - line i ppf "Pmod_structure\n"; - structure i ppf s; + | Pmod_ident li -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li + | Pmod_structure s -> + line i ppf "Pmod_structure\n"; + structure i ppf s | Pmod_functor (s, mt, me) -> - line i ppf "Pmod_functor %a\n" fmt_string_loc s; - Misc.may (module_type i ppf) mt; - module_expr i ppf me; + line i ppf "Pmod_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt; + module_expr i ppf me | Pmod_apply (me1, me2) -> - line i ppf "Pmod_apply\n"; - module_expr i ppf me1; - module_expr i ppf me2; + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2 | Pmod_constraint (me, mt) -> - line i ppf "Pmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; - | Pmod_unpack (e) -> - line i ppf "Pmod_unpack\n"; - expression i ppf e; + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt + | Pmod_unpack e -> + line i ppf "Pmod_unpack\n"; + expression i ppf e | Pmod_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg and structure i ppf x = list i structure_item ppf x and structure_item i ppf x = line i ppf "structure_item %a\n" fmt_location x.pstr_loc; - let i = i+1 in + let i = i + 1 in match x.pstr_desc with | Pstr_eval (e, attrs) -> - line i ppf "Pstr_eval\n"; - attributes i ppf attrs; - expression i ppf e; + line i ppf "Pstr_eval\n"; + attributes i ppf attrs; + expression i ppf e | Pstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; - list i value_binding ppf l; + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l | Pstr_primitive vd -> - line i ppf "Pstr_primitive\n"; - value_description i ppf vd; + line i ppf "Pstr_primitive\n"; + value_description i ppf vd | Pstr_type (rf, l) -> - line i ppf "Pstr_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l | Pstr_typext te -> - line i ppf "Pstr_typext\n"; - type_extension i ppf te + line i ppf "Pstr_typext\n"; + type_extension i ppf te | Pstr_exception ext -> - line i ppf "Pstr_exception\n"; - extension_constructor i ppf ext; + line i ppf "Pstr_exception\n"; + extension_constructor i ppf ext | Pstr_module x -> - line i ppf "Pstr_module\n"; - module_binding i ppf x + line i ppf "Pstr_module\n"; + module_binding i ppf x | Pstr_recmodule bindings -> - line i ppf "Pstr_recmodule\n"; - list i module_binding ppf bindings; + line i ppf "Pstr_recmodule\n"; + list i module_binding ppf bindings | Pstr_modtype x -> - line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type + line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type | Pstr_open od -> - line i ppf "Pstr_open %a %a\n" - fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; - attributes i ppf od.popen_attributes + line i ppf "Pstr_open %a %a\n" fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes | Pstr_class () -> () | Pstr_class_type () -> () | Pstr_include incl -> - line i ppf "Pstr_include"; - attributes i ppf incl.pincl_attributes; - module_expr i ppf incl.pincl_mod + line i ppf "Pstr_include"; + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod | Pstr_extension ((s, arg), attrs) -> - line i ppf "Pstr_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg + line i ppf "Pstr_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg | Pstr_attribute (s, arg) -> - line i ppf "Pstr_attribute \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pstr_attribute \"%s\"\n" s.txt; + payload i ppf arg and module_declaration i ppf pmd = string_loc i ppf pmd.pmd_name; attributes i ppf pmd.pmd_attributes; - module_type (i+1) ppf pmd.pmd_type; + module_type (i + 1) ppf pmd.pmd_type and module_binding i ppf x = string_loc i ppf x.pmb_name; attributes i ppf x.pmb_attributes; - module_expr (i+1) ppf x.pmb_expr + module_expr (i + 1) ppf x.pmb_expr and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = line i ppf " %a\n" fmt_location l; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 and constructor_decl i ppf - {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = + {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = line i ppf "%a\n" fmt_location pcd_loc; - line (i+1) ppf "%a\n" fmt_string_loc pcd_name; + line (i + 1) ppf "%a\n" fmt_string_loc pcd_name; attributes i ppf pcd_attributes; - constructor_arguments (i+1) ppf pcd_args; - option (i+1) core_type ppf pcd_res + constructor_arguments (i + 1) ppf pcd_args; + option (i + 1) core_type ppf pcd_res and constructor_arguments i ppf = function | Pcstr_tuple l -> list i core_type ppf l | Pcstr_record l -> list i label_decl ppf l -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} + = line i ppf "%a\n" fmt_location pld_loc; attributes i ppf pld_attributes; - line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; - line (i+1) ppf "%a" fmt_string_loc pld_name; - core_type (i+1) ppf pld_type + line (i + 1) ppf "%a\n" fmt_mutable_flag pld_mutable; + line (i + 1) ppf "%a" fmt_string_loc pld_name; + core_type (i + 1) ppf pld_type and longident_x_pattern i ppf (li, p) = line i ppf "%a\n" fmt_longident_loc li; - pattern (i+1) ppf p; + pattern (i + 1) ppf p and case i ppf {pc_lhs; pc_guard; pc_rhs} = line i ppf "\n"; - pattern (i+1) ppf pc_lhs; - begin match pc_guard with + pattern (i + 1) ppf pc_lhs; + (match pc_guard with | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf pc_rhs; + | Some g -> + line (i + 1) ppf "\n"; + expression (i + 2) ppf g); + expression (i + 1) ppf pc_rhs and value_binding i ppf x = line i ppf "\n"; - attributes (i+1) ppf x.pvb_attributes; - pattern (i+1) ppf x.pvb_pat; - expression (i+1) ppf x.pvb_expr + attributes (i + 1) ppf x.pvb_attributes; + pattern (i + 1) ppf x.pvb_pat; + expression (i + 1) ppf x.pvb_expr and string_x_expression i ppf (s, e) = line i ppf " %a\n" fmt_string_loc s; - expression (i+1) ppf e; + expression (i + 1) ppf e and longident_x_expression i ppf (li, e) = line i ppf "%a\n" fmt_longident_loc li; - expression (i+1) ppf e; + expression (i + 1) ppf e -and label_x_expression i ppf (l,e) = +and label_x_expression i ppf (l, e) = line i ppf "\n"; arg_label i ppf l; - expression (i+1) ppf e; + expression (i + 1) ppf e and label_x_bool_x_core_type_list i ppf x = match x with - Rtag (l, attrs, b, ctl) -> - line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); - attributes (i+1) ppf attrs; - list (i+1) core_type ppf ctl - | Rinherit (ct) -> - line i ppf "Rinherit\n"; - core_type (i+1) ppf ct -;; - - -let interface ppf x = list 0 signature_item ppf x;; + | Rtag (l, attrs, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i + 1) ppf attrs; + list (i + 1) core_type ppf ctl + | Rinherit ct -> + line i ppf "Rinherit\n"; + core_type (i + 1) ppf ct -let implementation ppf x = list 0 structure_item ppf x;; +let interface ppf x = list 0 signature_item ppf x +let implementation ppf x = list 0 structure_item ppf x diff --git a/compiler/ml/printast.mli b/compiler/ml/printast.mli index eb94a3bcb6..87da25385c 100644 --- a/compiler/ml/printast.mli +++ b/compiler/ml/printast.mli @@ -13,13 +13,12 @@ (* *) (**************************************************************************) -open Parsetree;; -open Format;; +open Parsetree +open Format -val interface : formatter -> signature_item list -> unit;; -val implementation : formatter -> structure_item list -> unit;; +val interface : formatter -> signature_item list -> unit +val implementation : formatter -> structure_item list -> unit - -val expression: int -> formatter -> expression -> unit -val structure: int -> formatter -> structure -> unit -val payload: int -> formatter -> payload -> unit +val expression : int -> formatter -> expression -> unit +val structure : int -> formatter -> structure -> unit +val payload : int -> formatter -> payload -> unit diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 05bd881465..4512355c34 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -18,43 +18,42 @@ open Asttypes open Primitive open Lambda - let rec struct_const ppf = function - | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) - | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s + | Const_base (Const_int n) -> fprintf ppf "%i" n + | Const_base (Const_char i) -> + fprintf ppf "%s" (Pprintast.string_of_int_as_char i) + | Const_base (Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s - | Const_base(Const_float f) -> fprintf ppf "%s" f - | Const_base(Const_int32 n) -> fprintf ppf "%lil" n - | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n - | Const_base(Const_bigint (sign, n)) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) - | Const_pointer (n,_) -> fprintf ppf "%ia" n - | Const_block(tag_info, []) -> - let tag = Lambda.tag_of_tag_info tag_info in - fprintf ppf "[%i]" tag - | Const_block(tag_info,sc1::scl) -> - let tag = Lambda.tag_of_tag_info tag_info in - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_float_array [] -> - fprintf ppf "[| |]" + | Const_base (Const_float f) -> fprintf ppf "%s" f + | Const_base (Const_int32 n) -> fprintf ppf "%lil" n + | Const_base (Const_int64 n) -> fprintf ppf "%LiL" n + | Const_base (Const_bigint (sign, n)) -> + fprintf ppf "%sn" (Bigint_utils.to_string sign n) + | Const_pointer (n, _) -> fprintf ppf "%ia" n + | Const_block (tag_info, []) -> + let tag = Lambda.tag_of_tag_info tag_info in + fprintf ppf "[%i]" tag + | Const_block (tag_info, sc1 :: scl) -> + let tag = Lambda.tag_of_tag_info tag_info in + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl + in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + | Const_float_array [] -> fprintf ppf "[| |]" | Const_float_array (f1 :: fl) -> - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %s" f) fl in - fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl - - | Const_false -> fprintf ppf "false" + let floats ppf fl = List.iter (fun f -> fprintf ppf "@ %s" f) fl in + fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl + | Const_false -> fprintf ppf "false" | Const_true -> fprintf ppf "true" let value_kind = function | Pgenval -> "" (* let field_kind = function - | Pgenval -> "*" - | Pintval -> "int" - | Pfloatval -> "float" - | Pboxedintval bi -> boxed_integer_name bi *) + | Pgenval -> "*" + | Pintval -> "int" + | Pfloatval -> "float" + | Pboxedintval bi -> boxed_integer_name bi *) let string_of_loc_kind = function | Loc_FILE -> "loc_FILE" @@ -64,43 +63,48 @@ let string_of_loc_kind = function | Loc_LOC -> "loc_LOC" (* let block_shape ppf shape = match shape with - | None | Some [] -> () - | Some l when List.for_all ((=) Pgenval) l -> () - | Some [elt] -> - Format.fprintf ppf " (%s)" (field_kind elt) - | Some (h :: t) -> - Format.fprintf ppf " (%s" (field_kind h); - List.iter (fun elt -> - Format.fprintf ppf ",%s" (field_kind elt)) - t; - Format.fprintf ppf ")" *) + | None | Some [] -> () + | Some l when List.for_all ((=) Pgenval) l -> () + | Some [elt] -> + Format.fprintf ppf " (%s)" (field_kind elt) + | Some (h :: t) -> + Format.fprintf ppf " (%s" (field_kind h); + List.iter (fun elt -> + Format.fprintf ppf ",%s" (field_kind elt)) + t; + Format.fprintf ppf ")" *) - -let str_of_field_info (fld_info : Lambda.field_dbg_info)= - match fld_info with - | (Fld_module {name } | Fld_record {name} | Fld_record_inline {name} | Fld_record_extension {name}) - -> name +let str_of_field_info (fld_info : Lambda.field_dbg_info) = + match fld_info with + | Fld_module {name} + | Fld_record {name} + | Fld_record_inline {name} + | Fld_record_extension {name} -> + name | Fld_tuple -> "[]" - | Fld_poly_var_tag->"`" + | Fld_poly_var_tag -> "`" | Fld_poly_var_content -> "#" | Fld_extension -> "ext" | Fld_variant -> "var" | Fld_cons -> "cons" - | Fld_array -> "[||]" + | Fld_array -> "[||]" let print_taginfo ppf = function - | Blk_extension -> fprintf ppf "ext" - | Blk_record_ext {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) + | Blk_extension -> fprintf ppf "ext" + | Blk_record_ext {fields = ss} -> + fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss)) | Blk_tuple -> fprintf ppf "tuple" - | Blk_constructor {name ;num_nonconst} -> fprintf ppf "%s/%i" name num_nonconst - | Blk_poly_var name -> fprintf ppf "`%s" name - | Blk_record {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) - | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) + | Blk_constructor {name; num_nonconst} -> + fprintf ppf "%s/%i" name num_nonconst + | Blk_poly_var name -> fprintf ppf "`%s" name + | Blk_record {fields = ss} -> + fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss)) + | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) | Blk_some -> fprintf ppf "some" - | Blk_some_not_nested -> fprintf ppf "some_not_nested" + | Blk_some_not_nested -> fprintf ppf "some_not_nested" | Blk_lazy_general -> fprintf ppf "lazy_general" | Blk_module_export _ -> fprintf ppf "module/exports" - | Blk_record_inlined {fields = ss } - -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) + | Blk_record_inlined {fields = ss} -> + fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss)) let primitive ppf = function | Pidentity -> fprintf ppf "id" @@ -114,21 +118,19 @@ let primitive ppf = function | Pdirapply -> fprintf ppf "dirapply" | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id - | Pmakeblock(taginfo) -> - fprintf ppf "makeblock %a" print_taginfo taginfo - | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n - | Psetfield(n, _) -> - fprintf ppf "setfield %i" n + | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo + | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n + | Psetfield (n, _) -> fprintf ppf "setfield %i" n | Pduprecord -> fprintf ppf "duprecord" | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) - | Pobjcomp(Ceq) -> fprintf ppf "==" - | Pobjcomp(Cneq) -> fprintf ppf "!=" - | Pobjcomp(Clt) -> fprintf ppf "<" - | Pobjcomp(Cle) -> fprintf ppf "<=" - | Pobjcomp(Cgt) -> fprintf ppf ">" - | Pobjcomp(Cge) -> fprintf ppf ">=" + | Pobjcomp Ceq -> fprintf ppf "==" + | Pobjcomp Cneq -> fprintf ppf "!=" + | Pobjcomp Clt -> fprintf ppf "<" + | Pobjcomp Cle -> fprintf ppf "<=" + | Pobjcomp Cgt -> fprintf ppf ">" + | Pobjcomp Cge -> fprintf ppf ">=" | Pobjorder -> fprintf ppf "compare" | Pobjmin -> fprintf ppf "min" | Pobjmax -> fprintf ppf "max" @@ -137,12 +139,12 @@ let primitive ppf = function | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" - | Pboolcomp(Ceq) -> fprintf ppf "==" - | Pboolcomp(Cneq) -> fprintf ppf "!=" - | Pboolcomp(Clt) -> fprintf ppf "<" - | Pboolcomp(Cle) -> fprintf ppf "<=" - | Pboolcomp(Cgt) -> fprintf ppf ">" - | Pboolcomp(Cge) -> fprintf ppf ">=" + | Pboolcomp Ceq -> fprintf ppf "==" + | Pboolcomp Cneq -> fprintf ppf "!=" + | Pboolcomp Clt -> fprintf ppf "<" + | Pboolcomp Cle -> fprintf ppf "<=" + | Pboolcomp Cgt -> fprintf ppf ">" + | Pboolcomp Cge -> fprintf ppf ">=" | Pboolorder -> fprintf ppf "compare" | Pboolmin -> fprintf ppf "min" | Pboolmax -> fprintf ppf "max" @@ -160,17 +162,17 @@ let primitive ppf = function | Plslint -> fprintf ppf "lsl" | Plsrint -> fprintf ppf "lsr" | Pasrint -> fprintf ppf "asr" - | Pintcomp(Ceq) -> fprintf ppf "==" - | Pintcomp(Cneq) -> fprintf ppf "!=" - | Pintcomp(Clt) -> fprintf ppf "<" - | Pintcomp(Cle) -> fprintf ppf "<=" - | Pintcomp(Cgt) -> fprintf ppf ">" - | Pintcomp(Cge) -> fprintf ppf ">=" + | Pintcomp Ceq -> fprintf ppf "==" + | Pintcomp Cneq -> fprintf ppf "!=" + | Pintcomp Clt -> fprintf ppf "<" + | Pintcomp Cle -> fprintf ppf "<=" + | Pintcomp Cgt -> fprintf ppf ">" + | Pintcomp Cge -> fprintf ppf ">=" | Pintorder -> fprintf ppf "compare" | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i"n + | Poffsetref n -> fprintf ppf "+:=%i" n | Pintoffloat -> fprintf ppf "int_of_float" | Pfloatofint -> fprintf ppf "float_of_int" | Pnegfloat -> fprintf ppf "~." @@ -180,12 +182,12 @@ let primitive ppf = function | Pmulfloat -> fprintf ppf "*." | Pdivfloat -> fprintf ppf "/." | Pmodfloat -> fprintf ppf "mod" - | Pfloatcomp(Ceq) -> fprintf ppf "==." - | Pfloatcomp(Cneq) -> fprintf ppf "!=." - | Pfloatcomp(Clt) -> fprintf ppf "<." - | Pfloatcomp(Cle) -> fprintf ppf "<=." - | Pfloatcomp(Cgt) -> fprintf ppf ">." - | Pfloatcomp(Cge) -> fprintf ppf ">=." + | Pfloatcomp Ceq -> fprintf ppf "==." + | Pfloatcomp Cneq -> fprintf ppf "!=." + | Pfloatcomp Clt -> fprintf ppf "<." + | Pfloatcomp Cle -> fprintf ppf "<=." + | Pfloatcomp Cgt -> fprintf ppf ">." + | Pfloatcomp Cge -> fprintf ppf ">=." | Pfloatorder -> fprintf ppf "compare" | Pfloatmin -> fprintf ppf "min" | Pfloatmax -> fprintf ppf "max" @@ -201,35 +203,35 @@ let primitive ppf = function | Pasrbigint -> fprintf ppf "asr" | Pdivbigint -> fprintf ppf "/" | Pmodbigint -> fprintf ppf "mod" - | Pbigintcomp(Ceq) -> fprintf ppf "==," - | Pbigintcomp(Cneq) -> fprintf ppf "!=," - | Pbigintcomp(Clt) -> fprintf ppf "<," - | Pbigintcomp(Cle) -> fprintf ppf "<=," - | Pbigintcomp(Cgt) -> fprintf ppf ">," - | Pbigintcomp(Cge) -> fprintf ppf ">=," + | Pbigintcomp Ceq -> fprintf ppf "==," + | Pbigintcomp Cneq -> fprintf ppf "!=," + | Pbigintcomp Clt -> fprintf ppf "<," + | Pbigintcomp Cle -> fprintf ppf "<=," + | Pbigintcomp Cgt -> fprintf ppf ">," + | Pbigintcomp Cge -> fprintf ppf ">=," | Pbigintorder -> fprintf ppf "compare" | Pbigintmin -> fprintf ppf "min" | Pbigintmax -> fprintf ppf "max" | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" - | Pstringcomp(Ceq) -> fprintf ppf "==" - | Pstringcomp(Cneq) -> fprintf ppf "!=" - | Pstringcomp(Clt) -> fprintf ppf "<" - | Pstringcomp(Cle) -> fprintf ppf "<=" - | Pstringcomp(Cgt) -> fprintf ppf ">" - | Pstringcomp(Cge) -> fprintf ppf ">=" + | Pstringcomp Ceq -> fprintf ppf "==" + | Pstringcomp Cneq -> fprintf ppf "!=" + | Pstringcomp Clt -> fprintf ppf "<" + | Pstringcomp Cle -> fprintf ppf "<=" + | Pstringcomp Cgt -> fprintf ppf ">" + | Pstringcomp Cge -> fprintf ppf ">=" | Pstringorder -> fprintf ppf "compare" | Pstringmin -> fprintf ppf "min" | Pstringmax -> fprintf ppf "max" | Pstringadd -> fprintf ppf "string.concat" - | Parraylength -> fprintf ppf "array.length" - | Pmakearray Mutable -> fprintf ppf "makearray" - | Pmakearray Immutable -> fprintf ppf "makearray_imm" - | Parrayrefu -> fprintf ppf "array.unsafe_get" - | Parraysetu -> fprintf ppf "array.unsafe_set" - | Parrayrefs -> fprintf ppf "array.get" - | Parraysets -> fprintf ppf "array.set" + | Parraylength -> fprintf ppf "array.length" + | Pmakearray Mutable -> fprintf ppf "makearray" + | Pmakearray Immutable -> fprintf ppf "makearray_imm" + | Parrayrefu -> fprintf ppf "array.unsafe_get" + | Parraysetu -> fprintf ppf "array.unsafe_set" + | Parrayrefs -> fprintf ppf "array.get" + | Parraysets -> fprintf ppf "array.set" | Pmakelist Mutable -> fprintf ppf "makelist" | Pmakelist Immutable -> fprintf ppf "makelist_imm" | Pmakedict -> fprintf ppf "makedict" @@ -248,12 +250,12 @@ let primitive ppf = function | Phash_mixstring -> fprintf ppf "hash_mix_string" | Phash_finalmix -> fprintf ppf "hash_final_mix" | Pcurry_apply i -> fprintf ppf "apply[%d]" i - | Pjscomp(Ceq) -> fprintf ppf "==" - | Pjscomp(Cneq) -> fprintf ppf "!=" - | Pjscomp(Clt) -> fprintf ppf "<" - | Pjscomp(Cle) -> fprintf ppf "<=" - | Pjscomp(Cgt) -> fprintf ppf ">" - | Pjscomp(Cge) -> fprintf ppf ">=" + | Pjscomp Ceq -> fprintf ppf "==" + | Pjscomp Cneq -> fprintf ppf "!=" + | Pjscomp Clt -> fprintf ppf "<" + | Pjscomp Cle -> fprintf ppf "<=" + | Pjscomp Cgt -> fprintf ppf ">" + | Pjscomp Cge -> fprintf ppf ">=" | Pundefined_to_opt -> fprintf ppf "undefined_to_opt" | Pnull_to_opt -> fprintf ppf "null_to_opt" | Pnullable_to_opt -> fprintf ppf "nullable_to_opt" @@ -268,150 +270,135 @@ let primitive ppf = function | Pjs_fn_method -> fprintf ppf "#fn_method" | Pjs_unsafe_downgrade -> fprintf ppf "#unsafe_downgrade" -let function_attribute ppf { inline; is_a_functor; return_unit } = - if is_a_functor then - fprintf ppf "is_a_functor@ "; - if return_unit then - fprintf ppf "void@ "; - begin match inline with +let function_attribute ppf {inline; is_a_functor; return_unit} = + if is_a_functor then fprintf ppf "is_a_functor@ "; + if return_unit then fprintf ppf "void@ "; + match inline with | Default_inline -> () | Always_inline -> fprintf ppf "always_inline@ " | Never_inline -> fprintf ppf "never_inline@ " - end - let apply_inlined_attribute ppf = function | Default_inline -> () | Always_inline -> fprintf ppf " always_inline" | Never_inline -> fprintf ppf " never_inline" - let rec lam ppf = function - | Lvar id -> - Ident.print ppf id - | Lconst cst -> - struct_const ppf cst + | Lvar id -> Ident.print ppf id + | Lconst cst -> struct_const ppf cst | Lapply ap -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_inlined_attribute ap.ap_inlined - - | Lfunction{ params; body; attr} -> - let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params - in - fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params - function_attribute attr lam body - | Llet(str, k, id, arg, body) -> - let kind = function - Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" - in - let rec letbody = function - | Llet(str, k, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s%s@ %a@]" - Ident.print id (kind str) (value_kind k) lam arg; - letbody body - | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" - Ident.print id (kind str) (value_kind k) lam arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Lletrec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim(prim, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch(larg, sw, _loc) -> - let switch ppf sw = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) - sw.sw_consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) - sw.sw_blocks ; - begin match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - end in - fprintf ppf - "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with None -> "switch*" | _ -> "switch") - lam larg switch sw - | Lstringswitch(arg, cases, default, _) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - begin match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - end in - fprintf ppf - "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; - | Lstaticcatch(lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" - lam lbody i - (fun ppf vars -> match vars with - | [] -> () - | _ -> - List.iter - (fun x -> fprintf ppf " %a" Ident.print x) - vars) - vars - lam lhandler - | Ltrywith(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Ident.print param lam lhandler - | Lifthenelse(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence(l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lwhile(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor(param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Ident.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Lassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (name,obj, _) -> - fprintf ppf "@[<2>(send%s@ %a@ )@]" name lam obj + let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a%a)@]" lam ap.ap_func lams ap.ap_args + apply_inlined_attribute ap.ap_inlined + | Lfunction {params; body; attr} -> + let pr_params ppf params = + List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params + in + fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params function_attribute + attr lam body + | Llet (str, k, id, arg, body) -> + let kind = function + | Alias -> "a" + | Strict -> "" + | StrictOpt -> "o" + | Variable -> "v" + in + let rec letbody = function + | Llet (str, k, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s%s@ %a@]" Ident.print id (kind str) + (value_kind k) lam arg; + letbody body + | expr -> expr + in + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" Ident.print id + (kind str) (value_kind k) lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Lletrec (id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + id_arg_list + in + fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam + body + | Lprim (prim, largs, _) -> + let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs + | Lswitch (larg, sw, _loc) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n lam l) + sw.sw_consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l) + sw.sw_blocks; + match sw.sw_failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + in + fprintf ppf "@[<1>(%s %a@ @[%a@])@]" + (match sw.sw_failaction with + | None -> "switch*" + | _ -> "switch") + lam larg switch sw + | Lstringswitch (arg, cases, default, _) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + in + fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases + | Lstaticraise (i, ls) -> + let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls + | Lstaticcatch (lbody, (i, vars), lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i + (fun ppf vars -> + match vars with + | [] -> () + | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) + vars lam lhandler + | Ltrywith (lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print + param lam lhandler + | Lifthenelse (lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Lsequence (l1, l2) -> fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Lwhile (lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Lfor (param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo + (match dir with + | Upto -> "to" + | Downto -> "downto") + lam hi lam body + | Lassign (id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Lsend (name, obj, _) -> fprintf ppf "@[<2>(send%s@ %a@ )@]" name lam obj and sequence ppf = function - | Lsequence(l1, l2) -> - fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> - lam ppf l + | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 + | l -> lam ppf l let structured_constant = struct_const let lambda = lam - - diff --git a/compiler/ml/printlambda.mli b/compiler/ml/printlambda.mli index 31e9657d96..d20fa3ece0 100644 --- a/compiler/ml/printlambda.mli +++ b/compiler/ml/printlambda.mli @@ -17,5 +17,5 @@ open Lambda open Format -val structured_constant: formatter -> structured_constant -> unit -val lambda: formatter -> lambda -> unit +val structured_constant : formatter -> structured_constant -> unit +val lambda : formatter -> lambda -> unit diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 41664610f1..db74078259 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -25,14 +25,15 @@ open Types open Btype open Outcometree -let print_res_poly_identifier: (string -> string) ref = ref (fun _ -> assert false) +let print_res_poly_identifier : (string -> string) ref = + ref (fun _ -> assert false) (* Print a long identifier *) let rec longident ppf = function | Lident s -> pp_print_string ppf s - | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s - | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 + | Ldot (p, s) -> fprintf ppf "%a.%s" longident p s + | Lapply (p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 (* Print an identifier *) @@ -53,40 +54,35 @@ let ident ppf id = pp_print_string ppf (ident_name id) let ident_pervasives = Ident.create_persistent "Pervasives" let printing_env = ref Env.empty let non_shadowed_pervasive = function - | Pdot(Pident id, s, _pos) as path -> - (Ident.same id ident_pervasives) && - (try Path.same path (Env.lookup_type (Lident s) !printing_env) - with Not_found -> true) + | Pdot (Pident id, s, _pos) as path -> ( + Ident.same id ident_pervasives + && + try Path.same path (Env.lookup_type (Lident s) !printing_env) + with Not_found -> true) | _ -> false let rec tree_of_path = function - | Pident id -> - Oide_ident (ident_name id) - | Pdot(_, s, _pos) as path when non_shadowed_pervasive path -> - Oide_ident s - | Pdot(p, s, _pos) -> - Oide_dot (tree_of_path p, s) - | Papply(p1, p2) -> - Oide_apply (tree_of_path p1, tree_of_path p2) + | Pident id -> Oide_ident (ident_name id) + | Pdot (_, s, _pos) as path when non_shadowed_pervasive path -> Oide_ident s + | Pdot (p, s, _pos) -> Oide_dot (tree_of_path p, s) + | Papply (p1, p2) -> Oide_apply (tree_of_path p1, tree_of_path p2) let rec path ppf = function - | Pident id -> - ident ppf id - | Pdot(_, s, _pos) as path when non_shadowed_pervasive path -> - pp_print_string ppf s - | Pdot(p, s, _pos) -> - path ppf p; - pp_print_char ppf '.'; - pp_print_string ppf s - | Papply(p1, p2) -> - fprintf ppf "%a(%a)" path p1 path p2 + | Pident id -> ident ppf id + | Pdot (_, s, _pos) as path when non_shadowed_pervasive path -> + pp_print_string ppf s + | Pdot (p, s, _pos) -> + path ppf p; + pp_print_char ppf '.'; + pp_print_string ppf s + | Papply (p1, p2) -> fprintf ppf "%a(%a)" path p1 path p2 let rec string_of_out_ident = function | Oide_ident s -> s | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s] | Oide_apply (id1, id2) -> - String.concat "" - [string_of_out_ident id1; "("; string_of_out_ident id2; ")"] + String.concat "" + [string_of_out_ident id1; "("; string_of_out_ident id2; ")"] let string_of_path p = string_of_out_ident (tree_of_path p) @@ -100,129 +96,123 @@ let tree_of_rec = function (* Print a raw type expression, with sharing *) let raw_list pr ppf = function - [] -> fprintf ppf "[]" + | [] -> fprintf ppf "[]" | a :: l -> - fprintf ppf "@[<1>[%a%t]@]" pr a - (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) + fprintf ppf "@[<1>[%a%t]@]" pr a (fun ppf -> + List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) let kind_vars = ref [] let kind_count = ref 0 let rec safe_kind_repr v = function - Fvar {contents=Some k} -> - if List.memq k v then "Fvar loop" else - safe_kind_repr (k::v) k + | Fvar {contents = Some k} -> + if List.memq k v then "Fvar loop" else safe_kind_repr (k :: v) k | Fvar r -> - let vid = - try List.assq r !kind_vars - with Not_found -> - let c = incr kind_count; !kind_count in - kind_vars := (r,c) :: !kind_vars; - c - in - Printf.sprintf "Fvar {None}@%d" vid + let vid = + try List.assq r !kind_vars + with Not_found -> + let c = + incr kind_count; + !kind_count + in + kind_vars := (r, c) :: !kind_vars; + c + in + Printf.sprintf "Fvar {None}@%d" vid | Fpresent -> "Fpresent" | Fabsent -> "Fabsent" let rec safe_commu_repr v = function - Cok -> "Cok" + | Cok -> "Cok" | Cunknown -> "Cunknown" | Clink r -> - if List.memq r v then "Clink loop" else - safe_commu_repr (r::v) !r + if List.memq r v then "Clink loop" else safe_commu_repr (r :: v) !r let rec safe_repr v = function - {desc = Tlink t} when not (List.memq t v) -> - safe_repr (t::v) t + | {desc = Tlink t} when not (List.memq t v) -> safe_repr (t :: v) t | t -> t let rec list_of_memo = function - Mnil -> [] + | Mnil -> [] | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem | Mlink rem -> list_of_memo !rem let print_name ppf = function - None -> fprintf ppf "None" + | None -> fprintf ppf "None" | Some name -> fprintf ppf "\"%s\"" name let string_of_label = function - Nolabel -> "" + | Nolabel -> "" | Labelled s -> s - | Optional s -> "?"^s + | Optional s -> "?" ^ s let visited = ref [] let rec raw_type ppf ty = let ty = safe_repr [] ty in - if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin + if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id + else ( visited := ty :: !visited; - fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level - raw_type_desc ty.desc - end + fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level raw_type_desc + ty.desc) + and raw_type_list tl = raw_list raw_type tl + and raw_type_desc ppf = function - Tvar name -> fprintf ppf "Tvar %a" print_name name - | Tarrow(l,t1,t2,c) -> - fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" - (string_of_label l) raw_type t1 raw_type t2 - (safe_commu_repr [] c) - | Ttuple tl -> - fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow (l, t1, t2, c) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" (string_of_label l) + raw_type t1 raw_type t2 (safe_commu_repr [] c) + | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl | Tconstr (p, tl, abbrev) -> - fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p - raw_type_list tl - (raw_list path) (list_of_memo !abbrev) + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl + (raw_list path) (list_of_memo !abbrev) | Tobject (t, nm) -> - fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t - (fun ppf -> - match !nm with None -> fprintf ppf " None" - | Some(p,tl) -> - fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t (fun ppf -> + match !nm with + | None -> fprintf ppf " None" + | Some (p, tl) -> + fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) | Tfield (f, k, t1, t2) -> - fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (safe_kind_repr [] k) - raw_type t1 raw_type t2 + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (safe_kind_repr [] k) raw_type t1 raw_type t2 | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t | Tunivar name -> fprintf ppf "Tunivar %a" print_name name | Tpoly (t, tl) -> - fprintf ppf "@[Tpoly(@,%a,@,%a)@]" - raw_type t - raw_type_list tl + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" raw_type t raw_type_list tl | Tvariant row -> - fprintf ppf - "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]" - "row_fields=" - (raw_list (fun ppf (l, f) -> - fprintf ppf "@[%s,@ %a@]" l raw_field f)) - row.row_fields - "row_more=" raw_type row.row_more - "row_closed=" row.row_closed - "row_fixed=" row.row_fixed - "row_name=" - (fun ppf -> - match row.row_name with None -> fprintf ppf "None" - | Some(p,tl) -> - fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) + fprintf ppf + "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]" + "row_fields=" + (raw_list (fun ppf (l, f) -> fprintf ppf "@[%s,@ %a@]" l raw_field f)) + row.row_fields "row_more=" raw_type row.row_more "row_closed=" + row.row_closed "row_fixed=" row.row_fixed "row_name=" + (fun ppf -> + match row.row_name with + | None -> fprintf ppf "None" + | Some (p, tl) -> fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) | Tpackage (p, _, tl) -> - fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p - raw_type_list tl + fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p raw_type_list tl and raw_field ppf = function - Rpresent None -> fprintf ppf "Rpresent None" + | Rpresent None -> fprintf ppf "Rpresent None" | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t - | Reither (c,tl,m,e) -> - fprintf ppf "@[Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c - raw_type_list tl m - (fun ppf -> - match !e with None -> fprintf ppf " None" - | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) + | Reither (c, tl, m, e) -> + fprintf ppf "@[Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c raw_type_list + tl m (fun ppf -> + match !e with + | None -> fprintf ppf " None" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) | Rabsent -> fprintf ppf "Rabsent" let raw_type_expr ppf t = - visited := []; kind_vars := []; kind_count := 0; + visited := []; + kind_vars := []; + kind_count := 0; raw_type ppf t; - visited := []; kind_vars := [] + visited := []; + kind_vars := [] let () = Btype.print_raw := raw_type_expr @@ -231,20 +221,20 @@ let () = Btype.print_raw := raw_type_expr type param_subst = Id | Nth of int | Map of int list let is_nth = function - Nth _ -> true + | Nth _ -> true | _ -> false let compose l1 = function | Id -> Map l1 | Map l2 -> Map (List.map (List.nth l1) l2) - | Nth n -> Nth (List.nth l1 n) + | Nth n -> Nth (List.nth l1 n) let apply_subst s1 tyl = if tyl = [] then [] - (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) + (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) else match s1 with - Nth n1 -> [List.nth tyl n1] + | Nth n1 -> [List.nth tyl n1] | Map l1 -> List.map (List.nth tyl) l1 | Id -> tyl @@ -254,62 +244,56 @@ let printing_depth = ref 0 let printing_cont = ref ([] : Env.iter_cont list) let printing_old = ref Env.empty let printing_pers = ref Concr.empty -module PathMap = Map.Make(Path) +module PathMap = Map.Make (Path) let printing_map = ref PathMap.empty let same_type t t' = repr t == repr t' let rec index l x = match l with - [] -> raise Not_found + | [] -> raise Not_found | a :: l -> if x == a then 0 else 1 + index l x let rec uniq = function - [] -> true - | a :: l -> not (List.memq a l) && uniq l + | [] -> true + | a :: l -> (not (List.memq a l)) && uniq l -let rec normalize_type_path ?(cache=false) env p = +let rec normalize_type_path ?(cache = false) env p = try - let (params, ty, _) = Env.find_type_expansion p env in + let params, ty, _ = Env.find_type_expansion p env in let params = List.map repr params in match repr ty with - {desc = Tconstr (p1, tyl, _)} -> - let tyl = List.map repr tyl in - if List.length params = List.length tyl - && List.for_all2 (==) params tyl - then normalize_type_path ~cache env p1 - else if cache || List.length params <= List.length tyl - || not (uniq tyl) then (p, Id) - else - let l1 = List.map (index params) tyl in - let (p2, s2) = normalize_type_path ~cache env p1 in - (p2, compose l1 s2) - | ty -> - (p, Nth (index params ty)) - with - Not_found -> - (Env.normalize_path None env p, Id) + | {desc = Tconstr (p1, tyl, _)} -> + let tyl = List.map repr tyl in + if List.length params = List.length tyl && List.for_all2 ( == ) params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl || not (uniq tyl) + then (p, Id) + else + let l1 = List.map (index params) tyl in + let p2, s2 = normalize_type_path ~cache env p1 in + (p2, compose l1 s2) + | ty -> (p, Nth (index params ty)) + with Not_found -> (Env.normalize_path None env p, Id) let penalty s = - if s <> "" && s.[0] = '_' then - 10 + if s <> "" && s.[0] = '_' then 10 else try for i = 0 to String.length s - 2 do - if s.[i] = '_' && s.[i + 1] = '_' then - raise Exit + if s.[i] = '_' && s.[i + 1] = '_' then raise Exit done; 1 with Exit -> 10 let rec path_size = function - Pident id -> - penalty (Ident.name id), -Ident.binding_time id + | Pident id -> (penalty (Ident.name id), -Ident.binding_time id) | Pdot (p, _, _) -> - let (l, b) = path_size p in (1+l, b) + let l, b = path_size p in + (1 + l, b) | Papply (p1, p2) -> - let (l, b) = path_size p1 in - (l + fst (path_size p2), b) + let l, b = path_size p1 in + (l + fst (path_size p2), b) let same_printing_env env = let used_pers = Env.used_persistent () in @@ -317,9 +301,9 @@ let same_printing_env env = let set_printing_env env = printing_env := env; - if !Clflags.real_paths - || !printing_env == Env.empty || same_printing_env env then () else - begin + if !Clflags.real_paths || !printing_env == Env.empty || same_printing_env env + then () + else ( (* printf "Reset printing_map@."; *) printing_old := env; printing_pers := Env.used_persistent (); @@ -329,69 +313,74 @@ let set_printing_env env = let cont = Env.iter_types (fun p (p', _decl) -> - let (p1, s1) = normalize_type_path env p' ~cache:true in + let p1, s1 = normalize_type_path env p' ~cache:true in (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) if s1 = Id then - try - let r = PathMap.find p1 !printing_map in - match !r with - Paths l -> r := Paths (p :: l) - | Best p' -> r := Paths [p; p'] (* assert false *) - with Not_found -> - printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map) - env in - printing_cont := [cont]; - end + try + let r = PathMap.find p1 !printing_map in + match !r with + | Paths l -> r := Paths (p :: l) + | Best p' -> r := Paths [p; p'] + (* assert false *) + with Not_found -> + printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map) + env + in + printing_cont := [cont]) let wrap_printing_env env f = set_printing_env env; try_finally f (fun () -> set_printing_env Env.empty) -let wrap_printing_env env f = - Env.without_cmis (wrap_printing_env env) f +let wrap_printing_env env f = Env.without_cmis (wrap_printing_env env) f let is_unambiguous path env = let l = Env.find_shadowed_types path env in - List.exists (Path.same path) l || (* concrete paths are ok *) + List.exists (Path.same path) l + || + (* concrete paths are ok *) match l with - [] -> true + | [] -> true | p :: rem -> - (* allow also coherent paths: *) - let normalize p = fst (normalize_type_path ~cache:true env p) in - let p' = normalize p in - List.for_all (fun p -> Path.same (normalize p) p') rem || - (* also allow repeatedly defining and opening (for toplevel) *) - let id = lid_of_path p in - List.for_all (fun p -> lid_of_path p = id) rem && - Path.same p (Env.lookup_type id env) + (* allow also coherent paths: *) + let normalize p = fst (normalize_type_path ~cache:true env p) in + let p' = normalize p in + List.for_all (fun p -> Path.same (normalize p) p') rem + || + (* also allow repeatedly defining and opening (for toplevel) *) + let id = lid_of_path p in + List.for_all (fun p -> lid_of_path p = id) rem + && Path.same p (Env.lookup_type id env) let rec get_best_path r = match !r with - Best p' -> p' + | Best p' -> p' | Paths [] -> raise Not_found | Paths l -> - r := Paths []; - List.iter - (fun p -> - (* Format.eprintf "evaluating %a@." path p; *) - match !r with - Best p' when path_size p >= path_size p' -> () - | _ -> if is_unambiguous p !printing_env then r := Best p) - (* else Format.eprintf "%a ignored as ambiguous@." path p *) - l; - get_best_path r + r := Paths []; + List.iter + (fun p -> + (* Format.eprintf "evaluating %a@." path p; *) + match !r with + | Best p' when path_size p >= path_size p' -> () + | _ -> if is_unambiguous p !printing_env then r := Best p) + (* else Format.eprintf "%a ignored as ambiguous@." path p *) + l; + get_best_path r let best_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then (p, Id) + if !Clflags.real_paths || !printing_env == Env.empty then (p, Id) else - let (p', s) = normalize_type_path !printing_env p in - let get_path () = get_best_path (PathMap.find p' !printing_map) in - while !printing_cont <> [] && - try fst (path_size (get_path ())) > !printing_depth with Not_found -> true + let p', s = normalize_type_path !printing_env p in + let get_path () = get_best_path (PathMap.find p' !printing_map) in + while + !printing_cont <> [] + && + try fst (path_size (get_path ())) > !printing_depth + with Not_found -> true do printing_cont := List.map snd (Env.run_iter_cont !printing_cont); - incr printing_depth; + incr printing_depth done; let p'' = try get_path () with Not_found -> p' in (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) @@ -407,12 +396,14 @@ let weak_counter = ref 1 let weak_var_map = ref TypeMap.empty let named_weak_vars = ref StringSet.empty -let reset_names () = names := []; name_counter := 0; named_vars := [] +let reset_names () = + names := []; + name_counter := 0; + named_vars := [] let add_named_var ty = match ty.desc with - Tvar (Some name) | Tunivar (Some name) -> - if List.mem name !named_vars then () else - named_vars := name :: !named_vars + | Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else named_vars := name :: !named_vars | _ -> () let name_is_already_used name = @@ -422,10 +413,11 @@ let name_is_already_used name = let rec new_name () = let name = - if !name_counter < 26 - then String.make 1 (Char.chr(97 + !name_counter)) - else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ - string_of_int(!name_counter / 26) in + if !name_counter < 26 then String.make 1 (Char.chr (97 + !name_counter)) + else + String.make 1 (Char.chr (97 + (!name_counter mod 26))) + ^ string_of_int (!name_counter / 26) + in incr name_counter; if name_is_already_used name then new_name () else name @@ -433,241 +425,235 @@ let rec new_weak_name ty () = let name = "weak" ^ string_of_int !weak_counter in incr weak_counter; if name_is_already_used name then new_weak_name ty () - else begin - named_weak_vars := StringSet.add name !named_weak_vars; - weak_var_map := TypeMap.add ty name !weak_var_map; - name - end + else ( + named_weak_vars := StringSet.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name) let name_of_type name_generator t = (* We've already been through repr at this stage, so t is our representative of the union-find class. *) - try List.assq t !names with Not_found -> - try TypeMap.find t !weak_var_map with Not_found -> - let name = - match t.desc with - Tvar (Some name) | Tunivar (Some name) -> + try List.assq t !names + with Not_found -> ( + try TypeMap.find t !weak_var_map + with Not_found -> + let name = + match t.desc with + | Tvar (Some name) | Tunivar (Some name) -> (* Some part of the type we've already printed has assigned another * unification variable to that name. We want to keep the name, so try * adding a number until we find a name that's not taken. *) let current_name = ref name in let i = ref 0 in while List.exists (fun (_, name') -> !current_name = name') !names do - current_name := name ^ (string_of_int !i); - i := !i + 1; + current_name := name ^ string_of_int !i; + i := !i + 1 done; !current_name - | _ -> + | _ -> (* No name available, create a new one *) name_generator () - in - (* Exception for type declarations *) - if name <> "_" then names := (t, name) :: !names; - name + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name) -let check_name_of_type t = ignore(name_of_type new_name t) +let check_name_of_type t = ignore (name_of_type new_name t) let remove_names tyl = let tyl = List.map repr tyl in - names := Ext_list.filter !names (fun (ty,_) -> not (List.memq ty tyl)) + names := Ext_list.filter !names (fun (ty, _) -> not (List.memq ty tyl)) let visited_objects = ref ([] : type_expr list) let aliased = ref ([] : type_expr list) let delayed = ref ([] : type_expr list) -let add_delayed t = - if not (List.memq t !delayed) then delayed := t :: !delayed +let add_delayed t = if not (List.memq t !delayed) then delayed := t :: !delayed let is_aliased ty = List.memq (proxy ty) !aliased let add_alias ty = let px = proxy ty in - if not (is_aliased px) then begin + if not (is_aliased px) then ( aliased := px :: !aliased; - add_named_var px - end + add_named_var px) let aliasable ty = match ty.desc with - Tvar _ | Tunivar _ | Tpoly _ -> false - | Tconstr (p, _, _) -> - not (is_nth (snd (best_type_path p))) + | Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> not (is_nth (snd (best_type_path p))) | _ -> true let namable_row row = - row.row_name <> None && - List.for_all - (fun (_, f) -> - match row_field_repr f with - | Reither(c, l, _, _) -> + row.row_name <> None + && List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither (c, l, _, _) -> row.row_closed && if c then l = [] else List.length l = 1 - | _ -> true) - row.row_fields + | _ -> true) + row.row_fields let rec mark_loops_rec visited ty = let ty = repr ty in let px = proxy ty in - if List.memq px visited && aliasable ty then add_alias px else + if List.memq px visited && aliasable ty then add_alias px + else let visited = px :: visited in match ty.desc with | Tvar _ -> add_named_var ty - | Tarrow(_, ty1, ty2, _) -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Tarrow (_, ty1, ty2, _) -> + mark_loops_rec visited ty1; + mark_loops_rec visited ty2 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl - | Tconstr(p, tyl, _) -> - let (_p', s) = best_type_path p in - List.iter (mark_loops_rec visited) (apply_subst s tyl) - | Tpackage (_, _, tyl) -> - List.iter (mark_loops_rec visited) tyl - | Tvariant row -> - if List.memq px !visited_objects then add_alias px else - begin - let row = row_repr row in - if not (static_row row) then - visited_objects := px :: !visited_objects; - match row.row_name with - | Some(_p, tyl) when namable_row row -> - List.iter (mark_loops_rec visited) tyl - | _ -> - iter_row (mark_loops_rec visited) row - end + | Tconstr (p, tyl, _) -> + let _p', s = best_type_path p in + List.iter (mark_loops_rec visited) (apply_subst s tyl) + | Tpackage (_, _, tyl) -> List.iter (mark_loops_rec visited) tyl + | Tvariant row -> ( + if List.memq px !visited_objects then add_alias px + else + let row = row_repr row in + if not (static_row row) then visited_objects := px :: !visited_objects; + match row.row_name with + | Some (_p, tyl) when namable_row row -> + List.iter (mark_loops_rec visited) tyl + | _ -> iter_row (mark_loops_rec visited) row) | Tobject (fi, nm) -> - if List.memq px !visited_objects then add_alias px else - begin - if opened_object ty then - visited_objects := px :: !visited_objects; - begin match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpresent then - mark_loops_rec visited ty) - fields - | Some (_, l) -> - List.iter (mark_loops_rec visited) (List.tl l) - end - end - | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Tfield(_, _, _, ty2) -> - mark_loops_rec visited ty2 + if List.memq px !visited_objects then add_alias px + else ( + if opened_object ty then visited_objects := px :: !visited_objects; + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpresent then mark_loops_rec visited ty) + fields + | Some (_, l) -> List.iter (mark_loops_rec visited) (List.tl l)) + | Tfield (_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> + mark_loops_rec visited ty1; + mark_loops_rec visited ty2 + | Tfield (_, _, _, ty2) -> mark_loops_rec visited ty2 | Tnil -> () | Tsubst ty -> mark_loops_rec visited ty | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" | Tpoly (ty, tyl) -> - List.iter (fun t -> add_alias t) tyl; - mark_loops_rec visited ty + List.iter (fun t -> add_alias t) tyl; + mark_loops_rec visited ty | Tunivar _ -> add_named_var ty let mark_loops ty = normalize_type Env.empty ty; - mark_loops_rec [] ty;; + mark_loops_rec [] ty let reset_loop_marks () = - visited_objects := []; aliased := []; delayed := [] + visited_objects := []; + aliased := []; + delayed := [] let reset () = - unique_names := Ident.empty; reset_names (); reset_loop_marks () + unique_names := Ident.empty; + reset_names (); + reset_loop_marks () let reset_and_mark_loops ty = - reset (); mark_loops ty + reset (); + mark_loops ty let reset_and_mark_loops_list tyl = - reset (); List.iter mark_loops tyl + reset (); + List.iter mark_loops tyl (* Disabled in classic mode when printing an unification error *) - let rec tree_of_typexp sch ty = let ty = repr ty in let px = proxy ty in if List.mem_assq px !names && not (List.memq px !delayed) then - let mark = is_non_gen sch ty in - let name = name_of_type (if mark then new_weak_name ty else new_name) px in - Otyp_var (mark, name) else - - let pr_typ () = - match ty.desc with - | Tvar _ -> + let mark = is_non_gen sch ty in + let name = name_of_type (if mark then new_weak_name ty else new_name) px in + Otyp_var (mark, name) + else + let pr_typ () = + match ty.desc with + | Tvar _ -> (*let lev = if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*) let non_gen = is_non_gen sch ty in let name_gen = if non_gen then new_weak_name ty else new_name in Otyp_var (non_gen, name_of_type name_gen ty) - | Tarrow(l, ty1, ty2, _) -> + | Tarrow (l, ty1, ty2, _) -> let pr_arrow l ty1 ty2 = - let lab = - string_of_label l - in + let lab = string_of_label l in let t1 = if is_optional l then match (repr ty1).desc with - | Tconstr(path, [ty], _) - when Path.same path Predef.path_option -> - tree_of_typexp sch ty + | Tconstr (path, [ty], _) when Path.same path Predef.path_option + -> + tree_of_typexp sch ty | _ -> Otyp_stuff "" - else tree_of_typexp sch ty1 in - Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in + else tree_of_typexp sch ty1 + in + Otyp_arrow (lab, t1, tree_of_typexp sch ty2) + in pr_arrow l ty1 ty2 - | Ttuple tyl -> - Otyp_tuple (tree_of_typlist sch tyl) - | Tconstr(p, tyl, _abbrev) -> + | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl) + | Tconstr (p, tyl, _abbrev) -> let p', s = best_type_path p in let tyl' = apply_subst s tyl in - if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else - Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') - | Tvariant row -> + if is_nth s && not (tyl' = []) then tree_of_typexp sch (List.hd tyl') + else Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') + | Tvariant row -> ( let row = row_repr row in let fields = if row.row_closed then - Ext_list.filter row.row_fields (fun (_, f) -> row_field_repr f <> Rabsent) - else row.row_fields in + Ext_list.filter row.row_fields (fun (_, f) -> + row_field_repr f <> Rabsent) + else row.row_fields + in let present = - Ext_list.filter fields - (fun (_, f) -> - match row_field_repr f with - | Rpresent _ -> true - | _ -> false) + Ext_list.filter fields (fun (_, f) -> + match row_field_repr f with + | Rpresent _ -> true + | _ -> false) in let all_present = List.length present = List.length fields in - begin match row.row_name with - | Some(p, tyl) when namable_row row -> - let (p', s) = best_type_path p in - let id = tree_of_path p' in - let args = tree_of_typlist sch (apply_subst s tyl) in - let out_variant = - if is_nth s then List.hd args else Otyp_constr (id, args) in - if row.row_closed && all_present then - out_variant - else - let non_gen = is_non_gen sch px in - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags) - | _ -> - let non_gen = - not (row.row_closed && all_present) && is_non_gen sch px in - let fields = List.map (tree_of_row_field sch) fields in + match row.row_name with + | Some (p, tyl) when namable_row row -> + let p', s = best_type_path p in + let id = tree_of_path p' in + let args = tree_of_typlist sch (apply_subst s tyl) in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) + in + if row.row_closed && all_present then out_variant + else + let non_gen = is_non_gen sch px in let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) - end - | Tobject (fi, nm) -> - tree_of_typobject sch fi !nm - | Tnil | Tfield _ -> - tree_of_typobject sch ty None - | Tsubst ty -> - tree_of_typexp sch ty - | Tlink _ -> - fatal_error "Printtyp.tree_of_typexp" - | Tpoly (ty, []) -> - tree_of_typexp sch ty - | Tpoly (ty, tyl) -> + if all_present then None else Some (List.map fst present) + in + Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags) + | _ -> + let non_gen = + (not (row.row_closed && all_present)) && is_non_gen sch px + in + let fields = List.map (tree_of_row_field sch) fields in + let tags = + if all_present then None else Some (List.map fst present) + in + Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)) + | Tobject (fi, nm) -> tree_of_typobject sch fi !nm + | Tnil | Tfield _ -> tree_of_typobject sch ty None + | Tsubst ty -> tree_of_typexp sch ty + | Tlink _ -> fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> tree_of_typexp sch ty + | Tpoly (ty, tyl) -> (*let print_names () = List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; prerr_string "; " in *) let tyl = List.map repr tyl in - if tyl = [] then tree_of_typexp sch ty else begin + if tyl = [] then tree_of_typexp sch ty + else let old_delayed = !delayed in (* Make the names delayed, so that the real type is printed once when used as proxy *) @@ -676,107 +662,109 @@ let rec tree_of_typexp sch ty = let tr = Otyp_poly (tl, tree_of_typexp sch ty) in (* Forget names when we leave scope *) remove_names tyl; - delayed := old_delayed; tr - end - | Tunivar _ -> - Otyp_var (false, name_of_type new_name ty) - | Tpackage (p, n, tyl) -> + delayed := old_delayed; + tr + | Tunivar _ -> Otyp_var (false, name_of_type new_name ty) + | Tpackage (p, n, tyl) -> let n = - List.map (fun li -> String.concat "." (Longident.flatten li)) n in + List.map (fun li -> String.concat "." (Longident.flatten li)) n + in Otyp_module (Path.name p, n, tree_of_typlist sch tyl) - in - if List.memq px !delayed then delayed := Ext_list.filter !delayed ((!=) px) ; - if is_aliased px && aliasable ty then begin - check_name_of_type px; - Otyp_alias (pr_typ (), name_of_type new_name px) end - else pr_typ () + in + if List.memq px !delayed then + delayed := Ext_list.filter !delayed (( != ) px); + if is_aliased px && aliasable ty then ( + check_name_of_type px; + Otyp_alias (pr_typ (), name_of_type new_name px)) + else pr_typ () and tree_of_row_field sch (l, f) = match row_field_repr f with - | Rpresent None | Reither(true, [], _, _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) - | Reither(c, tyl, _, _) -> - if c (* contradiction: constant constructor with an argument *) - then (l, true, tree_of_typlist sch tyl) - else (l, false, tree_of_typlist sch tyl) + | Rpresent None | Reither (true, [], _, _) -> (l, false, []) + | Rpresent (Some ty) -> (l, false, [tree_of_typexp sch ty]) + | Reither (c, tyl, _, _) -> + if c (* contradiction: constant constructor with an argument *) then + (l, true, tree_of_typlist sch tyl) + else (l, false, tree_of_typlist sch tyl) | Rabsent -> (l, false, [] (* actually, an error *)) -and tree_of_typlist sch tyl = - List.map (tree_of_typexp sch) tyl +and tree_of_typlist sch tyl = List.map (tree_of_typexp sch) tyl and tree_of_typobject sch fi nm = - begin match nm with + match nm with | None -> - let pr_fields fi = - let (fields, rest) = flatten_fields fi in - let present_fields = - List.fold_right - (fun (n, k, t) l -> - match field_kind_repr k with - | Fpresent -> (n, t) :: l - | _ -> l) - fields [] in - let sorted_fields = - List.sort - (fun (n, _) (n', _) -> String.compare n n') present_fields in - tree_of_typfields sch rest sorted_fields in - let (fields, rest) = pr_fields fi in - Otyp_object (fields, rest) + let pr_fields fi = + let fields, rest = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpresent -> (n, t) :: l + | _ -> l) + fields [] + in + let sorted_fields = + List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields + in + tree_of_typfields sch rest sorted_fields + in + let fields, rest = pr_fields fi in + Otyp_object (fields, rest) | Some (p, ty :: tyl) -> - let non_gen = is_non_gen sch (repr ty) in - let args = tree_of_typlist sch tyl in - let (p', s) = best_type_path p in - assert (s = Id); - Otyp_class (non_gen, tree_of_path p', args) - | _ -> - fatal_error "Printtyp.tree_of_typobject" - end - -and is_non_gen sch ty = - sch && is_Tvar ty && ty.level <> generic_level + let non_gen = is_non_gen sch (repr ty) in + let args = tree_of_typlist sch tyl in + let p', s = best_type_path p in + assert (s = Id); + Otyp_class (non_gen, tree_of_path p', args) + | _ -> fatal_error "Printtyp.tree_of_typobject" + +and is_non_gen sch ty = sch && is_Tvar ty && ty.level <> generic_level and tree_of_typfields sch rest = function | [] -> - let rest = - match rest.desc with - | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) - | Tconstr _ -> Some false - | Tnil -> None - | _ -> fatal_error "typfields (1)" - in - ([], rest) + let rest = + match rest.desc with + | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) + | Tconstr _ -> Some false + | Tnil -> None + | _ -> fatal_error "typfields (1)" + in + ([], rest) | (s, t) :: l -> - let field = (s, tree_of_typexp sch t) in - let (fields, rest) = tree_of_typfields sch rest l in - (field :: fields, rest) + let field = (s, tree_of_typexp sch t) in + let fields, rest = tree_of_typfields sch rest l in + (field :: fields, rest) -let typexp sch ppf ty = - !Oprint.out_type ppf (tree_of_typexp sch ty) +let typexp sch ppf ty = !Oprint.out_type ppf (tree_of_typexp sch ty) let type_expr ppf ty = typexp false ppf ty and type_sch ppf ty = typexp true ppf ty -and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty +and type_scheme ppf ty = + reset_and_mark_loops ty; + typexp true ppf ty (* Maxence *) -let type_scheme_max ?(b_reset_names=true) ppf ty = - if b_reset_names then reset_names () ; +let type_scheme_max ?(b_reset_names = true) ppf ty = + if b_reset_names then reset_names (); typexp true ppf ty (* End Maxence *) -let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty +let tree_of_type_scheme ty = + reset_and_mark_loops ty; + tree_of_typexp true ty (* Print one type declaration *) let tree_of_constraints params = List.fold_right (fun ty list -> - let ty' = unalias ty in - if proxy ty != proxy ty' then - let tr = tree_of_typexp true ty in - (tr, tree_of_typexp true ty') :: list - else list) + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp true ty in + (tr, tree_of_typexp true ty') :: list + else list) params [] let filter_params tyl = @@ -787,28 +775,28 @@ let filter_params tyl = if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl else ty :: tyl) [] tyl - in List.rev params + in + List.rev params let mark_loops_constructor_arguments = function | Cstr_tuple l -> List.iter mark_loops l | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l let rec tree_of_type_decl id decl = - - reset(); + reset (); let params = filter_params decl.type_params in - begin match decl.type_manifest with + (match decl.type_manifest with | Some ty -> - let vars = free_variables ty in - List.iter - (function {desc = Tvar (Some "_")} as ty -> - if List.memq ty vars then ty.desc <- Tvar None - | _ -> ()) - params - | None -> () - end; + let vars = free_variables ty in + List.iter + (function + | {desc = Tvar (Some "_")} as ty -> + if List.memq ty vars then ty.desc <- Tvar None + | _ -> ()) + params + | None -> ()); List.iter add_alias params; List.iter mark_loops params; @@ -817,111 +805,103 @@ let rec tree_of_type_decl id decl = match decl.type_manifest with | None -> None | Some ty -> - let ty = - (* Special hack to hide variant name *) - match repr ty with {desc=Tvariant row} -> - let row = row_repr row in - begin match row.row_name with - Some (Pident id', _) when Ident.same id id' -> - newgenty (Tvariant {row with row_name = None}) - | _ -> ty - end - | _ -> ty - in - mark_loops ty; - Some ty + let ty = + (* Special hack to hide variant name *) + match repr ty with + | {desc = Tvariant row} -> ( + let row = row_repr row in + match row.row_name with + | Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant {row with row_name = None}) + | _ -> ty) + | _ -> ty + in + mark_loops ty; + Some ty in - begin match decl.type_kind with + (match decl.type_kind with | Type_abstract -> () | Type_variant cstrs -> - List.iter - (fun c -> - mark_loops_constructor_arguments c.cd_args; - may mark_loops c.cd_res) - cstrs - | Type_record(l, _rep) -> - List.iter (fun l -> mark_loops l.ld_type) l - | Type_open -> () - end; - - let type_param = - function + List.iter + (fun c -> + mark_loops_constructor_arguments c.cd_args; + may mark_loops c.cd_res) + cstrs + | Type_record (l, _rep) -> List.iter (fun l -> mark_loops l.ld_type) l + | Type_open -> ()); + + let type_param = function | Otyp_var (_, id) -> id | _ -> "?" in let type_defined decl = let abstr = match decl.type_kind with - Type_abstract -> - decl.type_manifest = None || decl.type_private = Private - | Type_record _ -> - decl.type_private = Private + | Type_abstract -> + decl.type_manifest = None || decl.type_private = Private + | Type_record _ -> decl.type_private = Private | Type_variant tll -> - decl.type_private = Private || - List.exists (fun cd -> cd.cd_res <> None) tll - | Type_open -> - decl.type_manifest = None + decl.type_private = Private + || List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> decl.type_manifest = None in let vari = List.map2 (fun ty v -> if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v - else (true,true)) + else (true, true)) decl.type_params decl.type_variance in - (Ident.name id, - List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn) - params vari) + ( Ident.name id, + List.map2 + (fun ty cocn -> (type_param (tree_of_typexp false ty), cocn)) + params vari ) in let tree_of_manifest ty1 = match ty_manifest with | None -> ty1 | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1) in - let (name, args) = type_defined decl in + let name, args = type_defined decl in let constraints = tree_of_constraints params in let untagged = ref false in let ty, priv = match decl.type_kind with - | Type_abstract -> - begin match ty_manifest with - | None -> (Otyp_abstract, Public) - | Some ty -> - tree_of_typexp false ty, decl.type_private - end + | Type_abstract -> ( + match ty_manifest with + | None -> (Otyp_abstract, Public) + | Some ty -> (tree_of_typexp false ty, decl.type_private)) | Type_variant cstrs -> - untagged := Ast_untagged_variants.process_untagged decl.type_attributes; - tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), - decl.type_private - | Type_record(lbls, _rep) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), - decl.type_private - | Type_open -> - tree_of_manifest Otyp_open, - decl.type_private + untagged := Ast_untagged_variants.process_untagged decl.type_attributes; + ( tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), + decl.type_private ) + | Type_record (lbls, _rep) -> + ( tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private ) + | Type_open -> (tree_of_manifest Otyp_open, decl.type_private) in - let immediate = - Builtin_attributes.immediate decl.type_attributes - in - { otype_name = name; - otype_params = args; - otype_type = ty; - otype_private = priv; - otype_immediate = immediate; - otype_unboxed = decl.type_unboxed.unboxed || !untagged; - otype_cstrs = constraints ; - } + let immediate = Builtin_attributes.immediate decl.type_attributes in + { + otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_immediate = immediate; + otype_unboxed = decl.type_unboxed.unboxed || !untagged; + otype_cstrs = constraints; + } and tree_of_constructor_arguments = function | Cstr_tuple l -> tree_of_typlist false l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + | Cstr_record l -> [Otyp_record (List.map tree_of_label l)] and tree_of_constructor cd = let name = Ident.name cd.cd_id in let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in let repr = if not nullary then None - else match Ast_untagged_variants.process_tag_type cd.cd_attributes with + else + match Ast_untagged_variants.process_tag_type cd.cd_attributes with | Some Null -> Some "@as(null)" | Some Undefined -> Some "@as(undefined)" | Some (String s) -> Some (Printf.sprintf "@as(%S)" s) @@ -929,24 +909,30 @@ and tree_of_constructor cd = | Some (Float f) -> Some (Printf.sprintf "@as(%s)" f) | Some (Bool b) -> Some (Printf.sprintf "@as(%b)" b) | Some (BigInt s) -> Some (Printf.sprintf "@as(%sn)" s) - | Some (Untagged _) (* should never happen *) - | None -> None in + | Some (Untagged _) (* should never happen *) | None -> None + in let arg () = tree_of_constructor_arguments cd.cd_args in match cd.cd_res with | None -> (name, arg (), None, repr) | Some res -> - let nm = !names in - names := []; - let ret = tree_of_typexp false res in - let args = arg () in - names := nm; - (name, args, Some ret, repr) + let nm = !names in + names := []; + let ret = tree_of_typexp false res in + let args = arg () in + names := nm; + (name, args, Some ret, repr) and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "ns.optional" || txt = "res.optional") in - let typ = match l.ld_type.desc with + let opt = + l.ld_attributes + |> List.exists (fun ({txt}, _) -> + txt = "ns.optional" || txt = "res.optional") + in + let typ = + match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 - | _ -> l.ld_type in + | _ -> l.ld_type + in (Ident.name l.ld_id, l.ld_mutable = Mutable, opt, tree_of_typexp false typ) let tree_of_type_declaration id decl rs = @@ -970,8 +956,7 @@ let tree_of_extension_constructor id ext es = List.iter check_name_of_type (List.map proxy ty_params); mark_loops_constructor_arguments ext.ext_args; may mark_loops ext.ext_ret_type; - let type_param = - function + let type_param = function | Otyp_var (_, id) -> id | _ -> "?" in @@ -983,29 +968,31 @@ let tree_of_extension_constructor id ext es = match ext.ext_ret_type with | None -> (tree_of_constructor_arguments ext.ext_args, None) | Some res -> - let nm = !names in - names := []; - let ret = tree_of_typexp false res in - let args = tree_of_constructor_arguments ext.ext_args in - names := nm; - (args, Some ret) + let nm = !names in + names := []; + let ret = tree_of_typexp false res in + let args = tree_of_constructor_arguments ext.ext_args in + names := nm; + (args, Some ret) in let ext = - { oext_name = name; + { + oext_name = name; oext_type_name = ty_name; oext_type_params = ty_params; oext_args = args; oext_ret_type = ret; oext_repr = None; - oext_private = ext.ext_private } + oext_private = ext.ext_private; + } in let es = match es with - Text_first -> Oext_first - | Text_next -> Oext_next - | Text_exception -> Oext_exception + | Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception in - Osig_typext (ext, es) + Osig_typext (ext, es) let extension_constructor id ppf ext = !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) @@ -1017,10 +1004,7 @@ let tree_of_value_description id decl = let id = Ident.name id in let ty = tree_of_type_scheme decl.val_type in let vd = - { oval_name = id; - oval_type = ty; - oval_prims = []; - oval_attributes = [] } + {oval_name = id; oval_type = ty; oval_prims = []; oval_attributes = []} in let vd = match decl.val_kind with @@ -1034,7 +1018,6 @@ let value_description id ppf decl = (* Print a class type *) - (* Print a module type *) let wrap_env fenv ftree arg = @@ -1045,93 +1028,96 @@ let wrap_env fenv ftree arg = tree let filter_rem_sig item rem = - match item, rem with - | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> - ([tydecl1; tydecl2], rem) - | _ -> - ([], rem) + match (item, rem) with + | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> ([tydecl1; tydecl2], rem) + | _ -> ([], rem) let dummy = - { type_params = []; type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = None; type_loc = Location.none; + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_newtype_level = None; + type_loc = Location.none; type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; } let hide_rec_items = function - | Sig_type(id, _decl, rs) ::rem + | Sig_type (id, _decl, rs) :: rem when rs = Trec_first && not !Clflags.real_paths -> - let rec get_ids = function - Sig_type (id, _, Trec_next) :: rem -> - id :: get_ids rem - | _ -> [] - in - let ids = id :: get_ids rem in - set_printing_env - (List.fold_right - (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) - ids !printing_env) + let rec get_ids = function + | Sig_type (id, _, Trec_next) :: rem -> id :: get_ids rem + | _ -> [] + in + let ids = id :: get_ids rem in + set_printing_env + (List.fold_right + (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) + ids !printing_env) | _ -> () -let rec tree_of_modtype ?(ellipsis=false) = function - | Mty_ident p -> - Omty_ident (tree_of_path p) +let rec tree_of_modtype ?(ellipsis = false) = function + | Mty_ident p -> Omty_ident (tree_of_path p) | Mty_signature sg -> - Omty_signature (if ellipsis then [Osig_ellipsis] - else tree_of_signature sg) - | Mty_functor(param, ty_arg, ty_res) -> - let res = - match ty_arg with None -> tree_of_modtype ~ellipsis ty_res - | Some mty -> - wrap_env (Env.add_module ~arg:true param mty) - (tree_of_modtype ~ellipsis) ty_res - in - Omty_functor (Ident.name param, - may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) - | Mty_alias(_, p) -> - Omty_alias (tree_of_path p) + Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) + | Mty_functor (param, ty_arg, ty_res) -> + let res = + match ty_arg with + | None -> tree_of_modtype ~ellipsis ty_res + | Some mty -> + wrap_env + (Env.add_module ~arg:true param mty) + (tree_of_modtype ~ellipsis) + ty_res + in + Omty_functor + (Ident.name param, may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) + | Mty_alias (_, p) -> Omty_alias (tree_of_path p) and tree_of_signature sg = wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg and tree_of_signature_rec env' in_type_group = function - [] -> [] + | [] -> [] | item :: rem as items -> - let in_type_group = - match in_type_group, item with - true, Sig_type (_, _, Trec_next) -> true - | _, Sig_type (_, _, (Trec_not | Trec_first)) -> - set_printing_env env'; true - | _ -> set_printing_env env'; false - in - let (sg, rem) = filter_rem_sig item rem in - hide_rec_items items; - let trees = trees_of_sigitem item in - let env' = Env.add_signature (item :: sg) env' in - trees @ tree_of_signature_rec env' in_type_group rem + let in_type_group = + match (in_type_group, item) with + | true, Sig_type (_, _, Trec_next) -> true + | _, Sig_type (_, _, (Trec_not | Trec_first)) -> + set_printing_env env'; + true + | _ -> + set_printing_env env'; + false + in + let sg, rem = filter_rem_sig item rem in + hide_rec_items items; + let trees = trees_of_sigitem item in + let env' = Env.add_signature (item :: sg) env' in + trees @ tree_of_signature_rec env' in_type_group rem and trees_of_sigitem = function - | Sig_value(id, decl) -> - [tree_of_value_description id decl] - | Sig_type(id, _, _) when is_row_name (Ident.name id) -> - [] - | Sig_type(id, decl, rs) -> - [tree_of_type_declaration id decl rs] - | Sig_typext(id, ext, es) -> - [tree_of_extension_constructor id ext es] - | Sig_module(id, md, rs) -> - let ellipsis = - List.exists (function ({txt="..."}, Parsetree.PStr []) -> true - | _ -> false) - md.md_attributes in - [tree_of_module id md.md_type rs ~ellipsis] - | Sig_modtype(id, decl) -> - [tree_of_modtype_declaration id decl] - | Sig_class() -> - [] - | Sig_class_type() -> [] + | Sig_value (id, decl) -> [tree_of_value_description id decl] + | Sig_type (id, _, _) when is_row_name (Ident.name id) -> [] + | Sig_type (id, decl, rs) -> [tree_of_type_declaration id decl rs] + | Sig_typext (id, ext, es) -> [tree_of_extension_constructor id ext es] + | Sig_module (id, md, rs) -> + let ellipsis = + List.exists + (function + | {txt = "..."}, Parsetree.PStr [] -> true + | _ -> false) + md.md_attributes + in + [tree_of_module id md.md_type rs ~ellipsis] + | Sig_modtype (id, decl) -> [tree_of_modtype_declaration id decl] + | Sig_class () -> [] + | Sig_class_type () -> [] and tree_of_modtype_declaration id decl = let mty = @@ -1152,28 +1138,26 @@ let modtype_declaration id ppf decl = (* Refresh weak variable map in the toplevel *) let refresh_weak () = - let refresh t name (m,s) = - if is_non_gen true (repr t) then - begin - TypeMap.add t name m, - StringSet.add name s - end - else m, s in + let refresh t name (m, s) = + if is_non_gen true (repr t) then (TypeMap.add t name m, StringSet.add name s) + else (m, s) + in let m, s = - TypeMap.fold refresh !weak_var_map (TypeMap.empty ,StringSet.empty) in + TypeMap.fold refresh !weak_var_map (TypeMap.empty, StringSet.empty) + in named_weak_vars := s; weak_var_map := m let print_items showval env x = - refresh_weak(); + refresh_weak (); let rec print showval env = function - | [] -> [] - | item :: rem as items -> - let (_sg, rem) = filter_rem_sig item rem in + | [] -> [] + | item :: rem as items -> + let _sg, rem = filter_rem_sig item rem in hide_rec_items items; let trees = trees_of_sigitem item in - List.map (fun d -> (d, showval env item)) trees @ - print showval env rem in + List.map (fun d -> (d, showval env item)) trees @ print showval env rem + in print showval env x (* Print a signature body (used by -i when compiling a .ml) *) @@ -1181,74 +1165,73 @@ let print_items showval env x = let print_signature ppf tree = fprintf ppf "@[%a@]" !Oprint.out_signature tree -let signature ppf sg = - fprintf ppf "%a" print_signature (tree_of_signature sg) +let signature ppf sg = fprintf ppf "%a" print_signature (tree_of_signature sg) (* Print an unification error *) let same_path t t' = let t = repr t and t' = repr t' in - t == t' || - match t.desc, t'.desc with - Tconstr(p,tl,_), Tconstr(p',tl',_) -> - let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in - begin match s1, s2 with - Nth n1, Nth n2 when n1 = n2 -> true - | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> - let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in - List.length tl = List.length tl' && - List.for_all2 same_type tl tl' - | _ -> false - end - | _ -> - false + t == t' + || + match (t.desc, t'.desc) with + | Tconstr (p, tl, _), Tconstr (p', tl', _) -> ( + let p1, s1 = best_type_path p and p2, s2 = best_type_path p' in + match (s1, s2) with + | Nth n1, Nth n2 when n1 = n2 -> true + | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> + let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in + List.length tl = List.length tl' && List.for_all2 same_type tl tl' + | _ -> false) + | _ -> false let type_expansion t ppf t' = - if same_path t t' - then begin add_delayed (proxy t); type_expr ppf t end + if same_path t t' then ( + add_delayed (proxy t); + type_expr ppf t) else - let t' = if proxy t == proxy t' then unalias t' else t' in - fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' + let t' = if proxy t == proxy t' then unalias t' else t' in + fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' let type_path_expansion tp ppf tp' = - if Path.same tp tp' then path ppf tp else - fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp' + if Path.same tp tp' then path ppf tp + else fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp' let rec trace fst txt ppf = function | (t1, t1') :: (t2, t2') :: rem -> - if not fst then fprintf ppf "@,"; - fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" - (type_expansion t1) t1' txt (type_expansion t2) t2' - (trace false txt) rem + if not fst then fprintf ppf "@,"; + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" (type_expansion t1) t1' txt + (type_expansion t2) t2' (trace false txt) rem | _ -> () let rec filter_trace keep_last = function - | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' -> - [] + | [(_, t1'); (_, t2')] when is_Tvar t1' || is_Tvar t2' -> [] | (t1, t1') :: (t2, t2') :: rem -> - let rem' = filter_trace keep_last rem in - if is_constr_row ~allow_ident:true t1' + let rem' = filter_trace keep_last rem in + if + is_constr_row ~allow_ident:true t1' || is_constr_row ~allow_ident:true t2' - || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = []) - then rem' - else (t1, t1') :: (t2, t2') :: rem' + || (same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])) + then rem' + else (t1, t1') :: (t2, t2') :: rem' | _ -> [] let rec type_path_list ppf = function - | [tp, tp'] -> type_path_expansion tp ppf tp' + | [(tp, tp')] -> type_path_expansion tp ppf tp' | (tp, tp') :: rem -> - fprintf ppf "%a@;<2 0>%a" - (type_path_expansion tp) tp' - type_path_list rem + fprintf ppf "%a@;<2 0>%a" (type_path_expansion tp) tp' type_path_list rem | [] -> () (* Hide variant name and var, to force printing the expanded type *) let hide_variant_name t = match repr t with | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> - newty2 t.level - (Tvariant {(row_repr row) with row_name = None; - row_more = newvar2 (row_more row).level}) + newty2 t.level + (Tvariant + { + (row_repr row) with + row_name = None; + row_more = newvar2 (row_more row).level; + }) | _ -> t let prepare_expansion (t, t') = @@ -1259,140 +1242,140 @@ let prepare_expansion (t, t') = let may_prepare_expansion compact (t, t') = match (repr t').desc with - Tvariant _ | Tobject _ when compact -> - mark_loops t; (t, t) + | (Tvariant _ | Tobject _) when compact -> + mark_loops t; + (t, t) | _ -> prepare_expansion (t, t') let print_tags ppf fields = - match fields with [] -> () + match fields with + | [] -> () | (t, _) :: fields -> - fprintf ppf "%s" (!print_res_poly_identifier t); - List.iter (fun (t, _) -> fprintf ppf ",@ %s" (!print_res_poly_identifier t)) fields + fprintf ppf "%s" (!print_res_poly_identifier t); + List.iter + (fun (t, _) -> fprintf ppf ",@ %s" (!print_res_poly_identifier t)) + fields let has_explanation t3 t4 = - match t3.desc, t4.desc with - Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _ - | Tnil, Tconstr _ | Tconstr _, Tnil - | _, Tvar _ | Tvar _, _ - | Tvariant _, Tvariant _ -> true - | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l' + match (t3.desc, t4.desc) with + | Tfield _, (Tnil | Tconstr _) + | (Tnil | Tconstr _), Tfield _ + | Tnil, Tconstr _ + | Tconstr _, Tnil + | _, Tvar _ + | Tvar _, _ + | Tvariant _, Tvariant _ -> + true + | Tfield (l, _, _, {desc = Tnil}), Tfield (l', _, _, {desc = Tnil}) -> l = l' | _ -> false let rec mismatch = function - (_, t) :: (_, t') :: rem -> - begin match mismatch rem with - Some _ as m -> m - | None -> - if has_explanation t t' then Some(t,t') else None - end + | (_, t) :: (_, t') :: rem -> ( + match mismatch rem with + | Some _ as m -> m + | None -> if has_explanation t t' then Some (t, t') else None) | [] -> None | _ -> assert false let explanation unif t3 t4 ppf = - match t3.desc, t4.desc with + match (t3.desc, t4.desc) with | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> - fprintf ppf "@,Self type cannot escape its class" - | Tconstr (p, _, _), Tvar _ - when unif && t4.level < Path.binding_time p -> - fprintf ppf - "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - path p - | Tvar _, Tconstr (p, _, _) - when unif && t3.level < Path.binding_time p -> - fprintf ppf - "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - path p + fprintf ppf "@,Self type cannot escape its class" + | Tconstr (p, _, _), Tvar _ when unif && t4.level < Path.binding_time p -> + fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p + | Tvar _, Tconstr (p, _, _) when unif && t3.level < Path.binding_time p -> + fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> - fprintf ppf "@,The universal variable %a would escape its scope" - type_expr (if is_Tunivar t3 then t3 else t4) + fprintf ppf "@,The universal variable %a would escape its scope" type_expr + (if is_Tunivar t3 then t3 else t4) | Tvar _, _ | _, Tvar _ -> - let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in - if occur_in Env.empty t t' then - fprintf ppf "@,@[The type variable %a occurs inside@ %a@]" - type_expr t type_expr t' - else - fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" - type_expr t' - "it would escape the scope of its equation" + let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in + if occur_in Env.empty t t' then + fprintf ppf "@,@[The type variable %a occurs inside@ %a@]" type_expr + t type_expr t' + else + fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" type_expr + t' "it would escape the scope of its equation" | Tfield (lab, _, _, _), _ when lab = dummy_method -> - fprintf ppf - "@,Self type cannot be unified with a closed object type" + fprintf ppf "@,Self type cannot be unified with a closed object type" | _, Tfield (lab, _, _, _) when lab = dummy_method -> - fprintf ppf - "@,Self type cannot be unified with a closed object type" - | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' -> - fprintf ppf "@,Types for method %s are incompatible" l - | (Tnil|Tconstr _), Tfield (l, _, _, _) -> - fprintf ppf - "@,@[The first object type has no field %s@]" l - | Tfield (l, _, _, _), (Tnil|Tconstr _) -> - fprintf ppf - "@,@[The second object type has no field %s@]" l + fprintf ppf "@,Self type cannot be unified with a closed object type" + | Tfield (l, _, _, {desc = Tnil}), Tfield (l', _, _, {desc = Tnil}) + when l = l' -> + fprintf ppf "@,Types for method %s are incompatible" l + | (Tnil | Tconstr _), Tfield (l, _, _, _) -> + fprintf ppf "@,@[The first object type has no field %s@]" l + | Tfield (l, _, _, _), (Tnil | Tconstr _) -> + fprintf ppf "@,@[The second object type has no field %s@]" l | Tnil, Tconstr _ | Tconstr _, Tnil -> + fprintf ppf + "@,@[The %s object type has an abstract row, it cannot be closed@]" + (if t4.desc = Tnil then "first" else "second") + | Tvariant row1, Tvariant row2 -> ( + let row1 = row_repr row1 and row2 = row_repr row2 in + match + (row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed) + with + | [], true, [], true -> + fprintf ppf "@,These two variant types have no intersection" + | [], true, (_ :: _ as fields), _ -> + fprintf ppf + "@,@[The first variant type does not allow tag(s)@ @[%a@]@]" + print_tags fields + | (_ :: _ as fields), _, [], true -> fprintf ppf - "@,@[The %s object type has an abstract row, it cannot be closed@]" - (if t4.desc = Tnil then "first" else "second") - | Tvariant row1, Tvariant row2 -> - let row1 = row_repr row1 and row2 = row_repr row2 in - begin match - row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with - | [], true, [], true -> - fprintf ppf "@,These two variant types have no intersection" - | [], true, (_::_ as fields), _ -> - fprintf ppf - "@,@[The first variant type does not allow tag(s)@ @[%a@]@]" - print_tags fields - | (_::_ as fields), _, [], true -> - fprintf ppf - "@,@[The second variant type does not allow tag(s)@ @[%a@]@]" - print_tags fields - | [l1,_], true, [l2,_], true when l1 = l2 -> - fprintf ppf "@,Types for tag %s are incompatible" (!print_res_poly_identifier l1) - | _ -> () - end + "@,@[The second variant type does not allow tag(s)@ @[%a@]@]" + print_tags fields + | [(l1, _)], true, [(l2, _)], true when l1 = l2 -> + fprintf ppf "@,Types for tag %s are incompatible" + (!print_res_poly_identifier l1) + | _ -> ()) | _ -> () - let warn_on_missing_def env ppf t = match t.desc with - | Tconstr (p,_,_) -> - begin - try - ignore(Env.find_type p env : Types.type_declaration) - with Not_found -> - fprintf ppf - "@,@[%a is abstract because no corresponding cmi file was found \ - in path.@]" path p - end + | Tconstr (p, _, _) -> ( + try ignore (Env.find_type p env : Types.type_declaration) + with Not_found -> + fprintf ppf + "@,\ + @[%a is abstract because no corresponding cmi file was found in \ + path.@]" + path p) | _ -> () let explanation unif mis ppf = match mis with - None -> () + | None -> () | Some (t3, t4) -> explanation unif t3 t4 ppf let ident_same_name id1 id2 = - if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin - add_unique id1; add_unique id2 - end + if Ident.equal id1 id2 && not (Ident.same id1 id2) then ( + add_unique id1; + add_unique id2) let rec path_same_name p1 p2 = - match p1, p2 with - Pident id1, Pident id2 -> ident_same_name id1 id2 + match (p1, p2) with + | Pident id1, Pident id2 -> ident_same_name id1 id2 | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2 | Papply (p1, p1'), Papply (p2, p2') -> - path_same_name p1 p2; path_same_name p1' p2' + path_same_name p1 p2; + path_same_name p1' p2' | _ -> () let type_same_name t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tconstr (p1, _, _), Tconstr (p2, _, _) -> - path_same_name (fst (best_type_path p1)) (fst (best_type_path p2)) + match ((repr t1).desc, (repr t2).desc) with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> + path_same_name (fst (best_type_path p1)) (fst (best_type_path p2)) | _ -> () let rec trace_same_names = function - (t1, t1') :: (t2, t2') :: rem -> - type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem + | (t1, t1') :: (t2, t2') :: rem -> + type_same_name t1 t2; + type_same_name t1' t2'; + trace_same_names rem | _ -> () let unification_error env unif tr txt1 ppf txt2 = @@ -1402,43 +1385,31 @@ let unification_error env unif tr txt1 ppf txt2 = let mis = mismatch tr in match tr with | [] | _ :: [] -> assert false - | t1 :: t2 :: tr -> + | t1 :: t2 :: tr -> ( try let tr = filter_trace (mis = None) tr in let t1, t1' = may_prepare_expansion (tr = []) t1 and t2, t2' = may_prepare_expansion (tr = []) t2 in let tr = List.map prepare_expansion tr in - fprintf ppf - "@[\ - @[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]%a%t\ - @]" - txt1 (type_expansion t1) t1' - txt2 (type_expansion t2) t2' - (trace false "is not compatible with type") tr - (explanation unif mis); - if env <> Env.empty - then begin + fprintf ppf "@[@[%t@;<1 2>%a@ %t@;<1 2>%a@]%a%t@]" txt1 + (type_expansion t1) t1' txt2 (type_expansion t2) t2' + (trace false "is not compatible with type") + tr (explanation unif mis); + if env <> Env.empty then ( warn_on_missing_def env ppf t1; - warn_on_missing_def env ppf t2 - end; - with exn -> - raise exn + warn_on_missing_def env ppf t2) + with exn -> raise exn) -let report_unification_error ppf env ?(unif=true) - tr txt1 txt2 = +let report_unification_error ppf env ?(unif = true) tr txt1 txt2 = wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2) -;; - let super_type_expansion ~tag t ppf t' = let tag = Format.String_tag tag in - if same_path t t' then begin + if same_path t t' then ( Format.pp_open_stag ppf tag; type_expr ppf t; - Format.pp_close_stag ppf (); - end else begin + Format.pp_close_stag ppf ()) + else let t' = if proxy t == proxy t' then unalias t' else t' in fprintf ppf "@[<2>"; Format.pp_open_stag ppf tag; @@ -1449,105 +1420,87 @@ let super_type_expansion ~tag t ppf t' = fprintf ppf "%a" type_expr t'; Format.pp_close_stag ppf (); fprintf ppf "@{)@}"; - fprintf ppf "@]"; - end + fprintf ppf "@]" let super_trace ppf = let rec super_trace first_report ppf = function | (t1, t1') :: (t2, t2') :: rem -> - fprintf ppf - "@,@,@["; - if first_report then - fprintf ppf "The incompatible parts:@," - else begin - fprintf ppf "Further expanded:@," - end; - fprintf ppf - "@[%a@ vs@ %a@]%a" - (super_type_expansion ~tag:"error" t1) t1' - (super_type_expansion ~tag:"info" t2) t2' - (super_trace false) rem; + fprintf ppf "@,@,@["; + if first_report then fprintf ppf "The incompatible parts:@," + else fprintf ppf "Further expanded:@,"; + fprintf ppf "@[%a@ vs@ %a@]%a" + (super_type_expansion ~tag:"error" t1) + t1' + (super_type_expansion ~tag:"info" t2) + t2' (super_trace false) rem; fprintf ppf "@]" | _ -> () - in super_trace true ppf + in + super_trace true ppf -let super_unification_error ?print_extra_info unif tr txt1 ppf txt2 = begin +let super_unification_error ?print_extra_info unif tr txt1 ppf txt2 = reset (); trace_same_names tr; let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in let mis = mismatch tr in match tr with | [] | _ :: [] -> assert false - | t1 :: t2 :: tr -> + | t1 :: t2 :: tr -> ( try let tr = filter_trace (mis = None) tr in let t1, t1' = may_prepare_expansion (tr = []) t1 and t2, t2' = may_prepare_expansion (tr = []) t2 in let tr = List.map prepare_expansion tr in - fprintf ppf - "@[\ - @[%t@ %a@]@,\ - @[%t@ %a@]\ - %a\ - %t\ - %t\ - @]" - txt1 (super_type_expansion ~tag:"error" t1) t1' - txt2 (super_type_expansion ~tag:"info" t2) t2' - super_trace tr - (explanation unif mis) - (fun ppf -> match print_extra_info with | None -> () | Some f -> f ppf t1 t2); - with exn -> - raise exn -end - -let super_report_unification_error ?print_extra_info ppf env ?(unif=true) - tr txt1 txt2 = - wrap_printing_env env (fun () -> super_unification_error ?print_extra_info unif tr txt1 ppf txt2) -;; - + fprintf ppf "@[@[%t@ %a@]@,@[%t@ %a@]%a%t%t@]" txt1 + (super_type_expansion ~tag:"error" t1) t1' txt2 + (super_type_expansion ~tag:"info" t2) + t2' super_trace tr (explanation unif mis) (fun ppf -> + match print_extra_info with + | None -> () + | Some f -> f ppf t1 t2) + with exn -> raise exn) + +let super_report_unification_error ?print_extra_info ppf env ?(unif = true) tr + txt1 txt2 = + wrap_printing_env env (fun () -> + super_unification_error ?print_extra_info unif tr txt1 ppf txt2) let trace fst keep_last txt ppf tr = trace_same_names tr; - try match tr with - t1 :: t2 :: tr' -> + try + match tr with + | t1 :: t2 :: tr' -> if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr') - else trace fst txt ppf (filter_trace keep_last tr); - | _ -> () - with exn -> - raise exn + else trace fst txt ppf (filter_trace keep_last tr) + | _ -> () + with exn -> raise exn let report_subtyping_error ppf env tr1 txt1 tr2 = wrap_printing_env env (fun () -> - reset (); - let tr1 = List.map prepare_expansion tr1 - and tr2 = List.map prepare_expansion tr2 in - fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; - if tr2 = [] then fprintf ppf "@]" else - let mis = mismatch tr2 in - fprintf ppf "%a%t@]" - (trace false (mis = None) "is not compatible with type") tr2 - (explanation true mis)) + reset (); + let tr1 = List.map prepare_expansion tr1 + and tr2 = List.map prepare_expansion tr2 in + fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; + if tr2 = [] then fprintf ppf "@]" + else + let mis = mismatch tr2 in + fprintf ppf "%a%t@]" + (trace false (mis = None) "is not compatible with type") + tr2 (explanation true mis)) let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = wrap_printing_env env (fun () -> - reset (); - List.iter - (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') - tpl; - match tpl with - [] -> assert false - | [tp, tp'] -> - fprintf ppf - "@[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]" - txt1 (type_path_expansion tp) tp' - txt3 (type_path_expansion tp0) tp0' - | _ -> - fprintf ppf - "@[%t@;<1 2>@[%a@]\ - @ %t@;<1 2>%a\ - @]" - txt2 type_path_list tpl - txt3 (type_path_expansion tp0) tp0') + reset (); + List.iter + (fun (tp, tp') -> + path_same_name tp0 tp; + path_same_name tp0' tp') + tpl; + match tpl with + | [] -> assert false + | [(tp, tp')] -> + fprintf ppf "@[%t@;<1 2>%a@ %t@;<1 2>%a@]" txt1 (type_path_expansion tp) + tp' txt3 (type_path_expansion tp0) tp0' + | _ -> + fprintf ppf "@[%t@;<1 2>@[%a@]@ %t@;<1 2>%a@]" txt2 type_path_list + tpl txt3 (type_path_expansion tp0) tp0') diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli index 061aab30fe..c95ee90e5e 100644 --- a/compiler/ml/printtyp.mli +++ b/compiler/ml/printtyp.mli @@ -19,75 +19,94 @@ open Format open Types open Outcometree -val print_res_poly_identifier: (string -> string) ref -val longident: formatter -> Longident.t -> unit -val ident: formatter -> Ident.t -> unit -val tree_of_path: Path.t -> out_ident -val path: formatter -> Path.t -> unit -val string_of_path: Path.t -> string -val raw_type_expr: formatter -> type_expr -> unit -val string_of_label: Asttypes.arg_label -> string +val print_res_poly_identifier : (string -> string) ref +val longident : formatter -> Longident.t -> unit +val ident : formatter -> Ident.t -> unit +val tree_of_path : Path.t -> out_ident +val path : formatter -> Path.t -> unit +val string_of_path : Path.t -> string +val raw_type_expr : formatter -> type_expr -> unit +val string_of_label : Asttypes.arg_label -> string -val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a - (* Call the function using the environment for type path shortening *) - (* This affects all the printing functions below *) +val wrap_printing_env : Env.t -> (unit -> 'a) -> 'a +(* Call the function using the environment for type path shortening *) +(* This affects all the printing functions below *) -val reset: unit -> unit -val mark_loops: type_expr -> unit -val reset_and_mark_loops: type_expr -> unit -val reset_and_mark_loops_list: type_expr list -> unit -val type_expr: formatter -> type_expr -> unit -val constructor_arguments: formatter -> constructor_arguments -> unit -val tree_of_type_scheme: type_expr -> out_type +val reset : unit -> unit +val mark_loops : type_expr -> unit +val reset_and_mark_loops : type_expr -> unit +val reset_and_mark_loops_list : type_expr list -> unit +val type_expr : formatter -> type_expr -> unit +val constructor_arguments : formatter -> constructor_arguments -> unit +val tree_of_type_scheme : type_expr -> out_type val type_sch : formatter -> type_expr -> unit -val type_scheme: formatter -> type_expr -> unit -(* Maxence *) -val reset_names: unit -> unit -val type_scheme_max: ?b_reset_names: bool -> - formatter -> type_expr -> unit -(* End Maxence *) -val tree_of_value_description: Ident.t -> value_description -> out_sig_item -val value_description: Ident.t -> formatter -> value_description -> unit -val tree_of_type_declaration: - Ident.t -> type_declaration -> rec_status -> out_sig_item -val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_extension_constructor: - Ident.t -> extension_constructor -> ext_status -> out_sig_item -val extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -val tree_of_module: - Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item -val modtype: formatter -> module_type -> unit -val signature: formatter -> signature -> unit -val tree_of_modtype_declaration: - Ident.t -> modtype_declaration -> out_sig_item -val tree_of_signature: Types.signature -> out_sig_item list -val tree_of_typexp: bool -> type_expr -> out_type -val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit -val type_expansion: type_expr -> Format.formatter -> type_expr -> unit -val prepare_expansion: type_expr * type_expr -> type_expr * type_expr -val trace: - bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit -val report_unification_error: - formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list -> - (formatter -> unit) -> (formatter -> unit) -> - unit +val type_scheme : formatter -> type_expr -> unit +(* Maxence *) +val reset_names : unit -> unit +val type_scheme_max : ?b_reset_names:bool -> formatter -> type_expr -> unit -val super_report_unification_error: - ?print_extra_info:(formatter -> type_expr -> type_expr -> unit) -> - formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list -> - (formatter -> unit) -> (formatter -> unit) -> - unit +(* End Maxence *) +val tree_of_value_description : Ident.t -> value_description -> out_sig_item +val value_description : Ident.t -> formatter -> value_description -> unit +val tree_of_type_declaration : + Ident.t -> type_declaration -> rec_status -> out_sig_item +val type_declaration : Ident.t -> formatter -> type_declaration -> unit +val tree_of_extension_constructor : + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val extension_constructor : + Ident.t -> formatter -> extension_constructor -> unit +val tree_of_module : + Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item +val modtype : formatter -> module_type -> unit +val signature : formatter -> signature -> unit +val tree_of_modtype_declaration : Ident.t -> modtype_declaration -> out_sig_item +val tree_of_signature : Types.signature -> out_sig_item list +val tree_of_typexp : bool -> type_expr -> out_type +val modtype_declaration : Ident.t -> formatter -> modtype_declaration -> unit +val type_expansion : type_expr -> Format.formatter -> type_expr -> unit +val prepare_expansion : type_expr * type_expr -> type_expr * type_expr +val trace : + bool -> bool -> string -> formatter -> (type_expr * type_expr) list -> unit +val report_unification_error : + formatter -> + Env.t -> + ?unif:bool -> + (type_expr * type_expr) list -> + (formatter -> unit) -> + (formatter -> unit) -> + unit +val super_report_unification_error : + ?print_extra_info:(formatter -> type_expr -> type_expr -> unit) -> + formatter -> + Env.t -> + ?unif:bool -> + (type_expr * type_expr) list -> + (formatter -> unit) -> + (formatter -> unit) -> + unit -val report_subtyping_error: - formatter -> Env.t -> (type_expr * type_expr) list -> - string -> (type_expr * type_expr) list -> unit -val report_ambiguous_type_error: - formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> - (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit +val report_subtyping_error : + formatter -> + Env.t -> + (type_expr * type_expr) list -> + string -> + (type_expr * type_expr) list -> + unit +val report_ambiguous_type_error : + formatter -> + Env.t -> + Path.t * Path.t -> + (Path.t * Path.t) list -> + (formatter -> unit) -> + (formatter -> unit) -> + (formatter -> unit) -> + unit (* for toploop *) -val print_items: (Env.t -> signature_item -> 'a option) -> - Env.t -> signature_item list -> (out_sig_item * 'a option) list +val print_items : + (Env.t -> signature_item -> 'a option) -> + Env.t -> + signature_item list -> + (out_sig_item * 'a option) list diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 5b514ac36e..63b673f3f1 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -13,72 +13,64 @@ (* *) (**************************************************************************) -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Typedtree;; +open Asttypes +open Format +open Lexing +open Location +open Typedtree let fmt_position f l = - if l.pos_lnum = -1 - then fprintf f "%s[%d]" l.pos_fname l.pos_cnum - else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol - (l.pos_cnum - l.pos_bol) -;; + if l.pos_lnum = -1 then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else + fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) let fmt_location f loc = if !Clflags.dump_location then ( - fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; - if loc.loc_ghost then fprintf f " ghost"; - ) -;; + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost") let rec fmt_longident_aux f x = match x with - | Longident.Lident (s) -> fprintf f "%s" s; - | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lident s -> fprintf f "%s" s + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; -;; + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z -let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt let fmt_ident = Ident.print let rec fmt_path_aux f x = match x with - | Path.Pident (s) -> fprintf f "%a" fmt_ident s; - | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s; - | Path.Papply (y, z) -> - fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z; -;; + | Path.Pident s -> fprintf f "%a" fmt_ident s + | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s + | Path.Papply (y, z) -> fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z -let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; +let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x let fmt_constant f x = match x with - | Const_int (i) -> fprintf f "Const_int %d" i; - | Const_char (c) -> fprintf f "Const_char %02x" c; - | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s; + | Const_int i -> fprintf f "Const_int %d" i + | Const_char c -> fprintf f "Const_char %02x" c + | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s | Const_string (s, Some delim) -> - fprintf f "Const_string (%S,Some %S)" s delim; - | Const_float (s) -> fprintf f "Const_float %s" s; - | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; - | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; - | Const_bigint (sign, i) -> fprintf f "Const_bigint %s" (Bigint_utils.to_string sign i); -;; + fprintf f "Const_string (%S,Some %S)" s delim + | Const_float s -> fprintf f "Const_float %s" s + | Const_int32 i -> fprintf f "Const_int32 %ld" i + | Const_int64 i -> fprintf f "Const_int64 %Ld" i + | Const_bigint (sign, i) -> + fprintf f "Const_bigint %s" (Bigint_utils.to_string sign i) let fmt_mutable_flag f x = match x with - | Immutable -> fprintf f "Immutable"; - | Mutable -> fprintf f "Mutable"; -;; + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" let fmt_override_flag f x = match x with - | Override -> fprintf f "Override"; - | Fresh -> fprintf f "Fresh"; -;; + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" let fmt_closed_flag f x = match x with @@ -87,63 +79,55 @@ let fmt_closed_flag f x = let fmt_rec_flag f x = match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" let fmt_direction_flag f x = match x with - | Upto -> fprintf f "Up"; - | Downto -> fprintf f "Down"; -;; + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" let fmt_private_flag f x = match x with - | Public -> fprintf f "Public"; - | Private -> fprintf f "Private"; -;; + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" let line i f s (*...*) = - fprintf f "%s" (String.make (2*i) ' '); + fprintf f "%s" (String.make (2 * i) ' '); fprintf f s (*...*) -;; let list i f ppf l = match l with - | [] -> line i ppf "[]\n"; + | [] -> line i ppf "[]\n" | _ :: _ -> - line i ppf "[\n"; - List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; + line i ppf "[\n"; + List.iter (f (i + 1) ppf) l; + line i ppf "]\n" let array i f ppf a = - if Array.length a = 0 then - line i ppf "[]\n" - else begin + if Array.length a = 0 then line i ppf "[]\n" + else ( line i ppf "[\n"; - Array.iter (f (i+1) ppf) a; - line i ppf "]\n" - end -;; + Array.iter (f (i + 1) ppf) a; + line i ppf "]\n") let option i f ppf x = match x with - | None -> line i ppf "None\n"; + | None -> line i ppf "None\n" | Some x -> - line i ppf "Some\n"; - f (i+1) ppf x; -;; + line i ppf "Some\n"; + f (i + 1) ppf x -let longident i ppf li = line i ppf "%a\n" fmt_longident li;; -let string i ppf s = line i ppf "\"%s\"\n" s;; +let longident i ppf li = line i ppf "%a\n" fmt_longident li +let string i ppf s = line i ppf "\"%s\"\n" s let arg_label i ppf = function | Nolabel -> line i ppf "Nolabel\n" | Optional s -> line i ppf "Optional \"%s\"\n" s | Labelled s -> line i ppf "Labelled \"%s\"\n" s -;; -let record_representation i ppf = let open Types in function +let record_representation i ppf = + let open Types in + function | Record_regular -> line i ppf "Record_regular\n" | Record_float_unused -> assert false | Record_optional_labels lbls -> @@ -157,55 +141,56 @@ let attributes i ppf l = List.iter (fun (s, arg) -> line i ppf "attribute \"%s\"\n" s.txt; - Printast.payload (i + 1) ppf arg; - ) + Printast.payload (i + 1) ppf arg) l let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ctyp_loc; attributes i ppf x.ctyp_attributes; - let i = i+1 in + let i = i + 1 in match x.ctyp_desc with - | Ttyp_any -> line i ppf "Ttyp_any\n"; - | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s; + | Ttyp_any -> line i ppf "Ttyp_any\n" + | Ttyp_var s -> line i ppf "Ttyp_var %s\n" s | Ttyp_arrow (l, ct1, ct2) -> - line i ppf "Ttyp_arrow\n"; - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2; + line i ppf "Ttyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2 | Ttyp_tuple l -> - line i ppf "Ttyp_tuple\n"; - list i core_type ppf l; + line i ppf "Ttyp_tuple\n"; + list i core_type ppf l | Ttyp_constr (li, _, l) -> - line i ppf "Ttyp_constr %a\n" fmt_path li; - list i core_type ppf l; + line i ppf "Ttyp_constr %a\n" fmt_path li; + list i core_type ppf l | Ttyp_variant (l, closed, low) -> - line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; - list i label_x_bool_x_core_type_list ppf l; - option i (fun i -> list i string) ppf low + line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low | Ttyp_object (l, c) -> - line i ppf "Ttyp_object %a\n" fmt_closed_flag c; - let i = i + 1 in - List.iter (function + line i ppf "Ttyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter + (function | OTtag (s, attrs, t) -> - line i ppf "method %s\n" s.txt; - attributes i ppf attrs; - core_type (i + 1) ppf t + line i ppf "method %s\n" s.txt; + attributes i ppf attrs; + core_type (i + 1) ppf t | OTinherit ct -> - line i ppf "OTinherit\n"; - core_type (i + 1) ppf ct - ) l + line i ppf "OTinherit\n"; + core_type (i + 1) ppf ct) + l | Ttyp_class () -> () | Ttyp_alias (ct, s) -> - line i ppf "Ttyp_alias \"%s\"\n" s; - core_type i ppf ct; + line i ppf "Ttyp_alias \"%s\"\n" s; + core_type i ppf ct | Ttyp_poly (sl, ct) -> - line i ppf "Ttyp_poly%a\n" - (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; - core_type i ppf ct; - | Ttyp_package { pack_path = s; pack_fields = l } -> - line i ppf "Ttyp_package %a\n" fmt_path s; - list i package_with ppf l; + line i ppf "Ttyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) + sl; + core_type i ppf ct + | Ttyp_package {pack_path = s; pack_fields = l} -> + line i ppf "Ttyp_package %a\n" fmt_path s; + list i package_with ppf l and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident s; @@ -214,238 +199,233 @@ and package_with i ppf (s, t) = and pattern i ppf x = line i ppf "pattern %a\n" fmt_location x.pat_loc; attributes i ppf x.pat_attributes; - let i = i+1 in + let i = i + 1 in match x.pat_extra with - | (Tpat_unpack, _, attrs) :: rem -> - line i ppf "Tpat_unpack\n"; - attributes i ppf attrs; - pattern i ppf { x with pat_extra = rem } - | (Tpat_constraint cty, _, attrs) :: rem -> - line i ppf "Tpat_constraint\n"; - attributes i ppf attrs; - core_type i ppf cty; - pattern i ppf { x with pat_extra = rem } - | (Tpat_type (id, _), _, attrs) :: rem -> - line i ppf "Tpat_type %a\n" fmt_path id; - attributes i ppf attrs; - pattern i ppf { x with pat_extra = rem } - | (Tpat_open (id,_,_), _, attrs)::rem -> - line i ppf "Tpat_open \"%a\"\n" fmt_path id; - attributes i ppf attrs; - pattern i ppf { x with pat_extra = rem } - | [] -> - match x.pat_desc with - | Tpat_any -> line i ppf "Tpat_any\n"; - | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; - | Tpat_alias (p, s,_) -> + | (Tpat_unpack, _, attrs) :: rem -> + line i ppf "Tpat_unpack\n"; + attributes i ppf attrs; + pattern i ppf {x with pat_extra = rem} + | (Tpat_constraint cty, _, attrs) :: rem -> + line i ppf "Tpat_constraint\n"; + attributes i ppf attrs; + core_type i ppf cty; + pattern i ppf {x with pat_extra = rem} + | (Tpat_type (id, _), _, attrs) :: rem -> + line i ppf "Tpat_type %a\n" fmt_path id; + attributes i ppf attrs; + pattern i ppf {x with pat_extra = rem} + | (Tpat_open (id, _, _), _, attrs) :: rem -> + line i ppf "Tpat_open \"%a\"\n" fmt_path id; + attributes i ppf attrs; + pattern i ppf {x with pat_extra = rem} + | [] -> ( + match x.pat_desc with + | Tpat_any -> line i ppf "Tpat_any\n" + | Tpat_var (s, _) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s + | Tpat_alias (p, s, _) -> line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; - pattern i ppf p; - | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; - | Tpat_tuple (l) -> + pattern i ppf p + | Tpat_constant c -> line i ppf "Tpat_constant %a\n" fmt_constant c + | Tpat_tuple l -> line i ppf "Tpat_tuple\n"; - list i pattern ppf l; - | Tpat_construct (li, _, po) -> + list i pattern ppf l + | Tpat_construct (li, _, po) -> line i ppf "Tpat_construct %a\n" fmt_longident li; - list i pattern ppf po; - | Tpat_variant (l, po, _) -> + list i pattern ppf po + | Tpat_variant (l, po, _) -> line i ppf "Tpat_variant \"%s\"\n" l; - option i pattern ppf po; - | Tpat_record (l, _c) -> + option i pattern ppf po + | Tpat_record (l, _c) -> line i ppf "Tpat_record\n"; - list i longident_x_pattern ppf l; - | Tpat_array (l) -> + list i longident_x_pattern ppf l + | Tpat_array l -> line i ppf "Tpat_array\n"; - list i pattern ppf l; - | Tpat_or (p1, p2, _) -> + list i pattern ppf l + | Tpat_or (p1, p2, _) -> line i ppf "Tpat_or\n"; pattern i ppf p1; - pattern i ppf p2; - | Tpat_lazy p -> + pattern i ppf p2 + | Tpat_lazy p -> line i ppf "Tpat_lazy\n"; - pattern i ppf p; + pattern i ppf p) and expression_extra i ppf x attrs = match x with | Texp_constraint ct -> - line i ppf "Texp_constraint\n"; - attributes i ppf attrs; - core_type i ppf ct; + line i ppf "Texp_constraint\n"; + attributes i ppf attrs; + core_type i ppf ct | Texp_coerce ((), cto2) -> - line i ppf "Texp_coerce\n"; - attributes i ppf attrs; - core_type i ppf cto2; + line i ppf "Texp_coerce\n"; + attributes i ppf attrs; + core_type i ppf cto2 | Texp_open (ovf, m, _, _) -> - line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; - attributes i ppf attrs; + line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + attributes i ppf attrs | Texp_poly cto -> - line i ppf "Texp_poly\n"; - attributes i ppf attrs; - option i core_type ppf cto; + line i ppf "Texp_poly\n"; + attributes i ppf attrs; + option i core_type ppf cto | Texp_newtype s -> - line i ppf "Texp_newtype \"%s\"\n" s; - attributes i ppf attrs; + line i ppf "Texp_newtype \"%s\"\n" s; + attributes i ppf attrs and expression i ppf x = line i ppf "expression %a\n" fmt_location x.exp_loc; attributes i ppf x.exp_attributes; let i = - List.fold_left (fun i (extra,_,attrs) -> - expression_extra i ppf extra attrs; i+1) - (i+1) x.exp_extra + List.fold_left + (fun i (extra, _, attrs) -> + expression_extra i ppf extra attrs; + i + 1) + (i + 1) x.exp_extra in match x.exp_desc with - | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; + | Texp_ident (li, _, _) -> line i ppf "Texp_ident %a\n" fmt_path li | Texp_instvar () -> assert false - | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c; + | Texp_constant c -> line i ppf "Texp_constant %a\n" fmt_constant c | Texp_let (rf, l, e) -> - line i ppf "Texp_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - expression i ppf e; - | Texp_function { arg_label = p; param ; cases; partial = _; } -> - line i ppf "Texp_function\n"; - line i ppf "%a" Ident.print param; - arg_label i ppf p; - list i case ppf cases; + line i ppf "Texp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e + | Texp_function {arg_label = p; param; cases; partial = _} -> + line i ppf "Texp_function\n"; + line i ppf "%a" Ident.print param; + arg_label i ppf p; + list i case ppf cases | Texp_apply (e, l) -> - line i ppf "Texp_apply\n"; - expression i ppf e; - list i label_x_expression ppf l; + line i ppf "Texp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l | Texp_match (e, l1, l2, _partial) -> - line i ppf "Texp_match\n"; - expression i ppf e; - list i case ppf l1; - list i case ppf l2; + line i ppf "Texp_match\n"; + expression i ppf e; + list i case ppf l1; + list i case ppf l2 | Texp_try (e, l) -> - line i ppf "Texp_try\n"; - expression i ppf e; - list i case ppf l; - | Texp_tuple (l) -> - line i ppf "Texp_tuple\n"; - list i expression ppf l; + line i ppf "Texp_try\n"; + expression i ppf e; + list i case ppf l + | Texp_tuple l -> + line i ppf "Texp_tuple\n"; + list i expression ppf l | Texp_construct (li, _, eo) -> - line i ppf "Texp_construct %a\n" fmt_longident li; - list i expression ppf eo; + line i ppf "Texp_construct %a\n" fmt_longident li; + list i expression ppf eo | Texp_variant (l, eo) -> - line i ppf "Texp_variant \"%s\"\n" l; - option i expression ppf eo; - | Texp_record { fields; representation; extended_expression } -> - line i ppf "Texp_record\n"; - let i = i+1 in - line i ppf "fields =\n"; - array (i+1) record_field ppf fields; - line i ppf "representation =\n"; - record_representation (i+1) ppf representation; - line i ppf "extended_expression =\n"; - option (i+1) expression ppf extended_expression; + line i ppf "Texp_variant \"%s\"\n" l; + option i expression ppf eo + | Texp_record {fields; representation; extended_expression} -> + line i ppf "Texp_record\n"; + let i = i + 1 in + line i ppf "fields =\n"; + array (i + 1) record_field ppf fields; + line i ppf "representation =\n"; + record_representation (i + 1) ppf representation; + line i ppf "extended_expression =\n"; + option (i + 1) expression ppf extended_expression | Texp_field (e, li, _) -> - line i ppf "Texp_field\n"; - expression i ppf e; - longident i ppf li; + line i ppf "Texp_field\n"; + expression i ppf e; + longident i ppf li | Texp_setfield (e1, li, _, e2) -> - line i ppf "Texp_setfield\n"; - expression i ppf e1; - longident i ppf li; - expression i ppf e2; - | Texp_array (l) -> - line i ppf "Texp_array\n"; - list i expression ppf l; + line i ppf "Texp_setfield\n"; + expression i ppf e1; + longident i ppf li; + expression i ppf e2 + | Texp_array l -> + line i ppf "Texp_array\n"; + list i expression ppf l | Texp_ifthenelse (e1, e2, eo) -> - line i ppf "Texp_ifthenelse\n"; - expression i ppf e1; - expression i ppf e2; - option i expression ppf eo; + line i ppf "Texp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo | Texp_sequence (e1, e2) -> - line i ppf "Texp_sequence\n"; - expression i ppf e1; - expression i ppf e2; + line i ppf "Texp_sequence\n"; + expression i ppf e1; + expression i ppf e2 | Texp_while (e1, e2) -> - line i ppf "Texp_while\n"; - expression i ppf e1; - expression i ppf e2; + line i ppf "Texp_while\n"; + expression i ppf e1; + expression i ppf e2 | Texp_for (s, _, e1, e2, df, e3) -> - line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; - expression i ppf e1; - expression i ppf e2; - expression i ppf e3; + line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3 | Texp_send (e, Tmeth_name s, eo) -> - line i ppf "Texp_send \"%s\"\n" s; - expression i ppf e; - option i expression ppf eo - | Texp_new _ - | Texp_setinstvar _ - | Texp_override _ -> - () + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e; + option i expression ppf eo + | Texp_new _ | Texp_setinstvar _ | Texp_override _ -> () | Texp_letmodule (s, _, me, e) -> - line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; - module_expr i ppf me; - expression i ppf e; + line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; + module_expr i ppf me; + expression i ppf e | Texp_letexception (cd, e) -> - line i ppf "Texp_letexception\n"; - extension_constructor i ppf cd; - expression i ppf e; - | Texp_assert (e) -> - line i ppf "Texp_assert"; - expression i ppf e; - | Texp_lazy (e) -> - line i ppf "Texp_lazy"; - expression i ppf e; - | Texp_object () -> - () + line i ppf "Texp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e + | Texp_assert e -> + line i ppf "Texp_assert"; + expression i ppf e + | Texp_lazy e -> + line i ppf "Texp_lazy"; + expression i ppf e + | Texp_object () -> () | Texp_pack me -> - line i ppf "Texp_pack"; - module_expr i ppf me - | Texp_unreachable -> - line i ppf "Texp_unreachable" + line i ppf "Texp_pack"; + module_expr i ppf me + | Texp_unreachable -> line i ppf "Texp_unreachable" | Texp_extension_constructor (li, _) -> - line i ppf "Texp_extension_constructor %a" fmt_longident li + line i ppf "Texp_extension_constructor %a" fmt_longident li and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location - x.val_loc; + x.val_loc; attributes i ppf x.val_attributes; - core_type (i+1) ppf x.val_desc; - list (i+1) string ppf x.val_prim; + core_type (i + 1) ppf x.val_desc; + list (i + 1) string ppf x.val_prim and type_parameter i ppf (x, _variance) = core_type i ppf x and type_declaration i ppf x = line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location - x.typ_loc; + x.typ_loc; attributes i ppf x.typ_attributes; - let i = i+1 in + let i = i + 1 in line i ppf "ptype_params =\n"; - list (i+1) type_parameter ppf x.typ_params; + list (i + 1) type_parameter ppf x.typ_params; line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; + list (i + 1) core_type_x_core_type_x_location ppf x.typ_cstrs; line i ppf "ptype_kind =\n"; - type_kind (i+1) ppf x.typ_kind; + type_kind (i + 1) ppf x.typ_kind; line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; line i ppf "ptype_manifest =\n"; - option (i+1) core_type ppf x.typ_manifest; + option (i + 1) core_type ppf x.typ_manifest and type_kind i ppf x = match x with - | Ttype_abstract -> - line i ppf "Ttype_abstract\n" + | Ttype_abstract -> line i ppf "Ttype_abstract\n" | Ttype_variant l -> - line i ppf "Ttype_variant\n"; - list (i+1) constructor_decl ppf l; + line i ppf "Ttype_variant\n"; + list (i + 1) constructor_decl ppf l | Ttype_record l -> - line i ppf "Ttype_record\n"; - list (i+1) label_decl ppf l; - | Ttype_open -> - line i ppf "Ttype_open\n" + line i ppf "Ttype_record\n"; + list (i + 1) label_decl ppf l + | Ttype_open -> line i ppf "Ttype_open\n" and type_extension i ppf x = line i ppf "type_extension\n"; attributes i ppf x.tyext_attributes; - let i = i+1 in + let i = i + 1 in line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path; line i ppf "ptyext_params =\n"; - list (i+1) type_parameter ppf x.tyext_params; + list (i + 1) type_parameter ppf x.tyext_params; line i ppf "ptyext_constructors =\n"; - list (i+1) extension_constructor ppf x.tyext_constructors; - line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private; + list (i + 1) extension_constructor ppf x.tyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private and extension_constructor i ppf x = line i ppf "extension_constructor %a\n" fmt_location x.ext_loc; @@ -453,95 +433,92 @@ and extension_constructor i ppf x = let i = i + 1 in line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id; line i ppf "pext_kind =\n"; - extension_constructor_kind (i + 1) ppf x.ext_kind; + extension_constructor_kind (i + 1) ppf x.ext_kind and extension_constructor_kind i ppf x = match x with - Text_decl(a, r) -> - line i ppf "Text_decl\n"; - constructor_arguments (i+1) ppf a; - option (i+1) core_type ppf r; - | Text_rebind(p, _) -> - line i ppf "Text_rebind\n"; - line (i+1) ppf "%a\n" fmt_path p; + | Text_decl (a, r) -> + line i ppf "Text_decl\n"; + constructor_arguments (i + 1) ppf a; + option (i + 1) core_type ppf r + | Text_rebind (p, _) -> + line i ppf "Text_rebind\n"; + line (i + 1) ppf "%a\n" fmt_path p and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.mty_loc; attributes i ppf x.mty_attributes; - let i = i+1 in + let i = i + 1 in match x.mty_desc with - | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li; - | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li; - | Tmty_signature (s) -> - line i ppf "Tmty_signature\n"; - signature i ppf s; + | Tmty_ident (li, _) -> line i ppf "Tmty_ident %a\n" fmt_path li + | Tmty_alias (li, _) -> line i ppf "Tmty_alias %a\n" fmt_path li + | Tmty_signature s -> + line i ppf "Tmty_signature\n"; + signature i ppf s | Tmty_functor (s, _, mt1, mt2) -> - line i ppf "Tmty_functor \"%a\"\n" fmt_ident s; - Misc.may (module_type i ppf) mt1; - module_type i ppf mt2; + line i ppf "Tmty_functor \"%a\"\n" fmt_ident s; + Misc.may (module_type i ppf) mt1; + module_type i ppf mt2 | Tmty_with (mt, l) -> - line i ppf "Tmty_with\n"; - module_type i ppf mt; - list i longident_x_with_constraint ppf l; + line i ppf "Tmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l | Tmty_typeof m -> - line i ppf "Tmty_typeof\n"; - module_expr i ppf m; + line i ppf "Tmty_typeof\n"; + module_expr i ppf m and signature i ppf x = list i signature_item ppf x.sig_items and signature_item i ppf x = line i ppf "signature_item %a\n" fmt_location x.sig_loc; - let i = i+1 in + let i = i + 1 in match x.sig_desc with | Tsig_value vd -> - line i ppf "Tsig_value\n"; - value_description i ppf vd; + line i ppf "Tsig_value\n"; + value_description i ppf vd | Tsig_type (rf, l) -> - line i ppf "Tsig_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; + line i ppf "Tsig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l | Tsig_typext e -> - line i ppf "Tsig_typext\n"; - type_extension i ppf e; + line i ppf "Tsig_typext\n"; + type_extension i ppf e | Tsig_exception ext -> - line i ppf "Tsig_exception\n"; - extension_constructor i ppf ext + line i ppf "Tsig_exception\n"; + extension_constructor i ppf ext | Tsig_module md -> - line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id; - attributes i ppf md.md_attributes; - module_type i ppf md.md_type + line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id; + attributes i ppf md.md_attributes; + module_type i ppf md.md_type | Tsig_recmodule decls -> - line i ppf "Tsig_recmodule\n"; - list i module_declaration ppf decls; + line i ppf "Tsig_recmodule\n"; + list i module_declaration ppf decls | Tsig_modtype x -> - line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; - attributes i ppf x.mtd_attributes; - modtype_declaration i ppf x.mtd_type + line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type | Tsig_open od -> - line i ppf "Tsig_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; - attributes i ppf od.open_attributes + line i ppf "Tsig_open %a %a\n" fmt_override_flag od.open_override fmt_path + od.open_path; + attributes i ppf od.open_attributes | Tsig_include incl -> - line i ppf "Tsig_include\n"; - attributes i ppf incl.incl_attributes; - module_type i ppf incl.incl_mod - | Tsig_class () -> - () - | Tsig_class_type () -> - () + line i ppf "Tsig_include\n"; + attributes i ppf incl.incl_attributes; + module_type i ppf incl.incl_mod + | Tsig_class () -> () + | Tsig_class_type () -> () | Tsig_attribute (s, arg) -> - line i ppf "Tsig_attribute \"%s\"\n" s.txt; - Printast.payload i ppf arg + line i ppf "Tsig_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg and module_declaration i ppf md = line i ppf "%a" fmt_ident md.md_id; attributes i ppf md.md_attributes; - module_type (i+1) ppf md.md_type; + module_type (i + 1) ppf md.md_type and module_binding i ppf x = line i ppf "%a\n" fmt_ident x.mb_id; attributes i ppf x.mb_attributes; - module_expr (i+1) ppf x.mb_expr + module_expr (i + 1) ppf x.mb_expr and modtype_declaration i ppf = function | None -> line i ppf "#abstract" @@ -549,165 +526,164 @@ and modtype_declaration i ppf = function and with_constraint i ppf x = match x with - | Twith_type (td) -> - line i ppf "Twith_type\n"; - type_declaration (i+1) ppf td; - | Twith_typesubst (td) -> - line i ppf "Twith_typesubst\n"; - type_declaration (i+1) ppf td; - | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; - | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; + | Twith_type td -> + line i ppf "Twith_type\n"; + type_declaration (i + 1) ppf td + | Twith_typesubst td -> + line i ppf "Twith_typesubst\n"; + type_declaration (i + 1) ppf td + | Twith_module (li, _) -> line i ppf "Twith_module %a\n" fmt_path li + | Twith_modsubst (li, _) -> line i ppf "Twith_modsubst %a\n" fmt_path li and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.mod_loc; attributes i ppf x.mod_attributes; - let i = i+1 in + let i = i + 1 in match x.mod_desc with - | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li; - | Tmod_structure (s) -> - line i ppf "Tmod_structure\n"; - structure i ppf s; + | Tmod_ident (li, _) -> line i ppf "Tmod_ident %a\n" fmt_path li + | Tmod_structure s -> + line i ppf "Tmod_structure\n"; + structure i ppf s | Tmod_functor (s, _, mt, me) -> - line i ppf "Tmod_functor \"%a\"\n" fmt_ident s; - Misc.may (module_type i ppf) mt; - module_expr i ppf me; + line i ppf "Tmod_functor \"%a\"\n" fmt_ident s; + Misc.may (module_type i ppf) mt; + module_expr i ppf me | Tmod_apply (me1, me2, _) -> - line i ppf "Tmod_apply\n"; - module_expr i ppf me1; - module_expr i ppf me2; + line i ppf "Tmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2 | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> - line i ppf "Tmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; + line i ppf "Tmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me | Tmod_unpack (e, _) -> - line i ppf "Tmod_unpack\n"; - expression i ppf e; + line i ppf "Tmod_unpack\n"; + expression i ppf e and structure i ppf x = list i structure_item ppf x.str_items and structure_item i ppf x = line i ppf "structure_item %a\n" fmt_location x.str_loc; - let i = i+1 in + let i = i + 1 in match x.str_desc with | Tstr_eval (e, attrs) -> - line i ppf "Tstr_eval\n"; - attributes i ppf attrs; - expression i ppf e; + line i ppf "Tstr_eval\n"; + attributes i ppf attrs; + expression i ppf e | Tstr_value (rf, l) -> - line i ppf "Tstr_value %a\n" fmt_rec_flag rf; - list i value_binding ppf l; + line i ppf "Tstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l | Tstr_primitive vd -> - line i ppf "Tstr_primitive\n"; - value_description i ppf vd; + line i ppf "Tstr_primitive\n"; + value_description i ppf vd | Tstr_type (rf, l) -> - line i ppf "Tstr_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; + line i ppf "Tstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l | Tstr_typext te -> - line i ppf "Tstr_typext\n"; - type_extension i ppf te + line i ppf "Tstr_typext\n"; + type_extension i ppf te | Tstr_exception ext -> - line i ppf "Tstr_exception\n"; - extension_constructor i ppf ext; + line i ppf "Tstr_exception\n"; + extension_constructor i ppf ext | Tstr_module x -> - line i ppf "Tstr_module\n"; - module_binding i ppf x + line i ppf "Tstr_module\n"; + module_binding i ppf x | Tstr_recmodule bindings -> - line i ppf "Tstr_recmodule\n"; - list i module_binding ppf bindings + line i ppf "Tstr_recmodule\n"; + list i module_binding ppf bindings | Tstr_modtype x -> - line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; - attributes i ppf x.mtd_attributes; - modtype_declaration i ppf x.mtd_type + line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type | Tstr_open od -> - line i ppf "Tstr_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; - attributes i ppf od.open_attributes + line i ppf "Tstr_open %a %a\n" fmt_override_flag od.open_override fmt_path + od.open_path; + attributes i ppf od.open_attributes | Tstr_class () -> () | Tstr_class_type () -> () | Tstr_include incl -> - line i ppf "Tstr_include"; - attributes i ppf incl.incl_attributes; - module_expr i ppf incl.incl_mod; + line i ppf "Tstr_include"; + attributes i ppf incl.incl_attributes; + module_expr i ppf incl.incl_mod | Tstr_attribute (s, arg) -> - line i ppf "Tstr_attribute \"%s\"\n" s.txt; - Printast.payload i ppf arg + line i ppf "Tstr_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg and longident_x_with_constraint i ppf (li, _, wc) = line i ppf "%a\n" fmt_path li; - with_constraint (i+1) ppf wc; + with_constraint (i + 1) ppf wc and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = line i ppf " %a\n" fmt_location l; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 -and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; - cd_attributes} = +and constructor_decl i ppf + {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attributes} = line i ppf "%a\n" fmt_location cd_loc; - line (i+1) ppf "%a\n" fmt_ident cd_id; + line (i + 1) ppf "%a\n" fmt_ident cd_id; attributes i ppf cd_attributes; - constructor_arguments (i+1) ppf cd_args; - option (i+1) core_type ppf cd_res + constructor_arguments (i + 1) ppf cd_args; + option (i + 1) core_type ppf cd_res and constructor_arguments i ppf = function | Cstr_tuple l -> list i core_type ppf l | Cstr_record l -> list i label_decl ppf l -and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; - ld_attributes} = +and label_decl i ppf + {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} = line i ppf "%a\n" fmt_location ld_loc; attributes i ppf ld_attributes; - line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable; - line (i+1) ppf "%a" fmt_ident ld_id; - core_type (i+1) ppf ld_type + line (i + 1) ppf "%a\n" fmt_mutable_flag ld_mutable; + line (i + 1) ppf "%a" fmt_ident ld_id; + core_type (i + 1) ppf ld_type and longident_x_pattern i ppf (li, _, p) = line i ppf "%a\n" fmt_longident li; - pattern (i+1) ppf p; + pattern (i + 1) ppf p and case i ppf {c_lhs; c_guard; c_rhs} = line i ppf "\n"; - pattern (i+1) ppf c_lhs; - begin match c_guard with + pattern (i + 1) ppf c_lhs; + (match c_guard with | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf c_rhs; + | Some g -> + line (i + 1) ppf "\n"; + expression (i + 2) ppf g); + expression (i + 1) ppf c_rhs and value_binding i ppf x = line i ppf "\n"; - attributes (i+1) ppf x.vb_attributes; - pattern (i+1) ppf x.vb_pat; - expression (i+1) ppf x.vb_expr - + attributes (i + 1) ppf x.vb_attributes; + pattern (i + 1) ppf x.vb_pat; + expression (i + 1) ppf x.vb_expr and record_field i ppf = function | _, Overridden (li, e) -> - line i ppf "%a\n" fmt_longident li; - expression (i+1) ppf e; - | _, Kept _ -> - line i ppf "" + line i ppf "%a\n" fmt_longident li; + expression (i + 1) ppf e + | _, Kept _ -> line i ppf "" and label_x_expression i ppf (l, e) = line i ppf "\n"; - arg_label (i+1) ppf l; - (match e with None -> () | Some e -> expression (i+1) ppf e) + arg_label (i + 1) ppf l; + match e with + | None -> () + | Some e -> expression (i + 1) ppf e and label_x_bool_x_core_type_list i ppf x = match x with - Ttag (l, attrs, b, ctl) -> - line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b); - attributes (i+1) ppf attrs; - list (i+1) core_type ppf ctl - | Tinherit (ct) -> - line i ppf "Tinherit\n"; - core_type (i+1) ppf ct -;; - -let interface ppf x = list 0 signature_item ppf x.sig_items;; - -let implementation ppf x = list 0 structure_item ppf x.str_items;; + | Ttag (l, attrs, b, ctl) -> + line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i + 1) ppf attrs; + list (i + 1) core_type ppf ctl + | Tinherit ct -> + line i ppf "Tinherit\n"; + core_type (i + 1) ppf ct + +let interface ppf x = list 0 signature_item ppf x.sig_items + +let implementation ppf x = list 0 structure_item ppf x.str_items let implementation_with_coercion ppf (x, _) = implementation ppf x diff --git a/compiler/ml/printtyped.mli b/compiler/ml/printtyped.mli index ded42bb325..11837f15e3 100644 --- a/compiler/ml/printtyped.mli +++ b/compiler/ml/printtyped.mli @@ -13,11 +13,11 @@ (* *) (**************************************************************************) -open Typedtree;; -open Format;; +open Typedtree +open Format -val interface : formatter -> signature -> unit;; -val implementation : formatter -> structure -> unit;; +val interface : formatter -> signature -> unit +val implementation : formatter -> structure -> unit val implementation_with_coercion : - formatter -> (structure * module_coercion) -> unit;; + formatter -> structure * module_coercion -> unit diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index bb2f981b3e..061b9ed984 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -120,7 +120,9 @@ module Rec_context = struct !r let unguarded = - list_matching (function Unguarded | Dereferenced -> true | _ -> false) + list_matching (function + | Unguarded | Dereferenced -> true + | _ -> false) let dependent = list_matching (function _ -> true) end @@ -147,7 +149,7 @@ let rec pattern_variables : Typedtree.pattern -> Ident.t list = fun pat -> match pat.pat_desc with | Tpat_any -> [] - | Tpat_var (id, _) -> [ id ] + | Tpat_var (id, _) -> [id] | Tpat_alias (pat, id, _) -> id :: pattern_variables pat | Tpat_constant _ -> [] | Tpat_tuple pats -> List.concat (List.map pattern_variables pats) @@ -155,7 +157,7 @@ let rec pattern_variables : Typedtree.pattern -> Ident.t list = | Tpat_variant (_, Some pat, _) -> pattern_variables pat | Tpat_variant (_, None, _) -> [] | Tpat_record (fields, _) -> - List.concat (List.map (fun (_, _, p) -> pattern_variables p) fields) + List.concat (List.map (fun (_, _, p) -> pattern_variables p) fields) | Tpat_array pats -> List.concat (List.map pattern_variables pats) | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r | Tpat_lazy p -> pattern_variables p @@ -173,9 +175,9 @@ let build_unguarded_env : Ident.t list -> Env.env = let is_ref : Types.value_description -> bool = function | { Types.val_kind = - Types.Val_prim { Primitive.prim_name = "%makeref"; prim_arity = 1 }; + Types.Val_prim {Primitive.prim_name = "%makeref"; prim_arity = 1}; } -> - true + true | _ -> false type sd = Static | Dynamic @@ -192,98 +194,96 @@ let rec classify_expression : Typedtree.expression -> sd = | Texp_letmodule (_, _, _, e) | Texp_sequence (_, e) | Texp_letexception (_, e) -> - classify_expression e + classify_expression e | Texp_ident _ | Texp_for _ | Texp_constant _ | Texp_new _ | Texp_instvar _ | Texp_tuple _ | Texp_array _ | Texp_construct _ | Texp_variant _ | Texp_record _ | Texp_setfield _ | Texp_while _ | Texp_setinstvar _ | Texp_pack _ | Texp_object _ | Texp_function _ | Texp_lazy _ | Texp_unreachable | Texp_extension_constructor _ -> - Static - | Texp_apply ({ exp_desc = Texp_ident (_, _, vd) }, _) when is_ref vd -> - Static + Static + | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _) when is_ref vd -> Static | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ | Texp_field _ | Texp_assert _ | Texp_try _ | Texp_override _ -> - Dynamic + Dynamic let rec expression : Env.env -> Typedtree.expression -> Use.t = fun env exp -> match exp.exp_desc with | Texp_ident (pth, _, _) -> path env pth | Texp_let (rec_flag, bindings, body) -> - let env', ty = value_bindings rec_flag env bindings in - (* Here and in other binding constructs 'discard' is used in a - similar way to the way it's used in sequence: uses are - propagated, but unguarded access are not. *) - Use.join (Use.discard ty) (expression (Env.join env env') body) + let env', ty = value_bindings rec_flag env bindings in + (* Here and in other binding constructs 'discard' is used in a + similar way to the way it's used in sequence: uses are + propagated, but unguarded access are not. *) + Use.join (Use.discard ty) (expression (Env.join env env') body) | Texp_letmodule (x, _, m, e) -> - let ty = modexp env m in - Use.join (Use.discard ty) (expression (Ident.add x ty env) e) + let ty = modexp env m in + Use.join (Use.discard ty) (expression (Ident.add x ty env) e) | Texp_match (e, val_cases, exn_cases, _) -> - let t = expression env e in - let exn_case env { Typedtree.c_rhs } = expression env c_rhs in - let cs = list (case ~scrutinee:t) env val_cases - and es = list exn_case env exn_cases in - Use.(join cs es) + let t = expression env e in + let exn_case env {Typedtree.c_rhs} = expression env c_rhs in + let cs = list (case ~scrutinee:t) env val_cases + and es = list exn_case env exn_cases in + Use.(join cs es) | Texp_for (_, _, e1, e2, _, e3) -> - Use.( - join - (join (inspect (expression env e1)) (inspect (expression env e2))) - (* The body is evaluated, but not used, and not available - for inclusion in another value *) - (discard (expression env e3))) + Use.( + join + (join (inspect (expression env e1)) (inspect (expression env e2))) + (* The body is evaluated, but not used, and not available + for inclusion in another value *) + (discard (expression env e3))) | Texp_constant _ -> Use.empty | Texp_new _ -> assert false | Texp_instvar _ -> Use.empty - | Texp_apply ({ exp_desc = Texp_ident (_, _, vd) }, [ (_, Some arg) ]) + | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [(_, Some arg)]) when is_ref vd -> - Use.guard (expression env arg) + Use.guard (expression env arg) | Texp_apply (e, args) -> - let arg env (_, eo) = option expression env eo in - Use.(join (inspect (expression env e)) (inspect (list arg env args))) + let arg env (_, eo) = option expression env eo in + Use.(join (inspect (expression env e)) (inspect (list arg env args))) | Texp_tuple exprs -> Use.guard (list expression env exprs) | Texp_array exprs -> Use.guard (list expression env exprs) | Texp_construct (_, desc, exprs) -> - let access_constructor = - match desc.cstr_tag with - | Cstr_extension (pth) -> Use.inspect (path env pth) - | _ -> Use.empty - in - let use = - match desc.cstr_tag with - | Cstr_unboxed -> fun x -> x - | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard - in - Use.join access_constructor (use (list expression env exprs)) + let access_constructor = + match desc.cstr_tag with + | Cstr_extension pth -> Use.inspect (path env pth) + | _ -> Use.empty + in + let use = + match desc.cstr_tag with + | Cstr_unboxed -> fun x -> x + | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard + in + Use.join access_constructor (use (list expression env exprs)) | Texp_variant (_, eo) -> Use.guard (option expression env eo) - | Texp_record { fields = es; extended_expression = eo; representation = rep } - -> - let use = - match rep with - | Record_unboxed _ -> fun x -> x - | Record_float_unused -> assert false - | Record_optional_labels _ | Record_regular | Record_inlined _ | Record_extension - -> - Use.guard - in - let field env = function - | _, Kept _ -> Use.empty - | _, Overridden (_, e) -> expression env e - in - Use.join (use (array field env es)) (option expression env eo) + | Texp_record {fields = es; extended_expression = eo; representation = rep} -> + let use = + match rep with + | Record_unboxed _ -> fun x -> x + | Record_float_unused -> assert false + | Record_optional_labels _ | Record_regular | Record_inlined _ + | Record_extension -> + Use.guard + in + let field env = function + | _, Kept _ -> Use.empty + | _, Overridden (_, e) -> expression env e + in + Use.join (use (array field env es)) (option expression env eo) | Texp_ifthenelse (cond, ifso, ifnot) -> - Use.( - join - (inspect (expression env cond)) - (join (expression env ifso) (option expression env ifnot))) + Use.( + join + (inspect (expression env cond)) + (join (expression env ifso) (option expression env ifnot))) | Texp_setfield (e1, _, _, e2) -> - Use.(join (inspect (expression env e1)) (inspect (expression env e2))) + Use.(join (inspect (expression env e1)) (inspect (expression env e2))) | Texp_sequence (e1, e2) -> - Use.(join (discard (expression env e1)) (expression env e2)) + Use.(join (discard (expression env e1)) (expression env e2)) | Texp_while (e1, e2) -> - Use.(join (inspect (expression env e1)) (discard (expression env e2))) + Use.(join (inspect (expression env e1)) (discard (expression env e2))) | Texp_send (e1, _, eo) -> - Use.( - join (inspect (expression env e1)) (inspect (option expression env eo))) + Use.( + join (inspect (expression env e1)) (inspect (option expression env eo))) | Texp_field (e, _, _) -> Use.(inspect (expression env e)) | Texp_setinstvar () -> assert false | Texp_letexception (_, e) -> expression env e @@ -291,16 +291,16 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Texp_pack m -> modexp env m | Texp_object () -> assert false | Texp_try (e, cases) -> - (* This is more permissive than the old check. *) - let case env { Typedtree.c_rhs } = expression env c_rhs in - Use.join (expression env e) (list case env cases) + (* This is more permissive than the old check. *) + let case env {Typedtree.c_rhs} = expression env c_rhs in + Use.join (expression env e) (list case env cases) | Texp_override () -> assert false - | Texp_function { cases } -> - Use.delay (list (case ~scrutinee:Use.empty) env cases) + | Texp_function {cases} -> + Use.delay (list (case ~scrutinee:Use.empty) env cases) | Texp_lazy e -> ( - match Typeopt.classify_lazy_argument e with - | `Constant_or_function | `Identifier _ | `Float -> expression env e - | `Other -> Use.delay (expression env e)) + match Typeopt.classify_lazy_argument e with + | `Constant_or_function | `Identifier _ | `Float -> expression env e + | `Other -> Use.delay (expression env e)) | Texp_unreachable -> Use.empty | Texp_extension_constructor _ -> Use.empty @@ -322,7 +322,7 @@ and modexp : Env.env -> Typedtree.module_expr -> Use.t = | Tmod_structure s -> structure env s | Tmod_functor (_, _, _, e) -> Use.delay (modexp env e) | Tmod_apply (f, p, _) -> - Use.(join (inspect (modexp env f)) (inspect (modexp env p))) + Use.(join (inspect (modexp env f)) (inspect (modexp env p))) | Tmod_constraint (m, _, _, Tcoerce_none) -> modexp env m | Tmod_constraint (m, _, _, _) -> Use.inspect (modexp env m) | Tmod_unpack (e, _) -> expression env e @@ -350,13 +350,13 @@ and structure_item : Env.env -> Typedtree.structure_item -> Env.env * Use.t = match s.str_desc with | Tstr_eval (e, _) -> (Env.empty, expression env e) | Tstr_value (rec_flag, valbinds) -> value_bindings rec_flag env valbinds - | Tstr_module { mb_id; mb_expr } -> - let ty = modexp env mb_expr in - (Ident.add mb_id ty Env.empty, ty) + | Tstr_module {mb_id; mb_expr} -> + let ty = modexp env mb_expr in + (Ident.add mb_id ty Env.empty, ty) | Tstr_recmodule mbs -> - let modbind env { mb_expr } = modexp env mb_expr in - (* Over-approximate: treat any access as a use *) - (Env.empty, Use.inspect (list modbind env mbs)) + let modbind env {mb_expr} = modexp env mb_expr in + (* Over-approximate: treat any access as a use *) + (Env.empty, Use.inspect (list modbind env mbs)) | Tstr_primitive _ -> (Env.empty, Use.empty) | Tstr_type _ -> (Env.empty, Use.empty) | Tstr_typext _ -> (Env.empty, Use.empty) @@ -366,14 +366,14 @@ and structure_item : Env.env -> Typedtree.structure_item -> Env.env * Use.t = | Tstr_class () -> (Env.empty, Use.empty) | Tstr_class_type _ -> (Env.empty, Use.empty) | Tstr_include inc -> - (* This is a kind of projection. There's no need to add - anything to the environment because everything is used in - the type component already *) - (Env.empty, Use.inspect (modexp env inc.incl_mod)) + (* This is a kind of projection. There's no need to add + anything to the environment because everything is used in + the type component already *) + (Env.empty, Use.inspect (modexp env inc.incl_mod)) | Tstr_attribute _ -> (Env.empty, Use.empty) and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = - fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty -> + fun env {Typedtree.c_lhs; c_guard; c_rhs} ~scrutinee:ty -> let ty = if is_destructuring_pattern c_lhs then Use.inspect ty else Use.discard ty (* as in 'let' *) @@ -389,38 +389,38 @@ and value_bindings : fun rec_flag env bindings -> match rec_flag with | Recursive -> - (* Approximation: - let rec y = - let rec x1 = e1 - and x2 = e2 - in e - treated as - let rec y = - let rec x = (e1, e2)[x1:=fst x, x2:=snd x] in - e[x1:=fst x, x2:=snd x] - Further, use the fact that x1,x2 cannot occur unguarded in e1, e2 - to avoid recursive trickiness. - *) - let ids, ty = - List.fold_left - (fun (pats, tys) { vb_pat = p; vb_expr = e } -> - (pattern_variables p @ pats, Use.join (expression env e) tys)) - ([], Use.empty) bindings - in - ( List.fold_left - (fun (env : Env.env) (id : Ident.t) -> Ident.add id ty env) - Env.empty ids, - ty ) - | Nonrecursive -> + (* Approximation: + let rec y = + let rec x1 = e1 + and x2 = e2 + in e + treated as + let rec y = + let rec x = (e1, e2)[x1:=fst x, x2:=snd x] in + e[x1:=fst x, x2:=snd x] + Further, use the fact that x1,x2 cannot occur unguarded in e1, e2 + to avoid recursive trickiness. + *) + let ids, ty = List.fold_left - (fun (env2, ty) binding -> - let env', ty' = value_binding env binding in - (Env.join env2 env', Use.join ty ty')) - (Env.empty, Use.empty) bindings + (fun (pats, tys) {vb_pat = p; vb_expr = e} -> + (pattern_variables p @ pats, Use.join (expression env e) tys)) + ([], Use.empty) bindings + in + ( List.fold_left + (fun (env : Env.env) (id : Ident.t) -> Ident.add id ty env) + Env.empty ids, + ty ) + | Nonrecursive -> + List.fold_left + (fun (env2, ty) binding -> + let env', ty' = value_binding env binding in + (Env.join env2 env', Use.join ty ty')) + (Env.empty, Use.empty) bindings and value_binding : Env.env -> Typedtree.value_binding -> Env.env * Use.t = (* NB: returns new environment only *) - fun env { vb_pat; vb_expr } -> + fun env {vb_pat; vb_expr} -> let vars = pattern_variables vb_pat in let ty = expression env vb_expr in let ty = if is_destructuring_pattern vb_pat then Use.inspect ty else ty in @@ -439,7 +439,7 @@ and is_destructuring_pattern : Typedtree.pattern -> bool = | Tpat_record (_, _) -> true | Tpat_array _ -> true | Tpat_or (l, r, _) -> - is_destructuring_pattern l || is_destructuring_pattern r + is_destructuring_pattern l || is_destructuring_pattern r | Tpat_lazy _ -> true let check_recursive_expression idlist expr = @@ -447,31 +447,31 @@ let check_recursive_expression idlist expr = match (Use.unguarded ty, Use.dependent ty, classify_expression expr) with | _ :: _, _, _ (* The expression inspects rec-bound variables *) | _, _ :: _, Dynamic -> - (* The expression depends on rec-bound variables - and its size is unknown *) - raise (Error (expr.exp_loc, Illegal_letrec_expr)) + (* The expression depends on rec-bound variables + and its size is unknown *) + raise (Error (expr.exp_loc, Illegal_letrec_expr)) | [], _, Static (* The expression has known size *) | [], [], Dynamic -> - (* The expression has unknown size, - but does not depend on rec-bound variables *) - () + (* The expression has unknown size, + but does not depend on rec-bound variables *) + () let check_recursive_bindings valbinds = let ids = List.concat (List.map (fun b -> pattern_variables b.vb_pat) valbinds) in - Ext_list.iter valbinds (fun { vb_expr } -> + Ext_list.iter valbinds (fun {vb_expr} -> match vb_expr.exp_desc with | Texp_record - { fields = [| (_, Overridden (_, { exp_desc = Texp_function _ })) |] } + {fields = [|(_, Overridden (_, {exp_desc = Texp_function _}))|]} | Texp_function _ -> - () + () (*TODO: add uncurried function too*) | _ -> check_recursive_expression ids vb_expr) let report_error ppf = function | Illegal_letrec_expr -> - Format.fprintf ppf - "This kind of expression is not allowed as right-hand side of `let rec'" + Format.fprintf ppf + "This kind of expression is not allowed as right-hand side of `let rec'" let () = Location.register_error_of_exn (function diff --git a/compiler/ml/rec_check.mli b/compiler/ml/rec_check.mli index f37e891450..28469fa595 100644 --- a/compiler/ml/rec_check.mli +++ b/compiler/ml/rec_check.mli @@ -1,4 +1 @@ - - - -val check_recursive_bindings : Typedtree.value_binding list -> unit +val check_recursive_bindings : Typedtree.value_binding list -> unit diff --git a/compiler/ml/record_coercion.ml b/compiler/ml/record_coercion.ml index 338749e524..9a0c4eb747 100644 --- a/compiler/ml/record_coercion.ml +++ b/compiler/ml/record_coercion.ml @@ -30,4 +30,4 @@ let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list) (acc1, acc2) in let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in - (!violation, tl1, tl2) \ No newline at end of file + (!violation, tl1, tl2) diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 76cc710f63..73c283b60f 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -85,4 +85,4 @@ let extract_type_vars (type_params : Types.type_expr list) match t.Types.desc with | Tvar (Some tname) -> Some (tname, applied_tvar) | _ -> None) - else [] \ No newline at end of file + else [] diff --git a/compiler/ml/rescript_cpp.ml b/compiler/ml/rescript_cpp.ml index 9e9cb15e25..98f2ac7576 100644 --- a/compiler/ml/rescript_cpp.ml +++ b/compiler/ml/rescript_cpp.ml @@ -22,9 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type pp_error = - | Unterminated_if - | Unterminated_else +type pp_error = Unterminated_if | Unterminated_else exception Pp_error of pp_error * Location.t @@ -120,7 +118,6 @@ let define_key_value key v = true) else false - type dir_conditional = Dir_if_true | Dir_out (* let string_of_dir_conditional (x : dir_conditional) = *) diff --git a/compiler/ml/rescript_cpp.mli b/compiler/ml/rescript_cpp.mli index 6a72da92df..7881cc878a 100644 --- a/compiler/ml/rescript_cpp.mli +++ b/compiler/ml/rescript_cpp.mli @@ -24,7 +24,6 @@ val at_bol : Lexing.lexbuf -> bool - val eof_check : Lexing.lexbuf -> unit val init : unit -> unit diff --git a/compiler/ml/stypes.ml b/compiler/ml/stypes.ml index 879aef7f40..0584b16938 100644 --- a/compiler/ml/stypes.ml +++ b/compiler/ml/stypes.ml @@ -22,43 +22,38 @@ interesting in case of errors. *) -open Annot;; -open Lexing;; -open Location;; -open Typedtree;; +open Annot +open Lexing +open Location +open Typedtree let output_int oc i = output_string oc (string_of_int i) type annotation = - | Ti_pat of pattern - | Ti_expr of expression + | Ti_pat of pattern + | Ti_expr of expression | Ti_class of unit - | Ti_mod of module_expr + | Ti_mod of module_expr | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident -;; let get_location ti = match ti with - Ti_pat p -> p.pat_loc - | Ti_expr e -> e.exp_loc + | Ti_pat p -> p.pat_loc + | Ti_expr e -> e.exp_loc | Ti_class () -> assert false - | Ti_mod m -> m.mod_loc + | Ti_mod m -> m.mod_loc | An_call (l, _k) -> l | An_ident (l, _s, _k) -> l -;; -let annotations = ref ([] : annotation list);; -let phrases = ref ([] : Location.t list);; +let annotations = ref ([] : annotation list) +let phrases = ref ([] : Location.t list) let record ti = if !Clflags.annotations && not (get_location ti).Location.loc_ghost then annotations := ti :: !annotations -;; -let record_phrase loc = - if !Clflags.annotations then phrases := loc :: !phrases; -;; +let record_phrase loc = if !Clflags.annotations then phrases := loc :: !phrases (* comparison order: the intervals are sorted by order of increasing upper bound @@ -68,15 +63,12 @@ let cmp_loc_inner_first loc1 loc2 = match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum | x -> x -;; let cmp_ti_inner_first ti1 ti2 = cmp_loc_inner_first (get_location ti1) (get_location ti2) -;; let print_position pp pos = - if pos = dummy_pos then - output_string pp "--" - else begin + if pos = dummy_pos then output_string pp "--" + else ( output_char pp '\"'; output_string pp (String.escaped pos.pos_fname); output_string pp "\" "; @@ -84,15 +76,12 @@ let print_position pp pos = output_char pp ' '; output_int pp pos.pos_bol; output_char pp ' '; - output_int pp pos.pos_cnum; - end -;; + output_int pp pos.pos_cnum) let print_location pp loc = print_position pp loc.loc_start; output_char pp ' '; - print_position pp loc.loc_end; -;; + print_position pp loc.loc_end let sort_filter_phrases () = let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in @@ -100,111 +89,100 @@ let sort_filter_phrases () = match l with | [] -> accu | loc :: t -> - if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum - && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum - then loop accu cur t - else loop (loc :: accu) loc t + if + cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum + && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum + then loop accu cur t + else loop (loc :: accu) loc t in - phrases := loop [] Location.none ph; -;; + phrases := loop [] Location.none ph let rec printtyp_reset_maybe loc = match !phrases with | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> - Printtyp.reset (); - phrases := t; - printtyp_reset_maybe loc; + Printtyp.reset (); + phrases := t; + printtyp_reset_maybe loc | _ -> () -;; let call_kind_string k = match k with | Tail -> "tail" | Stack -> "stack" | Inline -> "inline" -;; let print_ident_annot pp str k = match k with | Idef l -> - output_string pp "def "; - output_string pp str; - output_char pp ' '; - print_location pp l; - output_char pp '\n' + output_string pp "def "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' | Iref_internal l -> - output_string pp "int_ref "; - output_string pp str; - output_char pp ' '; - print_location pp l; - output_char pp '\n' + output_string pp "int_ref "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' | Iref_external -> - output_string pp "ext_ref "; - output_string pp str; - output_char pp '\n' -;; + output_string pp "ext_ref "; + output_string pp str; + output_char pp '\n' (* The format of the annotation file is documented in emacs/caml-types.el. *) let print_info pp prev_loc ti = match ti with | Ti_class _ | Ti_mod _ -> prev_loc - | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env} + | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env} | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> - if loc <> prev_loc then begin - print_location pp loc; - output_char pp '\n' - end; - output_string pp "type(\n"; - printtyp_reset_maybe loc; - Printtyp.mark_loops typ; - Format.pp_print_string Format.str_formatter " "; - Printtyp.wrap_printing_env env - (fun () -> Printtyp.type_sch Format.str_formatter typ); - Format.pp_print_newline Format.str_formatter (); - let s = Format.flush_str_formatter () in - output_string pp s; - output_string pp ")\n"; - loc + if loc <> prev_loc then ( + print_location pp loc; + output_char pp '\n'); + output_string pp "type(\n"; + printtyp_reset_maybe loc; + Printtyp.mark_loops typ; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env env (fun () -> + Printtyp.type_sch Format.str_formatter typ); + Format.pp_print_newline Format.str_formatter (); + let s = Format.flush_str_formatter () in + output_string pp s; + output_string pp ")\n"; + loc | An_call (loc, k) -> - if loc <> prev_loc then begin - print_location pp loc; - output_char pp '\n' - end; - output_string pp "call(\n "; - output_string pp (call_kind_string k); - output_string pp "\n)\n"; - loc + if loc <> prev_loc then ( + print_location pp loc; + output_char pp '\n'); + output_string pp "call(\n "; + output_string pp (call_kind_string k); + output_string pp "\n)\n"; + loc | An_ident (loc, str, k) -> - if loc <> prev_loc then begin - print_location pp loc; - output_char pp '\n' - end; - output_string pp "ident(\n "; - print_ident_annot pp str k; - output_string pp ")\n"; - loc -;; + if loc <> prev_loc then ( + print_location pp loc; + output_char pp '\n'); + output_string pp "ident(\n "; + print_ident_annot pp str k; + output_string pp ")\n"; + loc let get_info () = let info = List.fast_sort cmp_ti_inner_first !annotations in annotations := []; info -;; let dump filename = - if !Clflags.annotations then begin + if !Clflags.annotations then ( let do_dump _temp_filename pp = let info = get_info () in sort_filter_phrases (); - ignore (List.fold_left (print_info pp) Location.none info) in - begin match filename with + ignore (List.fold_left (print_info pp) Location.none info) + in + (match filename with | None -> do_dump "" stdout | Some filename -> - Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump - end; - phrases := []; - end else begin - annotations := []; - end; -;; + Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump); + phrases := []) + else annotations := [] diff --git a/compiler/ml/stypes.mli b/compiler/ml/stypes.mli index 770956c864..3182f7eb9a 100644 --- a/compiler/ml/stypes.mli +++ b/compiler/ml/stypes.mli @@ -17,20 +17,19 @@ (* Clflags.save_types must be true *) -open Typedtree;; +open Typedtree type annotation = - | Ti_pat of pattern - | Ti_expr of expression + | Ti_pat of pattern + | Ti_expr of expression | Ti_class of unit - | Ti_mod of module_expr + | Ti_mod of module_expr | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident -;; -val record : annotation -> unit;; -val record_phrase : Location.t -> unit;; -val dump : string option -> unit;; +val record : annotation -> unit +val record_phrase : Location.t -> unit +val dump : string option -> unit -val get_location : annotation -> Location.t;; -val get_info : unit -> annotation list;; +val get_location : annotation -> Location.t +val get_info : unit -> annotation list diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index 65c4091471..2c6e454a33 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -22,36 +22,37 @@ open Btype type type_replacement = | Path of Path.t - | Type_function of { params : type_expr list; body : type_expr } + | Type_function of {params: type_expr list; body: type_expr} -module PathMap = Map.Make(Path) +module PathMap = Map.Make (Path) -type t = - { types: type_replacement PathMap.t; - modules: Path.t PathMap.t; - modtypes: (Ident.t, module_type) Tbl.t; - for_saving: bool; - } +type t = { + types: type_replacement PathMap.t; + modules: Path.t PathMap.t; + modtypes: (Ident.t, module_type) Tbl.t; + for_saving: bool; +} let identity = - { types = PathMap.empty; + { + types = PathMap.empty; modules = PathMap.empty; modtypes = Tbl.empty; for_saving = false; } -let add_type_path id p s = { s with types = PathMap.add id (Path p) s.types } +let add_type_path id p s = {s with types = PathMap.add id (Path p) s.types} let add_type id p s = add_type_path (Pident id) p s let add_type_function id ~params ~body s = - { s with types = PathMap.add id (Type_function { params; body }) s.types } + {s with types = PathMap.add id (Type_function {params; body}) s.types} -let add_module_path id p s = { s with modules = PathMap.add id p s.modules } +let add_module_path id p s = {s with modules = PathMap.add id p s.modules} let add_module id p s = add_module_path (Pident id) p s -let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes } +let add_modtype id ty s = {s with modtypes = Tbl.add id ty s.modtypes} -let for_saving s = { s with for_saving = true } +let for_saving s = {s with for_saving = true} let loc s x = if s.for_saving && not !Clflags.keep_locs then Location.none else x @@ -61,50 +62,44 @@ let remove_loc = {default_mapper with location = (fun _this _loc -> Location.none)} let attrs s x = - if s.for_saving && not !Clflags.keep_locs - then remove_loc.Ast_mapper.attributes remove_loc x + if s.for_saving && not !Clflags.keep_locs then + remove_loc.Ast_mapper.attributes remove_loc x else x let rec module_path s path = try PathMap.find path s.modules - with Not_found -> + with Not_found -> ( match path with | Pident _ -> path - | Pdot(p, n, pos) -> - Pdot(module_path s p, n, pos) - | Papply(p1, p2) -> - Papply(module_path s p1, module_path s p2) + | Pdot (p, n, pos) -> Pdot (module_path s p, n, pos) + | Papply (p1, p2) -> Papply (module_path s p1, module_path s p2)) let modtype_path s = function - Pident id as p -> - begin try - match Tbl.find id s.modtypes with - | Mty_ident p -> p - | _ -> fatal_error "Subst.modtype_path" - with Not_found -> p end - | Pdot(p, n, pos) -> - Pdot(module_path s p, n, pos) - | Papply _ -> - fatal_error "Subst.modtype_path" + | Pident id as p -> ( + try + match Tbl.find id s.modtypes with + | Mty_ident p -> p + | _ -> fatal_error "Subst.modtype_path" + with Not_found -> p) + | Pdot (p, n, pos) -> Pdot (module_path s p, n, pos) + | Papply _ -> fatal_error "Subst.modtype_path" let type_path s path = match PathMap.find path s.types with | Path p -> p | Type_function _ -> assert false - | exception Not_found -> - match path with - | Pident _ -> path - | Pdot(p, n, pos) -> - Pdot(module_path s p, n, pos) - | Papply _ -> - fatal_error "Subst.type_path" + | exception Not_found -> ( + match path with + | Pident _ -> path + | Pdot (p, n, pos) -> Pdot (module_path s p, n, pos) + | Papply _ -> fatal_error "Subst.type_path") let type_path s p = match Path.constructor_typath p with | Regular p -> type_path s p - | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos) + | Cstr (ty_path, cstr) -> Pdot (type_path s ty_path, cstr, nopos) | LocalExt _ -> type_path s p - | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos) + | Ext (p, cstr) -> Pdot (module_path s p, cstr, nopos) let to_subst_by_type_function s p = match PathMap.find p s.types with @@ -119,7 +114,7 @@ let reset_for_saving () = new_id := -1 let newpersty desc = decr new_id; - { desc = desc; level = generic_level; id = !new_id } + {desc; level = generic_level; id = !new_id} (* ensure that all occurrences of 'Tvar None' are physically shared *) let tvar_none = Tvar None @@ -135,102 +130,112 @@ let ctype_apply_env_empty = ref (fun _ -> assert false) let rec typexp s ty = let ty = repr ty in match ty.desc with - Tvar _ | Tunivar _ as desc -> - if s.for_saving || ty.id < 0 then - let ty' = - if s.for_saving then newpersty (norm desc) - else newty2 ty.level desc - in - save_desc ty desc; ty.desc <- Tsubst ty'; ty' - else ty - | Tsubst ty -> - ty - | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method - && field_kind_repr k <> Fabsent && (repr ty).level < generic_level -> - (* do not copy the type of self when it is not generalized *) - ty -(* cannot do it, since it would omit substitution - | Tvariant row when not (static_row row) -> - ty -*) + | (Tvar _ | Tunivar _) as desc -> + if s.for_saving || ty.id < 0 then ( + let ty' = + if s.for_saving then newpersty (norm desc) else newty2 ty.level desc + in + save_desc ty desc; + ty.desc <- Tsubst ty'; + ty') + else ty + | Tsubst ty -> ty + | Tfield (m, k, _t1, _t2) + when (not s.for_saving) && m = dummy_method + && field_kind_repr k <> Fabsent + && (repr ty).level < generic_level -> + (* do not copy the type of self when it is not generalized *) + ty + (* cannot do it, since it would omit substitution + | Tvariant row when not (static_row row) -> + ty + *) | _ -> let desc = ty.desc in save_desc ty desc; let tm = row_of_type ty in let has_fixed_row = - not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in + (not (is_Tconstr ty)) && is_constr_row ~allow_ident:false tm + in (* Make a stub *) let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in ty.desc <- Tsubst ty'; ty'.desc <- - begin if has_fixed_row then - match tm.desc with (* PR#7348 *) - Tconstr (Pdot(m,i,pos), tl, _abbrev) -> - let i' = String.sub i 0 (String.length i - 4) in - Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil) - | _ -> assert false - else match desc with - | Tconstr (p, args, _abbrev) -> - let args = List.map (typexp s) args in - begin match PathMap.find p s.types with - | exception Not_found -> Tconstr(type_path s p, args, ref Mnil) - | Path _ -> Tconstr(type_path s p, args, ref Mnil) - | Type_function { params; body } -> - (!ctype_apply_env_empty params body args).desc - end - | Tpackage(p, n, tl) -> - Tpackage(modtype_path s p, n, List.map (typexp s) tl) - | Tobject (t1, name) -> - Tobject (typexp s t1, - ref (match !name with - None -> None - | Some (p, tl) -> - if to_subst_by_type_function s p - then None - else Some (type_path s p, List.map (typexp s) tl))) - | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in - (* We must substitute in a subtle way *) - (* Tsubst takes a tuple containing the row var and the variant *) - begin match more.desc with - Tsubst {desc = Ttuple [_;ty2]} -> - (* This variant type has been already copied *) - ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) - Tlink ty2 - | _ -> - let dup = - s.for_saving || more.level = generic_level || static_row row || - match more.desc with Tconstr _ -> true | _ -> false in - (* Various cases for the row variable *) - let more' = - match more.desc with - Tsubst ty -> ty - | Tconstr _ | Tnil -> typexp s more - | Tunivar _ | Tvar _ -> - save_desc more more.desc; - if s.for_saving then newpersty (norm more.desc) else - if dup && is_Tvar more then newgenty more.desc else more - | _ -> assert false - in - (* Register new type first for recursion *) - more.desc <- Tsubst(newgenty(Ttuple[more';ty'])); - (* Return a new copy *) - let row = - copy_row (typexp s) true row (not dup) more' in - match row.row_name with - | Some (p, tl) -> - Tvariant {row with row_name = - if to_subst_by_type_function s p - then None - else Some (type_path s p, tl)} - | None -> - Tvariant row - end - | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> - Tlink (typexp s t2) - | _ -> copy_type_desc (typexp s) desc - end; + (if has_fixed_row then + match tm.desc with + (* PR#7348 *) + | Tconstr (Pdot (m, i, pos), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + Tconstr (type_path s (Pdot (m, i', pos)), tl, ref Mnil) + | _ -> assert false + else + match desc with + | Tconstr (p, args, _abbrev) -> ( + let args = List.map (typexp s) args in + match PathMap.find p s.types with + | exception Not_found -> Tconstr (type_path s p, args, ref Mnil) + | Path _ -> Tconstr (type_path s p, args, ref Mnil) + | Type_function {params; body} -> + (!ctype_apply_env_empty params body args).desc) + | Tpackage (p, n, tl) -> + Tpackage (modtype_path s p, n, List.map (typexp s) tl) + | Tobject (t1, name) -> + Tobject + ( typexp s t1, + ref + (match !name with + | None -> None + | Some (p, tl) -> + if to_subst_by_type_function s p then None + else Some (type_path s p, List.map (typexp s) tl)) ) + | Tvariant row -> ( + let row = row_repr row in + let more = repr row.row_more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + match more.desc with + | Tsubst {desc = Ttuple [_; ty2]} -> + (* This variant type has been already copied *) + ty.desc <- Tsubst ty2; + (* avoid Tlink in the new type *) + Tlink ty2 + | _ -> ( + let dup = + s.for_saving || more.level = generic_level || static_row row + || + match more.desc with + | Tconstr _ -> true + | _ -> false + in + (* Various cases for the row variable *) + let more' = + match more.desc with + | Tsubst ty -> ty + | Tconstr _ | Tnil -> typexp s more + | Tunivar _ | Tvar _ -> + save_desc more more.desc; + if s.for_saving then newpersty (norm more.desc) + else if dup && is_Tvar more then newgenty more.desc + else more + | _ -> assert false + in + (* Register new type first for recursion *) + more.desc <- Tsubst (newgenty (Ttuple [more'; ty'])); + (* Return a new copy *) + let row = copy_row (typexp s) true row (not dup) more' in + match row.row_name with + | Some (p, tl) -> + Tvariant + { + row with + row_name = + (if to_subst_by_type_function s p then None + else Some (type_path s p, tl)); + } + | None -> Tvariant row)) + | Tfield (_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> + Tlink (typexp s t2) + | _ -> copy_type_desc (typexp s) desc); ty' (* @@ -252,10 +257,8 @@ let label_declaration s l = } let constructor_arguments s = function - | Cstr_tuple l -> - Cstr_tuple (List.map (typexp s) l) - | Cstr_record l -> - Cstr_record (List.map (label_declaration s) l) + | Cstr_tuple l -> Cstr_tuple (List.map (typexp s) l) + | Cstr_record l -> Cstr_record (List.map (label_declaration s) l) let constructor_declaration s c = { @@ -268,23 +271,21 @@ let constructor_declaration s c = let type_declaration s decl = let decl = - { type_params = List.map (typexp s) decl.type_params; + { + type_params = List.map (typexp s) decl.type_params; type_arity = decl.type_arity; type_kind = - begin match decl.type_kind with - Type_abstract -> Type_abstract + (match decl.type_kind with + | Type_abstract -> Type_abstract | Type_variant cstrs -> - Type_variant (List.map (constructor_declaration s) cstrs) - | Type_record(lbls, rep) -> - Type_record (List.map (label_declaration s) lbls, rep) - | Type_open -> Type_open - end; + Type_variant (List.map (constructor_declaration s) cstrs) + | Type_record (lbls, rep) -> + Type_record (List.map (label_declaration s) lbls, rep) + | Type_open -> Type_open); type_manifest = - begin - match decl.type_manifest with - None -> None - | Some ty -> Some(typexp s ty) - end; + (match decl.type_manifest with + | None -> None + | Some ty -> Some (typexp s ty)); type_private = decl.type_private; type_variance = decl.type_variance; type_newtype_level = None; @@ -297,88 +298,79 @@ let type_declaration s decl = cleanup_types (); decl - let value_description s descr = - { val_type = type_expr s descr.val_type; + { + val_type = type_expr s descr.val_type; val_kind = descr.val_kind; val_loc = loc s descr.val_loc; val_attributes = attrs s descr.val_attributes; - } + } let extension_constructor s ext = let ext = - { ext_type_path = type_path s ext.ext_type_path; + { + ext_type_path = type_path s ext.ext_type_path; ext_type_params = List.map (typexp s) ext.ext_type_params; 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 = attrs s ext.ext_attributes; - ext_loc = if s.for_saving then Location.none else ext.ext_loc; - ext_is_exception = ext.ext_is_exception; } + ext_loc = (if s.for_saving then Location.none else ext.ext_loc); + ext_is_exception = ext.ext_is_exception; + } in - cleanup_types (); - ext + cleanup_types (); + ext let rec rename_bound_idents s idents = function - [] -> (List.rev idents, s) - | Sig_type(id, _, _) :: sg -> - let id' = Ident.rename id in - rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | Sig_module(id, _, _) :: sg -> - let id' = Ident.rename id in - rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg - | Sig_modtype(id, _) :: sg -> - let id' = Ident.rename id in - rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) - (id' :: idents) sg - | Sig_class_type () :: _ -> assert false - | (Sig_value(id, _) | Sig_typext(id, _, _)) :: sg -> - let id' = Ident.rename id in - rename_bound_idents s (id' :: idents) sg + | [] -> (List.rev idents, s) + | Sig_type (id, _, _) :: sg -> + let id' = Ident.rename id in + rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg + | Sig_module (id, _, _) :: sg -> + let id' = Ident.rename id in + rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg + | Sig_modtype (id, _) :: sg -> + let id' = Ident.rename id in + rename_bound_idents + (add_modtype id (Mty_ident (Pident id')) s) + (id' :: idents) sg + | Sig_class_type () :: _ -> assert false + | (Sig_value (id, _) | Sig_typext (id, _, _)) :: sg -> + let id' = Ident.rename id in + rename_bound_idents s (id' :: idents) sg | Sig_class _ :: _ -> assert false let rec modtype s = function - Mty_ident p as mty -> - begin match p with - Pident id -> - begin try Tbl.find id s.modtypes with Not_found -> mty end - | Pdot(p, n, pos) -> - Mty_ident(Pdot(module_path s p, n, pos)) - | Papply _ -> - fatal_error "Subst.modtype" - end - | Mty_signature sg -> - Mty_signature(signature s sg) - | Mty_functor(id, arg, res) -> - let id' = Ident.rename id in - Mty_functor(id', may_map (modtype s) arg, - modtype (add_module id (Pident id') s) res) - | Mty_alias(pres, p) -> - Mty_alias(pres, module_path s p) + | Mty_ident p as mty -> ( + match p with + | Pident id -> ( try Tbl.find id s.modtypes with Not_found -> mty) + | Pdot (p, n, pos) -> Mty_ident (Pdot (module_path s p, n, pos)) + | Papply _ -> fatal_error "Subst.modtype") + | Mty_signature sg -> Mty_signature (signature s sg) + | Mty_functor (id, arg, res) -> + let id' = Ident.rename id in + Mty_functor + (id', may_map (modtype s) arg, modtype (add_module id (Pident id') s) res) + | Mty_alias (pres, p) -> Mty_alias (pres, module_path s p) and signature s sg = (* Components of signature may be mutually recursive (e.g. type declarations or class and type declarations), so first build global renaming substitution... *) - let (new_idents, s') = rename_bound_idents s [] sg in + let new_idents, s' = rename_bound_idents s [] sg in (* ... then apply it to each signature component in turn *) List.map2 (signature_component s') sg new_idents and signature_component s comp newid = match comp with - Sig_value(_id, d) -> - Sig_value(newid, value_description s d) - | Sig_type(_id, d, rs) -> - Sig_type(newid, type_declaration s d, rs) - | Sig_typext(_id, ext, es) -> - Sig_typext(newid, extension_constructor s ext, es) - | Sig_module(_id, d, rs) -> - Sig_module(newid, module_declaration s d, rs) - | Sig_modtype(_id, d) -> - Sig_modtype(newid, modtype_declaration s d) - | Sig_class() -> - Sig_class() - | Sig_class_type () -> - Sig_class_type () + | Sig_value (_id, d) -> Sig_value (newid, value_description s d) + | Sig_type (_id, d, rs) -> Sig_type (newid, type_declaration s d, rs) + | Sig_typext (_id, ext, es) -> + Sig_typext (newid, extension_constructor s ext, es) + | Sig_module (_id, d, rs) -> Sig_module (newid, module_declaration s d, rs) + | Sig_modtype (_id, d) -> Sig_modtype (newid, modtype_declaration s d) + | Sig_class () -> Sig_class () + | Sig_class_type () -> Sig_class_type () and module_declaration s decl = { @@ -387,7 +379,7 @@ and module_declaration s decl = md_loc = loc s decl.md_loc; } -and modtype_declaration s decl = +and modtype_declaration s decl = { mtd_type = may_map (modtype s) decl.mtd_type; mtd_attributes = attrs s decl.mtd_attributes; @@ -397,24 +389,24 @@ and modtype_declaration s decl = (* For every binding k |-> d of m1, add k |-> f d to m2 and return resulting merged map. *) -let merge_tbls f m1 m2 = - Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2 +let merge_tbls f m1 m2 = Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2 let merge_path_maps f m1 m2 = PathMap.fold (fun k d accu -> PathMap.add k (f d) accu) m1 m2 let type_replacement s = function | Path p -> Path (type_path s p) - | Type_function { params; body } -> - let params = List.map (typexp s) params in - let body = typexp s body in - Type_function { params; body } + | Type_function {params; body} -> + let params = List.map (typexp s) params in + let body = typexp s body in + Type_function {params; body} (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) let compose s1 s2 = - { types = merge_path_maps (type_replacement s2) s1.types s2.types; + { + types = merge_path_maps (type_replacement s2) s1.types s2.types; modules = merge_path_maps (module_path s2) s1.modules s2.modules; modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes; for_saving = s1.for_saving || s2.for_saving; diff --git a/compiler/ml/subst.mli b/compiler/ml/subst.mli index 50ee2ad934..10438bfcb1 100644 --- a/compiler/ml/subst.mli +++ b/compiler/ml/subst.mli @@ -31,37 +31,36 @@ type t well-formed (decreasing levels), even if the original one was not. *) -val identity: t +val identity : t -val add_type: Ident.t -> Path.t -> t -> t -val add_type_path: Path.t -> Path.t -> t -> t -val add_type_function: +val add_type : Ident.t -> Path.t -> t -> t +val add_type_path : Path.t -> Path.t -> t -> t +val add_type_function : Path.t -> params:type_expr list -> body:type_expr -> t -> t -val add_module: Ident.t -> Path.t -> t -> t -val add_module_path: Path.t -> Path.t -> t -> t -val add_modtype: Ident.t -> module_type -> t -> t -val for_saving: t -> t -val reset_for_saving: unit -> unit +val add_module : Ident.t -> Path.t -> t -> t +val add_module_path : Path.t -> Path.t -> t -> t +val add_modtype : Ident.t -> module_type -> t -> t +val for_saving : t -> t +val reset_for_saving : unit -> unit -val module_path: t -> Path.t -> Path.t -val type_path: t -> Path.t -> Path.t +val module_path : t -> Path.t -> Path.t +val type_path : t -> Path.t -> Path.t -val type_expr: t -> type_expr -> type_expr -val value_description: t -> value_description -> value_description -val type_declaration: t -> type_declaration -> type_declaration -val extension_constructor: - t -> extension_constructor -> extension_constructor +val type_expr : t -> type_expr -> type_expr +val value_description : t -> value_description -> value_description +val type_declaration : t -> type_declaration -> type_declaration +val extension_constructor : t -> extension_constructor -> extension_constructor -val modtype: t -> module_type -> module_type -val signature: t -> signature -> signature -val modtype_declaration: t -> modtype_declaration -> modtype_declaration -val module_declaration: t -> module_declaration -> module_declaration +val modtype : t -> module_type -> module_type +val signature : t -> signature -> signature +val modtype_declaration : t -> modtype_declaration -> modtype_declaration +val module_declaration : t -> module_declaration -> module_declaration val typexp : t -> Types.type_expr -> Types.type_expr (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) -val compose: t -> t -> t +val compose : t -> t -> t (* A forward reference to be filled in ctype.ml. *) -val ctype_apply_env_empty: +val ctype_apply_env_empty : (type_expr list -> type_expr -> type_expr list -> type_expr) ref diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index c8a1d9cdc5..6236310e49 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -13,14 +13,14 @@ (* *) (**************************************************************************) - type 'a shared = Shared of 'a | Single of 'a -type 'a t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'a -> int ; - act_store_shared : 'a -> int ; } +type 'a t_store = { + act_get: unit -> 'a array; + act_get_shared: unit -> 'a shared array; + act_store: 'a -> int; + act_store_shared: 'a -> int; +} exception Not_simple @@ -31,85 +31,93 @@ module type Stored = sig val make_key : t -> key option end -module Store(A:Stored) = struct - module AMap = - Map.Make(struct type t = A.key let compare = A.compare_key end) +module Store (A : Stored) = struct + module AMap = Map.Make (struct + type t = A.key + let compare = A.compare_key + end) - type intern = - { mutable map : (bool * int) AMap.t ; - mutable next : int ; - mutable acts : (bool * A.t) list; } + type intern = { + mutable map: (bool * int) AMap.t; + mutable next: int; + mutable acts: (bool * A.t) list; + } let mk_store () = - let st = - { map = AMap.empty ; - next = 0 ; - acts = [] ; } in + let st = {map = AMap.empty; next = 0; acts = []} in let add mustshare act = let i = st.next in - st.acts <- (mustshare,act) :: st.acts ; - st.next <- i+1 ; - i in - - let store mustshare act = match A.make_key act with - | Some key -> - begin try - let (shared,i) = AMap.find key st.map in - if not shared then st.map <- AMap.add key (true,i) st.map ; + st.acts <- (mustshare, act) :: st.acts; + st.next <- i + 1; + i + in + + let store mustshare act = + match A.make_key act with + | Some key -> ( + try + let shared, i = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true, i) st.map; i with Not_found -> let i = add mustshare act in - st.map <- AMap.add key (mustshare,i) st.map ; - i - end - | None -> - add mustshare act - - and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) - + st.map <- AMap.add key (mustshare, i) st.map; + i) + | None -> add mustshare act + and get () = Array.of_list (List.rev_map (fun (_, act) -> act) st.acts) and get_shared () = let acts = Array.of_list (List.rev_map - (fun (shared,act) -> - if shared then Shared act else Single act) - st.acts) in + (fun (shared, act) -> if shared then Shared act else Single act) + st.acts) + in AMap.iter - (fun _ (shared,i) -> - if shared then match acts.(i) with - | Single act -> acts.(i) <- Shared act - | Shared _ -> ()) - st.map ; - acts in - {act_store = store false ; act_store_shared = store true ; - act_get = get; act_get_shared = get_shared; } + (fun _ (shared, i) -> + if shared then + match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map; + acts + in + { + act_store = store false; + act_store_shared = store true; + act_get = get; + act_get_shared = get_shared; + } end - - -module type S = - sig - type primitive - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - type act - - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - val make_switch : Location.t -> act -> int array -> act array -> offset:int -> Ast_untagged_variants.switch_names option -> act - val make_catch : act -> int * (act -> act) - val make_exit : int -> act - end +module type S = sig + type primitive + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + type act + + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + val make_switch : + Location.t -> + act -> + int array -> + act array -> + offset:int -> + Ast_untagged_variants.switch_names option -> + act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act +end (* The module will ``produce good code for the case statement'' *) (* @@ -131,19 +139,16 @@ module type S = which leads to exhaustive search for finding the optimal test sequence in small cases and heuristics otherwise. *) -module Make (Arg : S) = - struct +module Make (Arg : S) = struct + type 'a inter = {cases: (int * int * int) array; actions: 'a array} - type 'a inter = - {cases : (int * int * int) array ; - actions : 'a array} + type 'a t_ctx = {off: int; arg: 'a} -type 'a t_ctx = {off : int ; arg : 'a} + let cut = ref 8 -let cut = ref 8 -and more_cut = ref 16 + and more_cut = ref 16 -(* + (* let pint chan i = if i = min_int then Printf.fprintf chan "-oo" else if i=max_int then Printf.fprintf chan "oo" @@ -162,21 +167,19 @@ let prerr_inter i = Printf.fprintf stderr "cases=%a" pcases i.cases *) -let get_act cases i = - let _,_,r = cases.(i) in - r -and get_low cases i = - let r,_,_ = cases.(i) in - r + let get_act cases i = + let _, _, r = cases.(i) in + r -type ctests = { - mutable n : int ; - mutable ni : int ; - } + and get_low cases i = + let r, _, _ = cases.(i) in + r -let too_much = {n=max_int ; ni=max_int} + type ctests = {mutable n: int; mutable ni: int} -(* + let too_much = {n = max_int; ni = max_int} + + (* let ptests chan {n=n ; ni=ni} = Printf.fprintf chan "{n=%d ; ni=%d}" n ni @@ -186,118 +189,96 @@ let pta chan t = done *) -let less_tests c1 c2 = - if c1.n < c2.n then - true - else if c1.n = c2.n then begin - if c1.ni < c2.ni then - true - else - false - end else - false + let less_tests c1 c2 = + if c1.n < c2.n then true + else if c1.n = c2.n then if c1.ni < c2.ni then true else false + else false -and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni + and eq_tests c1 c2 = c1.n = c2.n && c1.ni = c2.ni -let less2tests (c1,d1) (c2,d2) = - if eq_tests c1 c2 then - less_tests d1 d2 - else - less_tests c1 c2 + let less2tests (c1, d1) (c2, d2) = + if eq_tests c1 c2 then less_tests d1 d2 else less_tests c1 c2 -let add_test t1 t2 = - t1.n <- t1.n + t2.n ; - t1.ni <- t1.ni + t2.ni ; + let add_test t1 t2 = + t1.n <- t1.n + t2.n; + t1.ni <- t1.ni + t2.ni -type t_ret = Inter of int * int | Sep of int | No + type t_ret = Inter of int * int | Sep of int | No -(* + (* let pret chan = function | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j | Sep i -> Printf.fprintf chan "Sep %d" i | No -> Printf.fprintf chan "No" *) -let coupe cases i = - let l,_,_ = cases.(i) in - l, - Array.sub cases 0 i, - Array.sub cases i (Array.length cases-i) - - -let case_append c1 c2 = - let len1 = Array.length c1 - and len2 = Array.length c2 in - match len1,len2 with - | 0,_ -> c2 - | _,0 -> c1 - | _,_ -> - let l1,h1,act1 = c1.(Array.length c1-1) - and l2,h2,act2 = c2.(0) in - if act1 = act2 then - let r = Array.make (len1+len2-1) c1.(0) in - for i = 0 to len1-2 do + let coupe cases i = + let l, _, _ = cases.(i) in + (l, Array.sub cases 0 i, Array.sub cases i (Array.length cases - i)) + + let case_append c1 c2 = + let len1 = Array.length c1 and len2 = Array.length c2 in + match (len1, len2) with + | 0, _ -> c2 + | _, 0 -> c1 + | _, _ -> + let l1, h1, act1 = c1.(Array.length c1 - 1) and l2, h2, act2 = c2.(0) in + if act1 = act2 then ( + let r = Array.make (len1 + len2 - 1) c1.(0) in + for i = 0 to len1 - 2 do r.(i) <- c1.(i) - done ; + done; let l = - if len1-2 >= 0 then begin - let _,h,_ = r.(len1-2) in - if h+1 < l1 then - h+1 - else - l1 - end else - l1 + if len1 - 2 >= 0 then + let _, h, _ = r.(len1 - 2) in + if h + 1 < l1 then h + 1 else l1 + else l1 and h = - if 1 < len2-1 then begin - let l,_,_ = c2.(1) in - if h2+1 < l then - l-1 - else - h2 - end else - h2 in - r.(len1-1) <- (l,h,act1) ; - for i=1 to len2-1 do - r.(len1-1+i) <- c2.(i) - done ; - r - else if h1 > l1 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-2 do + if 1 < len2 - 1 then + let l, _, _ = c2.(1) in + if h2 + 1 < l then l - 1 else h2 + else h2 + in + r.(len1 - 1) <- (l, h, act1); + for i = 1 to len2 - 1 do + r.(len1 - 1 + i) <- c2.(i) + done; + r) + else if h1 > l1 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 2 do r.(i) <- c1.(i) - done ; - r.(len1-1) <- (l1,l2-1,act1) ; - for i=0 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else if h2 > l2 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-1 do + done; + r.(len1 - 1) <- (l1, l2 - 1, act1); + for i = 0 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else if h2 > l2 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 1 do r.(i) <- c1.(i) - done ; - r.(len1) <- (h1+1,h2,act2) ; - for i=1 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else - Array.append c1 c2 - - -let coupe_inter i j cases = - let lcases = Array.length cases in - let low,_,_ = cases.(i) - and _,high,_ = cases.(j) in - low,high, - Array.sub cases i (j-i+1), - case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) - -type kind = Kvalue of int | Kinter of int | Kempty - -(* + done; + r.(len1) <- (h1 + 1, h2, act2); + for i = 1 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else Array.append c1 c2 + + let coupe_inter i j cases = + let lcases = Array.length cases in + let low, _, _ = cases.(i) and _, high, _ = cases.(j) in + ( low, + high, + Array.sub cases i (j - i + 1), + case_append (Array.sub cases 0 i) + (Array.sub cases (j + 1) (lcases - (j + 1))) ) + + type kind = Kvalue of int | Kinter of int | Kempty + + (* let pkind chan = function | Kvalue i ->Printf.fprintf chan "V%d" i | Kinter i -> Printf.fprintf chan "I%d" i @@ -310,55 +291,46 @@ let rec pkey chan = function Printf.fprintf chan "%a %a" pkey rem pkind k *) -let t = Hashtbl.create 17 + let t = Hashtbl.create 17 -let make_key cases = - let seen = ref [] - and count = ref 0 in - let rec got_it act = function - | [] -> - seen := (act,!count):: !seen ; + let make_key cases = + let seen = ref [] and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act, !count) :: !seen; let r = !count in - incr count ; + incr count; r - | (act0,index) :: rem -> - if act0 = act then - index - else - got_it act rem in + | (act0, index) :: rem -> if act0 = act then index else got_it act rem + in - let make_one (l:int) h act = - if l=h then - Kvalue (got_it act !seen) - else - Kinter (got_it act !seen) in + let make_one (l : int) h act = + if l = h then Kvalue (got_it act !seen) else Kinter (got_it act !seen) + in - let rec make_rec i pl = - if i < 0 then - [] - else - let l,h,act = cases.(i) in - if pl = h+1 then - make_one l h act::make_rec (i-1) l + let rec make_rec i pl = + if i < 0 then [] else - Kempty::make_one l h act::make_rec (i-1) l in - - let l,h,act = cases.(Array.length cases-1) in - make_one l h act::make_rec (Array.length cases-2) l - - - let same_act t = - let len = Array.length t in - let a = get_act t (len-1) in - let rec do_rec i = - if i < 0 then true - else - let b = get_act t i in - b=a && do_rec (i-1) in - do_rec (len-2) - + let l, h, act = cases.(i) in + if pl = h + 1 then make_one l h act :: make_rec (i - 1) l + else Kempty :: make_one l h act :: make_rec (i - 1) l + in + + let l, h, act = cases.(Array.length cases - 1) in + make_one l h act :: make_rec (Array.length cases - 2) l + + let same_act t = + let len = Array.length t in + let a = get_act t (len - 1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b = a && do_rec (i - 1) + in + do_rec (len - 2) -(* + (* Interval test x in [l,h] works by checking x-l in [0,h-l] * This may be false for arithmetic modulo 2^31 * Subtracting l may change the relative ordering of values @@ -370,477 +342,401 @@ let make_key cases = in [-2^16 ; 2^16] This condition is checked by zyva -*) + *) -let inter_limit = 1 lsl 16 + let inter_limit = 1 lsl 16 -let ok_inter = ref false + let ok_inter = ref false -let rec opt_count top cases = - let key = make_key cases in - try - Hashtbl.find t key - with - | Not_found -> + let rec opt_count top cases = + let key = make_key cases in + try Hashtbl.find t key + with Not_found -> let r = let lcases = Array.length cases in match lcases with | 0 -> assert false - | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) + | _ when same_act cases -> (No, ({n = 0; ni = 0}, {n = 0; ni = 0})) | _ -> - if lcases < !cut then - enum top cases - else if lcases < !more_cut then - heuristic cases - else - divide cases in - Hashtbl.add t key r ; + if lcases < !cut then enum top cases + else if lcases < !more_cut then heuristic cases + else divide cases + in + Hashtbl.add t key r; r -and divide cases = - let lcases = Array.length cases in - let m = lcases/2 in - let _,left,right = coupe cases m in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - Sep m,(cm, ci) - -and heuristic cases = - let lcases = Array.length cases in - - let sep,csep = divide cases - - and inter,cinter = - if !ok_inter then begin - let _,_,act0 = cases.(0) - and _,_,act1 = cases.(lcases-1) in - if act0 = act1 then begin - let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - Inter (1,lcases-2),(cmij,cij) - end else - Inter (-1,-1),(too_much, too_much) - end else - Inter (-1,-1),(too_much, too_much) in - if less2tests csep cinter then - sep,csep - else - inter,cinter - - -and enum top cases = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much,too_much) in - - for i = 1 to lcases-(1) do - let _,left,right = coupe cases i in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr + and divide cases = + let lcases = Array.length cases in + let m = lcases / 2 in + let _, left, right = coupe cases m in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + (Sep m, (cm, ci)) + + and heuristic cases = + let lcases = Array.length cases in + + let sep, csep = divide cases + and inter, cinter = + if !ok_inter then + let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in + if act0 = act1 then ( + let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = (if low = high then 0 else 1)} + and cij = {n = 1; ni = (if low = high then 0 else 1)} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + (Inter (1, lcases - 2), (cmij, cij))) + else (Inter (-1, -1), (too_much, too_much)) + else (Inter (-1, -1), (too_much, too_much)) + in + if less2tests csep cinter then (sep, csep) else (inter, cinter) + + and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much, too_much) in + + for i = 1 to lcases - 1 do + let _, left, right = coupe cases i in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + + if less2tests (cm, ci) !best_cost then ( + if top then Printf.fprintf stderr "Get it: %d\n" i; + best := i; + best_cost := (cm, ci)) + done; + (!best, !best_cost) + in + + let ilow, ihigh, with_inter = + if not !ok_inter then ( + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + let low, high, inside, outside = coupe_inter i i cases in + if low = high then ( + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = 0} + and cij = {n = 1; ni = 0} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := i; + best_cost := (cmij, cij))) + done; + (!rlow, !rhigh, !best_cost)) else - add_test cm cml ; - - if - less2tests (cm,ci) !best_cost - then begin - if top then - Printf.fprintf stderr "Get it: %d\n" i ; - best := i ; - best_cost := (cm,ci) - end - done ; - !best, !best_cost in - - let ilow, ihigh, with_inter = - if not !ok_inter then - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - let low, high, inside, outside = coupe_inter i i cases in - if low=high then begin - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=0} - and cij = {n=1 ; ni=0} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := i ; - best_cost := (cmij,cij) - end - end - done ; - !rlow, !rhigh, !best_cost - else - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - for j=i to lcases-2 do - let low, high, inside, outside = coupe_inter i j cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := j ; - best_cost := (cmij,cij) - end - done - done ; - !rlow, !rhigh, !best_cost in - let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in - if less2tests with_sep !rc then begin - r := Sep lim ; rc := with_sep - end ; - !r, !rc - - let make_if_test test arg i ifso ifnot = - Arg.make_if - (Arg.make_prim test [arg ; Arg.make_const i]) - ifso ifnot - - let make_if_lt arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.leint arg 0 ifso ifnot - | _ -> - make_if_test Arg.ltint arg i ifso ifnot - - and make_if_ge arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.gtint arg 0 ifso ifnot + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + for j = i to lcases - 2 do + let low, high, inside, outside = coupe_inter i j cases in + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = (if low = high then 0 else 1)} + and cij = {n = 1; ni = (if low = high then 0 else 1)} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := j; + best_cost := (cmij, cij)) + done + done; + (!rlow, !rhigh, !best_cost) + in + let r = ref (Inter (ilow, ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then ( + r := Sep lim; + rc := with_sep); + (!r, !rc) + + let make_if_test test arg i ifso ifnot = + Arg.make_if (Arg.make_prim test [arg; Arg.make_const i]) ifso ifnot + + let make_if_lt arg i ifso ifnot = + match i with + | 1 -> make_if_test Arg.leint arg 0 ifso ifnot + | _ -> make_if_test Arg.ltint arg i ifso ifnot + + and make_if_ge arg i ifso ifnot = + match i with + | 1 -> make_if_test Arg.gtint arg 0 ifso ifnot + | _ -> make_if_test Arg.geint arg i ifso ifnot + + and make_if_eq arg i ifso ifnot = make_if_test Arg.eqint arg i ifso ifnot + + and make_if_ne arg i ifso ifnot = make_if_test Arg.neint arg i ifso ifnot + + let do_make_if_out h arg ifso ifno = + Arg.make_if (Arg.make_isout h arg) ifso ifno + + let make_if_out ctx l d mk_ifso mk_ifno = + match l with + | 0 -> do_make_if_out (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> - make_if_test Arg.geint arg i ifso ifnot - - and make_if_eq arg i ifso ifnot = - make_if_test Arg.eqint arg i ifso ifnot + do_make_if_out (Arg.make_const d) + (Arg.make_offset ctx.arg (-l)) + (mk_ifso ctx) (mk_ifno ctx) - and make_if_ne arg i ifso ifnot = - make_if_test Arg.neint arg i ifso ifnot + let do_make_if_in h arg ifso ifno = + Arg.make_if (Arg.make_isin h arg) ifso ifno - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno - - let make_if_out ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_out - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - do_make_if_out - (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) - - let do_make_if_in h arg ifso ifno = - Arg.make_if (Arg.make_isin h arg) ifso ifno - - let make_if_in ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_in - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + let make_if_in ctx l d mk_ifso mk_ifno = + match l with + | 0 -> do_make_if_in (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> - do_make_if_in - (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) - - let rec c_test ctx ({cases=cases ; actions=actions} as s) = - let lcases = Array.length cases in - assert(lcases > 0) ; - if lcases = 1 then - actions.(get_act cases 0) ctx - - else begin - - let w,_c = opt_count false cases in -(* + do_make_if_in (Arg.make_const d) + (Arg.make_offset ctx.arg (-l)) + (mk_ifso ctx) (mk_ifno ctx) + + let rec c_test ctx ({cases; actions} as s) = + let lcases = Array.length cases in + assert (lcases > 0); + if lcases = 1 then actions.(get_act cases 0) ctx + else + let w, _c = opt_count false cases in + (* Printf.fprintf stderr "off=%d tactic=%a for %a\n" ctx.off pret w pcases cases ; *) - match w with - | No -> actions.(get_act cases 0) ctx - | Inter (i,j) -> - let low,high,inside, outside = coupe_inter i j cases in - let _,(cinside,_) = opt_count false inside - and _,(coutside,_) = opt_count false outside in -(* Costs are retrieved to put the code with more remaining tests - in the privileged (positive) branch of ``if'' *) - if low=high then begin - if less_tests coutside cinside then - make_if_eq - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=inside}) - (c_test ctx {s with cases=outside}) - else - make_if_ne - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=outside}) - (c_test ctx {s with cases=inside}) - end else begin + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i, j) -> + let low, high, inside, outside = coupe_inter i j cases in + let _, (cinside, _) = opt_count false inside + and _, (coutside, _) = opt_count false outside in + (* Costs are retrieved to put the code with more remaining tests + in the privileged (positive) branch of ``if'' *) + if low = high then if less_tests coutside cinside then - make_if_in - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=inside}) - (fun ctx -> c_test ctx {s with cases=outside}) + make_if_eq ctx.arg (low + ctx.off) + (c_test ctx {s with cases = inside}) + (c_test ctx {s with cases = outside}) else - make_if_out - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=outside}) - (fun ctx -> c_test ctx {s with cases=inside}) - end - | Sep i -> - let lim,left,right = coupe cases i in - let _,(cleft,_) = opt_count false left - and _,(cright,_) = opt_count false right in - let left = {s with cases=left} - and right = {s with cases=right} in - - if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne - ctx.arg 0 - (c_test ctx right) (c_test ctx left) + make_if_ne ctx.arg (low + ctx.off) + (c_test ctx {s with cases = outside}) + (c_test ctx {s with cases = inside}) + else if less_tests coutside cinside then + make_if_in ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = inside}) + (fun ctx -> c_test ctx {s with cases = outside}) + else + make_if_out ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = outside}) + (fun ctx -> c_test ctx {s with cases = inside}) + | Sep i -> + let lim, left, right = coupe cases i in + let _, (cleft, _) = opt_count false left + and _, (cright, _) = opt_count false right in + let left = {s with cases = left} and right = {s with cases = right} in + + if i = 1 && lim + ctx.off = 1 && get_low cases 0 + ctx.off = 0 then + make_if_ne ctx.arg 0 (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt - ctx.arg (lim+ctx.off) - (c_test ctx left) (c_test ctx right) + make_if_lt ctx.arg (lim + ctx.off) (c_test ctx left) + (c_test ctx right) else - make_if_ge - ctx.arg (lim+ctx.off) - (c_test ctx right) (c_test ctx left) - - end - - -(* Minimal density of switches *) -let theta = ref 0.33333 - -(* Minimal number of tests to make a switch *) -let switch_min = ref 3 - -(* Particular case 0, 1, 2 *) -let particular_case cases i j = - j-i = 2 && - (let l1,_h1,act1 = cases.(i) - and l2,_h2,_act2 = cases.(i+1) - and l3,h3,act3 = cases.(i+2) in - l1+1=l2 && l2+1=l3 && l3=h3 && - act1 <> act3) - -let approx_count cases i j = - let l = j-i+1 in - if l < !cut then - let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in - ntests - else - l-1 - -(* Sends back a boolean that says whether is switch is worth or not *) - -let dense {cases} i j = - if i=j then true - else - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - let ntests = approx_count cases i j in -(* + make_if_ge ctx.arg (lim + ctx.off) (c_test ctx right) + (c_test ctx left) + + (* Minimal density of switches *) + let theta = ref 0.33333 + + (* Minimal number of tests to make a switch *) + let switch_min = ref 3 + + (* Particular case 0, 1, 2 *) + let particular_case cases i j = + j - i = 2 + && + let l1, _h1, act1 = cases.(i) + and l2, _h2, _act2 = cases.(i + 1) + and l3, h3, act3 = cases.(i + 2) in + l1 + 1 = l2 && l2 + 1 = l3 && l3 = h3 && act1 <> act3 + + let approx_count cases i j = + let l = j - i + 1 in + if l < !cut then + let _, (_, {n = ntests}) = opt_count false (Array.sub cases i l) in + ntests + else l - 1 + + (* Sends back a boolean that says whether is switch is worth or not *) + + let dense {cases} i j = + if i = j then true + else + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + let ntests = approx_count cases i j in + (* (ntests+1) >= theta * (h-l+1) *) - particular_case cases i j || - (ntests >= !switch_min && - float_of_int ntests +. 1.0 >= - !theta *. (float_of_int h -. float_of_int l +. 1.0)) - -(* Compute clusters by dynamic programming - Adaptation of the correction to Bernstein - ``Correction to `Producing Good Code for the Case Statement' '' - S.K. Kannan and T.A. Proebsting - Software Practice and Experience Vol. 24(2) 233 (Feb 1994) -*) + particular_case cases i j + || ntests >= !switch_min + && float_of_int ntests +. 1.0 + >= !theta *. (float_of_int h -. float_of_int l +. 1.0) + + (* Compute clusters by dynamic programming + Adaptation of the correction to Bernstein + ``Correction to `Producing Good Code for the Case Statement' '' + S.K. Kannan and T.A. Proebsting + Software Practice and Experience Vol. 24(2) 233 (Feb 1994) + *) -let comp_clusters s = - let len = Array.length s.cases in - let min_clusters = Array.make len max_int - and k = Array.make len 0 in - let get_min i = if i < 0 then 0 else min_clusters.(i) in - - for i = 0 to len-1 do - for j = 0 to i do - if - dense s j i && - get_min (j-1) + 1 < min_clusters.(i) - then begin - k.(i) <- j ; - min_clusters.(i) <- get_min (j-1) + 1 - end - done ; - done ; - min_clusters.(len-1),k - -(* Assume j > i *) -let make_switch loc {cases=cases ; actions=actions} i j sw_names = - let ll,_,_ = cases.(i) - and _,hh,_ = cases.(j) in - let tbl = Array.make (hh-ll+1) 0 - and t = Hashtbl.create 17 - and index = ref 0 in - let get_index act = - try - Hashtbl.find t act - with - | Not_found -> + let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int and k = Array.make len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len - 1 do + for j = 0 to i do + if dense s j i && get_min (j - 1) + 1 < min_clusters.(i) then ( + k.(i) <- j; + min_clusters.(i) <- get_min (j - 1) + 1) + done + done; + (min_clusters.(len - 1), k) + + (* Assume j > i *) + let make_switch loc {cases; actions} i j sw_names = + let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in + let tbl = Array.make (hh - ll + 1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try Hashtbl.find t act + with Not_found -> let i = !index in - incr index ; - Hashtbl.add t act i ; - i in - - for k=i to j do - let l,h,act = cases.(k) in - let index = get_index act in - for kk=l-ll to h-ll do - tbl.(kk) <- index - done - done ; - let acts = Array.make !index actions.(0) in - Hashtbl.iter - (fun act i -> acts.(i) <- actions.(act)) - t ; - (fun ctx -> - Arg.make_switch ~offset:(ll+ctx.off) loc ctx.arg tbl acts sw_names) - - -let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k sw_names = - let len = Array.length cases in - let r = Array.make n_clusters (0,0,0) - and t = Hashtbl.create 17 - and index = ref 0 - and bidon = ref (Array.length actions) in - let get_index act = - try - let i,_ = Hashtbl.find t act in - i - with - | Not_found -> + incr index; + Hashtbl.add t act i; + i + in + + for k = i to j do + let l, h, act = cases.(k) in + let index = get_index act in + for kk = l - ll to h - ll do + tbl.(kk) <- index + done + done; + let acts = Array.make !index actions.(0) in + Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; + fun ctx -> + Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts sw_names + + let make_clusters loc ({cases; actions} as s) n_clusters k sw_names = + let len = Array.length cases in + let r = Array.make n_clusters (0, 0, 0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i, _ = Hashtbl.find t act in + i + with Not_found -> let i = !index in - incr index ; - Hashtbl.add - t act - (i,(fun _ -> actions.(act))) ; + incr index; + Hashtbl.add t act (i, fun _ -> actions.(act)); i - and add_index act = - let i = !index in - incr index ; - incr bidon ; - Hashtbl.add t !bidon (i,act) ; - i in - - let rec zyva j ir = - let i = k.(j) in - begin if i=j then - let l,h,act = cases.(i) in - r.(ir) <- (l,h,get_index act) - else (* assert i < j *) - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - r.(ir) <- (l,h,add_index (make_switch loc s i j sw_names)) - end ; - if i > 0 then zyva (i-1) (ir-1) in - - zyva (len-1) (n_clusters-1) ; - let acts = Array.make !index (fun _ -> assert false) in - Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; - {cases = r ; actions = acts} -;; - - -let do_zyva loc (low,high) arg cases actions sw_names = - let old_ok = !ok_inter in - ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - - let s = {cases=cases ; actions=actions} in - -(* + and add_index act = + let i = !index in + incr index; + incr bidon; + Hashtbl.add t !bidon (i, act); + i + in + + let rec zyva j ir = + let i = k.(j) in + (if i = j then + let l, h, act = cases.(i) in + r.(ir) <- (l, h, get_index act) + else + (* assert i < j *) + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + r.(ir) <- (l, h, add_index (make_switch loc s i j sw_names))); + if i > 0 then zyva (i - 1) (ir - 1) + in + + zyva (len - 1) (n_clusters - 1); + let acts = Array.make !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; + {cases = r; actions = acts} + + let do_zyva loc (low, high) arg cases actions sw_names = + let old_ok = !ok_inter in + ok_inter := abs low <= inter_limit && abs high <= inter_limit; + if !ok_inter <> old_ok then Hashtbl.clear t; + + let s = {cases; actions} in + + (* Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; pcases stderr cases ; prerr_endline "" ; *) - let n_clusters,k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k sw_names in - c_test {arg=arg ; off=0} clusters - -let abstract_shared actions = - let handlers = ref (fun x -> x) in - let actions = - Array.map - (fun act -> match act with - | Single act -> act - | Shared act -> - let i,h = Arg.make_catch act in - let oh = !handlers in - handlers := (fun act -> h (oh act)) ; - Arg.make_exit i) - actions in - !handlers,actions - -let zyva loc lh arg cases actions names = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions names) - -and test_sequence arg cases actions = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - let s = - {cases=cases ; - actions=Array.map (fun act -> (fun _ -> act)) actions} in -(* + let n_clusters, k = comp_clusters s in + let clusters = make_clusters loc s n_clusters k sw_names in + c_test {arg; off = 0} clusters + + let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> + match act with + | Single act -> act + | Shared act -> + let i, h = Arg.make_catch act in + let oh = !handlers in + (handlers := fun act -> h (oh act)); + Arg.make_exit i) + actions + in + (!handlers, actions) + + let zyva loc lh arg cases actions names = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + hs (do_zyva loc lh arg cases actions names) + + and test_sequence arg cases actions = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + let old_ok = !ok_inter in + ok_inter := false; + if !ok_inter <> old_ok then Hashtbl.clear t; + let s = {cases; actions = Array.map (fun act _ -> act) actions} in + (* Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; pcases stderr cases ; prerr_endline "" ; *) - hs (c_test {arg=arg ; off=0} s) -;; - + hs (c_test {arg; off = 0} s) end diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index a12a1be0b7..8edf18a963 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -21,21 +21,22 @@ (* For detecting action sharing, object style *) (* Store for actions in object style: - act_store : store an action, returns index in table - In case an action with equal key exists, returns index - of the stored action. Otherwise add entry in table. - act_store_shared : This stored action will always be shared. - act_get : retrieve table - act_get_shared : retrieve table, with sharing explicit + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit *) type 'a shared = Shared of 'a | Single of 'a -type 'a t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'a -> int ; - act_store_shared : 'a -> int ; } +type 'a t_store = { + act_get: unit -> 'a array; + act_get_shared: unit -> 'a shared array; + act_store: 'a -> int; + act_store_shared: 'a -> int; +} exception Not_simple @@ -46,46 +47,52 @@ module type Stored = sig val make_key : t -> key option end -module Store(A:Stored) : - sig - val mk_store : unit -> A.t t_store - end +module Store (A : Stored) : sig + val mk_store : unit -> A.t t_store +end (* Arguments to the Make functor *) -module type S = - sig - (* type of basic tests *) - type primitive - (* basic tests themselves *) - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - (* type of actions *) - type act - - (* Various constructors, for making a binder, - adding one integer, etc. *) - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - (* construct an actual switch : - make_switch arg cases acts - NB: cases is in the value form *) - val make_switch : - Location.t -> act -> int array -> act array -> offset:int -> Ast_untagged_variants.switch_names option -> act - (* Build last minute sharing of action stuff *) - val make_catch : act -> int * (act -> act) - val make_exit : int -> act - - end +module type S = sig + (* type of basic tests *) + type primitive + + (* basic tests themselves *) + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + + (* type of actions *) + type act + + (* Various constructors, for making a binder, + adding one integer, etc. *) + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + (* construct an actual switch : + make_switch arg cases acts + NB: cases is in the value form *) + val make_switch : + Location.t -> + act -> + int array -> + act array -> + offset:int -> + Ast_untagged_variants.switch_names option -> + act + + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act +end (* Make.zyva arg low high cases actions where @@ -97,23 +104,18 @@ module type S = All these arguments specify a switch construct and zyva returns an action that performs the switch. *) -module Make : - functor (Arg : S) -> - sig -(* Standard entry point, sharing is tracked *) - val zyva : - Location.t -> - (int * int) -> - Arg.act -> - (int * int * int) array -> - Arg.act t_store -> - Ast_untagged_variants.switch_names option -> - Arg.act - -(* Output test sequence, sharing tracked *) - val test_sequence : - Arg.act -> - (int * int * int) array -> - Arg.act t_store -> - Arg.act - end +module Make : functor (Arg : S) -> sig + (* Standard entry point, sharing is tracked *) + val zyva : + Location.t -> + int * int -> + Arg.act -> + (int * int * int) array -> + Arg.act t_store -> + Ast_untagged_variants.switch_names option -> + Arg.act + + (* Output test sequence, sharing tracked *) + val test_sequence : + Arg.act -> (int * int * int) array -> Arg.act t_store -> Arg.act +end diff --git a/compiler/ml/syntaxerr.ml b/compiler/ml/syntaxerr.ml index 0bb55ab676..6bc31b6eaa 100644 --- a/compiler/ml/syntaxerr.ml +++ b/compiler/ml/syntaxerr.ml @@ -16,7 +16,7 @@ (* Auxiliary type for reporting syntax errors *) type error = - Unclosed of Location.t * string * Location.t * string + | Unclosed of Location.t * string * Location.t * string | Expecting of Location.t * string | Not_expecting of Location.t * string | Applicative_path of Location.t @@ -29,59 +29,52 @@ exception Error of error exception Escape_error let prepare_error = function - | Unclosed(opening_loc, opening, closing_loc, closing) -> - Location.errorf ~loc:closing_loc - ~sub:[ - Location.errorf ~loc:opening_loc - "This '%s' might be unmatched" opening + | Unclosed (opening_loc, opening, closing_loc, closing) -> + Location.errorf ~loc:closing_loc + ~sub: + [ + Location.errorf ~loc:opening_loc "This '%s' might be unmatched" opening; ] - ~if_highlight: - (Printf.sprintf "Syntax error: '%s' expected, \ - the highlighted '%s' might be unmatched" - closing opening) - "Syntax error: '%s' expected" closing - + ~if_highlight: + (Printf.sprintf + "Syntax error: '%s' expected, the highlighted '%s' might be \ + unmatched" + closing opening) + "Syntax error: '%s' expected" closing | Expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %s expected." nonterm + Location.errorf ~loc "Syntax error: %s expected." nonterm | Not_expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %s not expected." nonterm + Location.errorf ~loc "Syntax error: %s not expected." nonterm | Applicative_path loc -> - Location.errorf ~loc - "Syntax error: applicative paths of the form F(X).t \ - are not supported when the option -no-app-func is set." + Location.errorf ~loc + "Syntax error: applicative paths of the form F(X).t are not supported \ + when the option -no-app-func is set." | Variable_in_scope (loc, var) -> - Location.errorf ~loc - "In this scoped type, variable '%s \ - is reserved for the local type %s." - var var - | Other loc -> - Location.errorf ~loc "Syntax error" + Location.errorf ~loc + "In this scoped type, variable '%s is reserved for the local type %s." var + var + | Other loc -> Location.errorf ~loc "Syntax error" | Ill_formed_ast (loc, s) -> - Location.errorf ~loc "broken invariant in parsetree: %s" s + Location.errorf ~loc "broken invariant in parsetree: %s" s | Invalid_package_type (loc, s) -> - Location.errorf ~loc "invalid package type: %s" s + Location.errorf ~loc "invalid package type: %s" s let () = - Location.register_error_of_exn - (function - | Error err -> Some (prepare_error err) - | _ -> None - ) - + Location.register_error_of_exn (function + | Error err -> Some (prepare_error err) + | _ -> None) -let report_error ppf err = - Location.report_error ppf (prepare_error err) +let report_error ppf err = Location.report_error ppf (prepare_error err) let location_of_error = function - | Unclosed(l,_,_,_) + | Unclosed (l, _, _, _) | Applicative_path l - | Variable_in_scope(l,_) + | Variable_in_scope (l, _) | Other l | Not_expecting (l, _) | Ill_formed_ast (l, _) | Invalid_package_type (l, _) - | Expecting (l, _) -> l - + | Expecting (l, _) -> + l -let ill_formed_ast loc s = - raise (Error (Ill_formed_ast (loc, s))) +let ill_formed_ast loc s = raise (Error (Ill_formed_ast (loc, s))) diff --git a/compiler/ml/syntaxerr.mli b/compiler/ml/syntaxerr.mli index 319eb57948..b737acaaf3 100644 --- a/compiler/ml/syntaxerr.mli +++ b/compiler/ml/syntaxerr.mli @@ -18,7 +18,7 @@ open Format type error = - Unclosed of Location.t * string * Location.t * string + | Unclosed of Location.t * string * Location.t * string | Expecting of Location.t * string | Not_expecting of Location.t * string | Applicative_path of Location.t @@ -30,8 +30,8 @@ type error = exception Error of error exception Escape_error -val report_error: formatter -> error -> unit - (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *) +val report_error : formatter -> error -> unit +(** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *) -val location_of_error: error -> Location.t -val ill_formed_ast: Location.t -> string -> 'a +val location_of_error : error -> Location.t +val ill_formed_ast : Location.t -> string -> 'a diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 76c2e72fc2..cf01423a9c 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -19,46 +19,49 @@ open Typedtree (* TODO: add 'methods' for location, attribute, extension, open_description, include_declaration, include_description *) -type mapper = - { - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - env: mapper -> Env.t -> Env.t; - expr: mapper -> expression -> expression; - extension_constructor: mapper -> extension_constructor -> - extension_constructor; - module_binding: mapper -> module_binding -> module_binding; - module_coercion: mapper -> module_coercion -> module_coercion; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: - mapper -> module_type_declaration -> module_type_declaration; - package_type: mapper -> package_type -> package_type; - pat: mapper -> pattern -> pattern; - row_field: mapper -> row_field -> row_field; - object_field: mapper -> object_field -> object_field; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_declarations: mapper -> (rec_flag * type_declaration list) -> - (rec_flag * type_declaration list); - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_bindings: mapper -> (rec_flag * value_binding list) -> - (rec_flag * value_binding list); - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } +type mapper = { + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: mapper -> pattern -> pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: + mapper -> + rec_flag * type_declaration list -> + rec_flag * type_declaration list; + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: + mapper -> rec_flag * value_binding list -> rec_flag * value_binding list; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} let id x = x let tuple2 f1 f2 (x, y) = (f1 x, f2 y) let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let opt f = function None -> None | Some x -> Some (f x) +let opt f = function + | None -> None + | Some x -> Some (f x) let structure sub {str_items; str_type; str_final_env} = { @@ -77,31 +80,29 @@ let module_declaration sub x = let include_infos f x = {x with incl_mod = f x.incl_mod} - let structure_item sub {str_desc; str_loc; str_env} = let str_env = sub.env sub str_env in let str_desc = match str_desc with | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs) | Tstr_value (rec_flag, list) -> - let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in - Tstr_value (rec_flag, list) + let rec_flag, list = sub.value_bindings sub (rec_flag, list) in + Tstr_value (rec_flag, list) | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v) | Tstr_type (rec_flag, list) -> - let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in - Tstr_type (rec_flag, list) + let rec_flag, list = sub.type_declarations sub (rec_flag, list) in + Tstr_type (rec_flag, list) | Tstr_typext te -> Tstr_typext (sub.type_extension sub te) | Tstr_exception ext -> Tstr_exception (sub.extension_constructor sub ext) | Tstr_module mb -> Tstr_module (sub.module_binding sub mb) | Tstr_recmodule list -> - Tstr_recmodule (List.map (sub.module_binding sub) list) + Tstr_recmodule (List.map (sub.module_binding sub) list) | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x) | Tstr_class () -> Tstr_class () | Tstr_class_type () -> Tstr_class_type () | Tstr_include incl -> - Tstr_include (include_infos (sub.module_expr sub) incl) - | Tstr_open _ - | Tstr_attribute _ as d -> d + Tstr_include (include_infos (sub.module_expr sub) incl) + | (Tstr_open _ | Tstr_attribute _) as d -> d in {str_desc; str_env; str_loc} @@ -130,9 +131,7 @@ let type_kind sub = function let type_declaration sub x = let typ_cstrs = - List.map - (tuple3 (sub.typ sub) (sub.typ sub) id) - x.typ_cstrs + List.map (tuple3 (sub.typ sub) (sub.typ sub) id) x.typ_cstrs in let typ_kind = sub.type_kind sub x.typ_kind in let typ_manifest = opt (sub.typ sub) x.typ_manifest in @@ -152,35 +151,31 @@ let type_extension sub x = let extension_constructor sub x = let ext_kind = match x.ext_kind with - Text_decl(ctl, cto) -> - Text_decl(constructor_args sub ctl, opt (sub.typ sub) cto) + | Text_decl (ctl, cto) -> + Text_decl (constructor_args sub ctl, opt (sub.typ sub) cto) | Text_rebind _ as d -> d in {x with ext_kind} let pat sub x = let extra = function - | Tpat_type _ - | Tpat_unpack as d -> d - | Tpat_open (path,loc,env) -> Tpat_open (path, loc, sub.env sub env) + | (Tpat_type _ | Tpat_unpack) as d -> d + | Tpat_open (path, loc, env) -> Tpat_open (path, loc, sub.env sub env) | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) in let pat_env = sub.env sub x.pat_env in let pat_extra = List.map (tuple3 extra id id) x.pat_extra in let pat_desc = match x.pat_desc with - | Tpat_any - | Tpat_var _ - | Tpat_constant _ as d -> d + | (Tpat_any | Tpat_var _ | Tpat_constant _) as d -> d | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) | Tpat_construct (loc, cd, l) -> - Tpat_construct (loc, cd, List.map (sub.pat sub) l) + Tpat_construct (loc, cd, List.map (sub.pat sub) l) | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) | Tpat_record (l, closed) -> - Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) + Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) - | Tpat_or (p1, p2, rd) -> - Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) + | Tpat_or (p1, p2, rd) -> Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) in @@ -188,12 +183,10 @@ let pat sub x = let expr sub x = let extra = function - | Texp_constraint cty -> - Texp_constraint (sub.typ sub cty) - | Texp_coerce ((), cty2) -> - Texp_coerce ((), (sub.typ sub cty2)) + | Texp_constraint cty -> Texp_constraint (sub.typ sub cty) + | Texp_coerce ((), cty2) -> Texp_coerce ((), sub.typ sub cty2) | Texp_open (ovf, path, loc, env) -> - Texp_open (ovf, path, loc, sub.env sub env) + Texp_open (ovf, path, loc, sub.env sub env) | Texp_newtype _ as d -> d | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) in @@ -201,124 +194,69 @@ let expr sub x = let exp_env = sub.env sub x.exp_env in let exp_desc = match x.exp_desc with - | Texp_ident _ - | Texp_constant _ as d -> d + | (Texp_ident _ | Texp_constant _) as d -> d | Texp_let (rec_flag, list, exp) -> - let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in - Texp_let (rec_flag, list, sub.expr sub exp) - | Texp_function { arg_label; param; cases; partial; } -> - Texp_function { arg_label; param; cases = sub.cases sub cases; - partial; } + let rec_flag, list = sub.value_bindings sub (rec_flag, list) in + Texp_let (rec_flag, list, sub.expr sub exp) + | Texp_function {arg_label; param; cases; partial} -> + Texp_function {arg_label; param; cases = sub.cases sub cases; partial} | Texp_apply (exp, list) -> - Texp_apply ( - sub.expr sub exp, - List.map (tuple2 id (opt (sub.expr sub))) list - ) + Texp_apply + (sub.expr sub exp, List.map (tuple2 id (opt (sub.expr sub))) list) | Texp_match (exp, cases, exn_cases, p) -> - Texp_match ( - sub.expr sub exp, - sub.cases sub cases, - sub.cases sub exn_cases, - p - ) - | Texp_try (exp, cases) -> - Texp_try ( - sub.expr sub exp, - sub.cases sub cases - ) - | Texp_tuple list -> - Texp_tuple (List.map (sub.expr sub) list) + Texp_match + (sub.expr sub exp, sub.cases sub cases, sub.cases sub exn_cases, p) + | Texp_try (exp, cases) -> Texp_try (sub.expr sub exp, sub.cases sub cases) + | Texp_tuple list -> Texp_tuple (List.map (sub.expr sub) list) | Texp_construct (lid, cd, args) -> - Texp_construct (lid, cd, List.map (sub.expr sub) args) - | Texp_variant (l, expo) -> - Texp_variant (l, opt (sub.expr sub) expo) - | Texp_record { fields; representation; extended_expression } -> - let fields = Array.map (function - | label, Kept t -> label, Kept t + Texp_construct (lid, cd, List.map (sub.expr sub) args) + | Texp_variant (l, expo) -> Texp_variant (l, opt (sub.expr sub) expo) + | Texp_record {fields; representation; extended_expression} -> + let fields = + Array.map + (function + | label, Kept t -> (label, Kept t) | label, Overridden (lid, exp) -> - label, Overridden (lid, sub.expr sub exp)) - fields - in - Texp_record { - fields; representation; + (label, Overridden (lid, sub.expr sub exp))) + fields + in + Texp_record + { + fields; + representation; extended_expression = opt (sub.expr sub) extended_expression; } - | Texp_field (exp, lid, ld) -> - Texp_field (sub.expr sub exp, lid, ld) + | Texp_field (exp, lid, ld) -> Texp_field (sub.expr sub exp, lid, ld) | Texp_setfield (exp1, lid, ld, exp2) -> - Texp_setfield ( - sub.expr sub exp1, - lid, - ld, - sub.expr sub exp2 - ) - | Texp_array list -> - Texp_array (List.map (sub.expr sub) list) + Texp_setfield (sub.expr sub exp1, lid, ld, sub.expr sub exp2) + | Texp_array list -> Texp_array (List.map (sub.expr sub) list) | Texp_ifthenelse (exp1, exp2, expo) -> - Texp_ifthenelse ( - sub.expr sub exp1, - sub.expr sub exp2, - opt (sub.expr sub) expo - ) + Texp_ifthenelse + (sub.expr sub exp1, sub.expr sub exp2, opt (sub.expr sub) expo) | Texp_sequence (exp1, exp2) -> - Texp_sequence ( - sub.expr sub exp1, - sub.expr sub exp2 - ) + Texp_sequence (sub.expr sub exp1, sub.expr sub exp2) | Texp_while (exp1, exp2) -> - Texp_while ( - sub.expr sub exp1, - sub.expr sub exp2 - ) + Texp_while (sub.expr sub exp1, sub.expr sub exp2) | Texp_for (id, p, exp1, exp2, dir, exp3) -> - Texp_for ( - id, - p, - sub.expr sub exp1, - sub.expr sub exp2, - dir, - sub.expr sub exp3 - ) + Texp_for + (id, p, sub.expr sub exp1, sub.expr sub exp2, dir, sub.expr sub exp3) | Texp_send (exp, meth, expo) -> - Texp_send - ( - sub.expr sub exp, - meth, - opt (sub.expr sub) expo - ) - | Texp_new _ - | Texp_instvar _ as d -> d - | Texp_setinstvar _ - | Texp_override _ -> - assert false + Texp_send (sub.expr sub exp, meth, opt (sub.expr sub) expo) + | (Texp_new _ | Texp_instvar _) as d -> d + | Texp_setinstvar _ | Texp_override _ -> assert false | Texp_letmodule (id, s, mexpr, exp) -> - Texp_letmodule ( - id, - s, - sub.module_expr sub mexpr, - sub.expr sub exp - ) + Texp_letmodule (id, s, sub.module_expr sub mexpr, sub.expr sub exp) | Texp_letexception (cd, exp) -> - Texp_letexception ( - sub.extension_constructor sub cd, - sub.expr sub exp - ) - | Texp_assert exp -> - Texp_assert (sub.expr sub exp) - | Texp_lazy exp -> - Texp_lazy (sub.expr sub exp) - | Texp_object () -> - Texp_object () - | Texp_pack mexpr -> - Texp_pack (sub.module_expr sub mexpr) - | Texp_unreachable -> - Texp_unreachable - | Texp_extension_constructor _ as e -> - e + Texp_letexception (sub.extension_constructor sub cd, sub.expr sub exp) + | Texp_assert exp -> Texp_assert (sub.expr sub exp) + | Texp_lazy exp -> Texp_lazy (sub.expr sub exp) + | Texp_object () -> Texp_object () + | Texp_pack mexpr -> Texp_pack (sub.module_expr sub mexpr) + | Texp_unreachable -> Texp_unreachable + | Texp_extension_constructor _ as e -> e in {x with exp_extra; exp_desc; exp_env} - let package_type sub x = let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in {x with pack_fields} @@ -332,75 +270,59 @@ let signature_item sub x = let sig_env = sub.env sub x.sig_env in let sig_desc = match x.sig_desc with - | Tsig_value v -> - Tsig_value (sub.value_description sub v) + | Tsig_value v -> Tsig_value (sub.value_description sub v) | Tsig_type (rec_flag, list) -> - let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in - Tsig_type (rec_flag, list) - | Tsig_typext te -> - Tsig_typext (sub.type_extension sub te) - | Tsig_exception ext -> - Tsig_exception (sub.extension_constructor sub ext) - | Tsig_module x -> - Tsig_module (sub.module_declaration sub x) + let rec_flag, list = sub.type_declarations sub (rec_flag, list) in + Tsig_type (rec_flag, list) + | Tsig_typext te -> Tsig_typext (sub.type_extension sub te) + | Tsig_exception ext -> Tsig_exception (sub.extension_constructor sub ext) + | Tsig_module x -> Tsig_module (sub.module_declaration sub x) | Tsig_recmodule list -> - Tsig_recmodule (List.map (sub.module_declaration sub) list) - | Tsig_modtype x -> - Tsig_modtype (sub.module_type_declaration sub x) + Tsig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype x -> Tsig_modtype (sub.module_type_declaration sub x) | Tsig_include incl -> - Tsig_include (include_infos (sub.module_type sub) incl) - | Tsig_class_type _ - | Tsig_class _ - | Tsig_open _ - | Tsig_attribute _ as d -> d + Tsig_include (include_infos (sub.module_type sub) incl) + | (Tsig_class_type _ | Tsig_class _ | Tsig_open _ | Tsig_attribute _) as d + -> + d in {x with sig_desc; sig_env} - let module_type sub x = let mty_env = sub.env sub x.mty_env in let mty_desc = match x.mty_desc with - | Tmty_ident _ - | Tmty_alias _ as d -> d + | (Tmty_ident _ | Tmty_alias _) as d -> d | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) | Tmty_functor (id, s, mtype1, mtype2) -> - Tmty_functor ( - id, - s, - opt (sub.module_type sub) mtype1, - sub.module_type sub mtype2 - ) + Tmty_functor + (id, s, opt (sub.module_type sub) mtype1, sub.module_type sub mtype2) | Tmty_with (mtype, list) -> - Tmty_with ( - sub.module_type sub mtype, - List.map (tuple3 id id (sub.with_constraint sub)) list - ) - | Tmty_typeof mexpr -> - Tmty_typeof (sub.module_expr sub mexpr) + Tmty_with + ( sub.module_type sub mtype, + List.map (tuple3 id id (sub.with_constraint sub)) list ) + | Tmty_typeof mexpr -> Tmty_typeof (sub.module_expr sub mexpr) in {x with mty_desc; mty_env} let with_constraint sub = function | Twith_type decl -> Twith_type (sub.type_declaration sub decl) | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) - | Twith_module _ - | Twith_modsubst _ as d -> d + | (Twith_module _ | Twith_modsubst _) as d -> d let module_coercion sub = function | Tcoerce_none -> Tcoerce_none - | Tcoerce_functor (c1,c2) -> - Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) - | Tcoerce_alias (p, c1) -> - Tcoerce_alias (p, sub.module_coercion sub c1) + | Tcoerce_functor (c1, c2) -> + Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) + | Tcoerce_alias (p, c1) -> Tcoerce_alias (p, sub.module_coercion sub c1) | Tcoerce_structure (l1, l2, runtime_fields) -> - let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in - let l2' = - List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2 - in - Tcoerce_structure (l1', l2', runtime_fields) + let l1' = List.map (fun (i, c) -> (i, sub.module_coercion sub c)) l1 in + let l2' = + List.map (fun (id, i, c) -> (id, i, sub.module_coercion sub c)) l2 + in + Tcoerce_structure (l1', l2', runtime_fields) | Tcoerce_primitive pc -> - Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env} + Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env} let module_expr sub x = let mod_env = sub.env sub x.mod_env in @@ -409,34 +331,26 @@ let module_expr sub x = | Tmod_ident _ as d -> d | Tmod_structure st -> Tmod_structure (sub.structure sub st) | Tmod_functor (id, s, mtype, mexpr) -> - Tmod_functor ( - id, - s, - opt (sub.module_type sub) mtype, - sub.module_expr sub mexpr - ) + Tmod_functor + (id, s, opt (sub.module_type sub) mtype, sub.module_expr sub mexpr) | Tmod_apply (mexp1, mexp2, c) -> - Tmod_apply ( - sub.module_expr sub mexp1, + Tmod_apply + ( sub.module_expr sub mexp1, sub.module_expr sub mexp2, - sub.module_coercion sub c - ) + sub.module_coercion sub c ) | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> - Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit, - sub.module_coercion sub c) + Tmod_constraint + ( sub.module_expr sub mexpr, + mt, + Tmodtype_implicit, + sub.module_coercion sub c ) | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) -> - Tmod_constraint ( - sub.module_expr sub mexpr, + Tmod_constraint + ( sub.module_expr sub mexpr, mt, Tmodtype_explicit (sub.module_type sub mtype), - sub.module_coercion sub c - ) - | Tmod_unpack (exp, mty) -> - Tmod_unpack - ( - sub.expr sub exp, - mty - ) + sub.module_coercion sub c ) + | Tmod_unpack (exp, mty) -> Tmod_unpack (sub.expr sub exp, mty) in {x with mod_desc; mod_env} @@ -448,45 +362,36 @@ let typ sub x = let ctyp_env = sub.env sub x.ctyp_env in let ctyp_desc = match x.ctyp_desc with - | Ttyp_any - | Ttyp_var _ as d -> d + | (Ttyp_any | Ttyp_var _) as d -> d | Ttyp_arrow (label, ct1, ct2) -> - Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) | Ttyp_constr (path, lid, list) -> - Ttyp_constr (path, lid, List.map (sub.typ sub) list) + Ttyp_constr (path, lid, List.map (sub.typ sub) list) | Ttyp_object (list, closed) -> - Ttyp_object ((List.map (sub.object_field sub) list), closed) + Ttyp_object (List.map (sub.object_field sub) list, closed) | Ttyp_class () -> Ttyp_class () - | Ttyp_alias (ct, s) -> - Ttyp_alias (sub.typ sub ct, s) + | Ttyp_alias (ct, s) -> Ttyp_alias (sub.typ sub ct, s) | Ttyp_variant (list, closed, labels) -> - Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) - | Ttyp_poly (sl, ct) -> - Ttyp_poly (sl, sub.typ sub ct) - | Ttyp_package pack -> - Ttyp_package (sub.package_type sub pack) + Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) + | Ttyp_poly (sl, ct) -> Ttyp_poly (sl, sub.typ sub ct) + | Ttyp_package pack -> Ttyp_package (sub.package_type sub pack) in {x with ctyp_desc; ctyp_env} - let row_field sub = function | Ttag (label, attrs, b, list) -> - Ttag (label, attrs, b, List.map (sub.typ sub) list) + Ttag (label, attrs, b, List.map (sub.typ sub) list) | Tinherit ct -> Tinherit (sub.typ sub ct) let object_field sub = function - | OTtag (label, attrs, ct) -> - OTtag (label, attrs, (sub.typ sub ct)) + | OTtag (label, attrs, ct) -> OTtag (label, attrs, sub.typ sub ct) | OTinherit ct -> OTinherit (sub.typ sub ct) - - let value_bindings sub (rec_flag, list) = (rec_flag, List.map (sub.value_binding sub) list) -let cases sub l = - List.map (sub.case sub) l +let cases sub l = List.map (sub.case sub) l let case sub {c_lhs; c_guard; c_rhs} = { diff --git a/compiler/ml/tast_mapper.mli b/compiler/ml/tast_mapper.mli index f22f8aeac2..50f3ba23d0 100644 --- a/compiler/ml/tast_mapper.mli +++ b/compiler/ml/tast_mapper.mli @@ -18,41 +18,41 @@ open Typedtree (** {1 A generic Typedtree mapper} *) -type mapper = - { - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - env: mapper -> Env.t -> Env.t; - expr: mapper -> expression -> expression; - extension_constructor: mapper -> extension_constructor -> - extension_constructor; - module_binding: mapper -> module_binding -> module_binding; - module_coercion: mapper -> module_coercion -> module_coercion; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: - mapper -> module_type_declaration -> module_type_declaration; - package_type: mapper -> package_type -> package_type; - pat: mapper -> pattern -> pattern; - row_field: mapper -> row_field -> row_field; - object_field: mapper -> object_field -> object_field; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_declarations: mapper -> (rec_flag * type_declaration list) -> - (rec_flag * type_declaration list); - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_bindings: mapper -> (rec_flag * value_binding list) -> - (rec_flag * value_binding list); - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } +type mapper = { + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: mapper -> pattern -> pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: + mapper -> + rec_flag * type_declaration list -> + rec_flag * type_declaration list; + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: + mapper -> rec_flag * value_binding list -> rec_flag * value_binding list; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} - -val default: mapper +val default : mapper diff --git a/compiler/ml/tbl.ml b/compiler/ml/tbl.ml index fa278b43bb..d37ba50e77 100644 --- a/compiler/ml/tbl.ml +++ b/compiler/ml/tbl.ml @@ -13,111 +13,99 @@ (* *) (**************************************************************************) -type ('k, 'v) t = - Empty - | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int +type ('k, 'v) t = Empty | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int let empty = Empty let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h + | Empty -> 0 + | Node (_, _, _, _, h) -> h let create l x d r = let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1) let bal l x d r = let hl = height l and hr = height r in if hl > hr + 1 then match l with | Node (ll, lv, ld, lr, _) when height ll >= height lr -> - create ll lv ld (create lr x d r) + create ll lv ld (create lr x d r) | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) -> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) + create (create ll lv ld lrl) lrv lrd (create lrr x d r) | _ -> assert false else if hr > hl + 1 then match r with | Node (rl, rv, rd, rr, _) when height rr >= height rl -> - create (create l x d rl) rv rd rr + create (create l x d rl) rv rd rr | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) + create (create l x d rll) rlv rld (create rlr rv rd rr) | _ -> assert false - else - create l x d r + else create l x d r let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - let c = compare x v in - if c = 0 then - Node(l, x, data, r, h) - else if c < 0 then - bal (add x data l) v d r - else - bal l v d (add x data r) + | Empty -> Node (Empty, x, data, Empty, 1) + | Node (l, v, d, r, h) -> + let c = compare x v in + if c = 0 then Node (l, x, data, r, h) + else if c < 0 then bal (add x data l) v d r + else bal l v d (add x data r) let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = compare x v in - if c = 0 then d - else find x (if c < 0 then l else r) + | Empty -> raise Not_found + | Node (l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d else find x (if c < 0 then l else r) let rec find_str (x : string) = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = compare x v in - if c = 0 then d - else find_str x (if c < 0 then l else r) + | Empty -> raise Not_found + | Node (l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d else find_str x (if c < 0 then l else r) let rec mem x = function - Empty -> false - | Node(l, v, _d, r, _) -> - let c = compare x v in - c = 0 || mem x (if c < 0 then l else r) + | Empty -> false + | Node (l, v, _d, r, _) -> + let c = compare x v in + c = 0 || mem x (if c < 0 then l else r) let rec merge t1 t2 = match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) -> - bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) + | Empty, t -> t + | t, Empty -> t + | Node (l1, v1, d1, r1, _h1), Node (l2, v2, d2, r2, _h2) -> + bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) let rec remove x = function - Empty -> - Empty - | Node(l, v, d, r, _h) -> - let c = compare x v in - if c = 0 then - merge l r - else if c < 0 then - bal (remove x l) v d r - else - bal l v d (remove x r) + | Empty -> Empty + | Node (l, v, d, r, _h) -> + let c = compare x v in + if c = 0 then merge l r + else if c < 0 then bal (remove x l) v d r + else bal l v d (remove x r) let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r + | Empty -> () + | Node (l, v, d, r, _) -> + iter f l; + f v d; + iter f r let rec map f = function - Empty -> Empty - | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h) + | Empty -> Empty + | Node (l, v, d, r, h) -> Node (map f l, v, f v d, map f r, h) let rec fold f m accu = match m with | Empty -> accu - | Node(l, v, d, r, _) -> - fold f r (f v d (fold f l accu)) + | Node (l, v, d, r, _) -> fold f r (f v d (fold f l accu)) open Format let print print_key print_data ppf tbl = let print_tbl ppf tbl = - iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) - tbl in + iter + (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) + tbl + in fprintf ppf "@[[[%a]]@]" print_tbl tbl diff --git a/compiler/ml/tbl.mli b/compiler/ml/tbl.mli index d23b959c72..7d9296eb25 100644 --- a/compiler/ml/tbl.mli +++ b/compiler/ml/tbl.mli @@ -18,17 +18,21 @@ type ('k, 'v) t -val empty: ('k, 'v) t -val add: 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t -val find: 'k -> ('k, 'v) t -> 'v -val find_str: string -> (string, 'v) t -> 'v -val mem: 'k -> ('k, 'v) t -> bool -val remove: 'k -> ('k, 'v) t -> ('k, 'v) t -val iter: ('k -> 'v -> unit) -> ('k, 'v) t -> unit -val map: ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t -val fold: ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc +val empty : ('k, 'v) t +val add : 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t +val find : 'k -> ('k, 'v) t -> 'v +val find_str : string -> (string, 'v) t -> 'v +val mem : 'k -> ('k, 'v) t -> bool +val remove : 'k -> ('k, 'v) t -> ('k, 'v) t +val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit +val map : ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t +val fold : ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc open Format -val print: (formatter -> 'k -> unit) -> (formatter -> 'v -> unit) -> - formatter -> ('k, 'v) t -> unit +val print : + (formatter -> 'k -> unit) -> + (formatter -> 'v -> unit) -> + formatter -> + ('k, 'v) t -> + unit diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 0ec99a93b9..5d3cd38e59 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -27,38 +27,39 @@ let cstr_non_const = 2 let init_shape modl = let add_name x id = - Const_block - (Blk_tuple, [ x; Const_base (Const_string (Ident.name id, None)) ]) + Const_block (Blk_tuple, [x; Const_base (Const_string (Ident.name id, None))]) in let module_tag_info : Lambda.tag_info = - Blk_constructor { name="Module"; num_nonconst = 2; tag = 0; attrs = [] } + Blk_constructor {name = "Module"; num_nonconst = 2; tag = 0; attrs = []} in let value_tag_info : Lambda.tag_info = - Blk_constructor { name = "value"; num_nonconst = 2; tag = 1; attrs = [] } + Blk_constructor {name = "value"; num_nonconst = 2; tag = 1; attrs = []} in let rec init_shape_mod env mty = match Mtype.scrape env mty with | Mty_ident _ -> raise Not_found | Mty_alias _ -> - Const_block (value_tag_info, [ Const_pointer (0, Pt_module_alias) ]) + Const_block (value_tag_info, [Const_pointer (0, Pt_module_alias)]) | Mty_signature sg -> - Const_block - ( module_tag_info, - [ Const_block (Blk_tuple, init_shape_struct env sg) ] ) + Const_block + (module_tag_info, [Const_block (Blk_tuple, init_shape_struct env sg)]) | Mty_functor _ -> raise Not_found (* can we do better? *) and init_shape_struct env sg = match sg with | [] -> [] - | Sig_value (id, { val_kind = Val_reg; val_type = ty }) :: rem -> - let is_function t = - Ast_uncurried_utils.type_is_uncurried_fun t || match t.desc with - | Tarrow _ -> true - | _ -> false in - let init_v = - match Ctype.expand_head env ty with - | t when is_function t -> - Const_pointer + | Sig_value (id, {val_kind = Val_reg; val_type = ty}) :: rem -> + let is_function t = + Ast_uncurried_utils.type_is_uncurried_fun t + || + match t.desc with + | Tarrow _ -> true + | _ -> false + in + let init_v = + match Ctype.expand_head env ty with + | t when is_function t -> + Const_pointer ( 0, Pt_constructor { @@ -67,32 +68,30 @@ let init_shape modl = non_const = cstr_non_const; attrs = []; } ) - | { desc = Tconstr (p, _, _) } when Path.same p Predef.path_lazy_t -> - Const_pointer - ( 1, - Pt_constructor - { - name = "Lazy"; - const = cstr_const; - non_const = cstr_non_const; - attrs = []; - } ) - | _ -> raise Not_found - in - add_name init_v id :: init_shape_struct env rem - | Sig_value (_, { val_kind = Val_prim _ }) :: rem -> - init_shape_struct env rem + | {desc = Tconstr (p, _, _)} when Path.same p Predef.path_lazy_t -> + Const_pointer + ( 1, + Pt_constructor + { + name = "Lazy"; + const = cstr_const; + non_const = cstr_non_const; + attrs = []; + } ) + | _ -> raise Not_found + in + add_name init_v id :: init_shape_struct env rem + | Sig_value (_, {val_kind = Val_prim _}) :: rem -> init_shape_struct env rem | Sig_type (id, tdecl, _) :: rem -> - init_shape_struct (Env.add_type ~check:false id tdecl env) rem + init_shape_struct (Env.add_type ~check:false id tdecl env) rem | Sig_typext _ :: _ -> raise Not_found | Sig_module (id, md, _) :: rem -> - add_name (init_shape_mod env md.md_type) id - :: - init_shape_struct - (Env.add_module_declaration ~check:false id md env) - rem + add_name (init_shape_mod env md.md_type) id + :: init_shape_struct + (Env.add_module_declaration ~check:false id md env) + rem | Sig_modtype (id, minfo) :: rem -> - init_shape_struct (Env.add_modtype id minfo env) rem + init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class _ :: _ -> assert false | Sig_class_type _ :: rem -> init_shape_struct env rem in @@ -118,13 +117,13 @@ let reorder_rec_bindings bindings = | Defined -> () | Inprogress -> raise (Error (loc.(i), Circular_dependency id.(i))) | Undefined -> - if init.(i) = None then ( - status.(i) <- Inprogress; - for j = 0 to num_bindings - 1 do - if IdentSet.mem id.(j) fv.(i) then emit_binding j - done); - res := (id.(i), init.(i), rhs.(i)) :: !res; - status.(i) <- Defined + if init.(i) = None then ( + status.(i) <- Inprogress; + for j = 0 to num_bindings - 1 do + if IdentSet.mem id.(j) fv.(i) then emit_binding j + done); + res := (id.(i), init.(i), rhs.(i)) :: !res; + status.(i) <- Defined in for i = 0 to num_bindings - 1 do match status.(i) with @@ -150,18 +149,18 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | [] -> acc | (_id, None, _rhs) :: rem -> bind_inits rem acc | (id, Some (loc, shape), _rhs) :: rem -> - Lambda.Llet - ( Strict, - Pgenval, - id, - Lprim (Pinit_mod, [ loc; shape ], Location.none), - bind_inits rem acc ) + Lambda.Llet + ( Strict, + Pgenval, + id, + Lprim (Pinit_mod, [loc; shape], Location.none), + bind_inits rem acc ) in let rec bind_strict args acc = match args with | [] -> acc | (id, None, rhs) :: rem -> - Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) + Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) | (_id, Some _, _rhs) :: rem -> bind_strict rem acc in let rec patch_forwards args = @@ -169,9 +168,9 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | [] -> cont | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> - Lsequence - ( Lprim (Pupdate_mod, [ shape; Lvar id; rhs ], Location.none), - patch_forwards rem ) + Lsequence + ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), + patch_forwards rem ) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) @@ -182,27 +181,27 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = let rec is_function_or_const_block (lam : Lambda.lambda) acc = match lam with | Lprim (Pmakeblock _, args, _) -> - Ext_list.for_all args (fun x -> - match x with - | Lvar id -> Set_ident.mem acc id - | Lfunction _ | Lconst _ -> true - | _ -> false) + Ext_list.for_all args (fun x -> + match x with + | Lvar id -> Set_ident.mem acc id + | Lfunction _ | Lconst _ -> true + | _ -> false) | Llet (_, _, id, Lfunction _, cont) -> - is_function_or_const_block cont (Set_ident.add acc id) + is_function_or_const_block cont (Set_ident.add acc id) | Lletrec (bindings, cont) -> ( - let rec aux_bindings bindings acc = - match bindings with - | [] -> Some acc - | (id, Lambda.Lfunction _) :: rest -> - aux_bindings rest (Set_ident.add acc id) - | (_, _) :: _ -> None - in - match aux_bindings bindings acc with - | None -> false - | Some acc -> is_function_or_const_block cont acc) + let rec aux_bindings bindings acc = + match bindings with + | [] -> Some acc + | (id, Lambda.Lfunction _) :: rest -> + aux_bindings rest (Set_ident.add acc id) + | (_, _) :: _ -> None + in + match aux_bindings bindings acc with + | None -> false + | Some acc -> is_function_or_const_block cont acc) | Llet (_, _, _, Lconst _, cont) -> is_function_or_const_block cont acc | Llet (_, _, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> - is_function_or_const_block cont (Set_ident.add acc id1) + is_function_or_const_block cont (Set_ident.add acc id1) | _ -> false let is_strict_or_all_functions (xs : binding list) = @@ -214,14 +213,14 @@ let is_strict_or_all_functions (xs : binding list) = (* Without such optimizations: {[ - module rec X : sig - val f : int -> int - end = struct + module rec X : sig + val f : int -> int + end = struct let f x = x + 1 - end - and Y : sig - val f : int -> int - end = struct + end + and Y : sig + val f : int -> int + end = struct let f x = x + 2 end ]} @@ -252,17 +251,17 @@ let compile_recmodule compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings (List.map - (fun { mb_id = id; mb_expr = modl; mb_loc = loc; _ } -> + (fun {mb_id = id; mb_expr = modl; mb_loc = loc; _} -> (id, modl.mod_loc, init_shape modl, compile_rhs id modl loc)) bindings)) cont let report_error ppf = function | Circular_dependency id -> - Format.fprintf ppf - "@[Cannot safely evaluate the definition@ of the recursively-defined \ - module %a@]" - Printtyp.ident id + Format.fprintf ppf + "@[Cannot safely evaluate the definition@ of the recursively-defined \ + module %a@]" + Printtyp.ident id let () = Location.register_error_of_exn (function diff --git a/compiler/ml/transl_recmodule.mli b/compiler/ml/transl_recmodule.mli index a94a418466..8261108445 100644 --- a/compiler/ml/transl_recmodule.mli +++ b/compiler/ml/transl_recmodule.mli @@ -21,7 +21,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - val compile_recmodule : (Ident.t -> Typedtree.module_expr -> Location.t -> Lambda.lambda) -> Typedtree.module_binding list -> diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index d286de95ef..ed63ecbdf1 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -16,47 +16,51 @@ type t = Parsetree.attribute let is_inline_attribute (attr : t) = - match attr with { txt = "inline" }, _ -> true | _ -> false + match attr with + | {txt = "inline"}, _ -> true + | _ -> false let is_inlined_attribute (attr : t) = - match attr with { txt = "inlined" }, _ -> true | _ -> false + match attr with + | {txt = "inlined"}, _ -> true + | _ -> false let find_attribute p (attributes : t list) = let inline_attribute, other_attributes = List.partition p attributes in let attr = match inline_attribute with | [] -> None - | [ attr ] -> Some attr - | _ :: ({ txt; loc }, _) :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt); - None + | [attr] -> Some attr + | _ :: ({txt; loc}, _) :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt); + None in (attr, other_attributes) let parse_inline_attribute (attr : t option) : Lambda.inline_attribute = match attr with | None -> Default_inline - | Some ({ txt; loc }, payload) -> ( - let open Parsetree in - (* the 'inline' and 'inlined' attributes can be used as - [@inline], [@inline never] or [@inline always]. - [@inline] is equivalent to [@inline always] *) - let warning txt = - Warnings.Attribute_payload - (txt, "It must be either empty, 'always' or 'never'") - in - match payload with - | PStr [] -> Always_inline - | PStr [ { pstr_desc = Pstr_eval ({ pexp_desc }, []) } ] -> ( - match pexp_desc with - | Pexp_ident { txt = Longident.Lident "never" } -> Never_inline - | Pexp_ident { txt = Longident.Lident "always" } -> Always_inline - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline) + | Some ({txt; loc}, payload) -> ( + let open Parsetree in + (* the 'inline' and 'inlined' attributes can be used as + [@inline], [@inline never] or [@inline always]. + [@inline] is equivalent to [@inline always] *) + let warning txt = + Warnings.Attribute_payload + (txt, "It must be either empty, 'always' or 'never'") + in + match payload with + | PStr [] -> Always_inline + | PStr [{pstr_desc = Pstr_eval ({pexp_desc}, [])}] -> ( + match pexp_desc with + | Pexp_ident {txt = Longident.Lident "never"} -> Never_inline + | Pexp_ident {txt = Longident.Lident "always"} -> Always_inline | _ -> - Location.prerr_warning loc (warning txt); - Default_inline) + Location.prerr_warning loc (warning txt); + Default_inline) + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline) let get_inline_attribute l = let attr, _ = find_attribute is_inline_attribute l in @@ -65,21 +69,21 @@ let get_inline_attribute l = let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = match (expr, get_inline_attribute attributes) with | expr, Default_inline -> expr - | Lfunction ({ attr } as funct), inline -> - (match attr.inline with - | Default_inline -> () - | Always_inline | Never_inline -> - Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); - let attr = { attr with inline } in - Lfunction { funct with attr } - | Lprim (Pjs_fn_make _ | Pjs_fn_make_unit as p, [e], l), _ -> + | Lfunction ({attr} as funct), inline -> + (match attr.inline with + | Default_inline -> () + | Always_inline | Never_inline -> + Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); + let attr = {attr with inline} in + Lfunction {funct with attr} + | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l), _ -> Lambda.Lprim (p, [add_inline_attribute e loc attributes], l) - | expr, (Always_inline) -> - Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); - expr - | expr, (Never_inline) -> - Location.prerr_warning loc (Warnings.Misplaced_attribute "inline2"); - expr + | expr, Always_inline -> + Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); + expr + | expr, Never_inline -> + Location.prerr_warning loc (Warnings.Misplaced_attribute "inline2"); + expr (* Get the [@inlined] attribute payload (or default if not present). It also returns the expression without this attribute. This is @@ -91,34 +95,34 @@ let get_and_remove_inlined_attribute (e : Typedtree.expression) = find_attribute is_inlined_attribute e.exp_attributes in let inlined = parse_inline_attribute attr in - (inlined, { e with exp_attributes }) + (inlined, {e with exp_attributes}) let get_and_remove_inlined_attribute_on_module (e : Typedtree.module_expr) = let attr, mod_attributes = find_attribute is_inlined_attribute e.mod_attributes in let inlined = parse_inline_attribute attr in - (inlined, { e with mod_attributes }) + (inlined, {e with mod_attributes}) -let check_attribute (e : Typedtree.expression) (({ txt; loc }, _) : t) = +let check_attribute (e : Typedtree.expression) (({txt; loc}, _) : t) = match txt with | "inline" -> ( - match e.exp_desc with - | Texp_function _ -> () - | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) + match e.exp_desc with + | Texp_function _ -> () + | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) | "inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc (Warnings.Misplaced_attribute txt) + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc (Warnings.Misplaced_attribute txt) | _ -> () -let check_attribute_on_module (e : Typedtree.module_expr) - (({ txt; loc }, _) : t) = +let check_attribute_on_module (e : Typedtree.module_expr) (({txt; loc}, _) : t) + = match txt with | "inline" -> ( - match e.mod_desc with - | Tmod_functor _ -> () - | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) + match e.mod_desc with + | Tmod_functor _ -> () + | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) | "inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc (Warnings.Misplaced_attribute txt) + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc (Warnings.Misplaced_attribute txt) | _ -> () diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index f9ea9c80e4..4b080b5f14 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -50,13 +50,13 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) type specialized = { - objcomp : Lambda.primitive; - intcomp : Lambda.primitive; - boolcomp : Lambda.primitive; - floatcomp : Lambda.primitive; - stringcomp : Lambda.primitive; - bigintcomp : Lambda.primitive; - simplify_constant_constructor : bool; + objcomp: Lambda.primitive; + intcomp: Lambda.primitive; + boolcomp: Lambda.primitive; + floatcomp: Lambda.primitive; + stringcomp: Lambda.primitive; + bigintcomp: Lambda.primitive; + simplify_constant_constructor: bool; } let comparisons_table = @@ -182,7 +182,6 @@ let comparisons_table = bigintcomp = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); - (* FIXME: Core compatibility *) ( "%bs_min", { @@ -213,21 +212,17 @@ let primitives_table = ("%ignore", Pignore); ("%revapply", Prevapply); ("%apply", Pdirapply); - ("%loc_LOC", Ploc Loc_LOC); ("%loc_FILE", Ploc Loc_FILE); ("%loc_LINE", Ploc Loc_LINE); ("%loc_POS", Ploc Loc_POS); ("%loc_MODULE", Ploc Loc_MODULE); - (* BEGIN Triples for ref data type *) ("%makeref", Pmakeblock Lambda.ref_tag_info); ("%refset", Psetfield (0, Lambda.ref_field_set_info)); ("%refget", Pfield (0, Lambda.ref_field_info)); - ("%incr", Poffsetref 1); ("%decr", Poffsetref (-1)); - (* Finish Triples for ref data type *) ("%field0", Pfield (0, Fld_tuple)); ("%field1", Pfield (1, Fld_tuple)); @@ -236,9 +231,7 @@ let primitives_table = ("%obj_size", Pobjsize); ("%obj_get_field", Parrayrefu); ("%obj_set_field", Parraysetu); - ("%raise", Praise Raise_regular); - (* bool primitives *) ("%sequand", Psequand); ("%sequor", Psequor); @@ -246,7 +239,6 @@ let primitives_table = ("%boolorder", Pboolorder); ("%boolmin", Pboolmin); ("%boolmax", Pboolmax); - (* int primitives *) ("%obj_is_int", Pisint); ("%negint", Pnegint); @@ -272,7 +264,6 @@ let primitives_table = ("%intorder", Pintorder); ("%intmin", Pintmin); ("%intmax", Pintmax); - (* float primitives *) ("%negfloat", Pnegfloat); ("%absfloat", Pabsfloat); @@ -290,7 +281,6 @@ let primitives_table = ("%floatorder", Pfloatorder); ("%floatmin", Pfloatmin); ("%floatmax", Pfloatmax); - (* bigint primitives *) ("%negbigint", Pnegbigint); ("%addbigint", Paddbigint); @@ -313,7 +303,6 @@ let primitives_table = ("%bigintorder", Pbigintorder); ("%bigintmin", Pbigintmin); ("%bigintmax", Pbigintmax); - (* string primitives *) ("%string_length", Pstringlength); ("%string_safe_get", Pstringrefs); @@ -322,29 +311,23 @@ let primitives_table = ("%stringmin", Pstringmin); ("%stringmax", Pstringmax); ("%string_concat", Pstringadd); - (* array primitives *) ("%array_length", Parraylength); ("%array_safe_get", Parrayrefs); ("%array_safe_set", Parraysets); ("%array_unsafe_get", Parrayrefu); ("%array_unsafe_set", Parraysetu); - (* dict primitives *) ("%makedict", Pmakedict); - (* promise *) ("%await", Pawait); - (* module *) ("%import", Pimport); - (* hash *) ("%hash", Phash); ("%hash_mix_int", Phash_mixint); ("%hash_mix_string", Phash_mixstring); ("%hash_final_mix", Phash_finalmix); - (* etc *) ("%typeof", Ptypeof); ("%debugger", Pdebugger); @@ -374,11 +357,9 @@ let primitives_table = ("%curry_apply8", Pcurry_apply 8); ("%makemutablelist", Pmakelist Mutable); ("%unsafe_to_method", Pjs_fn_method); - (* Compiler internals, never expose to ReScript files *) ("#raw_expr", Pjs_raw_expr); ("#raw_stmt", Pjs_raw_stmt); - (* FIXME: Core compatibility *) ("#null", Pundefined); ("#undefined", Pundefined); @@ -388,7 +369,6 @@ let primitives_table = ("#nullable_to_opt", Pnull_to_opt); ("#undefined_to_opt", Pundefined_to_opt); ("#makemutablelist", Pmakelist Mutable); - (* FIXME: Deprecated *) ("%obj_field", Parrayrefu); |] @@ -396,14 +376,14 @@ let primitives_table = let find_primitive prim_name = Hashtbl.find primitives_table prim_name let specialize_comparison - ({ objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp } : + ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : specialized) env ty = match () with | () when is_base_type env ty Predef.path_int || is_base_type env ty Predef.path_char || maybe_pointer_type env ty = Immediate -> - intcomp + intcomp | () when is_base_type env ty Predef.path_float -> floatcomp | () when is_base_type env ty Predef.path_string -> stringcomp | () when is_base_type env ty Predef.path_bigint -> bigintcomp @@ -411,7 +391,7 @@ let specialize_comparison | () -> objcomp (* Specialize a primitive from available type information, - raise Not_found if primitive is unknown *) + raise Not_found if primitive is unknown *) let specialize_primitive p env ty (* ~has_constant_constructor *) = try @@ -431,85 +411,75 @@ let transl_primitive loc p env ty = in match prim with | Plazyforce -> - let parm = Ident.create "prim" in + let parm = Ident.create "prim" in + Lfunction + { + params = [parm]; + body = Matching.inline_lazy_force (Lvar parm) Location.none; + loc; + attr = default_function_attribute; + } + | Ploc kind -> ( + let lam = lam_of_loc kind loc in + match p.prim_arity with + | 0 -> lam + | 1 -> + (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in Lfunction { - params = [ parm ]; - body = Matching.inline_lazy_force (Lvar parm) Location.none; - loc; + params = [param]; attr = default_function_attribute; + loc; + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); } - | Ploc kind -> ( - let lam = lam_of_loc kind loc in - match p.prim_arity with - | 0 -> lam - | 1 -> - (* TODO: we should issue a warning ? *) - let param = Ident.create "prim" in - Lfunction - { - params = [ param ]; - attr = default_function_attribute; - loc; - body = Lprim (Pmakeblock Blk_tuple, [ lam; Lvar param ], loc); - } - | _ -> assert false) + | _ -> assert false) | _ -> - let rec make_params n total = - if n <= 0 then [] - else - Ident.create ("prim" ^ string_of_int (total - n)) - :: make_params (n - 1) total - in - let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) + let rec make_params n total = + if n <= 0 then [] else - let params = - if prim_arity = 1 then [ Ident.create "prim" ] - else make_params prim_arity prim_arity - in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); - } + Ident.create ("prim" ^ string_of_int (total - n)) + :: make_params (n - 1) total + in + let prim_arity = p.prim_arity in + if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) + else + let params = + if prim_arity = 1 then [Ident.create "prim"] + else make_params prim_arity prim_arity + in + Lfunction + { + params; + attr = default_function_attribute; + loc; + body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); + } let transl_primitive_application loc prim env ty args = let prim_name = prim.prim_name in try match args with - | [ arg1; _ ] + | [arg1; _] when is_base_type env arg1.exp_type Predef.path_bool && Hashtbl.mem comparisons_table prim_name -> - (Hashtbl.find comparisons_table prim_name).boolcomp + (Hashtbl.find comparisons_table prim_name).boolcomp | _ -> - let has_constant_constructor = - match args with - | [ - _; - { - exp_desc = Texp_construct (_, { cstr_tag = Cstr_constant _ }, _); - }; - ] - | [ - { - exp_desc = Texp_construct (_, { cstr_tag = Cstr_constant _ }, _); - }; - _; - ] - | [ _; { exp_desc = Texp_variant (_, None) } ] - | [ { exp_desc = Texp_variant (_, None) }; _ ] -> - true - | _ -> false - in - if has_constant_constructor then - match Hashtbl.find_opt comparisons_table prim_name with - | Some table when table.simplify_constant_constructor -> table.intcomp - | Some _ | None -> specialize_primitive prim env ty - (* ~has_constant_constructor*) - else specialize_primitive prim env ty + let has_constant_constructor = + match args with + | [_; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}] + | [{exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _] + | [_; {exp_desc = Texp_variant (_, None)}] + | [{exp_desc = Texp_variant (_, None)}; _] -> + true + | _ -> false + in + if has_constant_constructor then + match Hashtbl.find_opt comparisons_table prim_name with + | Some table when table.simplify_constant_constructor -> table.intcomp + | Some _ | None -> specialize_primitive prim env ty + (* ~has_constant_constructor*) + else specialize_primitive prim env ty with Not_found -> if String.length prim_name > 0 && prim_name.[0] = '%' then raise (Error (loc, Unknown_builtin_primitive prim_name)); @@ -537,110 +507,104 @@ let rec push_defaults loc bindings cases partial = c_lhs = pat; c_guard = None; c_rhs = - { exp_desc = Texp_function { arg_label; param; cases; partial } } as exp; + {exp_desc = Texp_function {arg_label; param; cases; partial}} as exp; }; ] -> - let cases = push_defaults exp.exp_loc bindings cases partial in - [ - { - c_lhs = pat; - c_guard = None; - c_rhs = - { - exp with - exp_desc = Texp_function { arg_label; param; cases; partial }; - }; - }; - ] + let cases = push_defaults exp.exp_loc bindings cases partial in + [ + { + c_lhs = pat; + c_guard = None; + c_rhs = + {exp with exp_desc = Texp_function {arg_label; param; cases; partial}}; + }; + ] | [ { c_lhs = pat; c_guard = None; c_rhs = { - exp_attributes = [ ({ txt = "#default" }, _) ]; + exp_attributes = [({txt = "#default"}, _)]; exp_desc = - Texp_let (Nonrecursive, binds, ({ exp_desc = Texp_function _ } as e2)); + Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2)); }; }; ] -> - push_defaults loc - (Bind_value binds :: bindings) - [ { c_lhs = pat; c_guard = None; c_rhs = e2 } ] - partial + push_defaults loc + (Bind_value binds :: bindings) + [{c_lhs = pat; c_guard = None; c_rhs = e2}] + partial | [ { c_lhs = pat; c_guard = None; c_rhs = { - exp_attributes = [ ({ txt = "#modulepat" }, _) ]; + exp_attributes = [({txt = "#modulepat"}, _)]; exp_desc = - Texp_letmodule - (id, name, mexpr, ({ exp_desc = Texp_function _ } as e2)); + Texp_letmodule (id, name, mexpr, ({exp_desc = Texp_function _} as e2)); }; }; ] -> - push_defaults loc - (Bind_module (id, name, mexpr) :: bindings) - [ { c_lhs = pat; c_guard = None; c_rhs = e2 } ] - partial - | [ case ] -> - let exp = - List.fold_left - (fun exp binds -> - { - exp with - exp_desc = - (match binds with - | Bind_value binds -> Texp_let (Nonrecursive, binds, exp) - | Bind_module (id, name, mexpr) -> - Texp_letmodule (id, name, mexpr, exp)); - }) - case.c_rhs bindings - in - [ { case with c_rhs = exp } ] - | { c_lhs = pat; c_rhs = exp; c_guard = _ } :: _ when bindings <> [] -> - let param = Typecore.name_pattern "param" cases in - let name = Ident.name param in - let exp = - { - exp with - exp_loc = loc; - exp_desc = - Texp_match - ( { - exp with - exp_type = pat.pat_type; - exp_desc = - Texp_ident - ( Path.Pident param, - mknoloc (Longident.Lident name), - { - val_type = pat.pat_type; - val_kind = Val_reg; - val_attributes = []; - Types.val_loc = Location.none; - } ); - }, - cases, - [], - partial ); - } - in - push_defaults loc bindings - [ + push_defaults loc + (Bind_module (id, name, mexpr) :: bindings) + [{c_lhs = pat; c_guard = None; c_rhs = e2}] + partial + | [case] -> + let exp = + List.fold_left + (fun exp binds -> { - c_lhs = { pat with pat_desc = Tpat_var (param, mknoloc name) }; - c_guard = None; - c_rhs = exp; - }; - ] - Total + exp with + exp_desc = + (match binds with + | Bind_value binds -> Texp_let (Nonrecursive, binds, exp) + | Bind_module (id, name, mexpr) -> + Texp_letmodule (id, name, mexpr, exp)); + }) + case.c_rhs bindings + in + [{case with c_rhs = exp}] + | {c_lhs = pat; c_rhs = exp; c_guard = _} :: _ when bindings <> [] -> + let param = Typecore.name_pattern "param" cases in + let name = Ident.name param in + let exp = + { + exp with + exp_loc = loc; + exp_desc = + Texp_match + ( { + exp with + exp_type = pat.pat_type; + exp_desc = + Texp_ident + ( Path.Pident param, + mknoloc (Longident.Lident name), + { + val_type = pat.pat_type; + val_kind = Val_reg; + val_attributes = []; + Types.val_loc = Location.none; + } ); + }, + cases, + [], + partial ); + } + in + push_defaults loc bindings + [ + { + c_lhs = {pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard = None; + c_rhs = exp; + }; + ] + Total | _ -> cases - - (* Assertions *) let assert_failed exp = @@ -674,19 +638,21 @@ let rec cut n l = match l with | [] -> failwith "Translcore.cut" | a :: l -> - let l1, l2 = cut (n - 1) l in - (a :: l1, l2) + let l1, l2 = cut (n - 1) l in + (a :: l1, l2) (* Translation of expressions *) let try_ids = Hashtbl.create 8 -let has_async_attribute exp = exp.exp_attributes |> List.exists (fun ({txt}, _payload) -> txt = "res.async") - -let extract_directive_for_fn exp = - exp.exp_attributes |> List.find_map ( - fun ({txt}, payload) -> if txt = "directive" then Ast_payload.is_single_string payload else None) +let has_async_attribute exp = + exp.exp_attributes |> List.exists (fun ({txt}, _payload) -> txt = "res.async") +let extract_directive_for_fn exp = + exp.exp_attributes + |> List.find_map (fun ({txt}, payload) -> + if txt = "directive" then Ast_payload.is_single_string payload + else None) let rec transl_exp e = List.iter (Translattribute.check_attribute e) e.exp_attributes; @@ -694,278 +660,283 @@ let rec transl_exp e = and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match e.exp_desc with - | Texp_ident (_, _, { val_kind = Val_prim p }) -> - transl_primitive e.exp_loc p e.exp_env e.exp_type - | Texp_ident (path, _, { val_kind = Val_reg }) -> - transl_value_path ~loc:e.exp_loc e.exp_env path + | Texp_ident (_, _, {val_kind = Val_prim p}) -> + transl_primitive e.exp_loc p e.exp_env e.exp_type + | Texp_ident (path, _, {val_kind = Val_reg}) -> + transl_value_path ~loc:e.exp_loc e.exp_env path | Texp_constant cst -> Lconst (Const_base cst) | Texp_let (rec_flag, pat_expr_list, body) -> - transl_let rec_flag pat_expr_list (transl_exp body) - | Texp_function { arg_label = _; param; cases; partial } -> - let async = has_async_attribute e in - let directive = ( - match extract_directive_for_fn e with - | None -> None - | Some (directive, _) -> Some directive - ) in - let params, body, return_unit = - let pl = push_defaults e.exp_loc [] cases partial in - transl_function e.exp_loc partial param pl - in - let attr = - { - default_function_attribute with - inline = Translattribute.get_inline_attribute e.exp_attributes; - async; - return_unit; - directive; - } - in - let loc = e.exp_loc in - Lfunction { params; body; attr; loc } + transl_let rec_flag pat_expr_list (transl_exp body) + | Texp_function {arg_label = _; param; cases; partial} -> + let async = has_async_attribute e in + let directive = + match extract_directive_for_fn e with + | None -> None + | Some (directive, _) -> Some directive + in + let params, body, return_unit = + let pl = push_defaults e.exp_loc [] cases partial in + transl_function e.exp_loc partial param pl + in + let attr = + { + default_function_attribute with + inline = Translattribute.get_inline_attribute e.exp_attributes; + async; + return_unit; + directive; + } + in + let loc = e.exp_loc in + Lfunction {params; body; attr; loc} | Texp_apply ( ({ - exp_desc = Texp_ident (_, _, { val_kind = Val_prim p }); + exp_desc = Texp_ident (_, _, {val_kind = Val_prim p}); exp_type = prim_type; } as funct), oargs ) when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( - let args, args' = cut p.prim_arity oargs in - let wrap f = - if args' = [] then f - else - let inlined, _ = - Translattribute.get_and_remove_inlined_attribute funct - in - transl_apply ~inlined f args' e.exp_loc - in - let args = - List.map (function _, Some x -> x | _ -> assert false) args - in - let argl = transl_list args in - let prim = - transl_primitive_application e.exp_loc p e.exp_env prim_type args + let args, args' = cut p.prim_arity oargs in + let wrap f = + if args' = [] then f + else + let inlined, _ = + Translattribute.get_and_remove_inlined_attribute funct + in + transl_apply ~inlined f args' e.exp_loc + in + let args = + List.map + (function + | _, Some x -> x + | _ -> assert false) + args + in + let argl = transl_list args in + let prim = + transl_primitive_application e.exp_loc p e.exp_env prim_type args + in + match (prim, args) with + | Praise k, [_] -> + let targ = List.hd argl in + let k = + match (k, targ) with + | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> Raise_reraise + | _ -> k in - match (prim, args) with - | Praise k, [ _ ] -> - let targ = List.hd argl in - let k = - match (k, targ) with - | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> - Raise_reraise - | _ -> k - in - wrap (Lprim (Praise k, [ targ ], e.exp_loc)) - | Ploc kind, [] -> lam_of_loc kind e.exp_loc - | Ploc kind, [ arg1 ] -> - let lam = lam_of_loc kind arg1.exp_loc in - Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) - | Ploc _, _ -> assert false - | _, _ -> ( - match (prim, argl) with - | Plazyforce, [ a ] -> wrap (Matching.inline_lazy_force a e.exp_loc) - | Plazyforce, _ -> assert false - | _ -> - wrap (Lprim (prim, argl, e.exp_loc)) - )) + wrap (Lprim (Praise k, [targ], e.exp_loc)) + | Ploc kind, [] -> lam_of_loc kind e.exp_loc + | Ploc kind, [arg1] -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) + | Ploc _, _ -> assert false + | _, _ -> ( + match (prim, argl) with + | Plazyforce, [a] -> wrap (Matching.inline_lazy_force a e.exp_loc) + | Plazyforce, _ -> assert false + | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) | Texp_apply (funct, oargs) -> - let inlined, funct = - Translattribute.get_and_remove_inlined_attribute funct + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let uncurried_partial_application = + (* In case of partial application foo(args, ...) when some args are missing, + get the arity *) + let uncurried_partial_app = + Ext_list.exists e.exp_attributes (fun ({txt}, _) -> txt = "res.partial") in - let uncurried_partial_application = - (* In case of partial application foo(args, ...) when some args are missing, - get the arity *) - let uncurried_partial_app = Ext_list.exists e.exp_attributes (fun ({txt },_) -> txt = "res.partial") in - if uncurried_partial_app then - let arity_opt = Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env funct.exp_type in - match arity_opt with - | Some arity -> - let real_args = List.filter (fun (_, x) -> Option.is_some x) oargs in - if arity > List.length real_args then - Some arity - else None - | None -> None - else - None in - transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) oargs e.exp_loc + if uncurried_partial_app then + let arity_opt = + Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env + funct.exp_type + in + match arity_opt with + | Some arity -> + let real_args = List.filter (fun (_, x) -> Option.is_some x) oargs in + if arity > List.length real_args then Some arity else None + | None -> None + else None + in + transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) + oargs e.exp_loc | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> - transl_match e arg pat_expr_list exn_pat_expr_list partial + transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try (body, pat_expr_list) -> - let id = Typecore.name_pattern "exn" pat_expr_list in - Ltrywith - ( transl_exp body, - id, - Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list) ) + let id = Typecore.name_pattern "exn" pat_expr_list in + Ltrywith + ( transl_exp body, + id, + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list) ) | Texp_tuple el -> ( - let ll = transl_list el in - try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) - | Texp_construct ({ txt = Lident "false" }, _, []) -> Lconst Const_false - | Texp_construct ({ txt = Lident "true" }, _, []) -> Lconst Const_true - | Texp_construct ({ txt = Lident "Function$"}, _, [expr]) -> - (* ReScript uncurried encoding *) - let loc = expr.exp_loc in - let lambda = transl_exp expr in - let arity = Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type in - let prim = - match (Ctype.expand_head expr.exp_env expr.exp_type).desc with - | Tarrow (Nolabel, t, _, _) -> ( - match (Ctype.expand_head expr.exp_env t).desc with - | Tconstr (Pident {name= "unit"}, [], _) -> Pjs_fn_make_unit - | _ -> Pjs_fn_make arity - ) - | _ -> Pjs_fn_make arity - in - Lprim - ( prim - (* could be replaced with Opaque in the future except arity 0*), - [ lambda ], - loc ) + let ll = transl_list el in + try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) + with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) + | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false + | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true + | Texp_construct ({txt = Lident "Function$"}, _, [expr]) -> + (* ReScript uncurried encoding *) + let loc = expr.exp_loc in + let lambda = transl_exp expr in + let arity = + Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type + in + let prim = + match (Ctype.expand_head expr.exp_env expr.exp_type).desc with + | Tarrow (Nolabel, t, _, _) -> ( + match (Ctype.expand_head expr.exp_env t).desc with + | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit + | _ -> Pjs_fn_make arity) + | _ -> Pjs_fn_make arity + in + Lprim + ( prim (* could be replaced with Opaque in the future except arity 0*), + [lambda], + loc ) | Texp_construct (lid, cstr, args) -> ( - let ll = transl_list args in - if cstr.cstr_inlined <> None then - match ll with [ x ] -> x | _ -> assert false - else - match cstr.cstr_tag with - | Cstr_constant n -> - Lconst - (Const_pointer - ( n, - match lid.txt with - | Longident.Ldot (Longident.Lident "*predef*", "None") - | Longident.Lident "None" - when Datarepr.constructor_has_optional_shape cstr -> - Pt_shape_none - | _ -> - if Datarepr.constructor_has_optional_shape cstr then - Pt_shape_none - else - Pt_constructor - { - name = cstr.cstr_name; - const = cstr.cstr_consts; - non_const = cstr.cstr_nonconsts; - attrs = cstr.cstr_attributes; - } )) - | Cstr_unboxed -> ( match ll with [ v ] -> v | _ -> assert false) - | Cstr_block n -> ( - let tag_info : Lambda.tag_info = - if Datarepr.constructor_has_optional_shape cstr then - match args with - | [ arg ] - when Typeopt.type_cannot_contain_undefined arg.exp_type - arg.exp_env -> - (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) - Blk_some_not_nested - | _ -> Blk_some - else - Blk_constructor - { - name = cstr.cstr_name; - num_nonconst = cstr.cstr_nonconsts; - tag = n; - attrs = cstr.cstr_attributes; - } - in - try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) - | Cstr_extension (path) -> - Lprim - ( Pmakeblock Blk_extension, - transl_extension_path e.exp_env path :: ll, - e.exp_loc )) + let ll = transl_list args in + if cstr.cstr_inlined <> None then + match ll with + | [x] -> x + | _ -> assert false + else + match cstr.cstr_tag with + | Cstr_constant n -> + Lconst + (Const_pointer + ( n, + match lid.txt with + | Longident.Ldot (Longident.Lident "*predef*", "None") + | Longident.Lident "None" + when Datarepr.constructor_has_optional_shape cstr -> + Pt_shape_none + | _ -> + if Datarepr.constructor_has_optional_shape cstr then + Pt_shape_none + else + Pt_constructor + { + name = cstr.cstr_name; + const = cstr.cstr_consts; + non_const = cstr.cstr_nonconsts; + attrs = cstr.cstr_attributes; + } )) + | Cstr_unboxed -> ( + match ll with + | [v] -> v + | _ -> assert false) + | Cstr_block n -> ( + let tag_info : Lambda.tag_info = + if Datarepr.constructor_has_optional_shape cstr then + match args with + | [arg] + when Typeopt.type_cannot_contain_undefined arg.exp_type + arg.exp_env -> + (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) + Blk_some_not_nested + | _ -> Blk_some + else + Blk_constructor + { + name = cstr.cstr_name; + num_nonconst = cstr.cstr_nonconsts; + tag = n; + attrs = cstr.cstr_attributes; + } + in + try Lconst (Const_block (tag_info, List.map extract_constant ll)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + | Cstr_extension path -> + Lprim + ( Pmakeblock Blk_extension, + transl_extension_path e.exp_env path :: ll, + e.exp_loc )) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( - let tag = Btype.hash_variant l in - match arg with - | None -> Lconst (Const_pointer (tag, Pt_variant { name = l })) - | Some arg -> ( - let lam = transl_exp arg in - let tag_info = Blk_poly_var l in - try - Lconst - (Const_block - (tag_info, [ Const_base (Const_int tag); extract_constant lam ])) - with Not_constant -> - Lprim - ( Pmakeblock tag_info, - [ Lconst (Const_base (Const_int tag)); lam ], - e.exp_loc ))) - | Texp_record { fields; representation; extended_expression } -> - transl_record e.exp_loc e.exp_env fields representation - extended_expression + let tag = Btype.hash_variant l in + match arg with + | None -> Lconst (Const_pointer (tag, Pt_variant {name = l})) + | Some arg -> ( + let lam = transl_exp arg in + let tag_info = Blk_poly_var l in + try + Lconst + (Const_block + (tag_info, [Const_base (Const_int tag); extract_constant lam])) + with Not_constant -> + Lprim + ( Pmakeblock tag_info, + [Lconst (Const_base (Const_int tag)); lam], + e.exp_loc ))) + | Texp_record {fields; representation; extended_expression} -> + transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( - let targ = transl_exp arg in + let targ = transl_exp arg in + match lbl.lbl_repres with + | Record_float_unused -> assert false + | Record_regular | Record_optional_labels _ -> + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) + | Record_inlined _ -> + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) + | Record_unboxed _ -> targ + | Record_extension -> + Lprim + ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), + [targ], + e.exp_loc )) + | Texp_setfield (arg, _, lbl, newval) -> + let access = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> - Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [ targ ], e.exp_loc) + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> - Lprim - ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), - [ targ ], - e.exp_loc ) - | Record_unboxed _ -> targ + Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + | Record_unboxed _ -> assert false | Record_extension -> - Lprim - ( Pfield - (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), - [ targ ], - e.exp_loc )) - | Texp_setfield (arg, _, lbl, newval) -> - let access = - match lbl.lbl_repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) - | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) - | Record_unboxed _ -> assert false - | Record_extension -> - Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) - in - Lprim (access, [ transl_exp arg; transl_exp newval ], e.exp_loc) + Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + in + Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) | Texp_array expr_list -> - let ll = transl_list expr_list in - Lprim (Pmakearray Mutable, ll, e.exp_loc) + let ll = transl_list expr_list in + Lprim (Pmakearray Mutable, ll, e.exp_loc) | Texp_ifthenelse (cond, ifso, Some ifnot) -> - Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) + Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> - Lifthenelse (transl_exp cond, transl_exp ifso, lambda_unit) + Lifthenelse (transl_exp cond, transl_exp ifso, lambda_unit) | Texp_sequence (expr1, expr2) -> - Lsequence (transl_exp expr1, transl_exp expr2) + Lsequence (transl_exp expr1, transl_exp expr2) | Texp_while (cond, body) -> Lwhile (transl_exp cond, transl_exp body) | Texp_for (param, _, low, high, dir, body) -> - Lfor (param, transl_exp low, transl_exp high, dir, transl_exp body) + Lfor (param, transl_exp low, transl_exp high, dir, transl_exp body) | Texp_send (expr, Tmeth_name nm, _) -> - let obj = transl_exp expr in - Lsend (nm, obj, e.exp_loc) + let obj = transl_exp expr in + Lsend (nm, obj, e.exp_loc) | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ -> - assert false + assert false | Texp_letmodule (id, _loc, modl, body) -> - let defining_expr = !transl_module Tcoerce_none None modl in - Llet (Strict, Pgenval, id, defining_expr, transl_exp body) + let defining_expr = !transl_module Tcoerce_none None modl in + Llet (Strict, Pgenval, id, defining_expr, transl_exp body) | Texp_letexception (cd, body) -> - Llet - ( Strict, - Pgenval, - cd.ext_id, - transl_extension_constructor e.exp_env None cd, - transl_exp body ) + Llet + ( Strict, + Pgenval, + cd.ext_id, + transl_extension_constructor e.exp_env None cd, + transl_exp body ) | Texp_pack modl -> !transl_module Tcoerce_none None modl - | Texp_assert { exp_desc = Texp_construct (_, { cstr_name = "false" }, _) } -> - if !Clflags.no_assert_false then Lambda.lambda_assert_false - else assert_failed e + | Texp_assert {exp_desc = Texp_construct (_, {cstr_name = "false"}, _)} -> + if !Clflags.no_assert_false then Lambda.lambda_assert_false + else assert_failed e | Texp_assert cond -> - if !Clflags.noassert then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + if !Clflags.noassert then lambda_unit + else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) | Texp_lazy e -> - (* when e needs no computation (constants, identifiers, ...), we - optimize the translation just as Lazy.lazy_from_val would - do *) - Lprim (Pmakeblock Blk_lazy_general, [ transl_exp e ], e.exp_loc) + (* when e needs no computation (constants, identifiers, ...), we + optimize the translation just as Lazy.lazy_from_val would + do *) + Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc) | Texp_object () -> assert false | Texp_unreachable -> raise (Error (e.exp_loc, Unreachable_reached)) @@ -977,7 +948,7 @@ and transl_guard guard rhs = | None -> expr | Some cond -> Lifthenelse (transl_exp cond, expr, staticfail) -and transl_case { c_lhs; c_guard; c_rhs } = (c_lhs, transl_guard c_guard c_rhs) +and transl_case {c_lhs; c_guard; c_rhs} = (c_lhs, transl_guard c_guard c_rhs) and transl_cases cases = let cases = @@ -985,13 +956,13 @@ and transl_cases cases = in List.map transl_case cases -and transl_case_try { c_lhs; c_guard; c_rhs } = +and transl_case_try {c_lhs; c_guard; c_rhs} = match c_lhs.pat_desc with | Tpat_var (id, _) | Tpat_alias (_, id, _) -> - Hashtbl.replace try_ids id (); - Misc.try_finally - (fun () -> (c_lhs, transl_guard c_guard c_rhs)) - (fun () -> Hashtbl.remove try_ids id) + Hashtbl.replace try_ids id (); + Misc.try_finally + (fun () -> (c_lhs, transl_guard c_guard c_rhs)) + (fun () -> Hashtbl.remove try_ids id) | _ -> (c_lhs, transl_guard c_guard c_rhs) and transl_cases_try cases = @@ -1000,47 +971,46 @@ and transl_cases_try cases = in List.map transl_case_try cases -and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=None) lam sargs loc = +and transl_apply ?(inlined = Default_inline) + ?(uncurried_partial_application = None) lam sargs loc = let lapply ap_func ap_args = - Lapply { ap_loc = loc; ap_func; ap_args; ap_inlined = inlined } in + Lapply {ap_loc = loc; ap_func; ap_args; ap_inlined = inlined} + in let rec build_apply lam args = function | (None, optional) :: l -> - let defs = ref [] in - let protect name lam = - match lam with - | Lvar _ | Lconst _ -> lam - | _ -> - let id = Ident.create name in - defs := (id, lam) :: !defs; - Lvar id - in - let args, args' = - if List.for_all (fun (_, opt) -> opt) args then ([], args) - else (args, []) - in - let lam = - if args = [] then lam else lapply lam (List.rev_map fst args) - in - let handle = protect "func" lam - and l = - List.map (fun (arg, opt) -> (may_map (protect "arg") arg, opt)) l - and id_arg = Ident.create "param" in - let body = - match build_apply handle ((Lvar id_arg, optional) :: args') l with - | Lfunction { params = ids; body = lam; attr; loc } -> - Lfunction { params = id_arg :: ids; body = lam; attr; loc } - | lam -> - Lfunction - { - params = [ id_arg ]; - body = lam; - attr = default_function_attribute; - loc; - } - in - List.fold_left - (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) - body !defs + let defs = ref [] in + let protect name lam = + match lam with + | Lvar _ | Lconst _ -> lam + | _ -> + let id = Ident.create name in + defs := (id, lam) :: !defs; + Lvar id + in + let args, args' = + if List.for_all (fun (_, opt) -> opt) args then ([], args) + else (args, []) + in + let lam = if args = [] then lam else lapply lam (List.rev_map fst args) in + let handle = protect "func" lam + and l = List.map (fun (arg, opt) -> (may_map (protect "arg") arg, opt)) l + and id_arg = Ident.create "param" in + let body = + match build_apply handle ((Lvar id_arg, optional) :: args') l with + | Lfunction {params = ids; body = lam; attr; loc} -> + Lfunction {params = id_arg :: ids; body = lam; attr; loc} + | lam -> + Lfunction + { + params = [id_arg]; + body = lam; + attr = default_function_attribute; + loc; + } + in + List.fold_left + (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) + body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) in @@ -1048,27 +1018,32 @@ and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=Non | Some arity -> let extra_arity = arity - List.length sargs in let none_ids = ref [] in - let args = Ext_list.filter_map sargs (function - | _, Some e -> - Some (transl_exp e) - | _, None -> - let id_arg = Ident.create "none" in - none_ids := id_arg :: !none_ids; - Some (Lvar id_arg)) in - let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list in + let args = + Ext_list.filter_map sargs (function + | _, Some e -> Some (transl_exp e) + | _, None -> + let id_arg = Ident.create "none" in + none_ids := id_arg :: !none_ids; + Some (Lvar id_arg)) + in + let extra_ids = + Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list + in let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in let ap_args = args @ extra_args in - let l0 = Lapply { ap_func = lam; ap_args; ap_inlined = inlined; ap_loc = loc } in + let l0 = + Lapply {ap_func = lam; ap_args; ap_inlined = inlined; ap_loc = loc} + in Lfunction { - params = List.rev_append !none_ids extra_ids ; + params = List.rev_append !none_ids extra_ids; body = l0; attr = default_function_attribute; loc; } | _ -> (build_apply lam [] - (List.map + (List.map (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) sargs) : Lambda.lambda) @@ -1083,203 +1058,205 @@ and transl_function loc partial param cases = { exp_desc = Texp_function - { arg_label = _; param = param'; cases; partial = partial' }; + {arg_label = _; param = param'; cases; partial = partial'}; } as exp; }; ] when Parmatch.inactive ~partial pat && not (exp |> has_async_attribute) -> - let params, body, return_unit = - transl_function exp.exp_loc partial' param' cases - in - ( param :: params, - Matching.for_function loc None (Lvar param) [ (pat, body) ] partial, - return_unit ) - | { c_rhs = { exp_env; exp_type }; _ } :: _ -> - ( [ param ], - Matching.for_function loc None (Lvar param) (transl_cases cases) partial, - is_base_type exp_env exp_type Predef.path_unit ) + let params, body, return_unit = + transl_function exp.exp_loc partial' param' cases + in + ( param :: params, + Matching.for_function loc None (Lvar param) [(pat, body)] partial, + return_unit ) + | {c_rhs = {exp_env; exp_type}; _} :: _ -> + ( [param], + Matching.for_function loc None (Lvar param) (transl_cases cases) partial, + is_base_type exp_env exp_type Predef.path_unit ) | _ -> assert false and transl_let rec_flag pat_expr_list body = match rec_flag with | Nonrecursive -> - let rec transl = function - | [] -> body - | { vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc } :: rem - -> - let lam = transl_exp expr in - let lam = Translattribute.add_inline_attribute lam vb_loc attr in - Matching.for_let pat.pat_loc lam pat (transl rem) - in - transl pat_expr_list - | Recursive -> - let transl_case { vb_expr = expr; vb_attributes; vb_loc; vb_pat = pat } = - let id = - match pat.pat_desc with - | Tpat_var (id, _) -> id - | Tpat_alias ({ pat_desc = Tpat_any }, id, _) -> id - | _ -> assert false - (* Illegal_letrec_pat - Only variables are allowed as left-hand side of `let rec' - *) - in + let rec transl = function + | [] -> body + | {vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc} :: rem -> let lam = transl_exp expr in - let lam = - Translattribute.add_inline_attribute lam vb_loc vb_attributes - in - (id, lam) + let lam = Translattribute.add_inline_attribute lam vb_loc attr in + Matching.for_let pat.pat_loc lam pat (transl rem) + in + transl pat_expr_list + | Recursive -> + let transl_case {vb_expr = expr; vb_attributes; vb_loc; vb_pat = pat} = + let id = + match pat.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> id + | _ -> assert false + (* Illegal_letrec_pat + Only variables are allowed as left-hand side of `let rec' + *) in - Lletrec (Ext_list.map pat_expr_list transl_case, body) + let lam = transl_exp expr in + let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in + (id, lam) + in + Lletrec (Ext_list.map pat_expr_list transl_case, body) and transl_record loc env fields repres opt_init_expr = match (opt_init_expr, repres, fields) with - | None, Record_unboxed _, [| ({ lbl_name; lbl_loc }, Overridden (_, expr)) |] - -> - (* ReScript uncurried encoding *) - let loc = lbl_loc in - let lambda = transl_exp expr in - if lbl_name.[0] = 'I' then - let arity_s = String.sub lbl_name 1 (String.length lbl_name - 1) in - let arity = Int32.of_string arity_s |> Int32.to_int in - Lprim - ( Pjs_fn_make arity, - (* could be replaced with Opaque in the future except arity 0*) - [ lambda ], - loc ) - else lambda + | None, Record_unboxed _, [|({lbl_name; lbl_loc}, Overridden (_, expr))|] -> + (* ReScript uncurried encoding *) + let loc = lbl_loc in + let lambda = transl_exp expr in + if lbl_name.[0] = 'I' then + let arity_s = String.sub lbl_name 1 (String.length lbl_name - 1) in + let arity = Int32.of_string arity_s |> Int32.to_int in + Lprim + ( Pjs_fn_make arity, + (* could be replaced with Opaque in the future except arity 0*) + [lambda], + loc ) + else lambda | _ -> ( - let size = Array.length fields in - (* Determine if there are "enough" fields (only relevant if this is a - functional-style record update *) - let no_init = match opt_init_expr with None -> true | _ -> false in - if - no_init || (size < 20 && (match repres with Record_optional_labels _ -> false | _ -> true)) - (* TODO: More strategies - 3 + 2 * List.length lbl_expr_list >= size (density) - *) - then - (* Allocate new record with given fields (and remaining fields - taken from init_expr if any *) - let init_id = Ident.create "init" in - let lv = - Array.mapi - (fun i (lbl, definition) -> - match definition with - | Kept _ -> - let access = - match repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Pfield (i, Lambda.fld_record lbl) - | Record_inlined _ -> - Pfield (i, Lambda.fld_record_inline lbl) - | Record_unboxed _ -> assert false - | Record_extension -> - Pfield - (i + 1, Lambda.fld_record_extension lbl) - in - Lprim (access, [ Lvar init_id ], loc) - | Overridden (_lid, expr) -> transl_exp expr) - fields - in - let ll = Array.to_list lv in - let mut = - if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields then - Mutable - else Immutable - in - let lam = - try - if mut = Mutable then raise Not_constant; - let cl = List.map extract_constant ll in - match repres with - | Record_float_unused -> assert false - | Record_regular -> - Lconst - (Const_block (Lambda.blk_record fields mut Record_regular, cl)) - | Record_optional_labels _ -> - Lconst - (Const_block (Lambda.blk_record fields mut Record_optional, cl)) - | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> - Lconst - (Const_block - ( Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs - mut, - cl )) - | Record_unboxed _ -> - Lconst (match cl with [ v ] -> v | _ -> assert false) - | Record_extension -> raise Not_constant - with Not_constant -> ( - match repres with - | Record_regular -> - Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_regular), - ll, - loc ) - | Record_optional_labels _ -> - Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_optional), - ll, - loc ) - | Record_float_unused -> assert false - | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> - Lprim - ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs - mut), - ll, - loc ) - | Record_unboxed _ -> ( - match ll with [ v ] -> v | _ -> assert false) - | Record_extension -> - let path = - let label, _ = fields.(0) in - match label.lbl_res.desc with - | Tconstr (p, _, _) -> p - | _ -> assert false - in - let slot = transl_extension_path env path in - Lprim - ( Pmakeblock (Lambda.blk_record_ext fields mut), - slot :: ll, - loc )) - in - match opt_init_expr with - | None -> lam - | Some init_expr -> - Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) - else - (* Take a shallow copy of the init record, then mutate the fields - of the copy *) - let copy_id = Ident.create "newrecord" in - let update_field cont (lbl, definition) = - match definition with - | Kept _type -> cont - | Overridden (_lid, expr) -> - let upd = + let size = Array.length fields in + (* Determine if there are "enough" fields (only relevant if this is a + functional-style record update *) + let no_init = + match opt_init_expr with + | None -> true + | _ -> false + in + if + no_init + || size < 20 + && + match repres with + | Record_optional_labels _ -> false + | _ -> true + (* TODO: More strategies + 3 + 2 * List.length lbl_expr_list >= size (density) + *) + then + (* Allocate new record with given fields (and remaining fields + taken from init_expr if any *) + let init_id = Ident.create "init" in + let lv = + Array.mapi + (fun i (lbl, definition) -> + match definition with + | Kept _ -> + let access = match repres with | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) - | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + Pfield (i, Lambda.fld_record lbl) + | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl) | Record_unboxed _ -> assert false | Record_extension -> - Psetfield - (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lsequence - (Lprim (upd, [ Lvar copy_id; transl_exp expr ], loc), cont) - in - match opt_init_expr with - | None -> assert false - | Some init_expr -> - Llet - ( Strict, - Pgenval, - copy_id, - Lprim (Pduprecord, [ transl_exp init_expr ], loc), - Array.fold_left update_field (Lvar copy_id) fields )) + Lprim (access, [Lvar init_id], loc) + | Overridden (_lid, expr) -> transl_exp expr) + fields + in + let ll = Array.to_list lv in + let mut = + if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields then + Mutable + else Immutable + in + let lam = + try + if mut = Mutable then raise Not_constant; + let cl = List.map extract_constant ll in + match repres with + | Record_float_unused -> assert false + | Record_regular -> + Lconst + (Const_block (Lambda.blk_record fields mut Record_regular, cl)) + | Record_optional_labels _ -> + Lconst + (Const_block (Lambda.blk_record fields mut Record_optional, cl)) + | Record_inlined {tag; name; num_nonconsts; optional_labels; attrs} -> + Lconst + (Const_block + ( Lambda.blk_record_inlined fields name num_nonconsts + optional_labels ~tag ~attrs mut, + cl )) + | Record_unboxed _ -> + Lconst + (match cl with + | [v] -> v + | _ -> assert false) + | Record_extension -> raise Not_constant + with Not_constant -> ( + match repres with + | Record_regular -> + Lprim + (Pmakeblock (Lambda.blk_record fields mut Record_regular), ll, loc) + | Record_optional_labels _ -> + Lprim + ( Pmakeblock (Lambda.blk_record fields mut Record_optional), + ll, + loc ) + | Record_float_unused -> assert false + | Record_inlined {tag; name; num_nonconsts; optional_labels; attrs} -> + Lprim + ( Pmakeblock + (Lambda.blk_record_inlined fields name num_nonconsts + optional_labels ~tag ~attrs mut), + ll, + loc ) + | Record_unboxed _ -> ( + match ll with + | [v] -> v + | _ -> assert false) + | Record_extension -> + let path = + let label, _ = fields.(0) in + match label.lbl_res.desc with + | Tconstr (p, _, _) -> p + | _ -> assert false + in + let slot = transl_extension_path env path in + Lprim + (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) + in + match opt_init_expr with + | None -> lam + | Some init_expr -> + Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) + else + (* Take a shallow copy of the init record, then mutate the fields + of the copy *) + let copy_id = Ident.create "newrecord" in + let update_field cont (lbl, definition) = + match definition with + | Kept _type -> cont + | Overridden (_lid, expr) -> + let upd = + match repres with + | Record_float_unused -> assert false + | Record_regular | Record_optional_labels _ -> + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) + | Record_inlined _ -> + Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + | Record_unboxed _ -> assert false + | Record_extension -> + Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + in + Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) + in + match opt_init_expr with + | None -> assert false + | Some init_expr -> + Llet + ( Strict, + Pgenval, + copy_id, + Lprim (Pduprecord, [transl_exp init_expr], loc), + Array.fold_left update_field (Lvar copy_id) fields )) and transl_match e arg pat_expr_list exn_pat_expr_list partial = let id = Typecore.name_pattern "exn" exn_pat_expr_list @@ -1296,25 +1273,27 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = handler ) in match (arg, exn_cases) with - | { exp_desc = Texp_tuple argl }, [] -> - Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial - | { exp_desc = Texp_tuple argl }, _ :: _ -> - let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in - let lvars = List.map (fun id -> Lvar id) val_ids in - static_catch (transl_list argl) val_ids - (Matching.for_multiple_match e.exp_loc lvars cases partial) + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) | arg, [] -> - Matching.for_function e.exp_loc None (transl_exp arg) cases partial + Matching.for_function e.exp_loc None (transl_exp arg) cases partial | arg, _ :: _ -> - let val_id = Typecore.name_pattern "val" pat_expr_list in - static_catch [ transl_exp arg ] [ val_id ] - (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + let val_id = Typecore.name_pattern "val" pat_expr_list in + static_catch + [transl_exp arg] + [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) open Format let report_error ppf = function | Unknown_builtin_primitive prim_name -> - fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name | Unreachable_reached -> fprintf ppf "Unreachable expression was reached" let () = diff --git a/compiler/ml/translcore.mli b/compiler/ml/translcore.mli index eaf38f2f15..1847a4883c 100644 --- a/compiler/ml/translcore.mli +++ b/compiler/ml/translcore.mli @@ -16,7 +16,6 @@ (* Translation from typed abstract syntax to lambda terms, for the core language *) - val transl_exp : Typedtree.expression -> Lambda.lambda val transl_let : diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 7fea4909a1..60f02bcfc9 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -28,10 +28,14 @@ exception Error of Location.t * error let global_path glob : Path.t option = Some (Pident glob) let is_top (rootpath : Path.t option) = - match rootpath with Some (Pident _) -> true | _ -> false + match rootpath with + | Some (Pident _) -> true + | _ -> false let functor_path path param : Path.t option = - match path with None -> None | Some p -> Some (Papply (p, Pident param)) + match path with + | None -> None + | Some p -> Some (Papply (p, Pident param)) let field_path path field : Path.t option = match path with @@ -58,58 +62,53 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = match restr with | Tcoerce_none -> arg | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> - Lambda.name_lambda strict arg (fun id -> - let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module { name }), [ Lvar id ], loc) - in - let lam = - Lambda.Lprim - ( Pmakeblock (Blk_module runtime_fields), - Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> - apply_coercion loc Alias cc - (Lprim - (Pfield (pos, Fld_module { name }), [ Lvar id ], loc))), - loc ) - in - wrap_id_pos_list loc id_pos_list get_field_name lam) + Lambda.name_lambda strict arg (fun id -> + let get_field_name name pos = + Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) + in + let lam = + Lambda.Lprim + ( Pmakeblock (Blk_module runtime_fields), + Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> + apply_coercion loc Alias cc + (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), + loc ) + in + wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> - let param = Ident.create "funarg" in - let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [ param ] [ carg ] cc_res - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type } -> - Translcore.transl_primitive pc_loc pc_desc pc_env pc_type + let param = Ident.create "funarg" in + let carg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict arg [param] [carg] cc_res + | Tcoerce_primitive {pc_loc; pc_desc; pc_env; pc_type} -> + Translcore.transl_primitive pc_loc pc_desc pc_env pc_type | Tcoerce_alias (path, cc) -> - Lambda.name_lambda strict arg (fun _ -> - apply_coercion loc Alias cc (Lambda.transl_normal_path path)) + Lambda.name_lambda strict arg (fun _ -> + apply_coercion loc Alias cc (Lambda.transl_normal_path path)) and apply_coercion_result loc strict funct params args cc_res = match cc_res with | Tcoerce_functor (cc_arg, cc_res) -> - let param = Ident.create "funarg" in - let arg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict funct (param :: params) (arg :: args) - cc_res + let param = Ident.create "funarg" in + let arg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict funct (param :: params) (arg :: args) + cc_res | _ -> - Lambda.name_lambda strict funct (fun id -> - Lfunction - { - params = List.rev params; - attr = - { - Lambda.default_function_attribute with - is_a_functor = true; - }; - loc; - body = - apply_coercion loc Strict cc_res - (Lapply - { - ap_loc = loc; - ap_func = Lvar id; - ap_args = List.rev args; - ap_inlined = Default_inline; - }); - }) + Lambda.name_lambda strict funct (fun id -> + Lfunction + { + params = List.rev params; + attr = {Lambda.default_function_attribute with is_a_functor = true}; + loc; + body = + apply_coercion loc Strict cc_res + (Lapply + { + ap_loc = loc; + ap_func = Lvar id; + ap_args = List.rev args; + ap_inlined = Default_inline; + }); + }) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = Lambda.free_variables lam in @@ -143,27 +142,27 @@ let rec compose_coercions c1 c2 = | c1, Tcoerce_none -> c1 | ( Tcoerce_structure (pc1, ids1, runtime_fields1), Tcoerce_structure (pc2, ids2, _runtime_fields2) ) -> - let v2 = Array.of_list pc2 in - let ids1 = - List.map - (fun (id, pos1, c1) -> - let pos2, c2 = v2.(pos1) in - (id, pos2, compose_coercions c1 c2)) - ids1 - in - Tcoerce_structure - ( List.map - (function - | (_p1, Tcoerce_primitive _) as x -> - x (* (p1, Tcoerce_primitive p) *) - | p1, c1 -> - let p2, c2 = v2.(p1) in - (p2, compose_coercions c1 c2)) - pc1, - ids1 @ ids2, - runtime_fields1 ) + let v2 = Array.of_list pc2 in + let ids1 = + List.map + (fun (id, pos1, c1) -> + let pos2, c2 = v2.(pos1) in + (id, pos2, compose_coercions c1 c2)) + ids1 + in + Tcoerce_structure + ( List.map + (function + | (_p1, Tcoerce_primitive _) as x -> + x (* (p1, Tcoerce_primitive p) *) + | p1, c1 -> + let p2, c2 = v2.(p1) in + (p2, compose_coercions c1 c2)) + pc1, + ids1 @ ids2, + runtime_fields1 ) | Tcoerce_functor (arg1, res1), Tcoerce_functor (arg2, res2) -> - Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) + Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) | c1, Tcoerce_alias (path, c2) -> Tcoerce_alias (path, compose_coercions c1 c2) | _, _ -> Misc.fatal_error "Translmod.compose_coercions" @@ -198,8 +197,8 @@ let rec pure_module m : Lambda.let_kind = let rec bound_value_identifiers : Types.signature_item list -> Ident.t list = function | [] -> [] - | Sig_value (id, { val_kind = Val_reg }) :: rem -> - id :: bound_value_identifiers rem + | Sig_value (id, {val_kind = Val_reg}) :: rem -> + id :: bound_value_identifiers rem | Sig_typext (id, _, _) :: rem -> id :: bound_value_identifiers rem | Sig_module (id, _, _) :: rem -> id :: bound_value_identifiers rem | Sig_class _ :: _ -> assert false @@ -217,32 +216,32 @@ let merge_inline_attributes (attr1 : Lambda.inline_attribute) | Lambda.Default_inline, _ -> attr2 | _, Lambda.Default_inline -> attr1 | _, _ -> - if attr1 = attr2 then attr1 - else raise (Error (loc, Conflicting_inline_attributes)) + if attr1 = attr2 then attr1 + else raise (Error (loc, Conflicting_inline_attributes)) let merge_functors mexp coercion root_path = let rec merge mexp coercion path acc inline_attribute = let finished = (acc, mexp, path, coercion, inline_attribute) in match mexp.mod_desc with | Tmod_functor (param, _, _, body) -> - let inline_attribute' = - Translattribute.get_inline_attribute mexp.mod_attributes - in - let arg_coercion, res_coercion = - match coercion with - | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) - | Tcoerce_functor (arg_coercion, res_coercion) -> - (arg_coercion, res_coercion) - | _ -> Misc.fatal_error "Translmod.merge_functors: bad coercion" - in - let loc = mexp.mod_loc in - let path = functor_path path param in - let inline_attribute = - merge_inline_attributes inline_attribute inline_attribute' loc - in - merge body res_coercion path - ((param, loc, arg_coercion) :: acc) - inline_attribute + let inline_attribute' = + Translattribute.get_inline_attribute mexp.mod_attributes + in + let arg_coercion, res_coercion = + match coercion with + | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) + | Tcoerce_functor (arg_coercion, res_coercion) -> + (arg_coercion, res_coercion) + | _ -> Misc.fatal_error "Translmod.merge_functors: bad coercion" + in + let loc = mexp.mod_loc in + let path = functor_path path param in + let inline_attribute = + merge_inline_attributes inline_attribute inline_attribute' loc + in + merge body res_coercion path + ((param, loc, arg_coercion) :: acc) + inline_attribute | _ -> finished in merge mexp coercion root_path [] Default_inline @@ -288,205 +287,196 @@ and transl_module cc rootpath mexp = let loc = mexp.mod_loc in match mexp.mod_type with | Mty_alias (Mta_absent, _) -> - apply_coercion loc Alias cc Lambda.lambda_module_alias + apply_coercion loc Alias cc Lambda.lambda_module_alias | _ -> ( - match mexp.mod_desc with - | Tmod_ident (path, _) -> - apply_coercion loc Strict cc - (Lambda.transl_module_path ~loc mexp.mod_env path) - | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str) - | Tmod_functor _ -> compile_functor mexp cc rootpath loc - | Tmod_apply (funct, arg, ccarg) -> - let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct - in - apply_coercion loc Strict cc - (Lapply - { - ap_loc = loc; - ap_func = transl_module Tcoerce_none None funct; - ap_args = [ transl_module ccarg None arg ]; - ap_inlined = inlined_attribute; - }) - | Tmod_constraint (arg, _, _, ccarg) -> - transl_module (compose_coercions cc ccarg) rootpath arg - | Tmod_unpack (arg, _) -> - apply_coercion loc Strict cc (Translcore.transl_exp arg)) + match mexp.mod_desc with + | Tmod_ident (path, _) -> + apply_coercion loc Strict cc + (Lambda.transl_module_path ~loc mexp.mod_env path) + | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str) + | Tmod_functor _ -> compile_functor mexp cc rootpath loc + | Tmod_apply (funct, arg, ccarg) -> + let inlined_attribute, funct = + Translattribute.get_and_remove_inlined_attribute_on_module funct + in + apply_coercion loc Strict cc + (Lapply + { + ap_loc = loc; + ap_func = transl_module Tcoerce_none None funct; + ap_args = [transl_module ccarg None arg]; + ap_inlined = inlined_attribute; + }) + | Tmod_constraint (arg, _, _, ccarg) -> + transl_module (compose_coercions cc ccarg) rootpath arg + | Tmod_unpack (arg, _) -> + apply_coercion loc Strict cc (Translcore.transl_exp arg)) and transl_struct loc fields cc rootpath str = transl_structure loc fields cc rootpath str.str_final_env str.str_items and transl_structure loc fields cc rootpath final_env = function | [] -> ( - let is_top_root_path = is_top rootpath in - - match cc with - | Tcoerce_none -> - let block_fields = - List.fold_left - (fun acc id -> - if is_top_root_path then - export_identifiers := id :: !export_identifiers; - Lambda.Lvar id :: acc) - [] fields - in - ( Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then - Blk_module_export !export_identifiers - else - Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), - block_fields, - loc ), - List.length fields ) - | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> - (* Do not ignore id_pos_list ! *) - (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; - List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) - fields; - Format.eprintf "@]@.";*) - assert (List.length runtime_fields = List.length pos_cc_list); - let v = Ext_array.reverse_of_list fields in - let get_field pos = Lambda.Lvar v.(pos) - and ids = - List.fold_right Lambda.IdentSet.add fields Lambda.IdentSet.empty - in - let get_field_name _name = get_field in - let result = - List.fold_right - (fun (pos, cc) code -> - match cc with - | Tcoerce_primitive p -> - if is_top rootpath then - export_identifiers := p.pc_id :: !export_identifiers; - Translcore.transl_primitive p.pc_loc p.pc_desc p.pc_env - p.pc_type - :: code - | _ -> - if is_top rootpath then - export_identifiers := v.(pos) :: !export_identifiers; - apply_coercion loc Strict cc (get_field pos) :: code) - pos_cc_list [] - in - let lam = - Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then - Blk_module_export !export_identifiers - else Blk_module runtime_fields), - result, - loc ) - and id_pos_list = - Ext_list.filter id_pos_list (fun (id, _, _) -> - not (Lambda.IdentSet.mem id ids)) - in - ( wrap_id_pos_list loc id_pos_list get_field_name lam, - List.length pos_cc_list ) - | _ -> Misc.fatal_error "Translmod.transl_structure") + let is_top_root_path = is_top rootpath in + + match cc with + | Tcoerce_none -> + let block_fields = + List.fold_left + (fun acc id -> + if is_top_root_path then + export_identifiers := id :: !export_identifiers; + Lambda.Lvar id :: acc) + [] fields + in + ( Lambda.Lprim + ( Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), + block_fields, + loc ), + List.length fields ) + | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) + assert (List.length runtime_fields = List.length pos_cc_list); + let v = Ext_array.reverse_of_list fields in + let get_field pos = Lambda.Lvar v.(pos) + and ids = + List.fold_right Lambda.IdentSet.add fields Lambda.IdentSet.empty + in + let get_field_name _name = get_field in + let result = + List.fold_right + (fun (pos, cc) code -> + match cc with + | Tcoerce_primitive p -> + if is_top rootpath then + export_identifiers := p.pc_id :: !export_identifiers; + Translcore.transl_primitive p.pc_loc p.pc_desc p.pc_env p.pc_type + :: code + | _ -> + if is_top rootpath then + export_identifiers := v.(pos) :: !export_identifiers; + apply_coercion loc Strict cc (get_field pos) :: code) + pos_cc_list [] + in + let lam = + Lambda.Lprim + ( Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module runtime_fields), + result, + loc ) + and id_pos_list = + Ext_list.filter id_pos_list (fun (id, _, _) -> + not (Lambda.IdentSet.mem id ids)) + in + ( wrap_id_pos_list loc id_pos_list get_field_name lam, + List.length pos_cc_list ) + | _ -> Misc.fatal_error "Translmod.transl_structure") | item :: rem -> ( - match item.str_desc with - | Tstr_eval (expr, _) -> - let body, size = - transl_structure loc fields cc rootpath final_env rem - in - (Lsequence (Translcore.transl_exp expr, body), size) - | Tstr_value (rec_flag, pat_expr_list) -> - let ext_fields = rev_let_bound_idents pat_expr_list @ fields in - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - (* Recursve already excludes complex pattern bindings*) - if is_top rootpath && rec_flag = Nonrecursive then - Ext_list.iter pat_expr_list (fun { vb_pat } -> - match vb_pat.pat_desc with - | Tpat_var _ | Tpat_alias _ -> () - | _ -> - if not (Parmatch.irrefutable vb_pat) then - raise - (Error (vb_pat.pat_loc, Fragile_pattern_in_toplevel))); - (Translcore.transl_let rec_flag pat_expr_list body, size) - | Tstr_typext tyext -> - let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in - let body, size = - transl_structure loc - (List.rev_append ids fields) - cc rootpath final_env rem - in - (transl_type_extension item.str_env rootpath tyext body, size) - | Tstr_exception ext -> - let id = ext.ext_id in - let path = field_path rootpath id in - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in + match item.str_desc with + | Tstr_eval (expr, _) -> + let body, size = transl_structure loc fields cc rootpath final_env rem in + (Lsequence (Translcore.transl_exp expr, body), size) + | Tstr_value (rec_flag, pat_expr_list) -> + let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + (* Recursve already excludes complex pattern bindings*) + if is_top rootpath && rec_flag = Nonrecursive then + Ext_list.iter pat_expr_list (fun {vb_pat} -> + match vb_pat.pat_desc with + | Tpat_var _ | Tpat_alias _ -> () + | _ -> + if not (Parmatch.irrefutable vb_pat) then + raise (Error (vb_pat.pat_loc, Fragile_pattern_in_toplevel))); + (Translcore.transl_let rec_flag pat_expr_list body, size) + | Tstr_typext tyext -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let body, size = + transl_structure loc + (List.rev_append ids fields) + cc rootpath final_env rem + in + (transl_type_extension item.str_env rootpath tyext body, size) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + ( Llet + ( Strict, + Pgenval, + id, + Translcore.transl_extension_constructor item.str_env path ext, + body ), + size ) + | Tstr_module mb as s -> + let id = mb.mb_id in + let body, size = + transl_structure loc + (if Typemod.rescript_hide s then fields else id :: fields) + cc rootpath final_env rem + in + let module_body = + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr + in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes + in + (Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size) + | Tstr_recmodule bindings -> + let ext_fields = + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + let lam = + Transl_recmodule.compile_recmodule + (fun id modl _loc -> + transl_module Tcoerce_none (field_path rootpath id) modl) + bindings body + in + (lam, size) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create "include" in + let rec rebind_idents pos newfields = function + | [] -> transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = rebind_idents (pos + 1) (id :: newfields) ids in ( Llet - ( Strict, + ( Alias, Pgenval, id, - Translcore.transl_extension_constructor item.str_env path ext, - body ), - size ) - | Tstr_module mb as s -> - let id = mb.mb_id in - let body, size = - transl_structure loc - (if Typemod.rescript_hide s then fields else id :: fields) - cc rootpath final_env rem - in - let module_body = - transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr - in - let module_body = - Translattribute.add_inline_attribute module_body mb.mb_loc - mb.mb_attributes - in - (Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size) - | Tstr_recmodule bindings -> - let ext_fields = - List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields - in - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - let lam = - Transl_recmodule.compile_recmodule - (fun id modl _loc -> - transl_module Tcoerce_none (field_path rootpath id) modl) - bindings body - in - (lam, size) - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create "include" in - let rec rebind_idents pos newfields = function - | [] -> transl_structure loc newfields cc rootpath final_env rem - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - ( Llet - ( Alias, - Pgenval, - id, - Lprim - ( Pfield (pos, Fld_module { name = Ident.name id }), - [ Lvar mid ], - incl.incl_loc ), - body ), - size ) - in - let body, size = rebind_idents 0 fields ids in - ( Llet - ( pure_module modl, - Pgenval, - mid, - transl_module Tcoerce_none None modl, + Lprim + ( Pfield (pos, Fld_module {name = Ident.name id}), + [Lvar mid], + incl.incl_loc ), body ), size ) - | Tstr_class _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ - | Tstr_open _ | Tstr_class_type _ | Tstr_attribute _ -> - transl_structure loc fields cc rootpath final_env rem) + in + let body, size = rebind_idents 0 fields ids in + ( Llet + ( pure_module modl, + Pgenval, + mid, + transl_module Tcoerce_none None modl, + body ), + size ) + | Tstr_class _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ + | Tstr_open _ | Tstr_class_type _ | Tstr_attribute _ -> + transl_structure loc fields cc rootpath final_env rem) (* Update forward declaration in Translcore *) let _ = Translcore.transl_module := transl_module @@ -524,9 +514,9 @@ let transl_implementation module_name (str, cc) = let report_error ppf = function | Conflicting_inline_attributes -> - Format.fprintf ppf "@[Conflicting ``inline'' attributes@]" + Format.fprintf ppf "@[Conflicting ``inline'' attributes@]" | Fragile_pattern_in_toplevel -> - Format.fprintf ppf "@[Such fragile pattern not allowed in the toplevel@]" + Format.fprintf ppf "@[Such fragile pattern not allowed in the toplevel@]" let () = Location.register_error_of_exn (function diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index af45c84a4f..74ef747e10 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -25,6 +25,3 @@ type error (* exception Error of Location.t * error *) val report_error : Format.formatter -> error -> unit - - - diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index e818e0ac89..3499b5f7e5 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -25,18 +25,24 @@ open Ctype open Error_message_utils type error = - Polymorphic_label of Longident.t + | Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * (type_clash_context option) + | Expr_type_clash of (type_expr * type_expr) list * type_clash_context option | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr - | Label_multiply_defined of {label: string; jsx_component_info: jsx_prop_error_info option} - | Labels_missing of {labels: string list; jsx_component_info: jsx_prop_error_info option} + | Label_multiply_defined of { + label: string; + jsx_component_info: jsx_prop_error_info option; + } + | Labels_missing of { + labels: string list; + jsx_component_info: jsx_prop_error_info option; + } | Label_not_mutable of Longident.t | Wrong_name of string * type_expr * string * Path.t * string * string list | Name_type_mismatch of @@ -44,7 +50,6 @@ type error = | Undefined_method of type_expr * string * string list option | Private_type of type_expr | Private_label of Longident.t * type_expr - | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list | Too_many_arguments of bool * type_expr | Abstract_wrong_label of arg_label * type_expr @@ -82,21 +87,25 @@ exception Error_forward of Location.error (* Forward declaration, to be filled in by Typemod.type_module *) let type_module = - ref ((fun _env _md -> assert false) : - Env.t -> Parsetree.module_expr -> Typedtree.module_expr) + ref + (fun _env _md -> assert false + : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) (* Forward declaration, to be filled in by Typemod.type_open *) let type_open : - (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) + (?used_slot:bool ref -> + override_flag -> + Env.t -> + Location.t -> + Longident.t loc -> + Path.t * Env.t) ref = ref (fun ?used_slot:_ _ -> assert false) (* Forward declaration, to be filled in by Typemod.type_package *) -let type_package = - ref (fun _ -> assert false) +let type_package = ref (fun _ -> assert false) (* Forward declaration, to be filled in by Typemod.type_package *) @@ -110,46 +119,42 @@ let re node = Cmt_format.add_saved_type (Cmt_format.Partial_expression node); Stypes.record (Stypes.Ti_expr node); node -;; let rp node = Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); Stypes.record (Stypes.Ti_pat node); node -;; - -type recarg = - | Allowed - | Required - | Rejected +type recarg = Allowed | Required | Rejected - -let case lhs rhs = - {c_lhs = lhs; c_guard = None; c_rhs = rhs} +let case lhs rhs = {c_lhs = lhs; c_guard = None; c_rhs = rhs} (* Upper approximation of free identifiers on the parse tree *) let iter_expression f e = - let rec expr e = f e; match e.pexp_desc with | Pexp_extension _ (* we don't iterate under extension point *) - | Pexp_ident _ - | Pexp_new _ - | Pexp_constant _ -> () + | Pexp_ident _ | Pexp_new _ | Pexp_constant _ -> + () | Pexp_function pel -> List.iter case pel - | Pexp_fun (_, eo, _, e) -> may expr eo; expr e - | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel - | Pexp_let (_, pel, e) -> expr e; List.iter binding pel - | Pexp_match (e, pel) - | Pexp_try (e, pel) -> expr e; List.iter case pel - | Pexp_array el - | Pexp_tuple el -> List.iter expr el - | Pexp_construct (_, eo) - | Pexp_variant (_, eo) -> may expr eo + | Pexp_fun (_, eo, _, e) -> + may expr eo; + expr e + | Pexp_apply (e, lel) -> + expr e; + List.iter (fun (_, e) -> expr e) lel + | Pexp_let (_, pel, e) -> + expr e; + List.iter binding pel + | Pexp_match (e, pel) | Pexp_try (e, pel) -> + expr e; + List.iter case pel + | Pexp_array el | Pexp_tuple el -> List.iter expr el + | Pexp_construct (_, eo) | Pexp_variant (_, eo) -> may expr eo | Pexp_record (iel, eo) -> - may expr eo; List.iter (fun (_, e) -> expr e) iel + may expr eo; + List.iter (fun (_, e) -> expr e) iel | Pexp_open (_, _, e) | Pexp_newtype (_, e) | Pexp_poly (e, _) @@ -160,103 +165,95 @@ let iter_expression f e = | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) | Pexp_letexception (_, e) - | Pexp_field (e, _) -> expr e - | Pexp_while (e1, e2) - | Pexp_sequence (e1, e2) - | Pexp_setfield (e1, _, e2) -> expr e1; expr e2 - | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo - | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3 + | Pexp_field (e, _) -> + expr e + | Pexp_while (e1, e2) | Pexp_sequence (e1, e2) | Pexp_setfield (e1, _, e2) + -> + expr e1; + expr e2 + | Pexp_ifthenelse (e1, e2, eo) -> + expr e1; + expr e2; + may expr eo + | Pexp_for (_, e1, e2, _, e3) -> + expr e1; + expr e2; + expr e3 | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel - | Pexp_letmodule (_, me, e) -> expr e; module_expr me + | Pexp_letmodule (_, me, e) -> + expr e; + module_expr me | Pexp_object _ -> assert false | Pexp_pack me -> module_expr me | Pexp_unreachable -> () - and case {pc_lhs = _; pc_guard; pc_rhs} = may expr pc_guard; expr pc_rhs - - and binding x = - expr x.pvb_expr - + and binding x = expr x.pvb_expr and module_expr me = match me.pmod_desc with - | Pmod_extension _ - | Pmod_ident _ -> () + | Pmod_extension _ | Pmod_ident _ -> () | Pmod_structure str -> List.iter structure_item str - | Pmod_constraint (me, _) - | Pmod_functor (_, _, me) -> module_expr me - | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2 + | Pmod_constraint (me, _) | Pmod_functor (_, _, me) -> module_expr me + | Pmod_apply (me1, me2) -> + module_expr me1; + module_expr me2 | Pmod_unpack e -> expr e - - and structure_item str = match str.pstr_desc with | Pstr_eval (e, _) -> expr e | Pstr_value (_, pel) -> List.iter binding pel - | Pstr_primitive _ - | Pstr_type _ - | Pstr_typext _ - | Pstr_exception _ - | Pstr_modtype _ - | Pstr_open _ + | Pstr_primitive _ | Pstr_type _ | Pstr_typext _ | Pstr_exception _ + | Pstr_modtype _ | Pstr_open _ | Pstr_class_type () - | Pstr_attribute _ - | Pstr_extension _ -> () - | Pstr_include {pincl_mod = me} - | Pstr_module {pmb_expr = me} -> module_expr me + | Pstr_attribute _ | Pstr_extension _ -> + () + | Pstr_include {pincl_mod = me} | Pstr_module {pmb_expr = me} -> + module_expr me | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l | Pstr_class () -> () - - - - in - expr e + expr e let all_idents_cases el = let idents = Hashtbl.create 8 in let f = function - | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} -> - Hashtbl.replace idents id () + | {pexp_desc = Pexp_ident {txt = Longident.Lident id; _}; _} -> + Hashtbl.replace idents id () | _ -> () in List.iter (fun cp -> may (iter_expression f) cp.pc_guard; - iter_expression f cp.pc_rhs - ) + iter_expression f cp.pc_rhs) el; Hashtbl.fold (fun x () rest -> x :: rest) idents [] - (* Typing of constants *) let type_constant = function - Const_int _ -> instance_def Predef.type_int + | Const_int _ -> instance_def Predef.type_int | Const_char _ -> instance_def Predef.type_char | Const_string _ -> instance_def Predef.type_string | Const_float _ -> instance_def Predef.type_float | Const_int64 _ -> assert false | Const_bigint _ -> instance_def Predef.type_bigint - | Const_int32 _ -> assert false + | Const_int32 _ -> assert false let constant : Parsetree.constant -> (Asttypes.constant, error) result = function - | Pconst_integer (i,None) -> - begin - try Ok (Const_int (Misc.Int_literal_converter.int i)) - with Failure _ -> Error (Literal_overflow "int") - end - | Pconst_integer (i,Some 'n') -> + | Pconst_integer (i, None) -> ( + try Ok (Const_int (Misc.Int_literal_converter.int i)) + with Failure _ -> Error (Literal_overflow "int")) + | Pconst_integer (i, Some 'n') -> let sign, i = Bigint_utils.parse_bigint i in Ok (Const_bigint (sign, i)) - | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c)) + | Pconst_integer (i, Some c) -> Error (Unknown_literal (i, c)) | Pconst_char c -> Ok (Const_char c) - | Pconst_string (s,d) -> Ok (Const_string (s,d)) - | Pconst_float (f,None)-> Ok (Const_float f) - | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) + | Pconst_string (s, d) -> Ok (Const_string (s, d)) + | Pconst_float (f, None) -> Ok (Const_float f) + | Pconst_float (f, Some c) -> Error (Unknown_literal (f, c)) let constant_or_raise env loc cst = match constant cst with @@ -265,40 +262,41 @@ let constant_or_raise env loc cst = (* Specific version of type_option, using newty rather than newgenty *) -let type_option ty = - newty (Tconstr(Predef.path_option,[ty], ref Mnil)) +let type_option ty = newty (Tconstr (Predef.path_option, [ty], ref Mnil)) let mkexp exp_desc exp_type exp_loc exp_env = - { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } + {exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = []} let option_none ty loc = - let lid = Longident.Lident "None" - and env = Env.initial_safe_string in + let lid = Longident.Lident "None" and env = Env.initial_safe_string in let cnone = Env.lookup_constructor lid env in - mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env + mkexp (Texp_construct (mknoloc lid, cnone, [])) ty loc env let option_some texp = let lid = Longident.Lident "Some" in let csome = Env.lookup_constructor lid Env.initial_safe_string in - mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) - (type_option texp.exp_type) texp.exp_loc texp.exp_env + mkexp + (Texp_construct (mknoloc lid, csome, [texp])) + (type_option texp.exp_type) + texp.exp_loc texp.exp_env let extract_option_type env ty = - match expand_head env ty with {desc = Tconstr(path, [ty], _)} - when Path.same path Predef.path_option -> ty + match expand_head env ty with + | {desc = Tconstr (path, [ty], _)} when Path.same path Predef.path_option -> + ty | _ -> assert false let extract_concrete_record env ty = match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_record (fields, repr)}) -> (p0, p, fields, repr) + | p0, p, {type_kind = Type_record (fields, repr)} -> (p0, p, fields, repr) | _ -> raise Not_found let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_variant cstrs}) - when not (Ast_uncurried.type_is_uncurried_fun ty) - -> (p0, p, cstrs) - | (p0, p, {type_kind=Type_open}) -> (p0, p, []) + | p0, p, {type_kind = Type_variant cstrs} + when not (Ast_uncurried.type_is_uncurried_fun ty) -> + (p0, p, cstrs) + | p0, p, {type_kind = Type_open} -> (p0, p, []) | _ -> raise Not_found let has_optional_labels ld = @@ -310,44 +308,41 @@ let has_optional_labels ld = let label_is_optional ld = match ld.lbl_repres with | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name + | Record_inlined {optional_labels} -> + Ext_list.mem_string optional_labels ld.lbl_name | _ -> false let check_optional_attr env ld attrs loc = let check_redundant () = if not (label_is_optional ld) then raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); - true in + true + in Ext_list.exists attrs (fun ({txt}, _) -> - txt = "res.optional" && check_redundant ()) + txt = "res.optional" && check_redundant ()) (* unification inside type_pat*) let unify_pat_types loc env ty ty' = - try - unify env ty ty' - with - Unify trace -> - raise(Error(loc, env, Pattern_type_clash(trace))) - | Tags(l1,l2) -> - raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + try unify env ty ty' with + | Unify trace -> raise (Error (loc, env, Pattern_type_clash trace)) + | Tags (l1, l2) -> + raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2))) (* unification inside type_exp and type_expect *) let unify_exp_types ?type_clash_context loc env ty expected_ty = (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type - Printtyp.raw_type_expr expected_ty; *) - try - unify env ty expected_ty - with - Unify trace -> - raise(Error(loc, env, Expr_type_clash(trace, type_clash_context))) - | Tags(l1,l2) -> - raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + Printtyp.raw_type_expr expected_ty; *) + try unify env ty expected_ty with + | Unify trace -> + raise (Error (loc, env, Expr_type_clash (trace, type_clash_context))) + | Tags (l1, l2) -> + raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2))) (* level at which to create the local type declarations *) let newtype_level = ref None let get_newtype_level () = match !newtype_level with - Some y -> y + | Some y -> y | None -> assert false let unify_pat_types_gadt loc env ty ty' = @@ -356,16 +351,12 @@ let unify_pat_types_gadt loc env ty ty' = | None -> assert false | Some x -> x in - try - unify_gadt ~newtype_level env ty ty' - with - Unify trace -> - raise(Error(loc, !env, Pattern_type_clash(trace))) - | Tags(l1,l2) -> - raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) + try unify_gadt ~newtype_level env ty ty' with + | Unify trace -> raise (Error (loc, !env, Pattern_type_clash trace)) + | Tags (l1, l2) -> + raise (Typetexp.Error (loc, !env, Typetexp.Variant_tags (l1, l2))) | Unification_recursive_abbrev trace -> - raise(Error(loc, !env, Recursive_local_constraint trace)) - + raise (Error (loc, !env, Recursive_local_constraint trace)) (* Creating new conjunctive types is not allowed when typing patterns *) @@ -375,29 +366,30 @@ let unify_pat env pat expected_ty = (* make all Reither present in open variants *) let finalize_variant pat = match pat.pat_desc with - Tpat_variant(tag, opat, r) -> - let row = - match expand_head pat.pat_env pat.pat_type with - {desc = Tvariant row} -> r := row; row_repr row - | _ -> assert false - in - begin match row_field tag row with - | Rabsent -> () (* assert false *) - | Reither (true, [], _, e) when not row.row_closed -> - set_row_field e (Rpresent None) - | Reither (false, ty::tl, _, e) when not row.row_closed -> - set_row_field e (Rpresent (Some ty)); - begin match opat with None -> assert false - | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) - end - | Reither (c, _l, true, e) when not (row_fixed row) -> - set_row_field e (Reither (c, [], false, ref None)) - | _ -> () - end; - (* Force check of well-formedness WHY? *) - (* unify_pat pat.pat_env pat - (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; - row_bound=(); row_fixed=false; row_name=None})); *) + | Tpat_variant (tag, opat, r) -> ( + let row = + match expand_head pat.pat_env pat.pat_type with + | {desc = Tvariant row} -> + r := row; + row_repr row + | _ -> assert false + in + match row_field tag row with + | Rabsent -> () (* assert false *) + | Reither (true, [], _, e) when not row.row_closed -> + set_row_field e (Rpresent None) + | Reither (false, ty :: tl, _, e) when not row.row_closed -> ( + set_row_field e (Rpresent (Some ty)); + match opat with + | None -> assert false + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty :: tl)) + | Reither (c, _l, true, e) when not (row_fixed row) -> + set_row_field e (Reither (c, [], false, ref None)) + | _ -> () + (* Force check of well-formedness WHY? *) + (* unify_pat pat.pat_env pat + (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; + row_bound=(); row_fixed=false; row_name=None})); *)) | _ -> () let rec iter_pattern f p = @@ -406,18 +398,22 @@ let rec iter_pattern f p = let has_variants p = try - iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ()) + iter_pattern + (function + | {pat_desc = Tpat_variant _} -> raise Exit + | _ -> ()) p; false - with Exit -> - true - + with Exit -> true (* pattern environment *) -let pattern_variables = ref ([] : - (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list) +let pattern_variables = + ref + ([] + : (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) + list) let pattern_force = ref ([] : (unit -> unit) list) -let pattern_scope = ref (None : Annot.ident option);; +let pattern_scope = ref (None : Annot.ident option) let allow_modules = ref false let module_variables = ref ([] : (string loc * Location.t) list) let reset_pattern scope allow = @@ -425,181 +421,215 @@ let reset_pattern scope allow = pattern_force := []; pattern_scope := scope; allow_modules := allow; - module_variables := []; -;; + module_variables := [] -let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty = - if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) +let enter_variable ?(is_module = false) ?(is_as_variable = false) loc name ty = + if + List.exists + (fun (id, _, _, _, _) -> Ident.name id = name.txt) !pattern_variables - then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); + then raise (Error (loc, Env.empty, Multiply_bound_variable name.txt)); let id = Ident.create name.txt in - pattern_variables := - (id, ty, name, loc, is_as_variable) :: !pattern_variables; - if is_module then begin + pattern_variables := (id, ty, name, loc, is_as_variable) :: !pattern_variables; + if is_module then ( (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (Error (loc, Env.empty, Modules_not_allowed)); - module_variables := (name, loc) :: !module_variables - end else + module_variables := (name, loc) :: !module_variables) + else (* moved to genannot *) - may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) - !pattern_scope; + may + (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) + !pattern_scope; id let sort_pattern_variables vs = List.sort - (fun (x,_,_,_,_) (y,_,_,_,_) -> + (fun (x, _, _, _, _) (y, _, _, _, _) -> compare (Ident.name x) (Ident.name y)) vs -let enter_orpat_variables loc env p1_vs p2_vs = +let enter_orpat_variables loc env p1_vs p2_vs = (* unify_vars operate on sorted lists *) - let p1_vs = sort_pattern_variables p1_vs and p2_vs = sort_pattern_variables p2_vs in let rec unify_vars p1_vs p2_vs = - let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in - match p1_vs, p2_vs with - | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2 - when Ident.equal x1 x2 -> - if x1==x2 then - unify_vars rem1 rem2 - else begin - begin try - unify env t1 t2 - with - | Unify trace -> - raise(Error(loc, env, Or_pattern_type_clash(x1, trace))) - end; - (x2,x1)::unify_vars rem1 rem2 - end - | [],[] -> [] - | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars (x, []))) - | [],(y,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars (y, []))) - | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> - let err = - if Ident.name x < Ident.name y - then Orpat_vars (x, vars p2_vs) - else Orpat_vars (y, vars p1_vs) in - raise (Error (loc, env, err)) in + let vars vs = List.map (fun (x, _t, _, _l, _a) -> x) vs in + match (p1_vs, p2_vs) with + | (x1, t1, _, _l1, _a1) :: rem1, (x2, t2, _, _l2, _a2) :: rem2 + when Ident.equal x1 x2 -> + if x1 == x2 then unify_vars rem1 rem2 + else ( + (try unify env t1 t2 + with Unify trace -> + raise (Error (loc, env, Or_pattern_type_clash (x1, trace)))); + (x2, x1) :: unify_vars rem1 rem2) + | [], [] -> [] + | (x, _, _, _, _) :: _, [] -> raise (Error (loc, env, Orpat_vars (x, []))) + | [], (y, _, _, _, _) :: _ -> raise (Error (loc, env, Orpat_vars (y, []))) + | (x, _, _, _, _) :: _, (y, _, _, _, _) :: _ -> + let err = + if Ident.name x < Ident.name y then Orpat_vars (x, vars p2_vs) + else Orpat_vars (y, vars p1_vs) + in + raise (Error (loc, env, err)) + in unify_vars p1_vs p2_vs let rec build_as_type env p = match p.pat_desc with - Tpat_alias(p1,_, _) -> build_as_type env p1 + | Tpat_alias (p1, _, _) -> build_as_type env p1 | Tpat_tuple pl -> - let tyl = List.map (build_as_type env) pl in - newty (Ttuple tyl) - | Tpat_construct(_, cstr, pl) -> - let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in - if keep then p.pat_type else + let tyl = List.map (build_as_type env) pl in + newty (Ttuple tyl) + | Tpat_construct (_, cstr, pl) -> + let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in + if keep then p.pat_type + else let tyl = List.map (build_as_type env) pl in let ty_args, ty_res = instance_constructor cstr in - List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty}) + List.iter2 + (fun (p, ty) -> unify_pat env {p with pat_type = ty}) (List.combine pl tyl) ty_args; ty_res - | Tpat_variant(l, p', _) -> - let ty = may_map (build_as_type env) p' in - newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); - row_bound=(); row_name=None; - row_fixed=false; row_closed=false}) - | Tpat_record (lpl,_) -> - let lbl = snd3 (List.hd lpl) in - if lbl.lbl_private = Private then p.pat_type else + | Tpat_variant (l, p', _) -> + let ty = may_map (build_as_type env) p' in + newty + (Tvariant + { + row_fields = [(l, Rpresent ty)]; + row_more = newvar (); + row_bound = (); + row_name = None; + row_fixed = false; + row_closed = false; + }) + | Tpat_record (lpl, _) -> + let lbl = snd3 (List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type + else let ty = newvar () in - let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in + let ppl = List.map (fun (_, l, p) -> (l.lbl_pos, p)) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; let refinable = - lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && - match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in - if refinable then begin + lbl.lbl_mut = Immutable + && List.mem_assoc lbl.lbl_pos ppl + && + match (repr lbl.lbl_arg).desc with + | Tpoly _ -> false + | _ -> true + in + if refinable then let arg = List.assoc lbl.lbl_pos ppl in unify_pat env {arg with pat_type = build_as_type env arg} ty_arg - end else begin + else let _, ty_arg', ty_res' = instance_label false lbl in unify env ty_arg ty_arg'; unify_pat env p ty_res' - end in + in Array.iter do_label lbl.lbl_all; ty - | Tpat_or(p1, p2, row) -> - begin match row with - None -> - let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in - unify_pat env {p2 with pat_type = ty2} ty1; - ty1 - | Some row -> - let row = row_repr row in - newty (Tvariant{row with row_closed=false; row_more=newvar()}) - end - | Tpat_any | Tpat_var _ | Tpat_constant _ - | Tpat_array _ | Tpat_lazy _ -> p.pat_type + | Tpat_or (p1, p2, row) -> ( + match row with + | None -> + let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in + unify_pat env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let row = row_repr row in + newty (Tvariant {row with row_closed = false; row_more = newvar ()})) + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ | Tpat_lazy _ -> + p.pat_type let build_or_pat env loc lid = - let path, decl = Typetexp.find_type env lid.loc lid.txt - in - let tyl = List.map (fun _ -> newvar()) decl.type_params in + let path, decl = Typetexp.find_type env lid.loc lid.txt in + let tyl = List.map (fun _ -> newvar ()) decl.type_params in let row0 = - let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in + let ty = expand_head env (newty (Tconstr (path, tyl, ref Mnil))) in match ty.desc with - Tvariant row when static_row row -> row - | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt)) + | Tvariant row when static_row row -> row + | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) in let pats, fields = List.fold_left - (fun (pats,fields) (l,f) -> + (fun (pats, fields) (l, f) -> match row_field_repr f with - Rpresent None -> - (l,None) :: pats, - (l, Reither(true,[], true, ref None)) :: fields + | Rpresent None -> + ((l, None) :: pats, (l, Reither (true, [], true, ref None)) :: fields) | Rpresent (Some ty) -> - (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; - pat_type=ty; pat_extra=[]; pat_attributes=[]}) + ( ( l, + Some + { + pat_desc = Tpat_any; + pat_loc = Location.none; + pat_env = env; + pat_type = ty; + pat_extra = []; + pat_attributes = []; + } ) :: pats, - (l, Reither(false, [ty], true, ref None)) :: fields - | _ -> pats, fields) - ([],[]) (row_repr row0).row_fields in + (l, Reither (false, [ty], true, ref None)) :: fields ) + | _ -> (pats, fields)) + ([], []) (row_repr row0).row_fields + in let row = - { row_fields = List.rev fields; row_more = newvar(); row_bound = (); - row_closed = false; row_fixed = false; row_name = Some (path, tyl) } + { + row_fields = List.rev fields; + row_more = newvar (); + row_bound = (); + row_closed = false; + row_fixed = false; + row_name = Some (path, tyl); + } in let ty = newty (Tvariant row) in - let gloc = {loc with Location.loc_ghost=true} in - let row' = ref {row with row_more=newvar()} in + let gloc = {loc with Location.loc_ghost = true} in + let row' = ref {row with row_more = newvar ()} in let pats = List.map - (fun (l,p) -> - {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; - pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]}) + (fun (l, p) -> + { + pat_desc = Tpat_variant (l, p, row'); + pat_loc = gloc; + pat_env = env; + pat_type = ty; + pat_extra = []; + pat_attributes = []; + }) pats in match pats with - [] -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt)) + | [] -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) | pat :: pats -> - let r = - List.fold_left - (fun pat pat0 -> - {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; - pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]}) - pat pats in - (path, rp { r with pat_loc = loc },ty) + let r = + List.fold_left + (fun pat pat0 -> + { + pat_desc = Tpat_or (pat0, pat, Some row0); + pat_extra = []; + pat_loc = gloc; + pat_env = env; + pat_type = ty; + pat_attributes = []; + }) + pat pats + in + (path, rp {r with pat_loc = loc}, ty) let extract_type_from_pat_variant_spread env lid expected_ty = let path, decl = Typetexp.find_type env lid.loc lid.txt in match decl with - | {type_kind = Type_variant constructors; type_params} -> ( - if List.length type_params > 0 then raise (Error (lid.loc, env, Type_params_not_supported lid.txt)); + | {type_kind = Type_variant constructors; type_params} -> + if List.length type_params > 0 then + raise (Error (lid.loc, env, Type_params_not_supported lid.txt)); let ty = newgenty (Tconstr (path, [], ref Mnil)) in - (try - Ctype.subtype env ty expected_ty () - with - Ctype.Subtype (tr1, tr2) -> - raise(Error(lid.loc, env, Not_subtype(tr1, tr2))) - ); - (path, decl, constructors, ty)) + (try Ctype.subtype env ty expected_ty () + with Ctype.Subtype (tr1, tr2) -> + raise (Error (lid.loc, env, Not_subtype (tr1, tr2)))); + (path, decl, constructors, ty) | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) let build_ppat_or_for_variant_spread pat env expected_ty = @@ -613,8 +643,10 @@ let build_ppat_or_for_variant_spread pat env expected_ty = let synthetic_or_patterns = constructors |> List.map (fun (c : Types.constructor_declaration) -> - Ast_helper.Pat.mk ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] ~loc:lident.loc - (Ppat_construct + Ast_helper.Pat.mk + ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] + ~loc:lident.loc + (Ppat_construct ( Location.mkloc (Longident.Lident (Ident.name c.cd_id)) lident.loc, @@ -636,7 +668,7 @@ let maybe_expand_variant_spread_in_pattern pattern env expected_ty = match pattern.Parsetree.ppat_desc with | Ppat_type _ when Variant_coercion.has_res_pat_variant_spread_attribute - pattern.ppat_attributes -> ( + pattern.ppat_attributes -> ( match build_ppat_or_for_variant_spread pattern env expected_ty with | None -> assert false (* TODO: Fix. *) | Some (pattern, _) -> pattern) @@ -645,19 +677,15 @@ let maybe_expand_variant_spread_in_pattern pattern env expected_ty = (* Type paths *) let rec expand_path env p = - let decl = - try Some (Env.find_type p env) with Not_found -> None - in + let decl = try Some (Env.find_type p env) with Not_found -> None in match decl with - Some {type_manifest = Some ty} -> - begin match repr ty with - {desc=Tconstr(p,_,_)} -> expand_path env p - | _ -> p - (* PR#6394: recursive module may introduce incoherent manifest *) - end + | Some {type_manifest = Some ty} -> ( + match repr ty with + | {desc = Tconstr (p, _, _)} -> expand_path env p + | _ -> p (* PR#6394: recursive module may introduce incoherent manifest *)) | _ -> - let p' = Env.normalize_path None env p in - if Path.same p p' then p else expand_path env p' + let p' = Env.normalize_path None env p in + if Path.same p p' then p else expand_path env p' let compare_type_path env tpath1 tpath2 = Path.same (expand_path env tpath1) (expand_path env tpath2) @@ -665,64 +693,76 @@ let compare_type_path env tpath1 tpath2 = let fprintf = Format.fprintf let rec bottom_aliases = function - | (_, one) :: (_, two) :: rest -> begin match bottom_aliases rest with - | Some types -> Some types - | None -> Some (one, two) - end + | (_, one) :: (_, two) :: rest -> ( + match bottom_aliases rest with + | Some types -> Some types + | None -> Some (one, two)) | _ -> None -let simple_conversions = [ - (("float", "int"), "Belt.Float.toInt"); - (("float", "string"), "Belt.Float.toString"); - (("int", "float"), "Belt.Int.toFloat"); - (("int", "string"), "Belt.Int.toString"); - (("string", "float"), "Belt.Float.fromString"); - (("string", "int"), "Belt.Int.fromString"); -] +let simple_conversions = + [ + (("float", "int"), "Belt.Float.toInt"); + (("float", "string"), "Belt.Float.toString"); + (("int", "float"), "Belt.Int.toFloat"); + (("int", "string"), "Belt.Int.toString"); + (("string", "float"), "Belt.Float.fromString"); + (("string", "int"), "Belt.Int.fromString"); + ] let print_simple_conversion ppf (actual, expected) = - try ( + try let converter = List.assoc (actual, expected) simple_conversions in - fprintf ppf "@,@,@[You can convert @{%s@} to @{%s@} with @{%s@}.@]" actual expected converter - ) with | Not_found -> () - + fprintf ppf + "@,\ + @,\ + @[You can convert @{%s@} to @{%s@} with @{%s@}.@]" + actual expected converter + with Not_found -> () + let print_simple_message ppf = function - | ("float", "int") -> fprintf ppf "@ If this is a literal, try a number without a trailing dot (e.g. @{20@})." - | ("int", "float") -> fprintf ppf "@ If this is a literal, try a number with a trailing dot (e.g. @{20.@})." + | "float", "int" -> + fprintf ppf + "@ If this is a literal, try a number without a trailing dot (e.g. \ + @{20@})." + | "int", "float" -> + fprintf ppf + "@ If this is a literal, try a number with a trailing dot (e.g. \ + @{20.@})." | _ -> () -let show_extra_help ppf _env trace = begin +let show_extra_help ppf _env trace = match bottom_aliases trace with - | Some ({Types.desc = Tconstr (actual_path, actual_args, _)}, {desc = Tconstr (expected_path, expexted_args, _)}) -> begin - match (actual_path, actual_args, expected_path, expexted_args) with - | (Pident {name = actual_name}, [], Pident {name = expected_name}, []) -> begin - print_simple_conversion ppf (actual_name, expected_name); - print_simple_message ppf (actual_name, expected_name); - end - | _ -> () - end; - | _ -> (); -end + | Some + ( {Types.desc = Tconstr (actual_path, actual_args, _)}, + {desc = Tconstr (expected_path, expexted_args, _)} ) -> ( + match (actual_path, actual_args, expected_path, expexted_args) with + | Pident {name = actual_name}, [], Pident {name = expected_name}, [] -> + print_simple_conversion ppf (actual_name, expected_name); + print_simple_message ppf (actual_name, expected_name) + | _ -> ()) + | _ -> () -let rec collect_missing_arguments env type1 type2 = match type1 with +let rec collect_missing_arguments env type1 type2 = + match type1 with (* why do we use Ctype.matches here? Please see https://github.com/rescript-lang/rescript-compiler/pull/2554 *) - | {Types.desc=Tarrow (label, argtype, typ, _)} when Ctype.matches env typ type2 -> + | {Types.desc = Tarrow (label, argtype, typ, _)} + when Ctype.matches env typ type2 -> Some [(label, argtype)] - | {desc=Tarrow (label, argtype, typ, _)} -> begin - match collect_missing_arguments env typ type2 with - | Some res -> Some ((label, argtype) :: res) - | None -> None - end - | t when Ast_uncurried.type_is_uncurried_fun t -> - let typ = Ast_uncurried.type_extract_uncurried_fun t in + | {desc = Tarrow (label, argtype, typ, _)} -> ( + match collect_missing_arguments env typ type2 with + | Some res -> Some ((label, argtype) :: res) + | None -> None) + | t when Ast_uncurried.type_is_uncurried_fun t -> + let typ = Ast_uncurried.type_extract_uncurried_fun t in collect_missing_arguments env typ type2 | _ -> None -let print_expr_type_clash ?type_clash_context env trace ppf = begin +let print_expr_type_clash ?type_clash_context env trace ppf = (* this is the most frequent error. We should do whatever we can to provide specific guidance to this generic error before giving up *) let bottom_aliases_result = bottom_aliases trace in - let missing_arguments = match bottom_aliases_result with + let missing_arguments = + match bottom_aliases_result with | Some (actual, expected) -> collect_missing_arguments env actual expected | None -> assert false in @@ -730,13 +770,12 @@ let print_expr_type_clash ?type_clash_context env trace ppf = begin Format.pp_print_list ~pp_sep:(fun ppf _ -> fprintf ppf ",@ ") (fun ppf (label, argtype) -> - match label with - | Asttypes.Nolabel -> fprintf ppf "@[%a@]" Printtyp.type_expr argtype - | Labelled label -> - fprintf ppf "@[(~%s: %a)@]" label Printtyp.type_expr argtype - | Optional label -> - fprintf ppf "@[(?%s: %a)@]" label Printtyp.type_expr argtype - ) + match label with + | Asttypes.Nolabel -> fprintf ppf "@[%a@]" Printtyp.type_expr argtype + | Labelled label -> + fprintf ppf "@[(~%s: %a)@]" label Printtyp.type_expr argtype + | Optional label -> + fprintf ppf "@[(?%s: %a)@]" label Printtyp.type_expr argtype) in match missing_arguments with | Some [single_argument] -> @@ -748,94 +787,102 @@ let print_expr_type_clash ?type_clash_context env trace ppf = begin fprintf ppf "@[@{This call is missing arguments@} of type:@ %a@]" print_arguments arguments | None -> - let missing_parameters = match bottom_aliases_result with + let missing_parameters = + match bottom_aliases_result with | Some (actual, expected) -> collect_missing_arguments env expected actual | None -> assert false in - begin match missing_parameters with - | Some [single_parameter] -> - fprintf ppf "@[This value might need to be @{wrapped in a function@ that@ takes@ an@ extra@ parameter@}@ of@ type@ %a@]@,@," - print_arguments [single_parameter]; - fprintf ppf "@[@{Here's the original error message@}@]@," - | Some arguments -> - fprintf ppf "@[This value seems to @{need to be wrapped in a function that takes extra@ arguments@}@ of@ type:@ @[%a@]@]@,@," - print_arguments arguments; - fprintf ppf "@[@{Here's the original error message@}@]@," - | None -> () - end; + (match missing_parameters with + | Some [single_parameter] -> + fprintf ppf + "@[This value might need to be @{wrapped in a function@ that@ \ + takes@ an@ extra@ parameter@}@ of@ type@ %a@]@,\ + @," + print_arguments [single_parameter]; + fprintf ppf "@[@{Here's the original error message@}@]@," + | Some arguments -> + fprintf ppf + "@[This value seems to @{need to be wrapped in a function that \ + takes extra@ arguments@}@ of@ type:@ @[%a@]@]@,\ + @," + print_arguments arguments; + fprintf ppf "@[@{Here's the original error message@}@]@," + | None -> ()); Printtyp.super_report_unification_error ppf env trace - (function ppf -> - error_type_text ppf type_clash_context) - (function ppf -> - error_expected_type_text ppf type_clash_context); + (function + | ppf -> error_type_text ppf type_clash_context) + (function + | ppf -> error_expected_type_text ppf type_clash_context); print_extra_type_clash_help ppf trace type_clash_context; - show_extra_help ppf env trace; -end - + show_extra_help ppf env trace + let report_arity_mismatch ~arity_a ~arity_b ppf = fprintf ppf "This function expected @{%s@} %s, but got @{%s@}" arity_b (if arity_b = "1" then "argument" else "arguments") arity_a - + (* Records *) -let label_of_kind kind = - if kind = "record" then "field" else "constructor" +let label_of_kind kind = if kind = "record" then "field" else "constructor" -module NameChoice(Name : sig +module NameChoice (Name : sig type t - val type_kind: string - val get_name: t -> string - val get_type: t -> type_expr - val get_descrs: Env.type_descriptions -> t list - - val unsafe_do_not_use__add_with_name: t -> string -> t - val unbound_name_error: Env.t -> Longident.t loc -> 'a - -end) = struct + val type_kind : string + val get_name : t -> string + val get_type : t -> type_expr + val get_descrs : Env.type_descriptions -> t list + + val unsafe_do_not_use__add_with_name : t -> string -> t + val unbound_name_error : Env.t -> Longident.t loc -> 'a +end) = +struct open Name let get_type_path d = match (repr (get_type d)).desc with - | Tconstr(p, _, _) -> p + | Tconstr (p, _, _) -> p | _ -> assert false let lookup_from_type env tpath (lid : Longident.t loc) : Name.t = let descrs = get_descrs (Env.find_type_descrs tpath env) in Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); - if Path.same tpath Predef.path_dict then ( + if Path.same tpath Predef.path_dict then (* [dict] Handle directing any label lookup to the magic dict field. *) match lid.txt with - Longident.Lident s -> begin - let x = List.find (fun nd -> get_name nd = Dict_type_helpers.dict_magic_field_name) descrs in - unsafe_do_not_use__add_with_name x s - end - | _ -> raise Not_found) - else match lid.txt with - Longident.Lident s -> begin - try - List.find (fun nd -> get_name nd = s) descrs + | Longident.Lident s -> + let x = + List.find + (fun nd -> get_name nd = Dict_type_helpers.dict_magic_field_name) + descrs + in + unsafe_do_not_use__add_with_name x s + | _ -> raise Not_found + else + match lid.txt with + | Longident.Lident s -> ( + try List.find (fun nd -> get_name nd = s) descrs with Not_found -> let names = List.map get_name descrs in - raise (Error (lid.loc, env, - Wrong_name ("", newvar (), type_kind, tpath, s, names))) - end - | _ -> raise Not_found + raise + (Error + ( lid.loc, + env, + Wrong_name ("", newvar (), type_kind, tpath, s, names) ))) + | _ -> raise Not_found let rec unique eq acc = function - [] -> List.rev acc + | [] -> List.rev acc | x :: rem -> - if List.exists (eq x) acc then unique eq acc rem - else unique eq (x :: acc) rem + if List.exists (eq x) acc then unique eq acc rem + else unique eq (x :: acc) rem let ambiguous_types env lbl others = let tpath = get_type_path lbl in - let others = - List.map (fun (lbl, _) -> get_type_path lbl) others in + let others = List.map (fun (lbl, _) -> get_type_path lbl) others in let tpaths = unique (compare_type_path env) [tpath] others in match tpaths with - [_] -> [] + | [_] -> [] | _ -> List.map Printtyp.string_of_path tpaths let disambiguate_by_type env tpath lbls = @@ -845,66 +892,78 @@ end) = struct in List.find check_type lbls - let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ()) + let disambiguate ?(warn = Location.prerr_warning) ?(check_lk = fun _ _ -> ()) ?scope lid env opath lbls = - let scope = match scope with None -> lbls | Some l -> l in - let lbl = match opath with - None -> - begin match lbls with - [] -> unbound_name_error env lid + let scope = + match scope with + | None -> lbls + | Some l -> l + in + let lbl = + match opath with + | None -> ( + match lbls with + | [] -> unbound_name_error env lid | (lbl, use) :: rest -> - use (); - let paths = ambiguous_types env lbl rest in - if paths <> [] then - warn lid.loc - (Warnings.Ambiguous_name ([Longident.last lid.txt], - paths, false)); - lbl - end - | Some(tpath0, tpath) -> + use (); + let paths = ambiguous_types env lbl rest in + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], paths, false)); + lbl) + | Some (tpath0, tpath) -> ( try let lbl, use = disambiguate_by_type env tpath scope in use (); lbl - with Not_found -> try - let lbl = lookup_from_type env tpath lid in - check_lk tpath lbl; - lbl - with Not_found -> - if lbls = [] then unbound_name_error env lid else - let tp = (tpath0, expand_path env tpath) in - let tpl = - List.map - (fun (lbl, _) -> - let tp0 = get_type_path lbl in - let tp = expand_path env tp0 in - (tp0, tp)) - lbls - in - raise (Error (lid.loc, env, - Name_type_mismatch (type_kind, lid.txt, tp, tpl))) + with Not_found -> ( + try + let lbl = lookup_from_type env tpath lid in + check_lk tpath lbl; + lbl + with Not_found -> + if lbls = [] then unbound_name_error env lid + else + let tp = (tpath0, expand_path env tpath) in + let tpl = + List.map + (fun (lbl, _) -> + let tp0 = get_type_path lbl in + let tp = expand_path env tp0 in + (tp0, tp)) + lbls + in + raise + (Error + ( lid.loc, + env, + Name_type_mismatch (type_kind, lid.txt, tp, tpl) )))) in lbl end let wrap_disambiguate kind ty f x = - try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) -> - raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names))) + try f x + with Error (loc, env, Wrong_name ("", _, tk, tp, name, valid_names)) -> + raise (Error (loc, env, Wrong_name (kind, ty, tk, tp, name, valid_names))) module Label = NameChoice (struct type t = label_description let type_kind = "record" let get_name lbl = lbl.lbl_name - + let unsafe_do_not_use__add_with_name lbl name = - (* [dict] This is used in dicts and shouldn't be used anywhere else. + (* [dict] This is used in dicts and shouldn't be used anywhere else. It adds a new field to an existing record type, to "fool" the pattern matching into thinking the label exists. *) - let l = - {lbl with + let l = + { + lbl with lbl_name = name; lbl_pos = Array.length lbl.lbl_all; - lbl_repres = Record_optional_labels [name]} in + lbl_repres = Record_optional_labels [name]; + } + in let lbl_all_list = Array.to_list lbl.lbl_all @ [l] in let lbl_all = Array.of_list lbl_all_list in Ext_array.iter lbl_all (fun lbl -> lbl.lbl_all <- lbl_all); @@ -915,23 +974,29 @@ module Label = NameChoice (struct end) let disambiguate_label_by_ids closed ids labels = - let check_ids (lbl, _) = (* check that all ids are present *) + let check_ids (lbl, _) = + (* check that all ids are present *) let lbls = Hashtbl.create 8 in Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; - List.for_all (Hashtbl.mem lbls) ids in - let mandatory_labels_are_present num_ids lbl = (* check that all mandatory labels are present *) + List.for_all (Hashtbl.mem lbls) ids + in + let mandatory_labels_are_present num_ids lbl = + (* check that all mandatory labels are present *) if has_optional_labels lbl then ( let mandatory_lbls = ref 0 in - Ext_array.iter lbl.lbl_all (fun l -> if not (label_is_optional l) then incr mandatory_lbls); + Ext_array.iter lbl.lbl_all (fun l -> + if not (label_is_optional l) then incr mandatory_lbls); num_ids >= !mandatory_lbls) - else num_ids = Array.length lbl.lbl_all in + else num_ids = Array.length lbl.lbl_all + in let check_closed (lbl, _) = - (not closed || mandatory_labels_are_present (List.length ids) lbl) + (not closed) || mandatory_labels_are_present (List.length ids) lbl in let labels' = Ext_list.filter labels check_ids in - if labels' = [] then (false, labels) else - let labels'' = Ext_list.filter labels' check_closed in - if labels'' = [] then (false, labels') else (true, labels'') + if labels' = [] then (false, labels) + else + let labels'' = Ext_list.filter labels' check_closed in + if labels'' = [] then (false, labels') else (true, labels'') (* Only issue warnings once per record constructor/pattern *) let disambiguate_lid_a_list loc closed env opath lid_a_list = @@ -940,8 +1005,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = let warn loc msg = let open Warnings in match msg with - - | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb + | Ambiguous_name ([s], l, _) -> w_amb := (s, l) :: !w_amb | _ -> Location.prerr_warning loc msg in let process_label lid = @@ -954,109 +1018,121 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = * if there is no known type reduce it incrementally, so that there is still at least one candidate (for error message) * if the reduced list is valid, call Label.disambiguate - *) + *) let scope = Typetexp.find_all_labels env lid.loc lid.txt in - if opath = None && scope = [] then - Typetexp.unbound_label_error env lid; - let (ok, labels) = + if opath = None && scope = [] then Typetexp.unbound_label_error env lid; + let ok, labels = match opath with - Some _ -> (true, scope) (* disambiguate only checks scope *) - | _ -> disambiguate_label_by_ids closed ids scope + | Some _ -> (true, scope) (* disambiguate only checks scope *) + | _ -> disambiguate_label_by_ids closed ids scope in if ok then Label.disambiguate lid env opath labels ~warn ~scope - else fst (List.hd labels) (* will fail later *) + else fst (List.hd labels) + (* will fail later *) in let lbl_a_list = - List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in - begin - match List.rev !w_amb with - (_,types)::_ as amb -> - let paths = - List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in - let path = List.hd paths in - if List.for_all (compare_type_path env path) (List.tl paths) then - Location.prerr_warning loc - (Warnings.Ambiguous_name (List.map fst amb, types, true)) - else - List.iter - (fun (s,l) -> Location.prerr_warning loc - (Warnings.Ambiguous_name ([s],l,false))) - amb - | _ -> () - end; + List.map (fun (lid, a) -> (lid, process_label lid, a)) lid_a_list + in + (match List.rev !w_amb with + | (_, types) :: _ as amb -> + let paths = + List.map (fun (_, lbl, _) -> Label.get_type_path lbl) lbl_a_list + in + let path = List.hd paths in + if List.for_all (compare_type_path env path) (List.tl paths) then + Location.prerr_warning loc + (Warnings.Ambiguous_name (List.map fst amb, types, true)) + else + List.iter + (fun (s, l) -> + Location.prerr_warning loc (Warnings.Ambiguous_name ([s], l, false))) + amb + | _ -> ()); lbl_a_list let rec find_record_qual = function | [] -> None - | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname + | ({txt = Longident.Ldot (modname, _)}, _) :: _ -> Some modname | _ :: rest -> find_record_qual rest let map_fold_cont f xs k = - List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys))) - xs (fun ys -> k (List.rev ys)) [] + List.fold_right + (fun x k ys -> f x (fun y -> k (y :: ys))) + xs + (fun ys -> k (List.rev ys)) + [] let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k = let lbl_a_list = - match lid_a_list, labels with - ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s -> - (* Special case for rebuilt syntax trees *) - List.map - (function lid, a -> match lid.txt with - Longident.Lident s -> lid, Hashtbl.find labels s, a - | _ -> assert false) - lid_a_list + match (lid_a_list, labels) with + | ({txt = Longident.Lident s}, _) :: _, Some labels + when Hashtbl.mem labels s -> + (* Special case for rebuilt syntax trees *) + List.map + (function + | lid, a -> ( + match lid.txt with + | Longident.Lident s -> (lid, Hashtbl.find labels s, a) + | _ -> assert false)) + lid_a_list | _ -> - let lid_a_list = - match find_record_qual lid_a_list with - None -> lid_a_list - | Some modname -> - List.map - (fun (lid, a as lid_a) -> - match lid.txt with Longident.Lident s -> - {lid with txt=Longident.Ldot (modname, s)}, a - | _ -> lid_a) - lid_a_list - in - disambiguate_lid_a_list loc closed env opath lid_a_list + let lid_a_list = + match find_record_qual lid_a_list with + | None -> lid_a_list + | Some modname -> + List.map + (fun ((lid, a) as lid_a) -> + match lid.txt with + | Longident.Lident s -> + ({lid with txt = Longident.Ldot (modname, s)}, a) + | _ -> lid_a) + lid_a_list + in + disambiguate_lid_a_list loc closed env opath lid_a_list in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = List.sort - (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + (fun (_, lbl1, _) (_, lbl2, _) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in map_fold_cont type_lbl_a lbl_a_list k -;; (* Checks over the labels mentioned in a record pattern: no duplicate definitions (error); properly closed (warning) *) -let check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list closed = +let check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list closed + = match lbl_pat_list with - | [] -> () (* should not happen *) - | ((l: Longident.t loc), label1, _) :: _ -> - let all = label1.lbl_all in - let defined = Array.make (Array.length all) false in - let check_defined (_, label, _) = - if defined.(label.lbl_pos) - then raise(Error(l.loc, Env.empty, Label_multiply_defined { - label = label.lbl_name; - jsx_component_info = get_jsx_component_error_info (); - })) - else defined.(label.lbl_pos) <- true in - List.iter check_defined lbl_pat_list; - if closed = Closed + | [] -> () (* should not happen *) + | ((l : Longident.t loc), label1, _) :: _ -> + let all = label1.lbl_all in + let defined = Array.make (Array.length all) false in + let check_defined (_, label, _) = + if defined.(label.lbl_pos) then + raise + (Error + ( l.loc, + Env.empty, + Label_multiply_defined + { + label = label.lbl_name; + jsx_component_info = get_jsx_component_error_info (); + } )) + else defined.(label.lbl_pos) <- true + in + List.iter check_defined lbl_pat_list; + if + closed = Closed && Warnings.is_active (Warnings.Non_closed_record_pattern "") - then begin - let undefined = ref [] in - for i = 0 to Array.length all - 1 do - if not defined.(i) then undefined := all.(i).lbl_name :: !undefined - done; - if !undefined <> [] then begin - let u = String.concat ", " (List.rev !undefined) in - Location.prerr_warning loc (Warnings.Non_closed_record_pattern u) - end - end + then ( + let undefined = ref [] in + for i = 0 to Array.length all - 1 do + if not defined.(i) then undefined := all.(i).lbl_name :: !undefined + done; + if !undefined <> [] then + let u = String.concat ", " (List.rev !undefined) in + Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)) (* Constructors *) @@ -1074,12 +1150,12 @@ end) (* unification of a type with a tconstr with freshly created arguments *) let unify_head_only loc env ty constr = - let (_, ty_res) = instance_constructor constr in + let _, ty_res = instance_constructor constr in match (repr ty_res).desc with - | Tconstr(p,args,m) -> - ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m); - enforce_constraints env ty_res; - unify_pat_types loc env ty_res ty + | Tconstr (p, args, m) -> + ty_res.desc <- Tconstr (p, List.map (fun _ -> newvar ()) args, m); + enforce_constraints env ty_res; + unify_pat_types loc env ty_res ty | _ -> assert false (* Typing of patterns *) @@ -1087,14 +1163,9 @@ let unify_head_only loc env ty constr = (* Remember current state for backtracking. No variable information, as we only backtrack on patterns without variables (cf. assert statements). *) -type state = - { snapshot: Btype.snapshot; - levels: Ctype.levels; - env: Env.t; } +type state = {snapshot: Btype.snapshot; levels: Ctype.levels; env: Env.t} let save_state env = - { snapshot = Btype.snapshot (); - levels = Ctype.save_levels (); - env = !env; } + {snapshot = Btype.snapshot (); levels = Ctype.save_levels (); env = !env} let set_state s env = Btype.backtrack s.snapshot; Ctype.set_levels s.levels; @@ -1103,9 +1174,9 @@ let set_state s env = (* type_pat does not generate local constraints inside or patterns *) type type_pat_mode = | Normal - | Splitting_or (* splitting an or-pattern *) - | Inside_or (* inside a non-split or-pattern *) - | Split_or (* always split or-patterns *) + | Splitting_or (* splitting an or-pattern *) + | Inside_or (* inside a non-split or-pattern *) + | Split_or (* always split or-patterns *) exception Need_backtrack @@ -1114,458 +1185,533 @@ exception Need_backtrack Unification may update the typing environment. *) (* constrs <> None => called from parmatch: backtrack on or-patterns explode > 0 => explode Ppat_any for gadts *) -let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env - sp expected_ty k = - Builtin_attributes.warning_scope sp.ppat_attributes - (fun () -> - type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env - sp expected_ty k - ) - -and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env - sp expected_ty k = +let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env sp + expected_ty k = + Builtin_attributes.warning_scope sp.ppat_attributes (fun () -> + type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp + expected_ty k) + +and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp + expected_ty k = let sp = maybe_expand_variant_spread_in_pattern sp env expected_ty in let mode' = if mode = Splitting_or then Normal else mode in - let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode') - ?(explode=explode) ?(env=env) = - type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env in + let type_pat ?(constrs = constrs) ?(labels = labels) ?(mode = mode') + ?(explode = explode) ?(env = env) = + type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env + in let loc = sp.ppat_loc in let rp k x : pattern = if constrs = None then k (rp x) else k x in match sp.ppat_desc with - Ppat_any -> - let k' d = rp k { - pat_desc = d; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - in - if explode > 0 then - let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in - if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else - if mode = Inside_or then raise Need_backtrack else + | Ppat_any -> + let k' d = + rp k + { + pat_desc = d; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + in + if explode > 0 then + let sp, constrs, labels = Parmatch.ppat_of_type !env expected_ty in + if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any + else if mode = Inside_or then raise Need_backtrack + else let explode = match sp.ppat_desc with - Parsetree.Ppat_or _ -> explode - 5 + | Parsetree.Ppat_or _ -> explode - 5 | _ -> explode - 1 in - type_pat ~constrs:(Some constrs) ~labels:(Some labels) - ~explode sp expected_ty k - else k' Tpat_any + type_pat ~constrs:(Some constrs) ~labels:(Some labels) ~explode sp + expected_ty k + else k' Tpat_any | Ppat_var name -> - let id = (* PR#7330 *) - if name.txt = "*extension*" then Ident.create name.txt else - enter_variable loc name expected_ty - in - rp k { + let id = + (* PR#7330 *) + if name.txt = "*extension*" then Ident.create name.txt + else enter_variable loc name expected_ty + in + rp k + { pat_desc = Tpat_var (id, name); - pat_loc = loc; pat_extra=[]; + pat_loc = loc; + pat_extra = []; pat_type = expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !env; + } | Ppat_unpack name -> - assert (constrs = None); - let id = enter_variable loc name expected_ty ~is_module:true in - rp k { + assert (constrs = None); + let id = enter_variable loc name expected_ty ~is_module:true in + rp k + { pat_desc = Tpat_var (id, name); pat_loc = sp.ppat_loc; - pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; + pat_extra = [(Tpat_unpack, loc, sp.ppat_attributes)]; pat_type = expected_ty; pat_attributes = []; - pat_env = !env } - | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc}, - ({ptyp_desc=Ptyp_poly _} as sty)) -> - (* explicitly polymorphic type *) - assert (constrs = None); - let cty, force = Typetexp.transl_simple_type_delayed !env sty in - let ty = cty.ctyp_type in - unify_pat_types lloc !env ty expected_ty; - pattern_force := force :: !pattern_force; - begin match ty.desc with - | Tpoly (body, tyl) -> - begin_def (); - let _, ty' = instance_poly ~keep_names:true false tyl body in - end_def (); - generalize ty'; - let id = enter_variable lloc name ty' in - rp k { - pat_desc = Tpat_var (id, name); - pat_loc = lloc; - pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; - pat_type = ty; - pat_attributes = []; - pat_env = !env - } - | _ -> assert false - end - | Ppat_alias(sq, name) -> - let override_type_from_variant_spread, sq = - match sq with - | {ppat_desc = Ppat_type _; ppat_attributes} - when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes - -> ( - match build_ppat_or_for_variant_spread sq env expected_ty with - | Some (p, ty) -> (Some ty, p) - | None -> (None, sq)) - | _ -> (None, sq) - in - assert (constrs = None); - type_pat sq expected_ty (fun q -> + pat_env = !env; + } + | Ppat_constraint + ( {ppat_desc = Ppat_var name; ppat_loc = lloc}, + ({ptyp_desc = Ptyp_poly _} as sty) ) -> ( + (* explicitly polymorphic type *) + assert (constrs = None); + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in + unify_pat_types lloc !env ty expected_ty; + pattern_force := force :: !pattern_force; + match ty.desc with + | Tpoly (body, tyl) -> + begin_def (); + let _, ty' = instance_poly ~keep_names:true false tyl body in + end_def (); + generalize ty'; + let id = enter_variable lloc name ty' in + rp k + { + pat_desc = Tpat_var (id, name); + pat_loc = lloc; + pat_extra = [(Tpat_constraint cty, loc, sp.ppat_attributes)]; + pat_type = ty; + pat_attributes = []; + pat_env = !env; + } + | _ -> assert false) + | Ppat_alias (sq, name) -> + let override_type_from_variant_spread, sq = + match sq with + | {ppat_desc = Ppat_type _; ppat_attributes} + when Variant_coercion.has_res_pat_variant_spread_attribute + ppat_attributes -> ( + match build_ppat_or_for_variant_spread sq env expected_ty with + | Some (p, ty) -> (Some ty, p) + | None -> (None, sq)) + | _ -> (None, sq) + in + assert (constrs = None); + type_pat sq expected_ty (fun q -> begin_def (); - let ty_var = (match override_type_from_variant_spread with - | Some ty -> ty - | None -> build_as_type !env q) in + let ty_var = + match override_type_from_variant_spread with + | Some ty -> ty + | None -> build_as_type !env q + in end_def (); generalize ty_var; let id = enter_variable ~is_as_variable:true loc name ty_var in - rp k { - pat_desc = Tpat_alias(q, id, name); - pat_loc = loc; pat_extra=[]; - pat_type = q.pat_type; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) + rp k + { + pat_desc = Tpat_alias (q, id, name); + pat_loc = loc; + pat_extra = []; + pat_type = q.pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) | Ppat_constant cst -> - let cst = constant_or_raise !env loc cst in - unify_pat_types loc !env (type_constant cst) expected_ty; - rp k { + let cst = constant_or_raise !env loc cst in + unify_pat_types loc !env (type_constant cst) expected_ty; + rp k + { pat_desc = Tpat_constant cst; - pat_loc = loc; pat_extra=[]; + pat_loc = loc; + pat_extra = []; pat_type = expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !env; + } | Ppat_interval (Pconst_char c1, Pconst_char c2) -> - let open Ast_helper.Pat in - let gloc = {loc with Location.loc_ghost=true} in - let rec loop c1 c2 = - if c1 = c2 then constant ~loc:gloc (Pconst_char c1) - else - or_ ~loc:gloc - (constant ~loc:gloc (Pconst_char c1)) - (loop (c1 + 1) c2) - in - let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in - let p = {p with ppat_loc=loc} in - type_pat ~explode:0 p expected_ty k - (* TODO: record 'extra' to remember about interval *) - | Ppat_interval _ -> - raise (Error (loc, !env, Invalid_interval)) + let open Ast_helper.Pat in + let gloc = {loc with Location.loc_ghost = true} in + let rec loop c1 c2 = + if c1 = c2 then constant ~loc:gloc (Pconst_char c1) + else + or_ ~loc:gloc (constant ~loc:gloc (Pconst_char c1)) (loop (c1 + 1) c2) + in + let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in + let p = {p with ppat_loc = loc} in + type_pat ~explode:0 p expected_ty k + (* TODO: record 'extra' to remember about interval *) + | Ppat_interval _ -> raise (Error (loc, !env, Invalid_interval)) | Ppat_tuple spl -> - assert (List.length spl >= 2); - let spl_ann = List.map (fun p -> (p,newvar ())) spl in - let ty = newty (Ttuple(List.map snd spl_ann)) in - unify_pat_types loc !env ty expected_ty; - map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl -> - rp k { - pat_desc = Tpat_tuple pl; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_construct(lid, sarg) -> - let opath = - try - let (p0, p, _) = extract_concrete_variant !env expected_ty in - Some (p0, p) - with Not_found -> None - in - let candidates = - match lid.txt, constrs with - Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> - [Hashtbl.find constrs s, (fun () -> ())] - | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt - in - let check_lk tpath constr = - if constr.cstr_generalized then - raise (Error (lid.loc, !env, - Unqualified_gadt_pattern (tpath, constr.cstr_name))) - in - let constr = - wrap_disambiguate "This variant pattern is expected to have" expected_ty - (Constructor.disambiguate lid !env opath ~check_lk) candidates - in - if constr.cstr_generalized && constrs <> None && mode = Inside_or - then raise Need_backtrack; - Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; - Builtin_attributes.check_deprecated loc constr.cstr_attributes - constr.cstr_name; - if no_existentials && constr.cstr_existentials <> [] then - raise (Error (loc, !env, Unexpected_existential)); - (* if constructor is gadt, we must verify that the expected type has the - correct head *) + assert (List.length spl >= 2); + let spl_ann = List.map (fun p -> (p, newvar ())) spl in + let ty = newty (Ttuple (List.map snd spl_ann)) in + unify_pat_types loc !env ty expected_ty; + map_fold_cont + (fun (p, t) -> type_pat p t) + spl_ann + (fun pl -> + rp k + { + pat_desc = Tpat_tuple pl; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_construct (lid, sarg) -> + let opath = + try + let p0, p, _ = extract_concrete_variant !env expected_ty in + Some (p0, p) + with Not_found -> None + in + let candidates = + match (lid.txt, constrs) with + | Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> + [(Hashtbl.find constrs s, fun () -> ())] + | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt + in + let check_lk tpath constr = if constr.cstr_generalized then - unify_head_only loc !env expected_ty constr; - let sargs = - match sarg with - None -> [] - | Some {ppat_desc = Ppat_tuple spl} when - constr.cstr_arity > 1 || - Builtin_attributes.explicit_arity sp.ppat_attributes - -> spl - | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> - if constr.cstr_arity = 0 then - Location.prerr_warning sp.ppat_loc - Warnings.Wildcard_arg_to_constant_constr; - replicate_list sp constr.cstr_arity - | Some sp -> [sp] in - begin match sargs with - | [{ppat_desc = Ppat_constant _} as sp] - when Builtin_attributes.warn_on_literal_pattern - constr.cstr_attributes -> + raise + (Error + (lid.loc, !env, Unqualified_gadt_pattern (tpath, constr.cstr_name))) + in + let constr = + wrap_disambiguate "This variant pattern is expected to have" expected_ty + (Constructor.disambiguate lid !env opath ~check_lk) + candidates + in + if constr.cstr_generalized && constrs <> None && mode = Inside_or then + raise Need_backtrack; + Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; + Builtin_attributes.check_deprecated loc constr.cstr_attributes + constr.cstr_name; + if no_existentials && constr.cstr_existentials <> [] then + raise (Error (loc, !env, Unexpected_existential)); + (* if constructor is gadt, we must verify that the expected type has the + correct head *) + if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; + let sargs = + match sarg with + | None -> [] + | Some {ppat_desc = Ppat_tuple spl} + when constr.cstr_arity > 1 + || Builtin_attributes.explicit_arity sp.ppat_attributes -> + spl + | Some ({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> + if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc - Warnings.Fragile_literal_pattern + Warnings.Wildcard_arg_to_constant_constr; + replicate_list sp constr.cstr_arity + | Some sp -> [sp] + in + (match sargs with + | [({ppat_desc = Ppat_constant _} as sp)] + when Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes -> + Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern + | _ -> ()); + if List.length sargs <> constr.cstr_arity then + raise + (Error + ( loc, + !env, + Constructor_arity_mismatch + (lid.txt, constr.cstr_arity, List.length sargs) )); + let ty_args, ty_res = + instance_constructor ~in_pattern:(env, get_newtype_level ()) constr + in + (* PR#7214: do not use gadt unification for toplevel lets *) + if (not constr.cstr_generalized) || mode = Inside_or || no_existentials then + unify_pat_types loc !env ty_res expected_ty + else unify_pat_types_gadt loc env ty_res expected_ty; + + let rec check_non_escaping p = + match p.ppat_desc with + | Ppat_or (p1, p2) -> + check_non_escaping p1; + check_non_escaping p2 + | Ppat_alias (p, _) -> check_non_escaping p + | Ppat_constraint _ -> + raise (Error (p.ppat_loc, !env, Inlined_record_escape)) | _ -> () - end; - if List.length sargs <> constr.cstr_arity then - raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt, - constr.cstr_arity, List.length sargs))); - let (ty_args, ty_res) = - instance_constructor ~in_pattern:(env, get_newtype_level ()) constr - in - (* PR#7214: do not use gadt unification for toplevel lets *) - if not constr.cstr_generalized || mode = Inside_or || no_existentials - then unify_pat_types loc !env ty_res expected_ty - else unify_pat_types_gadt loc env ty_res expected_ty; - - let rec check_non_escaping p = - match p.ppat_desc with - | Ppat_or (p1, p2) -> - check_non_escaping p1; - check_non_escaping p2 - | Ppat_alias (p, _) -> - check_non_escaping p - | Ppat_constraint _ -> - raise (Error (p.ppat_loc, !env, Inlined_record_escape)) - | _ -> - () - in - if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; + in + if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; - map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args) + map_fold_cont + (fun (p, t) -> type_pat p t) + (List.combine sargs ty_args) (fun args -> - rp k { - pat_desc=Tpat_construct(lid, constr, args); - pat_loc = loc; pat_extra=[]; + rp k + { + pat_desc = Tpat_construct (lid, constr, args); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_variant (l, sarg) -> ( + let arg_type = + match sarg with + | None -> [] + | Some _ -> [newvar ()] + in + let row = + { + row_fields = [(l, Reither (sarg = None, arg_type, true, ref None))]; + row_bound = (); + row_closed = false; + row_more = newvar (); + row_fixed = false; + row_name = None; + } + in + (* PR#7404: allow some_other_tag blindly, as it would not unify with + the abstract row variable *) + if l = Parmatch.some_other_tag then assert (constrs <> None) + else unify_pat_types loc !env (newty (Tvariant row)) expected_ty; + let k arg = + rp k + { + pat_desc = Tpat_variant (l, arg, ref {row with row_more = newvar ()}); + pat_loc = loc; + pat_extra = []; pat_type = expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_variant(l, sarg) -> - let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in - let row = { row_fields = - [l, Reither(sarg = None, arg_type, true, ref None)]; - row_bound = (); - row_closed = false; - row_more = newvar (); - row_fixed = false; - row_name = None } in - (* PR#7404: allow some_other_tag blindly, as it would not unify with - the abstract row variable *) - if l = Parmatch.some_other_tag then assert (constrs <> None) - else unify_pat_types loc !env (newty (Tvariant row)) expected_ty; - let k arg = - rp k { - pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - in begin - (* PR#6235: propagate type information *) - match sarg, arg_type with - Some p, [ty] -> type_pat p ty (fun p -> k (Some p)) - | _ -> k None - end - | Ppat_record(lid_sp_list, closed) -> - let has_dict_pattern_attr = Dict_type_helpers.has_dict_pattern_attribute sp.ppat_attributes in - let opath, record_ty = ( - if has_dict_pattern_attr then ( - (* [dict] Make sure dict patterns are inferred as actual dicts *) - (Some (Predef.path_dict, Predef.path_dict), newgenty (Tconstr (Predef.path_dict, [newvar ()], ref Mnil))) - ) else + pat_env = !env; + } + in + (* PR#6235: propagate type information *) + match (sarg, arg_type) with + | Some p, [ty] -> type_pat p ty (fun p -> k (Some p)) + | _ -> k None) + | Ppat_record (lid_sp_list, closed) -> + let has_dict_pattern_attr = + Dict_type_helpers.has_dict_pattern_attribute sp.ppat_attributes + in + let opath, record_ty = + if has_dict_pattern_attr then + ( (* [dict] Make sure dict patterns are inferred as actual dicts *) + Some (Predef.path_dict, Predef.path_dict), + newgenty (Tconstr (Predef.path_dict, [newvar ()], ref Mnil)) ) + else try - let (p0, p, _, _) = extract_concrete_record !env expected_ty in - Some (p0, p), expected_ty - with Not_found -> None, newvar () - ) in - let get_jsx_component_error_info = get_jsx_component_error_info ~extract_concrete_typedecl opath !env record_ty in - let process_optional_label (ld, pat) = - let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in - let is_from_pamatch = match pat.ppat_desc with - | Ppat_construct ({txt = Lident s}, _) -> - String.length s >= 2 && s.[0] = '#' && s.[1] = '$' - | _ -> false - in - if label_is_optional ld && not exp_optional_attr && not is_from_pamatch then - let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in - Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) - else pat - in - let type_label_pat (label_lid, label, sarg) k = - let sarg = process_optional_label (label, sarg) in - begin_def (); - let (vars, ty_arg, ty_res) = instance_label false label in - if vars = [] then end_def (); - begin try - unify_pat_types loc !env ty_res record_ty - with Unify trace -> - raise(Error(label_lid.loc, !env, - Label_mismatch(label_lid.txt, trace))) - end; - type_pat sarg ty_arg (fun arg -> - if vars <> [] then begin + let p0, p, _, _ = extract_concrete_record !env expected_ty in + (Some (p0, p), expected_ty) + with Not_found -> (None, newvar ()) + in + let get_jsx_component_error_info = + get_jsx_component_error_info ~extract_concrete_typedecl opath !env + record_ty + in + let process_optional_label (ld, pat) = + let exp_optional_attr = + check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc + in + let is_from_pamatch = + match pat.ppat_desc with + | Ppat_construct ({txt = Lident s}, _) -> + String.length s >= 2 && s.[0] = '#' && s.[1] = '$' + | _ -> false + in + if label_is_optional ld && (not exp_optional_attr) && not is_from_pamatch + then + let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in + Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) + else pat + in + let type_label_pat (label_lid, label, sarg) k = + let sarg = process_optional_label (label, sarg) in + begin_def (); + let vars, ty_arg, ty_res = instance_label false label in + if vars = [] then end_def (); + (try unify_pat_types loc !env ty_res record_ty + with Unify trace -> + raise + (Error (label_lid.loc, !env, Label_mismatch (label_lid.txt, trace)))); + type_pat sarg ty_arg (fun arg -> + if vars <> [] then ( end_def (); generalize ty_arg; List.iter generalize vars; let instantiated tv = let tv = expand_head !env tv in - not (is_Tvar tv) || tv.level <> generic_level in + (not (is_Tvar tv)) || tv.level <> generic_level + in if List.exists instantiated vars then raise - (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt)) - end; + (Error (label_lid.loc, !env, Polymorphic_label label_lid.txt))); k (label_lid, label, arg)) + in + let k' k lbl_pat_list = + check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list + closed; + unify_pat_types loc !env record_ty expected_ty; + rp k + { + pat_desc = Tpat_record (lbl_pat_list, closed); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + in + if constrs = None then + k + (wrap_disambiguate "This record pattern is expected to have" expected_ty + (type_label_a_list ?labels loc false !env type_label_pat opath + lid_sp_list) + (k' (fun x -> x))) + else + type_label_a_list ?labels loc false !env type_label_pat opath lid_sp_list + (k' k) + | Ppat_array spl -> + let ty_elt = newvar () in + unify_pat_types loc !env + (instance_def (Predef.type_array ty_elt)) + expected_ty; + let spl_ann = List.map (fun p -> (p, newvar ())) spl in + map_fold_cont + (fun (p, _) -> type_pat p ty_elt) + spl_ann + (fun pl -> + rp k + { + pat_desc = Tpat_array pl; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_or (sp1, sp2) -> ( + let state = save_state env in + match + if mode = Split_or || mode = Splitting_or then raise Need_backtrack; + let initial_pattern_variables = !pattern_variables in + let initial_module_variables = !module_variables in + let p1 = + try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x)) + with Need_backtrack -> None in - let k' k lbl_pat_list = - check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list closed; - unify_pat_types loc !env record_ty expected_ty; - rp k { - pat_desc = Tpat_record (lbl_pat_list, closed); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } + let p1_variables = !pattern_variables in + let p1_module_variables = !module_variables in + pattern_variables := initial_pattern_variables; + module_variables := initial_module_variables; + let p2 = + try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x)) + with Need_backtrack -> None in - if constrs = None then - k (wrap_disambiguate "This record pattern is expected to have" - expected_ty - (type_label_a_list ?labels loc false !env type_label_pat opath - lid_sp_list) - (k' (fun x -> x))) - else - type_label_a_list ?labels loc false !env type_label_pat opath - lid_sp_list (k' k) - | Ppat_array spl -> - let ty_elt = newvar() in - unify_pat_types - loc !env (instance_def (Predef.type_array ty_elt)) expected_ty; - let spl_ann = List.map (fun p -> (p,newvar())) spl in - map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl -> - rp k { - pat_desc = Tpat_array pl; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_or(sp1, sp2) -> - let state = save_state env in - begin match - if mode = Split_or || mode = Splitting_or then raise Need_backtrack; - let initial_pattern_variables = !pattern_variables in - let initial_module_variables = !module_variables in - let p1 = - try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x)) - with Need_backtrack -> None in - let p1_variables = !pattern_variables in - let p1_module_variables = !module_variables in - pattern_variables := initial_pattern_variables; - module_variables := initial_module_variables; - let p2 = - try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x)) - with Need_backtrack -> None in - let p2_variables = !pattern_variables in - match p1, p2 with - None, None -> raise Need_backtrack - | Some p, None | None, Some p -> p (* no variables in this case *) - | Some p1, Some p2 -> + let p2_variables = !pattern_variables in + match (p1, p2) with + | None, None -> raise Need_backtrack + | Some p, None | None, Some p -> p (* no variables in this case *) + | Some p1, Some p2 -> let alpha_env = - enter_orpat_variables loc !env p1_variables p2_variables in + enter_orpat_variables loc !env p1_variables p2_variables + in pattern_variables := p1_variables; module_variables := p1_module_variables; - { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None); - pat_loc = loc; pat_extra=[]; + { + pat_desc = Tpat_or (p1, alpha_pat alpha_env p2, None); + pat_loc = loc; + pat_extra = []; pat_type = expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } - with - p -> rp k p - | exception Need_backtrack when mode <> Inside_or -> - assert (constrs <> None); - set_state state env; - let mode = - if mode = Split_or then mode else Splitting_or in - try type_pat ~mode sp1 expected_ty k with Error _ -> - set_state state env; - type_pat ~mode sp2 expected_ty k - end + pat_env = !env; + } + with + | p -> rp k p + | exception Need_backtrack when mode <> Inside_or -> ( + assert (constrs <> None); + set_state state env; + let mode = if mode = Split_or then mode else Splitting_or in + try type_pat ~mode sp1 expected_ty k + with Error _ -> + set_state state env; + type_pat ~mode sp2 expected_ty k)) | Ppat_lazy sp1 -> - let nv = newvar () in - unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) - expected_ty; - (* do not explode under lazy: PR#7421 *) - type_pat ~explode:0 sp1 nv (fun p1 -> - rp k { - pat_desc = Tpat_lazy p1; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_constraint(sp, sty) -> - (* Separate when not already separated by !principal *) - let separate = true in - if separate then begin_def(); - let cty, force = Typetexp.transl_simple_type_delayed !env sty in - let ty = cty.ctyp_type in - let ty, expected_ty' = - if separate then begin - end_def(); - generalize_structure ty; - instance !env ty, instance !env ty - end else ty, ty - in - unify_pat_types loc !env ty expected_ty; - type_pat sp expected_ty' (fun p -> + let nv = newvar () in + unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) expected_ty; + (* do not explode under lazy: PR#7421 *) + type_pat ~explode:0 sp1 nv (fun p1 -> + rp k + { + pat_desc = Tpat_lazy p1; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_constraint (sp, sty) -> + (* Separate when not already separated by !principal *) + let separate = true in + if separate then begin_def (); + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in + let ty, expected_ty' = + if separate then ( + end_def (); + generalize_structure ty; + (instance !env ty, instance !env ty)) + else (ty, ty) + in + unify_pat_types loc !env ty expected_ty; + type_pat sp expected_ty' (fun p -> (*Format.printf "%a@.%a@." Printtyp.raw_type_expr ty Printtyp.raw_type_expr p.pat_type;*) pattern_force := force :: !pattern_force; let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in let p = - if not separate then p else - match p.pat_desc with - Tpat_var (id,s) -> - {p with pat_type = ty; - pat_desc = Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); - pat_extra = [extra]; - } - | _ -> {p with pat_type = ty; - pat_extra = extra :: p.pat_extra} - in k p) + if not separate then p + else + match p.pat_desc with + | Tpat_var (id, s) -> + { + p with + pat_type = ty; + pat_desc = + Tpat_alias + ({p with pat_desc = Tpat_any; pat_attributes = []}, id, s); + pat_extra = [extra]; + } + | _ -> {p with pat_type = ty; pat_extra = extra :: p.pat_extra} + in + k p) | Ppat_type lid -> - let (path, p,ty) = build_or_pat !env loc lid in - unify_pat_types loc !env ty expected_ty; - k { p with pat_extra = - (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } - | Ppat_open (lid,p) -> - let path, new_env = - !type_open Asttypes.Fresh !env sp.ppat_loc lid in - let new_env = ref new_env in - type_pat ~env:new_env p expected_ty ( fun p -> + let path, p, ty = build_or_pat !env loc lid in + unify_pat_types loc !env ty expected_ty; + k + { + p with + pat_extra = + (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra; + } + | Ppat_open (lid, p) -> + let path, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc lid in + let new_env = ref new_env in + type_pat ~env:new_env p expected_ty (fun p -> env := Env.copy_local !env ~from:!new_env; - k { p with pat_extra =( Tpat_open (path,lid,!new_env), - loc, sp.ppat_attributes) :: p.pat_extra } - ) + k + { + p with + pat_extra = + (Tpat_open (path, lid, !new_env), loc, sp.ppat_attributes) + :: p.pat_extra; + }) | Ppat_exception _ -> - raise (Error (loc, !env, Exception_pattern_below_toplevel)) + raise (Error (loc, !env, Exception_pattern_below_toplevel)) | Ppat_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) -let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal) - ?(explode=0) ?(lev=get_current_level()) env sp expected_ty = +let type_pat ?(allow_existentials = false) ?constrs ?labels ?(mode = Normal) + ?(explode = 0) ?(lev = get_current_level ()) env sp expected_ty = newtype_level := Some lev; try let r = - type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels - ~mode ~explode ~env sp expected_ty (fun x -> x) in + type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels ~mode + ~explode ~env sp expected_ty (fun x -> x) + in iter_pattern (fun p -> p.pat_env <- !env) r; newtype_level := None; r @@ -1573,7 +1719,6 @@ let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal) newtype_level := None; raise e - (* this function is passed to Partial.parmatch to type check gadt nonexhaustiveness *) let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p = @@ -1583,8 +1728,8 @@ let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p = reset_pattern None true; let typed_p = Ctype.with_passive_variants - (type_pat ~allow_existentials:true ~lev - ~constrs ~labels ?mode ?explode env p) + (type_pat ~allow_existentials:true ~lev ~constrs ~labels ?mode ?explode + env p) expected_ty in set_state state env; @@ -1594,35 +1739,43 @@ let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p = set_state state env; None -let check_partial ?(lev=get_current_level ()) env expected_ty loc cases = - let explode = match cases with [_] -> 5 | _ -> 0 in +let check_partial ?(lev = get_current_level ()) env expected_ty loc cases = + let explode = + match cases with + | [_] -> 5 + | _ -> 0 + in Parmatch.check_partial_gadt - (partial_pred ~lev ~explode env expected_ty) loc cases + (partial_pred ~lev ~explode env expected_ty) + loc cases -let check_unused ?(lev=get_current_level ()) env expected_ty cases = +let check_unused ?(lev = get_current_level ()) env expected_ty cases = Parmatch.check_unused (fun refute constrs labels spat -> match - partial_pred ~lev ~mode:Split_or ~explode:5 - env expected_ty constrs labels spat + partial_pred ~lev ~mode:Split_or ~explode:5 env expected_ty constrs + labels spat with - Some pat when refute -> - raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat)) + | Some pat when refute -> + raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat)) | r -> r) cases let add_pattern_variables ?check ?check_as env = let pv = get_ref pattern_variables in - (List.fold_right - (fun (id, ty, _name, loc, as_var) env -> - let check = if as_var then check_as else check in - Env.add_value ?check id - {val_type = ty; val_kind = Val_reg; Types.val_loc = loc; - val_attributes = []; - } env - ) - pv env, - get_ref module_variables) + ( List.fold_right + (fun (id, ty, _name, loc, as_var) env -> + let check = if as_var then check_as else check in + Env.add_value ?check id + { + val_type = ty; + val_kind = Val_reg; + Types.val_loc = loc; + val_attributes = []; + } + env) + pv env, + get_ref module_variables ) let type_pattern ~lev env spat scope expected_ty = reset_pattern scope true; @@ -1631,94 +1784,90 @@ let type_pattern ~lev env spat scope expected_ty = let new_env, unpacks = add_pattern_variables !new_env ~check:(fun s -> Warnings.Unused_var_strict s) - ~check_as:(fun s -> Warnings.Unused_var s) in + ~check_as:(fun s -> Warnings.Unused_var s) + in (pat, new_env, get_ref pattern_force, unpacks) let type_pattern_list env spatl scope expected_tys allow = reset_pattern scope allow; let new_env = ref env in let type_pat (attrs, pat) ty = - Builtin_attributes.warning_scope ~ppwarning:false attrs - (fun () -> - type_pat new_env pat ty - ) + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + type_pat new_env pat ty) in let patl = List.map2 type_pat spatl expected_tys in let new_env, unpacks = add_pattern_variables !new_env in (patl, new_env, get_ref pattern_force, unpacks) - - - let rec final_subexpression sexp = match sexp.pexp_desc with - Pexp_let (_, _, e) + | Pexp_let (_, _, e) | Pexp_sequence (_, e) | Pexp_try (e, _) | Pexp_ifthenelse (_, e, _) - | Pexp_match (_, {pc_rhs=e} :: _) - -> final_subexpression e + | Pexp_match (_, {pc_rhs = e} :: _) -> + final_subexpression e | _ -> sexp (* Generalization criterion for expressions *) let rec is_nonexpansive exp = - List.exists (function (({txt = "internal.expansive"},_) : Parsetree.attribute) -> true | _ -> false) - exp.exp_attributes || + List.exists + (function + | (({txt = "internal.expansive"}, _) : Parsetree.attribute) -> true + | _ -> false) + exp.exp_attributes + || match exp.exp_desc with - Texp_ident(_,_,_) -> true + | Texp_ident (_, _, _) -> true | Texp_constant _ -> true - | Texp_let(_rec_flag, pat_exp_list, body) -> - List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && - is_nonexpansive body + | Texp_let (_rec_flag, pat_exp_list, body) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list + && is_nonexpansive body | Texp_function _ -> true - | Texp_apply(e, (_,None)::el) -> - is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) - | Texp_match(e, cases, [], _) -> - is_nonexpansive e && - List.for_all - (fun {c_lhs = _; c_guard; c_rhs} -> - is_nonexpansive_opt c_guard && is_nonexpansive c_rhs - ) cases - | Texp_tuple el -> - List.for_all is_nonexpansive el - | Texp_construct( _, _, el) -> - List.for_all is_nonexpansive el - | Texp_variant(_, arg) -> is_nonexpansive_opt arg - | Texp_record { fields; extended_expression } -> - Array.for_all - (fun (lbl, definition) -> - match definition with - | Overridden (_, exp) -> - lbl.lbl_mut = Immutable && is_nonexpansive exp - | Kept _ -> true) - fields - && is_nonexpansive_opt extended_expression - | Texp_field(exp, _, _) -> is_nonexpansive exp - | Texp_array [] -> !Config.unsafe_empty_array - | Texp_ifthenelse(_cond, ifso, ifnot) -> - is_nonexpansive ifso && is_nonexpansive_opt ifnot - | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) - | Texp_new _ -> - assert false + | Texp_apply (e, (_, None) :: el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) + | Texp_match (e, cases, [], _) -> + is_nonexpansive e + && List.for_all + (fun {c_lhs = _; c_guard; c_rhs} -> + is_nonexpansive_opt c_guard && is_nonexpansive c_rhs) + cases + | Texp_tuple el -> List.for_all is_nonexpansive el + | Texp_construct (_, _, el) -> List.for_all is_nonexpansive el + | Texp_variant (_, arg) -> is_nonexpansive_opt arg + | Texp_record {fields; extended_expression} -> + Array.for_all + (fun (lbl, definition) -> + match definition with + | Overridden (_, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp + | Kept _ -> true) + fields + && is_nonexpansive_opt extended_expression + | Texp_field (exp, _, _) -> is_nonexpansive exp + | Texp_array [] -> !Config.unsafe_empty_array + | Texp_ifthenelse (_cond, ifso, ifnot) -> + is_nonexpansive ifso && is_nonexpansive_opt ifnot + | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) + | Texp_new _ -> assert false (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e - | Texp_object () -> - assert false + | Texp_object () -> assert false | Texp_letmodule (_, _, mexp, e) -> - is_nonexpansive_mod mexp && is_nonexpansive e - | Texp_pack mexp -> - is_nonexpansive_mod mexp + is_nonexpansive_mod mexp && is_nonexpansive e + | Texp_pack mexp -> is_nonexpansive_mod mexp (* Computations which raise exceptions are nonexpansive, since (raise e) is equivalent to (raise e; diverge), and a nonexpansive "diverge" can be produced using lazy values or the relaxed value restriction. See GPR#1142 *) - | Texp_assert exp -> - is_nonexpansive exp - | Texp_apply ( - { exp_desc = Texp_ident (_, _, {val_kind = - Val_prim {Primitive.prim_name = "%raise"}}) }, - [Nolabel, Some e]) -> - is_nonexpansive e + | Texp_assert exp -> is_nonexpansive exp + | Texp_apply + ( { + exp_desc = + Texp_ident + (_, _, {val_kind = Val_prim {Primitive.prim_name = "%raise"}}); + }, + [(Nolabel, Some e)] ) -> + is_nonexpansive e | _ -> false and is_nonexpansive_mod mexp = @@ -1728,104 +1877,101 @@ and is_nonexpansive_mod mexp = | Tmod_unpack (e, _) -> is_nonexpansive e | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m | Tmod_structure str -> - List.for_all - (fun item -> match item.str_desc with - | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ - | Tstr_modtype _ | Tstr_open _ | Tstr_class_type () -> true - | Tstr_value (_, pat_exp_list) -> - List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list - | Tstr_module {mb_expr=m;_} - | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m - | Tstr_recmodule id_mod_list -> - List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m) - id_mod_list - | Tstr_exception {ext_kind = Text_decl _} -> - false (* true would be unsound *) - | Tstr_exception {ext_kind = Text_rebind _} -> true - | Tstr_typext te -> - List.for_all - (function {ext_kind = Text_decl _} -> false - | {ext_kind = Text_rebind _} -> true) - te.tyext_constructors - | Tstr_class () -> assert false (* impossible *) - | Tstr_attribute _ -> true - ) - str.str_items + List.for_all + (fun item -> + match item.str_desc with + | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type () -> + true + | Tstr_value (_, pat_exp_list) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list + | Tstr_module {mb_expr = m; _} | Tstr_include {incl_mod = m; _} -> + is_nonexpansive_mod m + | Tstr_recmodule id_mod_list -> + List.for_all + (fun {mb_expr = m; _} -> is_nonexpansive_mod m) + id_mod_list + | Tstr_exception {ext_kind = Text_decl _} -> + false (* true would be unsound *) + | Tstr_exception {ext_kind = Text_rebind _} -> true + | Tstr_typext te -> + List.for_all + (function + | {ext_kind = Text_decl _} -> false + | {ext_kind = Text_rebind _} -> true) + te.tyext_constructors + | Tstr_class () -> assert false (* impossible *) + | Tstr_attribute _ -> true) + str.str_items | Tmod_apply _ -> false and is_nonexpansive_opt = function - None -> true + | None -> true | Some e -> is_nonexpansive e - - - (* Approximate the type of an expression, for better recursion *) let rec approx_type env sty = match sty.ptyp_desc with - Ptyp_arrow (p, _, sty) -> - let ty1 = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow (p, ty1, approx_type env sty, Cok)) - | Ptyp_tuple args -> - newty (Ttuple (List.map (approx_type env) args)) - | Ptyp_constr (lid, ctl) -> - begin try - let path = Env.lookup_type lid.txt env in - let decl = Env.find_type path env in - if List.length ctl <> decl.type_arity then raise Not_found; - let tyl = List.map (approx_type env) ctl in - newconstr path tyl - with Not_found -> newvar () - end - | Ptyp_poly (_, sty) -> - approx_type env sty + | Ptyp_arrow (p, _, sty) -> + let ty1 = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow (p, ty1, approx_type env sty, Cok)) + | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) + | Ptyp_constr (lid, ctl) -> ( + try + let path = Env.lookup_type lid.txt env in + let decl = Env.find_type path env in + if List.length ctl <> decl.type_arity then raise Not_found; + let tyl = List.map (approx_type env) ctl in + newconstr path tyl + with Not_found -> newvar ()) + | Ptyp_poly (_, sty) -> approx_type env sty | _ -> newvar () let rec type_approx env sexp = match sexp.pexp_desc with - Pexp_let (_, _, e) -> type_approx env e + | Pexp_let (_, _, e) -> type_approx env e | Pexp_fun (p, _, _, e) -> - let ty = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow(p, ty, type_approx env e, Cok)) - | Pexp_function ({pc_rhs=e}::_) -> - newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok)) - | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e + let ty = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow (p, ty, type_approx env e, Cok)) + | Pexp_function ({pc_rhs = e} :: _) -> + newty (Tarrow (Nolabel, newvar (), type_approx env e, Cok)) + | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e | Pexp_try (e, _) -> type_approx env e - | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) - | Pexp_ifthenelse (_,e,_) -> type_approx env e - | Pexp_sequence (_,e) -> type_approx env e + | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l)) + | Pexp_ifthenelse (_, e, _) -> type_approx env e + | Pexp_sequence (_, e) -> type_approx env e | Pexp_constraint (e, sty) -> - let ty = type_approx env e in - let ty1 = approx_type env sty in - begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None))) - end; - ty1 + let ty = type_approx env e in + let ty1 = approx_type env sty in + (try unify env ty ty1 + with Unify trace -> + raise (Error (sexp.pexp_loc, env, Expr_type_clash (trace, None)))); + ty1 | Pexp_coerce (e, (), sty2) -> - let approx_ty_opt = function - | None -> newvar () - | Some sty -> approx_type env sty - in - let ty = type_approx env e - and ty1 = approx_ty_opt None - and ty2 = approx_type env sty2 in - begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None))) - end; - ty2 + let approx_ty_opt = function + | None -> newvar () + | Some sty -> approx_type env sty + in + let ty = type_approx env e + and ty1 = approx_ty_opt None + and ty2 = approx_type env sty2 in + (try unify env ty ty1 + with Unify trace -> + raise (Error (sexp.pexp_loc, env, Expr_type_clash (trace, None)))); + ty2 | _ -> newvar () (* List labels in a function type, and whether return type is a variable *) let rec list_labels_aux env visited ls ty_fun = let ty = expand_head env ty_fun in - if List.memq ty visited then - List.rev ls, false - else match ty.desc with - Tarrow (l, _, ty_res, _) -> - list_labels_aux env (ty::visited) (l::ls) ty_res - | _ -> - List.rev ls, is_Tvar ty + if List.memq ty visited then (List.rev ls, false) + else + match ty.desc with + | Tarrow (l, _, ty_res, _) -> + list_labels_aux env (ty :: visited) (l :: ls) ty_res + | _ -> (List.rev ls, is_Tvar ty) let list_labels env ty = wrap_trace_gadt_instances env (list_labels_aux env [] []) ty @@ -1838,66 +1984,79 @@ let check_univars env expans kind exp ty_expected vars = let vars = List.map (expand_head env) vars in let vars = List.map (expand_head env) vars in let vars' = - Ext_list.filter vars - (fun t -> + Ext_list.filter vars (fun t -> let t = repr t in generalize t; match t.desc with - Tvar name when t.level = generic_level -> - log_type t; t.desc <- Tunivar name; true + | Tvar name when t.level = generic_level -> + log_type t; + t.desc <- Tunivar name; + true | _ -> false) in - if List.length vars = List.length vars' then () else - let ty = newgenty (Tpoly(repr exp.exp_type, vars')) - and ty_expected = repr ty_expected in - raise (Error (exp.exp_loc, env, - Less_general(kind, [ty, ty; ty_expected, ty_expected]))) + if List.length vars = List.length vars' then () + else + let ty = newgenty (Tpoly (repr exp.exp_type, vars')) + and ty_expected = repr ty_expected in + raise + (Error + ( exp.exp_loc, + env, + Less_general (kind, [(ty, ty); (ty_expected, ty_expected)]) )) (* Check that a type is not a function *) let check_application_result env statement exp = let loc = exp.exp_loc in match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application | Tvar _ -> () | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () - | _ -> - if statement then - Location.prerr_warning loc Warnings.Statement_type + | _ -> if statement then Location.prerr_warning loc Warnings.Statement_type (* Check that a type is generalizable at some level *) let generalizable level ty = let rec check ty = let ty = repr ty in - if ty.level < lowest_level then () else - if ty.level <= level then raise Exit else - (mark_type_node ty; iter_type_expr check ty) + if ty.level < lowest_level then () + else if ty.level <= level then raise Exit + else ( + mark_type_node ty; + iter_type_expr check ty) in - try check ty; unmark_type ty; true - with Exit -> unmark_type ty; false + try + check ty; + unmark_type ty; + true + with Exit -> + unmark_type ty; + false (* Helpers for packaged modules. *) let create_package_type loc env (p, l) = let s = !Typetexp.transl_modtype_longident loc env p in - let fields = List.map (fun (name, ct) -> - name, Typetexp.transl_simple_type env false ct) l in - let ty = newty (Tpackage (s, - List.map fst l, - List.map (fun (_, cty) -> cty.ctyp_type) fields)) + let fields = + List.map + (fun (name, ct) -> (name, Typetexp.transl_simple_type env false ct)) + l + in + let ty = + newty + (Tpackage + (s, List.map fst l, List.map (fun (_, cty) -> cty.ctyp_type) fields)) in - (s, fields, ty) - - let wrap_unpacks sexp unpacks = - let open Ast_helper in - List.fold_left - (fun sexp (name, loc) -> - Exp.letmodule ~loc:sexp.pexp_loc ~attrs:[mknoloc "#modulepat",PStr []] - name - (Mod.unpack ~loc - (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) - name.loc))) - sexp - ) + (s, fields, ty) + +let wrap_unpacks sexp unpacks = + let open Ast_helper in + List.fold_left + (fun sexp (name, loc) -> + Exp.letmodule ~loc:sexp.pexp_loc + ~attrs:[(mknoloc "#modulepat", PStr [])] + name + (Mod.unpack ~loc + (Exp.ident ~loc:name.loc + (mkloc (Longident.Lident name.txt) name.loc))) + sexp) sexp unpacks (* Helpers for type_cases *) @@ -1905,102 +2064,140 @@ let create_package_type loc env (p, l) = let contains_variant_either ty = let rec loop ty = let ty = repr ty in - if ty.level >= lowest_level then begin + if ty.level >= lowest_level then ( mark_type_node ty; match ty.desc with - Tvariant row -> - let row = row_repr row in - if not row.row_fixed then - List.iter - (fun (_,f) -> - match row_field_repr f with Reither _ -> raise Exit | _ -> ()) - row.row_fields; - iter_row loop row - | _ -> - iter_type_expr loop ty - end + | Tvariant row -> + let row = row_repr row in + if not row.row_fixed then + List.iter + (fun (_, f) -> + match row_field_repr f with + | Reither _ -> raise Exit + | _ -> ()) + row.row_fields; + iter_row loop row + | _ -> iter_type_expr loop ty) in - try loop ty; unmark_type ty; false - with Exit -> unmark_type ty; true + try + loop ty; + unmark_type ty; + false + with Exit -> + unmark_type ty; + true let iter_ppat f p = match p.ppat_desc with - | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ - | Ppat_extension _ - | Ppat_type _ | Ppat_unpack _ -> () + | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ | Ppat_extension _ + | Ppat_type _ | Ppat_unpack _ -> + () | Ppat_array pats -> List.iter f pats - | Ppat_or (p1,p2) -> f p1; f p2 + | Ppat_or (p1, p2) -> + f p1; + f p2 | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg - | Ppat_tuple lst -> List.iter f lst - | Ppat_exception p | Ppat_alias (p,_) - | Ppat_open (_,p) - | Ppat_constraint (p,_) | Ppat_lazy p -> f p - | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args + | Ppat_tuple lst -> List.iter f lst + | Ppat_exception p + | Ppat_alias (p, _) + | Ppat_open (_, p) + | Ppat_constraint (p, _) + | Ppat_lazy p -> + f p + | Ppat_record (args, _flag) -> List.iter (fun (_, p) -> f p) args let contains_polymorphic_variant p = let rec loop p = match p.ppat_desc with - Ppat_variant _ | Ppat_type _ -> raise Exit + | Ppat_variant _ | Ppat_type _ -> raise Exit | _ -> iter_ppat loop p in - try loop p; false with Exit -> true + try + loop p; + false + with Exit -> true let contains_gadt env p = let rec loop env p = match p.ppat_desc with - | Ppat_construct (lid, _) -> - begin try - let cstrs = Env.lookup_all_constructors lid.txt env in - List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise_notrace Exit) - cstrs - with Not_found -> () - end; iter_ppat (loop env) p - | Ppat_open (lid,sub_p) -> - let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in - loop new_env sub_p + | Ppat_construct (lid, _) -> + (try + let cstrs = Env.lookup_all_constructors lid.txt env in + List.iter + (fun (cstr, _) -> if cstr.cstr_generalized then raise_notrace Exit) + cstrs + with Not_found -> ()); + iter_ppat (loop env) p + | Ppat_open (lid, sub_p) -> + let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in + loop new_env sub_p | _ -> iter_ppat (loop env) p in - try loop env p; false with Exit -> true + try + loop env p; + false + with Exit -> true let check_absent_variant env = - iter_pattern - (function {pat_desc = Tpat_variant (s, arg, row)} as pat -> + iter_pattern (function + | {pat_desc = Tpat_variant (s, arg, row)} as pat -> let row = row_repr !row in - if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) + if + List.exists + (fun (s', fi) -> s = s' && row_field_repr fi <> Rabsent) row.row_fields - || not row.row_fixed && not (static_row row) (* same as Ctype.poly *) - then () else - let ty_arg = - match arg with None -> [] | Some p -> [correct_levels p.pat_type] in - let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)]; - row_more = newvar (); row_bound = (); - row_closed = false; row_fixed = false; row_name = None} in - (* Should fail *) - unify_pat env {pat with pat_type = newty (Tvariant row')} - (correct_levels pat.pat_type) - | _ -> ()) + || ((not row.row_fixed) && not (static_row row)) + (* same as Ctype.poly *) + then () + else + let ty_arg = + match arg with + | None -> [] + | Some p -> [correct_levels p.pat_type] + in + let row' = + { + row_fields = [(s, Reither (arg = None, ty_arg, true, ref None))]; + row_more = newvar (); + row_bound = (); + row_closed = false; + row_fixed = false; + row_name = None; + } + in + (* Should fail *) + unify_pat env + {pat with pat_type = newty (Tvariant row')} + (correct_levels pat.pat_type) + | _ -> ()) (* Duplicate types of values in the environment *) (* XXX Should we do something about global type variables too? *) let duplicate_ident_types caselist env = let caselist = - Ext_list.filter caselist (fun {pc_lhs} -> contains_gadt env pc_lhs) in + Ext_list.filter caselist (fun {pc_lhs} -> contains_gadt env pc_lhs) + in Env.copy_types (all_idents_cases caselist) env - (* type_label_a_list returns a list of labels sorted by lbl_pos *) (* note: check_duplicates would better be implemented in - type_label_a_list directly *) + type_label_a_list directly *) let rec check_duplicates ~get_jsx_component_error_info loc env = function - | (_, lbl1, _) :: ((l: Longident.t loc), lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> - raise(Error(l.loc, env, Label_multiply_defined { - label = lbl1.lbl_name; - jsx_component_info = get_jsx_component_error_info(); - })) - | _ :: rem -> - check_duplicates ~get_jsx_component_error_info loc env rem - | [] -> () + | (_, lbl1, _) :: ((l : Longident.t loc), lbl2, _) :: _ + when lbl1.lbl_pos = lbl2.lbl_pos -> + raise + (Error + ( l.loc, + env, + Label_multiply_defined + { + label = lbl1.lbl_name; + jsx_component_info = get_jsx_component_error_info (); + } )) + | _ :: rem -> check_duplicates ~get_jsx_component_error_info loc env rem + | [] -> () + (* Getting proper location of already typed expressions. Used to avoid confusing locations on type error messages in presence of @@ -2022,22 +2219,23 @@ let proper_exp_loc exp = in aux exp.exp_extra -let id_of_pattern : Typedtree.pattern -> Ident.t option = fun pat -> - match pat.pat_desc with +let id_of_pattern : Typedtree.pattern -> Ident.t option = + fun pat -> + match pat.pat_desc with | Tpat_var (id, _) -> Some id - | Tpat_alias(_, id, _) -> Some id - | Tpat_construct (_,_, - [{pat_desc = (Tpat_var (id,_) | Tpat_alias(_,id,_))}]) - -> Some (Ident.rename id) + | Tpat_alias (_, id, _) -> Some id + | Tpat_construct + (_, _, [{pat_desc = Tpat_var (id, _) | Tpat_alias (_, id, _)}]) -> + Some (Ident.rename id) | _ -> None (* To find reasonable names for let-bound and lambda-bound idents *) let rec name_pattern default = function - [] -> Ident.create default - | {c_lhs=p; _} :: rem -> - match id_of_pattern p with + | [] -> Ident.create default + | {c_lhs = p; _} :: rem -> ( + match id_of_pattern p with | None -> name_pattern default rem - | Some id -> id + | Some id -> id) (* Typing of expressions *) @@ -2045,39 +2243,40 @@ let unify_exp ?type_clash_context env exp expected_ty = let loc = proper_exp_loc exp in unify_exp_types ?type_clash_context loc env exp.exp_type expected_ty - let is_ignore funct env = match funct.exp_desc with - Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) -> - (try ignore (filter_arrow env (instance env funct.exp_type) Nolabel); - true - with Unify _ -> false) + | Texp_ident (_, _, {val_kind = Val_prim {Primitive.prim_name = "%ignore"}}) + -> ( + try + ignore (filter_arrow env (instance env funct.exp_type) Nolabel); + true + with Unify _ -> false) | _ -> false let not_identity = function - | Texp_ident(_,_,{val_kind=Val_prim - {Primitive.prim_name="%identity"}}) -> + | Texp_ident (_, _, {val_kind = Val_prim {Primitive.prim_name = "%identity"}}) + -> false - | _ -> true + | _ -> true -let rec lower_args env seen ty_fun = +let rec lower_args env seen ty_fun = let ty = expand_head env ty_fun in - if List.memq ty seen then () else + if List.memq ty seen then () + else match ty.desc with - Tarrow (_l, ty_arg, ty_fun, _com) -> - (try unify_var env (newvar()) ty_arg with Unify _ -> assert false); - lower_args env (ty::seen) ty_fun + | Tarrow (_l, ty_arg, ty_fun, _com) -> + (try unify_var env (newvar ()) ty_arg with Unify _ -> assert false); + lower_args env (ty :: seen) ty_fun | _ -> () let not_function env ty = let ls, tvar = list_labels env ty in ls = [] && not tvar - -type lazy_args = + +type lazy_args = (Asttypes.arg_label * (unit -> Typedtree.expression) option) list -type targs = - (Asttypes.arg_label * Typedtree.expression option) list +type targs = (Asttypes.arg_label * Typedtree.expression option) list let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) type_expect ?recarg env sexp (newvar ()) @@ -2086,21 +2285,21 @@ let rec type_exp ?recarg env sexp = This provide better error messages, and allows controlled propagation of return type information. In the principal case, [type_expected'] may be at generic_level. - *) +*) and type_expect ?type_clash_context ?in_function ?recarg env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in let exp = - Builtin_attributes.warning_scope sexp.pexp_attributes - (fun () -> - type_expect_ ?type_clash_context ?in_function ?recarg env sexp ty_expected - ) + Builtin_attributes.warning_scope sexp.pexp_attributes (fun () -> + type_expect_ ?type_clash_context ?in_function ?recarg env sexp + ty_expected) in Cmt_format.set_saved_types - (Cmt_format.Partial_expression exp :: previous_saved_types); + (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty_expected = +and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp + ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = @@ -2108,545 +2307,663 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty exp in let process_optional_label (id, ld, e) = - let exp_optional_attr = check_optional_attr env ld e.pexp_attributes e.pexp_loc in + let exp_optional_attr = + check_optional_attr env ld e.pexp_attributes e.pexp_loc + in if label_is_optional ld && not exp_optional_attr then - let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in - let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) - in (id, ld, e) + let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in + let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) in + (id, ld, e) else (id, ld, e) in match sexp.pexp_desc with | Pexp_ident lid -> - begin - let (path, desc) = Typetexp.find_value env lid.loc lid.txt in - if !Clflags.annotations then begin - let dloc = desc.Types.val_loc in - let annot = - if dloc.Location.loc_ghost then Annot.Iref_external - else Annot.Iref_internal dloc - in - let name = Path.name ~paren:Oprint.parenthesized_ident path in - Stypes.record (Stypes.An_ident (loc, name, annot)) - end; - let is_recarg = - match (repr desc.val_type).desc with - | Tconstr(p, _, _) -> Path.is_constructor_typath p - | _ -> false - in + let path, desc = Typetexp.find_value env lid.loc lid.txt in + (if !Clflags.annotations then + let dloc = desc.Types.val_loc in + let annot = + if dloc.Location.loc_ghost then Annot.Iref_external + else Annot.Iref_internal dloc + in + let name = Path.name ~paren:Oprint.parenthesized_ident path in + Stypes.record (Stypes.An_ident (loc, name, annot))); + let is_recarg = + match (repr desc.val_type).desc with + | Tconstr (p, _, _) -> Path.is_constructor_typath p + | _ -> false + in - begin match is_recarg, recarg, (repr desc.val_type).desc with - | _, Allowed, _ - | true, Required, _ - | false, Rejected, _ - -> () - | true, Rejected, _ - | false, Required, (Tvar _ | Tconstr _) -> - raise (Error (loc, env, Inlined_record_escape)) - | false, Required, _ -> - () (* will fail later *) - end; - rue { - exp_desc = Texp_ident(path, lid, desc); - exp_loc = loc; exp_extra = []; - exp_type = instance env desc.val_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - end + (match (is_recarg, recarg, (repr desc.val_type).desc) with + | _, Allowed, _ | true, Required, _ | false, Rejected, _ -> () + | true, Rejected, _ | false, Required, (Tvar _ | Tconstr _) -> + raise (Error (loc, env, Inlined_record_escape)) + | false, Required, _ -> () (* will fail later *)); + rue + { + exp_desc = Texp_ident (path, lid, desc); + exp_loc = loc; + exp_extra = []; + exp_type = instance env desc.val_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } | Pexp_constant cst -> - let cst = constant_or_raise env loc cst in - rue { + let cst = constant_or_raise env loc cst in + rue + { exp_desc = Texp_constant cst; - exp_loc = loc; exp_extra = []; + exp_loc = loc; + exp_extra = []; exp_type = type_constant cst; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_let(Nonrecursive, - [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) + exp_env = env; + } + | Pexp_let + ( Nonrecursive, + [{pvb_pat = spat; pvb_expr = sval; pvb_attributes = []}], + sbody ) when contains_gadt env spat -> (* TODO: allow non-empty attributes? *) - type_expect ?in_function env - {sexp with - pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} - ty_expected - | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let scp = - match sexp.pexp_attributes, rec_flag with - | [{txt="#default"},_], _ -> None - | _, Recursive -> Some (Annot.Idef loc) - | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) - in - let (pat_exp_list, new_env, unpacks) = - type_let env rec_flag spat_sexp_list scp true in - let body = - type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in - let () = - if rec_flag = Recursive then - Rec_check.check_recursive_bindings pat_exp_list - in - re { - exp_desc = Texp_let(rec_flag, pat_exp_list, body); - exp_loc = loc; exp_extra = []; + type_expect ?in_function env + { + sexp with + pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody]); + } + ty_expected + | Pexp_let (rec_flag, spat_sexp_list, sbody) -> + let scp = + match (sexp.pexp_attributes, rec_flag) with + | [({txt = "#default"}, _)], _ -> None + | _, Recursive -> Some (Annot.Idef loc) + | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) + in + let pat_exp_list, new_env, unpacks = + type_let env rec_flag spat_sexp_list scp true + in + let body = type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in + let () = + if rec_flag = Recursive then + Rec_check.check_recursive_bindings pat_exp_list + in + re + { + exp_desc = Texp_let (rec_flag, pat_exp_list, body); + exp_loc = loc; + exp_extra = []; exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; - exp_env = env } + exp_env = env; + } | Pexp_fun (l, Some default, spat, sbody) -> - assert(is_optional l); (* default allowed only with optional argument *) - let open Ast_helper in - let default_loc = default.pexp_loc in - let scases = [ + assert (is_optional l); + (* default allowed only with optional argument *) + let open Ast_helper in + let default_loc = default.pexp_loc in + let scases = + [ Exp.case (Pat.construct ~loc:default_loc - (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (mknoloc Longident.(Ldot (Lident "*predef*", "Some"))) (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))) (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); - Exp.case (Pat.construct ~loc:default_loc - (mknoloc (Longident.(Ldot (Lident "*predef*", "None")))) + (mknoloc Longident.(Ldot (Lident "*predef*", "None"))) None) default; - ] - in - let sloc = - { Location.loc_start = spat.ppat_loc.Location.loc_start; - loc_end = default_loc.Location.loc_end; - loc_ghost = true } - in - let smatch = - Exp.match_ ~loc:sloc - (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) - scases - in - let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in - let body = - Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []] - [Vb.mk spat smatch] sbody - in - type_function ?in_function loc sexp.pexp_attributes env ty_expected - l [Exp.case pat body] + ] + in + let sloc = + { + Location.loc_start = spat.ppat_loc.Location.loc_start; + loc_end = default_loc.Location.loc_end; + loc_ghost = true; + } + in + let smatch = + Exp.match_ ~loc:sloc + (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in + let body = + Exp.let_ ~loc Nonrecursive + ~attrs:[(mknoloc "#default", PStr [])] + [Vb.mk spat smatch] + sbody + in + type_function ?in_function loc sexp.pexp_attributes env ty_expected l + [Exp.case pat body] | Pexp_fun (l, None, spat, sbody) -> - type_function ?in_function loc sexp.pexp_attributes env ty_expected - l [Ast_helper.Exp.case spat sbody] + type_function ?in_function loc sexp.pexp_attributes env ty_expected l + [Ast_helper.Exp.case spat sbody] | Pexp_function caselist -> - type_function ?in_function - loc sexp.pexp_attributes env ty_expected Nolabel caselist - | Pexp_apply(sfunct, sargs) -> - assert (sargs <> []); - begin_def (); (* one more level for non-returning functions *) - let funct = type_exp env sfunct in - let ty = instance env funct.exp_type in - end_def (); - wrap_trace_gadt_instances env (lower_args env []) ty; - begin_def (); - let uncurried = - not @@ Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.partial") - && not @@ is_automatic_curried_application env funct in - let type_clash_context = type_clash_context_from_function sexp sfunct in - let (args, ty_res, fully_applied) = type_application ?type_clash_context uncurried env funct sargs in - end_def (); - unify_var env (newvar()) funct.exp_type; + type_function ?in_function loc sexp.pexp_attributes env ty_expected Nolabel + caselist + | Pexp_apply (sfunct, sargs) -> + assert (sargs <> []); + begin_def (); + (* one more level for non-returning functions *) + let funct = type_exp env sfunct in + let ty = instance env funct.exp_type in + end_def (); + wrap_trace_gadt_instances env (lower_args env []) ty; + begin_def (); + let uncurried = + not + @@ Ext_list.exists sexp.pexp_attributes (fun ({txt}, _) -> + txt = "res.partial") + && (not @@ is_automatic_curried_application env funct) + in + let type_clash_context = type_clash_context_from_function sexp sfunct in + let args, ty_res, fully_applied = + type_application ?type_clash_context uncurried env funct sargs + in + end_def (); + unify_var env (newvar ()) funct.exp_type; - let mk_apply funct args = - rue { - exp_desc = Texp_apply(funct, args); - exp_loc = loc; exp_extra = []; + let mk_apply funct args = + rue + { + exp_desc = Texp_apply (funct, args); + exp_loc = loc; + exp_extra = []; exp_type = ty_res; exp_attributes = sexp.pexp_attributes; - exp_env = env } in + exp_env = env; + } + in - let is_primitive = match funct.exp_desc with - | Texp_ident (_, _, {val_kind = Val_prim _}) -> true - | _ -> false in + let is_primitive = + match funct.exp_desc with + | Texp_ident (_, _, {val_kind = Val_prim _}) -> true + | _ -> false + in - if fully_applied && not is_primitive then - rue (mk_apply funct args) - else - rue (mk_apply funct args) - | Pexp_match(sarg, caselist) -> - begin_def (); - let arg = type_exp env sarg in - end_def (); - if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type; - generalize arg.exp_type; - let rec split_cases vc ec = function - | [] -> List.rev vc, List.rev ec - | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest -> - split_cases vc ({c with pc_lhs = p} :: ec) rest - | c :: rest -> - split_cases (c :: vc) ec rest - in - let val_caselist, exn_caselist = split_cases [] [] caselist in - if val_caselist = [] && exn_caselist <> [] then - raise (Error (loc, env, No_value_clauses)); - (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully - empty pattern matching can be generated by Camlp4 with its - revised syntax. Let's accept it for backward compatibility. *) - let val_cases, partial = - type_cases ~root_type_clash_context:Switch env arg.exp_type ty_expected true loc val_caselist in - let exn_cases, _ = - type_cases ~root_type_clash_context:Switch env Predef.type_exn ty_expected false loc exn_caselist in - re { - exp_desc = Texp_match(arg, val_cases, exn_cases, partial); - exp_loc = loc; exp_extra = []; + if fully_applied && not is_primitive then rue (mk_apply funct args) + else rue (mk_apply funct args) + | Pexp_match (sarg, caselist) -> + begin_def (); + let arg = type_exp env sarg in + end_def (); + if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type; + generalize arg.exp_type; + let rec split_cases vc ec = function + | [] -> (List.rev vc, List.rev ec) + | ({pc_lhs = {ppat_desc = Ppat_exception p}} as c) :: rest -> + split_cases vc ({c with pc_lhs = p} :: ec) rest + | c :: rest -> split_cases (c :: vc) ec rest + in + let val_caselist, exn_caselist = split_cases [] [] caselist in + if val_caselist = [] && exn_caselist <> [] then + raise (Error (loc, env, No_value_clauses)); + (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully + empty pattern matching can be generated by Camlp4 with its + revised syntax. Let's accept it for backward compatibility. *) + let val_cases, partial = + type_cases ~root_type_clash_context:Switch env arg.exp_type ty_expected + true loc val_caselist + in + let exn_cases, _ = + type_cases ~root_type_clash_context:Switch env Predef.type_exn ty_expected + false loc exn_caselist + in + re + { + exp_desc = Texp_match (arg, val_cases, exn_cases, partial); + exp_loc = loc; + exp_extra = []; exp_type = instance env ty_expected; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_try(sbody, caselist) -> - let body = type_expect env sbody ty_expected in - let cases, _ = - type_cases env Predef.type_exn ty_expected false loc caselist in - re { - exp_desc = Texp_try(body, cases); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_try (sbody, caselist) -> + let body = type_expect env sbody ty_expected in + let cases, _ = + type_cases env Predef.type_exn ty_expected false loc caselist + in + re + { + exp_desc = Texp_try (body, cases); + exp_loc = loc; + exp_extra = []; exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; - exp_env = env } + exp_env = env; + } | Pexp_tuple sexpl -> - assert (List.length sexpl >= 2); - let subtypes = List.map (fun _ -> newgenvar ()) sexpl in - let to_unify = newgenty (Ttuple subtypes) in - unify_exp_types loc env to_unify ty_expected; - let expl = - List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes - in - re { + assert (List.length sexpl >= 2); + let subtypes = List.map (fun _ -> newgenvar ()) sexpl in + let to_unify = newgenty (Ttuple subtypes) in + unify_exp_types loc env to_unify ty_expected; + let expl = + List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes + in + re + { exp_desc = Texp_tuple expl; - exp_loc = loc; exp_extra = []; + exp_loc = loc; + exp_extra = []; (* Keep sharing *) exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_construct({txt = Lident "Function$"} as lid, sarg) -> - let state = Warnings.backup () in - let arity = Ast_uncurried.attributes_to_arity sexp.pexp_attributes in - let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity (newvar()) in - unify_exp_types loc env uncurried_typ ty_expected; - (* Disable Unerasable_optional_argument for uncurried functions *) - let unerasable_optional_argument = Warnings.number Unerasable_optional_argument in - Warnings.parse_options false ("-" ^ string_of_int unerasable_optional_argument); - let exp = type_construct env loc lid sarg uncurried_typ sexp.pexp_attributes in - Warnings.restore state; - exp - | Pexp_construct(lid, sarg) -> - type_construct env loc lid sarg ty_expected sexp.pexp_attributes - | Pexp_variant(l, sarg) -> - (* Keep sharing *) - let ty_expected0 = instance env ty_expected in - begin try match - sarg, expand_head env ty_expected, expand_head env ty_expected0 with - | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> - let row = row_repr row in - begin match row_field_repr (List.assoc l row.row_fields), - row_field_repr (List.assoc l row0.row_fields) with - Rpresent (Some ty), Rpresent (Some ty0) -> - let arg = type_argument env sarg ty ty0 in - re { exp_desc = Texp_variant(l, Some arg); - exp_loc = loc; exp_extra = []; - exp_type = ty_expected0; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | _ -> raise Not_found - end + exp_env = env; + } + | Pexp_construct (({txt = Lident "Function$"} as lid), sarg) -> + let state = Warnings.backup () in + let arity = Ast_uncurried.attributes_to_arity sexp.pexp_attributes in + let uncurried_typ = + Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) + in + unify_exp_types loc env uncurried_typ ty_expected; + (* Disable Unerasable_optional_argument for uncurried functions *) + let unerasable_optional_argument = + Warnings.number Unerasable_optional_argument + in + Warnings.parse_options false + ("-" ^ string_of_int unerasable_optional_argument); + let exp = + type_construct env loc lid sarg uncurried_typ sexp.pexp_attributes + in + Warnings.restore state; + exp + | Pexp_construct (lid, sarg) -> + type_construct env loc lid sarg ty_expected sexp.pexp_attributes + | Pexp_variant (l, sarg) -> ( + (* Keep sharing *) + let ty_expected0 = instance env ty_expected in + try + match + (sarg, expand_head env ty_expected, expand_head env ty_expected0) + with + | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> ( + let row = row_repr row in + match + ( row_field_repr (List.assoc l row.row_fields), + row_field_repr (List.assoc l row0.row_fields) ) + with + | Rpresent (Some ty), Rpresent (Some ty0) -> + let arg = type_argument env sarg ty ty0 in + re + { + exp_desc = Texp_variant (l, Some arg); + exp_loc = loc; + exp_extra = []; + exp_type = ty_expected0; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | _ -> raise Not_found) | _ -> raise Not_found - with Not_found -> - let arg = may_map (type_exp env) sarg in - let arg_type = may_map (fun arg -> arg.exp_type) arg in - rue { - exp_desc = Texp_variant(l, arg); - exp_loc = loc; exp_extra = []; - exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; - row_more = newvar (); - row_bound = (); - row_closed = false; - row_fixed = false; - row_name = None}); - exp_attributes = sexp.pexp_attributes; - exp_env = env } - end - | Pexp_record(lid_sexp_list, None) -> - let ty_record, opath, fields, repr_opt = - match extract_concrete_record env ty_expected with - | (p0, p, fields, repr) -> - (* XXX level may be wrong *) - ty_expected, Some (p0, p), fields, Some repr - | exception Not_found -> - newvar (), None, [], None - - in - let get_jsx_component_error_info () = (match opath with - | Some (p, _) -> get_jsx_component_props ~extract_concrete_typedecl env ty_record p - | None -> None) - in - let lbl_exp_list = - wrap_disambiguate "This record expression is expected to have" ty_record - (type_label_a_list loc true env - (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e))) - opath lid_sexp_list) - (fun x -> x) - in - unify_exp_types loc env ty_record (instance env ty_expected); - check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; - let label_descriptions, representation = match lbl_exp_list, repr_opt with - | (_, { lbl_all = label_descriptions; lbl_repres = representation}, _) :: _, _ -> label_descriptions, representation - | [], Some (representation) when lid_sexp_list = [] -> - let optional_labels = match representation with - | Record_optional_labels optional_labels -> optional_labels - | Record_inlined {optional_labels} -> optional_labels - | _ -> [] in - let filter_missing (ld : Types.label_declaration) = - let name = Ident.name ld.ld_id in - if List.mem name optional_labels then - None - else - Some name in - let labels_missing = fields |> List.filter_map filter_missing in - if labels_missing <> [] then ( - raise(Error(loc, env, Labels_missing { - labels = labels_missing; - jsx_component_info = get_jsx_component_error_info (); - }))); - [||], representation - | [], _ -> - if fields = [] && repr_opt <> None then - [||], Record_optional_labels [] - else - raise(Error(loc, env, Empty_record_literal)) in - let labels_missing = ref [] in - let label_definitions = - let matching_label lbl = - List.find - (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos) - lbl_exp_list - in - Array.map - (fun lbl -> - match matching_label lbl with - | (lid, _lbl, lbl_exp) -> - Overridden (lid, lbl_exp) - | exception Not_found -> - if not (label_is_optional lbl) then labels_missing := lbl.lbl_name :: !labels_missing; - Overridden ({loc ; txt = Lident lbl.lbl_name}, option_none lbl.lbl_arg loc)) - label_descriptions - in - if !labels_missing <> [] then ( - raise(Error(loc, env, Labels_missing { - labels=(List.rev !labels_missing); - jsx_component_info = get_jsx_component_error_info (); - }))); - let fields = - Array.map2 (fun descr def -> descr, def) - label_descriptions label_definitions - in - re { - exp_desc = Texp_record { - fields; representation; - extended_expression = None - }; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; + with Not_found -> + let arg = may_map (type_exp env) sarg in + let arg_type = may_map (fun arg -> arg.exp_type) arg in + rue + { + exp_desc = Texp_variant (l, arg); + exp_loc = loc; + exp_extra = []; + exp_type = + newty + (Tvariant + { + row_fields = [(l, Rpresent arg_type)]; + row_more = newvar (); + row_bound = (); + row_closed = false; + row_fixed = false; + row_name = None; + }); exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_record(lid_sexp_list, Some sexp) -> - assert (lid_sexp_list <> []); - let exp = type_exp ~recarg env sexp in - let ty_record, opath = - let get_path ty = - try - let (p0, p, _, _) = extract_concrete_record env ty in - (* XXX level may be wrong *) - Some (p0, p) - with Not_found -> None + exp_env = env; + }) + | Pexp_record (lid_sexp_list, None) -> + let ty_record, opath, fields, repr_opt = + match extract_concrete_record env ty_expected with + | p0, p, fields, repr -> + (* XXX level may be wrong *) + (ty_expected, Some (p0, p), fields, Some repr) + | exception Not_found -> (newvar (), None, [], None) + in + + let get_jsx_component_error_info () = + match opath with + | Some (p, _) -> + get_jsx_component_props ~extract_concrete_typedecl env ty_record p + | None -> None + in + let lbl_exp_list = + wrap_disambiguate "This record expression is expected to have" ty_record + (type_label_a_list loc true env + (fun e k -> + k + (type_label_exp true env loc ty_record (process_optional_label e))) + opath lid_sexp_list) + (fun x -> x) + in + unify_exp_types loc env ty_record (instance env ty_expected); + check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; + let label_descriptions, representation = + match (lbl_exp_list, repr_opt) with + | ( (_, {lbl_all = label_descriptions; lbl_repres = representation}, _) + :: _, + _ ) -> + (label_descriptions, representation) + | [], Some representation when lid_sexp_list = [] -> + let optional_labels = + match representation with + | Record_optional_labels optional_labels -> optional_labels + | Record_inlined {optional_labels} -> optional_labels + | _ -> [] in - match get_path ty_expected with - None -> - begin - match get_path exp.exp_type with - None -> newvar (), None - | Some (_, p') as op -> - let decl = Env.find_type p' env in - begin_def (); - let ty = - newconstr p' (instance_list env decl.type_params) in - end_def (); - generalize_structure ty; - ty, op - end - | op -> ty_expected, op - in - let get_jsx_component_error_info = get_jsx_component_error_info ~extract_concrete_typedecl opath env ty_record in - let closed = false in - let lbl_exp_list = - wrap_disambiguate "This record expression is expected to have" ty_record - (type_label_a_list loc closed env - (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e))) - opath lid_sexp_list) - (fun x -> x) - in - unify_exp_types loc env ty_record (instance env ty_expected); - check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; - let opt_exp, label_definitions = - let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in - let matching_label lbl = - List.find - (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos) - lbl_exp_list + let filter_missing (ld : Types.label_declaration) = + let name = Ident.name ld.ld_id in + if List.mem name optional_labels then None else Some name in - let ty_exp = instance env exp.exp_type in - let unify_kept lbl = - let _, ty_arg1, ty_res1 = instance_label false lbl in - unify_exp_types exp.exp_loc env ty_exp ty_res1; - match matching_label lbl with - | lid, _lbl, lbl_exp -> - (* do not connect result types for overridden labels *) - Overridden (lid, lbl_exp) - | exception Not_found -> begin - let _, ty_arg2, ty_res2 = instance_label false lbl in - unify_exp_types loc env ty_arg1 ty_arg2; - unify_exp_types loc env (instance env ty_expected) ty_res2; - Kept ty_arg1 - end - in - let label_definitions = Array.map unify_kept lbl.lbl_all in - Some {exp with exp_type = ty_exp}, label_definitions + let labels_missing = fields |> List.filter_map filter_missing in + if labels_missing <> [] then + raise + (Error + ( loc, + env, + Labels_missing + { + labels = labels_missing; + jsx_component_info = get_jsx_component_error_info (); + } )); + ([||], representation) + | [], _ -> + if fields = [] && repr_opt <> None then ([||], Record_optional_labels []) + else raise (Error (loc, env, Empty_record_literal)) + in + let labels_missing = ref [] in + let label_definitions = + let matching_label lbl = + List.find (fun (_, lbl', _) -> lbl'.lbl_pos = lbl.lbl_pos) lbl_exp_list in - let num_fields = - match lbl_exp_list with [] -> assert false - | (_, lbl,_)::_ -> Array.length lbl.lbl_all in - let opt_exp = - if List.length lid_sexp_list = num_fields then - (Location.prerr_warning loc Warnings.Useless_record_with; None) - else opt_exp + Array.map + (fun lbl -> + match matching_label lbl with + | lid, _lbl, lbl_exp -> Overridden (lid, lbl_exp) + | exception Not_found -> + if not (label_is_optional lbl) then + labels_missing := lbl.lbl_name :: !labels_missing; + Overridden + ({loc; txt = Lident lbl.lbl_name}, option_none lbl.lbl_arg loc)) + label_descriptions + in + if !labels_missing <> [] then + raise + (Error + ( loc, + env, + Labels_missing + { + labels = List.rev !labels_missing; + jsx_component_info = get_jsx_component_error_info (); + } )); + let fields = + Array.map2 + (fun descr def -> (descr, def)) + label_descriptions label_definitions + in + re + { + exp_desc = + Texp_record {fields; representation; extended_expression = None}; + exp_loc = loc; + exp_extra = []; + exp_type = instance env ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_record (lid_sexp_list, Some sexp) -> + assert (lid_sexp_list <> []); + let exp = type_exp ~recarg env sexp in + let ty_record, opath = + let get_path ty = + try + let p0, p, _, _ = extract_concrete_record env ty in + (* XXX level may be wrong *) + Some (p0, p) + with Not_found -> None in - let label_descriptions, representation = - let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in - lbl_all, lbl_repres + match get_path ty_expected with + | None -> ( + match get_path exp.exp_type with + | None -> (newvar (), None) + | Some (_, p') as op -> + let decl = Env.find_type p' env in + begin_def (); + let ty = newconstr p' (instance_list env decl.type_params) in + end_def (); + generalize_structure ty; + (ty, op)) + | op -> (ty_expected, op) + in + let get_jsx_component_error_info = + get_jsx_component_error_info ~extract_concrete_typedecl opath env + ty_record + in + let closed = false in + let lbl_exp_list = + wrap_disambiguate "This record expression is expected to have" ty_record + (type_label_a_list loc closed env + (fun e k -> + k + (type_label_exp true env loc ty_record (process_optional_label e))) + opath lid_sexp_list) + (fun x -> x) + in + unify_exp_types loc env ty_record (instance env ty_expected); + check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; + let opt_exp, label_definitions = + let _lid, lbl, _lbl_exp = List.hd lbl_exp_list in + let matching_label lbl = + List.find (fun (_, lbl', _) -> lbl'.lbl_pos = lbl.lbl_pos) lbl_exp_list in - let fields = - Array.map2 (fun descr def -> descr, def) - label_descriptions label_definitions + let ty_exp = instance env exp.exp_type in + let unify_kept lbl = + let _, ty_arg1, ty_res1 = instance_label false lbl in + unify_exp_types exp.exp_loc env ty_exp ty_res1; + match matching_label lbl with + | lid, _lbl, lbl_exp -> + (* do not connect result types for overridden labels *) + Overridden (lid, lbl_exp) + | exception Not_found -> + let _, ty_arg2, ty_res2 = instance_label false lbl in + unify_exp_types loc env ty_arg1 ty_arg2; + unify_exp_types loc env (instance env ty_expected) ty_res2; + Kept ty_arg1 in - re { - exp_desc = Texp_record { - fields; representation; - extended_expression = opt_exp - }; - exp_loc = loc; exp_extra = []; + let label_definitions = Array.map unify_kept lbl.lbl_all in + (Some {exp with exp_type = ty_exp}, label_definitions) + in + let num_fields = + match lbl_exp_list with + | [] -> assert false + | (_, lbl, _) :: _ -> Array.length lbl.lbl_all + in + let opt_exp = + if List.length lid_sexp_list = num_fields then ( + Location.prerr_warning loc Warnings.Useless_record_with; + None) + else opt_exp + in + let label_descriptions, representation = + let _, {lbl_all; lbl_repres}, _ = List.hd lbl_exp_list in + (lbl_all, lbl_repres) + in + let fields = + Array.map2 + (fun descr def -> (descr, def)) + label_descriptions label_definitions + in + re + { + exp_desc = + Texp_record {fields; representation; extended_expression = opt_exp}; + exp_loc = loc; + exp_extra = []; exp_type = instance env ty_expected; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_field(srecord, lid) -> - let (record, label, _) = type_label_access env srecord lid in - let (_, ty_arg, ty_res) = instance_label false label in - unify_exp env record ty_res; - rue { - exp_desc = Texp_field(record, lid, label); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_field (srecord, lid) -> + let record, label, _ = type_label_access env srecord lid in + let _, ty_arg, ty_res = instance_label false label in + unify_exp env record ty_res; + rue + { + exp_desc = Texp_field (record, lid, label); + exp_loc = loc; + exp_extra = []; exp_type = ty_arg; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_setfield(srecord, lid, snewval) -> - let (record, label, opath) = type_label_access env srecord lid in - let ty_record = if opath = None then newvar () else record.exp_type in - let (label_loc, label, newval) = - type_label_exp ~type_clash_context:SetRecordField false env loc ty_record (lid, label, snewval) in - unify_exp env record ty_record; - if label.lbl_mut = Immutable then - raise(Error(loc, env, Label_not_mutable lid.txt)); - Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes - (Longident.last lid.txt); - rue { - exp_desc = Texp_setfield(record, label_loc, label, newval); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_setfield (srecord, lid, snewval) -> + let record, label, opath = type_label_access env srecord lid in + let ty_record = if opath = None then newvar () else record.exp_type in + let label_loc, label, newval = + type_label_exp ~type_clash_context:SetRecordField false env loc ty_record + (lid, label, snewval) + in + unify_exp env record ty_record; + if label.lbl_mut = Immutable then + raise (Error (loc, env, Label_not_mutable lid.txt)); + Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes + (Longident.last lid.txt); + rue + { + exp_desc = Texp_setfield (record, label_loc, label, newval); + exp_loc = loc; + exp_extra = []; exp_type = instance_def Predef.type_unit; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_array(sargl) -> - let ty = newgenvar() in - let to_unify = Predef.type_array ty in - unify_exp_types loc env to_unify ty_expected; - let argl = List.map (fun sarg -> type_expect ~type_clash_context:ArrayValue env sarg ty) sargl in - re { + exp_env = env; + } + | Pexp_array sargl -> + let ty = newgenvar () in + let to_unify = Predef.type_array ty in + unify_exp_types loc env to_unify ty_expected; + let argl = + List.map + (fun sarg -> type_expect ~type_clash_context:ArrayValue env sarg ty) + sargl + in + re + { exp_desc = Texp_array argl; - exp_loc = loc; exp_extra = []; + exp_loc = loc; + exp_extra = []; exp_type = instance env ty_expected; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_ifthenelse(scond, sifso, sifnot) -> - let cond = type_expect ~type_clash_context:IfCondition env scond Predef.type_bool in - begin match sifnot with - None -> - let ifso = type_expect ~type_clash_context:IfReturn env sifso Predef.type_unit in - rue { - exp_desc = Texp_ifthenelse(cond, ifso, None); - exp_loc = loc; exp_extra = []; - exp_type = ifso.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Some sifnot -> - let ifso = type_expect ~type_clash_context:IfReturn env sifso ty_expected in - let ifnot = type_expect ~type_clash_context:IfReturn env sifnot ty_expected in - (* Keep sharing *) - unify_exp ~type_clash_context:IfReturn env ifnot ifso.exp_type; - re { - exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = loc; exp_extra = []; - exp_type = ifso.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - end - | Pexp_sequence(sexp1, sexp2) -> - let exp1 = type_statement env sexp1 in - let exp2 = type_expect env sexp2 ty_expected in - re { - exp_desc = Texp_sequence(exp1, exp2); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_ifthenelse (scond, sifso, sifnot) -> ( + let cond = + type_expect ~type_clash_context:IfCondition env scond Predef.type_bool + in + match sifnot with + | None -> + let ifso = + type_expect ~type_clash_context:IfReturn env sifso Predef.type_unit + in + rue + { + exp_desc = Texp_ifthenelse (cond, ifso, None); + exp_loc = loc; + exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Some sifnot -> + let ifso = + type_expect ~type_clash_context:IfReturn env sifso ty_expected + in + let ifnot = + type_expect ~type_clash_context:IfReturn env sifnot ty_expected + in + (* Keep sharing *) + unify_exp ~type_clash_context:IfReturn env ifnot ifso.exp_type; + re + { + exp_desc = Texp_ifthenelse (cond, ifso, Some ifnot); + exp_loc = loc; + exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + }) + | Pexp_sequence (sexp1, sexp2) -> + let exp1 = type_statement env sexp1 in + let exp2 = type_expect env sexp2 ty_expected in + re + { + exp_desc = Texp_sequence (exp1, exp2); + exp_loc = loc; + exp_extra = []; exp_type = exp2.exp_type; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_while(scond, sbody) -> - let cond = type_expect env scond Predef.type_bool in - let body = type_statement env sbody in - rue { - exp_desc = Texp_while(cond, body); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_while (scond, sbody) -> + let cond = type_expect env scond Predef.type_bool in + let body = type_statement env sbody in + rue + { + exp_desc = Texp_while (cond, body); + exp_loc = loc; + exp_extra = []; exp_type = instance_def Predef.type_unit; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_for(param, slow, shigh, dir, sbody) -> - let low = type_expect env slow Predef.type_int in - let high = type_expect env shigh Predef.type_int in - let id, new_env = - match param.ppat_desc with - | Ppat_any -> Ident.create "_for", env - | Ppat_var {txt} -> - Env.enter_value txt {val_type = instance_def Predef.type_int; - val_attributes = []; - val_kind = Val_reg; Types.val_loc = loc; } env - ~check:(fun s -> Warnings.Unused_for_index s) - | _ -> - raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) - in - let body = type_statement new_env sbody in - rue { - exp_desc = Texp_for(id, param, low, high, dir, body); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_for (param, slow, shigh, dir, sbody) -> + let low = type_expect env slow Predef.type_int in + let high = type_expect env shigh Predef.type_int in + let id, new_env = + match param.ppat_desc with + | Ppat_any -> (Ident.create "_for", env) + | Ppat_var {txt} -> + Env.enter_value txt + { + val_type = instance_def Predef.type_int; + val_attributes = []; + val_kind = Val_reg; + Types.val_loc = loc; + } + env + ~check:(fun s -> Warnings.Unused_for_index s) + | _ -> raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) + in + let body = type_statement new_env sbody in + rue + { + exp_desc = Texp_for (id, param, low, high, dir, body); + exp_loc = loc; + exp_extra = []; exp_type = instance_def Predef.type_unit; exp_attributes = sexp.pexp_attributes; - exp_env = env } + exp_env = env; + } | Pexp_constraint (sarg, sty) -> - let separate = true in (* always separate, 1% slowdown for lablgtk *) - if separate then begin_def (); - let cty = Typetexp.transl_simple_type env false sty in - let ty = cty.ctyp_type in - let (arg, ty') = - if separate then begin - end_def (); - generalize_structure ty; - (type_argument env sarg ty (instance env ty), instance env ty) - end else - (type_argument env sarg ty ty, ty) - in - rue { + let separate = true in + (* always separate, 1% slowdown for lablgtk *) + if separate then begin_def (); + let cty = Typetexp.transl_simple_type env false sty in + let ty = cty.ctyp_type in + let arg, ty' = + if separate then ( + end_def (); + generalize_structure ty; + (type_argument env sarg ty (instance env ty), instance env ty)) + else (type_argument env sarg ty ty, ty) + in + rue + { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; exp_type = ty'; @@ -2655,215 +2972,232 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty exp_extra = (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra; } - | Pexp_coerce(sarg, (), sty') -> - let separate = true in (* always separate, 1% slowdown for lablgtk *) - (* Also see PR#7199 for a problem with the following: - let separate = Env.has_local_constraints env in*) - let (arg, ty',cty') = - let (cty', force) = - Typetexp.transl_simple_type_delayed env sty' - in - let ty' = cty'.ctyp_type in - if separate then begin_def (); - let arg = type_exp env sarg in - let gen = - if separate then begin - end_def (); - let tv = newvar () in - let gen = generalizable tv.level arg.exp_type in - (try unify_var env tv arg.exp_type with Unify trace -> - raise(Error(arg.exp_loc, env, Expr_type_clash (trace, type_clash_context)))); - gen - end else true - in - if not gen && (* first try a single coercion *) - let snap = snapshot () in - let ty, _b = enlarge_type env ty' in - try - force (); Ctype.unify env arg.exp_type ty; true - with Unify _ -> - backtrack snap; false - then () - else begin try - let force' = subtype env arg.exp_type ty' in - force (); force' (); - with Subtype (tr1, tr2) -> - (* prerr_endline "coercion failed"; *) - raise(Error(loc, env, Not_subtype(tr1, tr2))) - end; - (arg, ty', cty') + | Pexp_coerce (sarg, (), sty') -> + let separate = true in + (* always separate, 1% slowdown for lablgtk *) + (* Also see PR#7199 for a problem with the following: + let separate = Env.has_local_constraints env in*) + let arg, ty', cty' = + let cty', force = Typetexp.transl_simple_type_delayed env sty' in + let ty' = cty'.ctyp_type in + if separate then begin_def (); + let arg = type_exp env sarg in + let gen = + if separate then ( + end_def (); + let tv = newvar () in + let gen = generalizable tv.level arg.exp_type in + (try unify_var env tv arg.exp_type + with Unify trace -> + raise + (Error + (arg.exp_loc, env, Expr_type_clash (trace, type_clash_context)))); + gen) + else true in - rue { + (if + (not gen) + && + (* first try a single coercion *) + let snap = snapshot () in + let ty, _b = enlarge_type env ty' in + try + force (); + Ctype.unify env arg.exp_type ty; + true + with Unify _ -> + backtrack snap; + false + then () + else + try + let force' = subtype env arg.exp_type ty' in + force (); + force' () + with Subtype (tr1, tr2) -> + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype (tr1, tr2)))); + (arg, ty', cty') + in + rue + { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; exp_type = ty'; exp_attributes = arg.exp_attributes; exp_env = env; - exp_extra = (Texp_coerce ((), cty'), loc, sexp.pexp_attributes) :: - arg.exp_extra; + exp_extra = + (Texp_coerce ((), cty'), loc, sexp.pexp_attributes) :: arg.exp_extra; } - | Pexp_send (e, {txt=met}) -> - let obj = type_exp env e in - let obj_meths = ref None in - begin try - let (meth, exp, typ) = - match obj.exp_desc with - | _ -> - (Tmeth_name met, None, - filter_method env met Public obj.exp_type) - in - let typ = - match repr typ with - {desc = Tpoly (ty, [])} -> - instance env ty - | {desc = Tpoly (ty, tl); level = _} -> - snd (instance_poly false tl ty) - | {desc = Tvar _} as ty -> - let ty' = newvar () in - unify env (instance_def ty) (newty(Tpoly(ty',[]))); - (* if not !Clflags.nolabels then - Location.prerr_warning loc (Warnings.Unknown_method met); *) - ty' - | _ -> - assert false - in - rue { - exp_desc = Texp_send(obj, meth, exp); - exp_loc = loc; exp_extra = []; + | Pexp_send (e, {txt = met}) -> ( + let obj = type_exp env e in + let obj_meths = ref None in + try + let meth, exp, typ = + match obj.exp_desc with + | _ -> (Tmeth_name met, None, filter_method env met Public obj.exp_type) + in + let typ = + match repr typ with + | {desc = Tpoly (ty, [])} -> instance env ty + | {desc = Tpoly (ty, tl); level = _} -> snd (instance_poly false tl ty) + | {desc = Tvar _} as ty -> + let ty' = newvar () in + unify env (instance_def ty) (newty (Tpoly (ty', []))); + (* if not !Clflags.nolabels then + Location.prerr_warning loc (Warnings.Unknown_method met); *) + ty' + | _ -> assert false + in + rue + { + exp_desc = Texp_send (obj, meth, exp); + exp_loc = loc; + exp_extra = []; exp_type = typ; exp_attributes = sexp.pexp_attributes; - exp_env = env } - with Unify _ -> - let valid_methods = - match !obj_meths with - | Some meths -> - Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths []) - | None -> - match (expand_head env obj.exp_type).desc with - | Tobject (fields, _) -> - let (fields, _) = Ctype.flatten_fields fields in - let collect_fields li (meth, meth_kind, _meth_ty) = - if meth_kind = Fpresent then meth::li else li in - Some (List.fold_left collect_fields [] fields) - | _ -> None - in - raise(Error(e.pexp_loc, env, - Undefined_method (obj.exp_type, met, valid_methods))) - end - | Pexp_new _ - | Pexp_setinstvar _ - | Pexp_override _ -> - assert false - | Pexp_letmodule(name, smodl, sbody) -> - let ty = newvar() in - (* remember original level *) - begin_def (); - Ident.set_current_time ty.level; - let context = Typetexp.narrow () in - let modl = !type_module env smodl in - let (id, new_env) = Env.enter_module name.txt modl.mod_type env in - Ctype.init_def(Ident.current_time()); - Typetexp.widen context; - let body = type_expect new_env sbody ty_expected in - (* go back to original level *) - end_def (); - (* Unification of body.exp_type with the fresh variable ty - fails if and only if the prefix condition is violated, - i.e. if generative types rooted at id show up in the - type body.exp_type. Thus, this unification enforces the - scoping condition on "let module". *) - (* Note that this code will only be reached if ty_expected - is a generic type variable, otherwise the error will occur - above in type_expect *) - begin try - Ctype.unify_var new_env ty body.exp_type - with Unify _ -> - raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type))) - end; - re { - exp_desc = Texp_letmodule(id, name, modl, body); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + with Unify _ -> + let valid_methods = + match !obj_meths with + | Some meths -> + Some (Meths.fold (fun meth _meth_ty li -> meth :: li) !meths []) + | None -> ( + match (expand_head env obj.exp_type).desc with + | Tobject (fields, _) -> + let fields, _ = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if meth_kind = Fpresent then meth :: li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None) + in + raise + (Error + (e.pexp_loc, env, Undefined_method (obj.exp_type, met, valid_methods))) + ) + | Pexp_new _ | Pexp_setinstvar _ | Pexp_override _ -> assert false + | Pexp_letmodule (name, smodl, sbody) -> + let ty = newvar () in + (* remember original level *) + begin_def (); + Ident.set_current_time ty.level; + let context = Typetexp.narrow () in + let modl = !type_module env smodl in + let id, new_env = Env.enter_module name.txt modl.mod_type env in + Ctype.init_def (Ident.current_time ()); + Typetexp.widen context; + let body = type_expect new_env sbody ty_expected in + (* go back to original level *) + end_def (); + (* Unification of body.exp_type with the fresh variable ty + fails if and only if the prefix condition is violated, + i.e. if generative types rooted at id show up in the + type body.exp_type. Thus, this unification enforces the + scoping condition on "let module". *) + (* Note that this code will only be reached if ty_expected + is a generic type variable, otherwise the error will occur + above in type_expect *) + (try Ctype.unify_var new_env ty body.exp_type + with Unify _ -> + raise (Error (loc, env, Scoping_let_module (name.txt, body.exp_type)))); + re + { + exp_desc = Texp_letmodule (id, name, modl, body); + exp_loc = loc; + exp_extra = []; exp_type = ty; exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_letexception(cd, sbody) -> - let (cd, newenv) = Typedecl.transl_exception env cd in - let body = type_expect newenv sbody ty_expected in - re { - exp_desc = Texp_letexception(cd, body); - exp_loc = loc; exp_extra = []; + exp_env = env; + } + | Pexp_letexception (cd, sbody) -> + let cd, newenv = Typedecl.transl_exception env cd in + let body = type_expect newenv sbody ty_expected in + re + { + exp_desc = Texp_letexception (cd, body); + exp_loc = loc; + exp_extra = []; exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; - exp_env = env } - - | Pexp_assert (e) -> - let cond = type_expect env e Predef.type_bool in - let exp_type = - match cond.exp_desc with - | Texp_construct(_, {cstr_name="false"}, _) -> - instance env ty_expected - | _ -> - instance_def Predef.type_unit - in - rue { + exp_env = env; + } + | Pexp_assert e -> + let cond = type_expect env e Predef.type_bool in + let exp_type = + match cond.exp_desc with + | Texp_construct (_, {cstr_name = "false"}, _) -> instance env ty_expected + | _ -> instance_def Predef.type_unit + in + rue + { exp_desc = Texp_assert cond; - exp_loc = loc; exp_extra = []; + exp_loc = loc; + exp_extra = []; exp_type; exp_attributes = sexp.pexp_attributes; exp_env = env; } | Pexp_lazy e -> - let ty = newgenvar () in - let to_unify = Predef.type_lazy_t ty in - unify_exp_types loc env to_unify ty_expected; - let arg = type_expect env e ty in - re { + let ty = newgenvar () in + let to_unify = Predef.type_lazy_t ty in + unify_exp_types loc env to_unify ty_expected; + let arg = type_expect env e ty in + re + { exp_desc = Texp_lazy arg; - exp_loc = loc; exp_extra = []; + exp_loc = loc; + exp_extra = []; exp_type = instance env ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_object _ -> assert false - | Pexp_poly(sbody, sty) -> - let ty, cty = - match sty with None -> repr ty_expected, None - | Some sty -> - let sty = Ast_helper.Typ.force_poly sty in - let cty = Typetexp.transl_simple_type env false sty in - repr cty.ctyp_type, Some cty - in - if sty <> None then - unify_exp_types loc env (instance env ty) (instance env ty_expected); - let exp = - match (expand_head env ty).desc with - Tpoly (ty', []) -> - let exp = type_expect env sbody ty' in - { exp with exp_type = instance env ty } - | Tpoly (ty', tl) -> - (* One more level to generalize locally *) - begin_def (); - let vars, ty'' = instance_poly true tl ty' in - let exp = type_expect env sbody ty'' in - end_def (); - check_univars env false "method" exp ty_expected vars; - { exp with exp_type = instance env ty } - | Tvar _ -> - let exp = type_exp env sbody in - let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in - unify_exp env exp ty; - exp - | _ -> assert false - in - re { exp with exp_extra = - (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } - | Pexp_newtype({txt=name}, sbody) -> - let ty = newvar () in - (* remember original level *) - begin_def (); - (* Create a fake abstract type declaration for name. *) - let level = get_current_level () in - let decl = { + | Pexp_object _ -> assert false + | Pexp_poly (sbody, sty) -> + let ty, cty = + match sty with + | None -> (repr ty_expected, None) + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env false sty in + (repr cty.ctyp_type, Some cty) + in + if sty <> None then + unify_exp_types loc env (instance env ty) (instance env ty_expected); + let exp = + match (expand_head env ty).desc with + | Tpoly (ty', []) -> + let exp = type_expect env sbody ty' in + {exp with exp_type = instance env ty} + | Tpoly (ty', tl) -> + (* One more level to generalize locally *) + begin_def (); + let vars, ty'' = instance_poly true tl ty' in + let exp = type_expect env sbody ty'' in + end_def (); + check_univars env false "method" exp ty_expected vars; + {exp with exp_type = instance env ty} + | Tvar _ -> + let exp = type_exp env sbody in + let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in + unify_exp env exp ty; + exp + | _ -> assert false + in + re + { + exp with + exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra; + } + | Pexp_newtype ({txt = name}, sbody) -> + let ty = newvar () in + (* remember original level *) + begin_def (); + (* Create a fake abstract type declaration for name. *) + let level = get_current_level () in + let decl = + { type_params = []; type_arity = 0; type_kind = Type_abstract; @@ -2876,139 +3210,152 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty type_immediate = false; type_unboxed = unboxed_false_default_false; } - in - Ident.set_current_time ty.level; - let (id, new_env) = Env.enter_type name decl env in - Ctype.init_def(Ident.current_time()); - - let body = type_exp new_env sbody in - (* Replace every instance of this type constructor in the resulting - type. *) - let seen = Hashtbl.create 8 in - let rec replace t = - if Hashtbl.mem seen t.id then () - else begin - Hashtbl.add seen t.id (); - match t.desc with - | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty - | _ -> Btype.iter_type_expr replace t - end - in - let ety = Subst.type_expr Subst.identity body.exp_type in - replace ety; - (* back to original level *) - end_def (); - (* lower the levels of the result type *) - (* unify_var env ty ety; *) - - (* non-expansive if the body is non-expansive, so we don't introduce - any new extra node in the typed AST. *) - rue { body with exp_loc = loc; exp_type = ety; - exp_extra = - (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } + in + Ident.set_current_time ty.level; + let id, new_env = Env.enter_type name decl env in + Ctype.init_def (Ident.current_time ()); + + let body = type_exp new_env sbody in + (* Replace every instance of this type constructor in the resulting + type. *) + let seen = Hashtbl.create 8 in + let rec replace t = + if Hashtbl.mem seen t.id then () + else ( + Hashtbl.add seen t.id (); + match t.desc with + | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty + | _ -> Btype.iter_type_expr replace t) + in + let ety = Subst.type_expr Subst.identity body.exp_type in + replace ety; + (* back to original level *) + end_def (); + + (* lower the levels of the result type *) + (* unify_var env ty ety; *) + + (* non-expansive if the body is non-expansive, so we don't introduce + any new extra node in the typed AST. *) + rue + { + body with + exp_loc = loc; + exp_type = ety; + exp_extra = + (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra; + } | Pexp_pack m -> - let (p, nl) = - match Ctype.expand_head env (instance env ty_expected) with - {desc = Tpackage (p, nl, _tl)} -> - (p, nl) - | {desc = Tvar _} -> - raise (Error (loc, env, Cannot_infer_signature)) - | _ -> - raise (Error (loc, env, Not_a_packed_module ty_expected)) - in - let (modl, tl') = !type_package env m p nl in - rue { + let p, nl = + match Ctype.expand_head env (instance env ty_expected) with + | {desc = Tpackage (p, nl, _tl)} -> (p, nl) + | {desc = Tvar _} -> raise (Error (loc, env, Cannot_infer_signature)) + | _ -> raise (Error (loc, env, Not_a_packed_module ty_expected)) + in + let modl, tl' = !type_package env m p nl in + rue + { exp_desc = Texp_pack modl; - exp_loc = loc; exp_extra = []; + exp_loc = loc; + exp_extra = []; exp_type = newty (Tpackage (p, nl, tl')); exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_open (ovf, lid, e) -> - let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in - let exp = type_expect newenv e ty_expected in - { exp with - exp_extra = (Texp_open (ovf, path, lid, newenv), loc, - sexp.pexp_attributes) :: - exp.exp_extra; + exp_env = env; } - - | Pexp_extension ({ txt = ("ocaml.extension_constructor" - |"extension_constructor"); _ }, - payload) -> - begin match payload with - | PStr [ { pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) - } ] -> - let path = - match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with - | Cstr_extension (path) -> path - | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) - in - rue { - exp_desc = Texp_extension_constructor (lid, path); - exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_extension_constructor; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | _ -> - raise (Error (loc, env, Invalid_extension_constructor_payload)) - end + | Pexp_open (ovf, lid, e) -> + let path, newenv = !type_open ovf env sexp.pexp_loc lid in + let exp = type_expect newenv e ty_expected in + { + exp with + exp_extra = + (Texp_open (ovf, path, lid, newenv), loc, sexp.pexp_attributes) + :: exp.exp_extra; + } + | Pexp_extension + ( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, + payload ) -> ( + match payload with + | PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_construct (lid, None); _}, _); + }; + ] -> + let path = + match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with + | Cstr_extension path -> path + | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) + in + rue + { + exp_desc = Texp_extension_constructor (lid, path); + exp_loc = loc; + exp_extra = []; + exp_type = instance_def Predef.type_extension_constructor; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | _ -> raise (Error (loc, env, Invalid_extension_constructor_payload))) | Pexp_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - + raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pexp_unreachable -> - re { exp_desc = Texp_unreachable; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } + re + { + exp_desc = Texp_unreachable; + exp_loc = loc; + exp_extra = []; + exp_type = instance env ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } and type_function ?in_function loc attrs env ty_expected l caselist = - let (loc_fun, ty_fun) = - match in_function with Some p -> p + let loc_fun, ty_fun = + match in_function with + | Some p -> p | None -> (loc, instance env ty_expected) in let separate = Env.has_local_constraints env in if separate then begin_def (); - let (ty_arg, ty_res) = + let ty_arg, ty_res = try filter_arrow env (instance env ty_expected) l - with Unify _ -> + with Unify _ -> ( match expand_head env ty_expected with - {desc = Tarrow _} as ty -> - raise(Error(loc, env, Abstract_wrong_label(l, ty))) + | {desc = Tarrow _} as ty -> + raise (Error (loc, env, Abstract_wrong_label (l, ty))) | _ -> - raise(Error(loc_fun, env, - Too_many_arguments (in_function <> None, ty_fun))) + raise + (Error (loc_fun, env, Too_many_arguments (in_function <> None, ty_fun)))) in let ty_arg = - if is_optional l then - let tv = newvar() in - begin - try unify env ty_arg (type_option tv) - with Unify _ -> assert false - end; - type_option tv + if is_optional l then ( + let tv = newvar () in + (try unify env ty_arg (type_option tv) with Unify _ -> assert false); + type_option tv) else ty_arg in - if separate then begin + if separate then ( end_def (); generalize_structure ty_arg; - generalize_structure ty_res - end; + generalize_structure ty_res); let cases, partial = - type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res - true loc caselist in + type_cases ~in_function:(loc_fun, ty_fun) env ty_arg ty_res true loc + caselist + in if is_optional l && not_function env ty_res then Location.prerr_warning (List.hd cases).c_lhs.pat_loc Warnings.Unerasable_optional_argument; let param = name_pattern "param" cases in - re { - exp_desc = Texp_function { arg_label = l; param; cases; partial; }; - exp_loc = loc; exp_extra = []; - exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); - exp_attributes = attrs; - exp_env = env } - + re + { + exp_desc = Texp_function {arg_label = l; param; cases; partial}; + exp_loc = loc; + exp_extra = []; + exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok))); + exp_attributes = attrs; + exp_env = env; + } and type_label_access env srecord lid = let record = type_exp ~recarg:Allowed env srecord in @@ -3016,171 +3363,209 @@ and type_label_access env srecord lid = let opath = try match extract_concrete_typedecl env ty_exp with - | (p0, _, {type_attributes}) - when Path.same p0 Predef.path_dict && Dict_type_helpers.has_dict_attribute type_attributes -> - (* [dict] Cover the case when trying to direct field access on a dict, e.g. `someDict.name`. - We need to disallow this because the fact that a dict is represented as a single magic - field record internally is just an implementation detail, and not intended to be exposed - to the user. *) - raise(Error(lid.loc, env, Field_access_on_dict_type)) - | (p0, p, {type_kind=Type_record _}) -> Some(p0, p) + | p0, _, {type_attributes} + when Path.same p0 Predef.path_dict + && Dict_type_helpers.has_dict_attribute type_attributes -> + (* [dict] Cover the case when trying to direct field access on a dict, e.g. `someDict.name`. + We need to disallow this because the fact that a dict is represented as a single magic + field record internally is just an implementation detail, and not intended to be exposed + to the user. *) + raise (Error (lid.loc, env, Field_access_on_dict_type)) + | p0, p, {type_kind = Type_record _} -> Some (p0, p) | _ -> None with Not_found -> None in let labels = Typetexp.find_all_labels env lid.loc lid.txt in let label = wrap_disambiguate "This expression has" ty_exp - (Label.disambiguate lid env opath) labels in + (Label.disambiguate lid env opath) + labels + in (record, label, opath) (* Typing format strings for printing or reading. These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) and type_label_exp ?type_clash_context create env loc ty_expected - (lid, label, sarg) = + (lid, label, sarg) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = Env.has_local_constraints env in - if separate then (begin_def (); begin_def ()); - let (vars, ty_arg, ty_res) = instance_label true label in - if separate then begin + if separate then ( + begin_def (); + begin_def ()); + let vars, ty_arg, ty_res = instance_label true label in + if separate then ( end_def (); (* Generalize label information *) generalize_structure ty_arg; - generalize_structure ty_res - end; - begin try - unify env (instance_def ty_res) (instance env ty_expected) - with Unify trace -> - raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace))) - end; + generalize_structure ty_res); + (try unify env (instance_def ty_res) (instance env ty_expected) + with Unify trace -> + raise (Error (lid.loc, env, Label_mismatch (lid.txt, trace)))); (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance_def ty_arg in - if separate then begin + if separate then ( end_def (); (* Generalize information merged from ty_expected *) - generalize_structure ty_arg - end; + generalize_structure ty_arg); if label.lbl_private = Private then - if create then - raise (Error(loc, env, Private_type ty_expected)) - else - raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); + if create then raise (Error (loc, env, Private_type ty_expected)) + else raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in - let arg = type_argument ?type_clash_context env sarg ty_arg (instance env ty_arg) in + let arg = + type_argument ?type_clash_context env sarg ty_arg (instance env ty_arg) + in end_def (); try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; arg - with exn when not (is_nonexpansive arg) -> try - (* Try to retype without propagating ty_arg, cf PR#4862 *) - may Btype.backtrack snap; - begin_def (); - let arg = type_exp env sarg in - end_def (); - generalize_expansive env arg.exp_type; - unify_exp env arg ty_arg; - check_univars env false "field value" arg label.lbl_arg vars; - arg - with Error (_, _, Less_general _) as e -> raise e - | _ -> raise exn (* In case of failure return the first error *) + with exn when not (is_nonexpansive arg) -> ( + try + (* Try to retype without propagating ty_arg, cf PR#4862 *) + may Btype.backtrack snap; + begin_def (); + let arg = type_exp env sarg in + end_def (); + generalize_expansive env arg.exp_type; + unify_exp env arg ty_arg; + check_univars env false "field value" arg label.lbl_arg vars; + arg + with + | Error (_, _, Less_general _) as e -> raise e + | _ -> raise exn (* In case of failure return the first error *)) in (lid, label, {arg with exp_type = instance env arg.exp_type}) -and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected = +and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected + = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in - not tvar && List.for_all (fun x -> x = Nolabel) ls + (not tvar) && List.for_all (fun x -> x = Nolabel) ls in let rec is_inferred sexp = match sexp.pexp_desc with - Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ - | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> + true | Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 | _ -> false in match expand_head env ty_expected' with - {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = _} + | {desc = Tarrow (Nolabel, ty_arg, ty_res, _); level = _} when is_inferred sarg -> - (* apply optional arguments when expected type is "" *) - (* we must be very careful about not breaking the semantics *) - let texp = type_exp env sarg in - let rec make_args args ty_fun = - match (expand_head env ty_fun).desc with - | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> - let ty = option_none (instance env ty_arg) sarg.pexp_loc in - make_args ((l, Some ty) :: args) ty_fun - | Tarrow (Nolabel,_,ty_res',_) -> - List.rev args, ty_fun, no_labels ty_res' - | Tvar _ -> List.rev args, ty_fun, false - | _ -> [], texp.exp_type, false - in - let args, ty_fun', simple_res = make_args [] texp.exp_type in - let texp = {texp with exp_type = instance env texp.exp_type} - and ty_fun = instance env ty_fun' in - if not (simple_res || no_labels ty_res) then begin - unify_exp env texp ty_expected; - texp - end else begin + (* apply optional arguments when expected type is "" *) + (* we must be very careful about not breaking the semantics *) + let texp = type_exp env sarg in + let rec make_args args ty_fun = + match (expand_head env ty_fun).desc with + | Tarrow (l, ty_arg, ty_fun, _) when is_optional l -> + let ty = option_none (instance env ty_arg) sarg.pexp_loc in + make_args ((l, Some ty) :: args) ty_fun + | Tarrow (Nolabel, _, ty_res', _) -> + (List.rev args, ty_fun, no_labels ty_res') + | Tvar _ -> (List.rev args, ty_fun, false) + | _ -> ([], texp.exp_type, false) + in + let args, ty_fun', simple_res = make_args [] texp.exp_type in + let texp = {texp with exp_type = instance env texp.exp_type} + and ty_fun = instance env ty_fun' in + if not (simple_res || no_labels ty_res) then ( + unify_exp env texp ty_expected; + texp) + else ( unify_exp env {texp with exp_type = ty_fun} ty_expected; - if args = [] then texp else - (* eta-expand to avoid side effects *) - let var_pair name ty = - let id = Ident.create name in - {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; - pat_attributes = []; - pat_loc = Location.none; pat_env = env}, - {exp_type = ty; exp_loc = Location.none; exp_env = env; - exp_extra = []; exp_attributes = []; - exp_desc = - Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), - {val_type = ty; val_kind = Val_reg; - val_attributes = []; - Types.val_loc = Location.none})} - in - let eta_pat, eta_var = var_pair "eta" ty_arg in - let func texp = - let e = - {texp with exp_type = ty_res; exp_desc = - Texp_apply - (texp, - args @ [Nolabel, Some eta_var])} + if args = [] then texp + else + (* eta-expand to avoid side effects *) + let var_pair name ty = + let id = Ident.create name in + ( { + pat_desc = Tpat_var (id, mknoloc name); + pat_type = ty; + pat_extra = []; + pat_attributes = []; + pat_loc = Location.none; + pat_env = env; + }, + { + exp_type = ty; + exp_loc = Location.none; + exp_env = env; + exp_extra = []; + exp_attributes = []; + exp_desc = + Texp_ident + ( Path.Pident id, + mknoloc (Longident.Lident name), + { + val_type = ty; + val_kind = Val_reg; + val_attributes = []; + Types.val_loc = Location.none; + } ); + } ) in - let cases = [case eta_pat e] in - let param = name_pattern "param" cases in - { texp with exp_type = ty_fun; exp_desc = - Texp_function { arg_label = Nolabel; param; cases; - partial = Total; } } - in - Location.prerr_warning texp.exp_loc - (Warnings.Eliminated_optional_arguments - (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); - (* let-expand to have side effects *) - let let_pat, let_var = var_pair "arg" texp.exp_type in - re { texp with exp_type = ty_fun; exp_desc = - Texp_let (Nonrecursive, - [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]; - vb_loc=Location.none; - }], - func let_var) } - end + let eta_pat, eta_var = var_pair "eta" ty_arg in + let func texp = + let e = + { + texp with + exp_type = ty_res; + exp_desc = Texp_apply (texp, args @ [(Nolabel, Some eta_var)]); + } + in + let cases = [case eta_pat e] in + let param = name_pattern "param" cases in + { + texp with + exp_type = ty_fun; + exp_desc = + Texp_function {arg_label = Nolabel; param; cases; partial = Total}; + } + in + Location.prerr_warning texp.exp_loc + (Warnings.Eliminated_optional_arguments + (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); + (* let-expand to have side effects *) + let let_pat, let_var = var_pair "arg" texp.exp_type in + re + { + texp with + exp_type = ty_fun; + exp_desc = + Texp_let + ( Nonrecursive, + [ + { + vb_pat = let_pat; + vb_expr = texp; + vb_attributes = []; + vb_loc = Location.none; + }; + ], + func let_var ); + }) | _ -> - let texp = type_expect ?type_clash_context ?recarg env sarg ty_expected' in - unify_exp ?type_clash_context env texp ty_expected; - texp + let texp = type_expect ?type_clash_context ?recarg env sarg ty_expected' in + unify_exp ?type_clash_context env texp ty_expected; + texp + and is_automatic_curried_application env funct = (* When a curried function is used with uncurried application, treat it as a curried application *) match (expand_head env funct.exp_type).desc with | Tarrow _ -> true | _ -> false -and type_application ?type_clash_context uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = + +and type_application ?type_clash_context uncurried env funct (sargs : sargs) : + targs * Types.type_expr * bool = (* funct.exp_type may be generic *) let result_type omitted ty_fun = List.fold_left - (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok))) + (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) ty_fun omitted in let has_label l ty_fun = @@ -3190,260 +3575,321 @@ and type_application ?type_clash_context uncurried env funct (sargs : sargs) : t let ignored = ref [] in let has_uncurried_type t = match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"},[t; t_arity],_) -> + | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> let arity = Ast_uncurried.type_to_arity t_arity in Some (arity, t) - | _ -> None in + | _ -> None + in let force_uncurried_type funct = match has_uncurried_type funct.exp_type with - | None -> + | None -> ( let arity = List.length sargs in - let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity (newvar()) in - begin - match (expand_head env funct.exp_type).desc with - | Tvar _ | Tarrow _ -> - unify_exp env funct uncurried_typ - | _ -> - raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) - end - | Some _ -> () in + let uncurried_typ = + Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) + in + match (expand_head env funct.exp_type).desc with + | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + | Some _ -> () + in let extract_uncurried_type t = match has_uncurried_type t with | Some (arity, t1) -> if List.length sargs > arity then - raise(Error(funct.exp_loc, env, - Uncurried_arity_mismatch (t, arity, List.length sargs))); - t1, arity - | None -> t, max_int in + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + (t1, arity) + | None -> (t, max_int) + in let update_uncurried_arity ~nargs t new_t = match has_uncurried_type t with | Some (arity, _) -> let newarity = arity - nargs in let fully_applied = newarity <= 0 in if uncurried && not fully_applied then - raise(Error(funct.exp_loc, env, - Uncurried_arity_mismatch (t, arity, List.length sargs))); - let new_t = if fully_applied then new_t else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t in + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + let new_t = + if fully_applied then new_t + else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t + in (fully_applied, new_t) | _ -> (false, new_t) in - let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun (syntax_args : sargs) - : targs * _ = + let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun + (syntax_args : sargs) : targs * _ = match syntax_args with | [] -> - let collect_args () = - (List.map - (function l, None -> l, None - | l, Some f -> l, Some (f ())) + let collect_args () = + ( List.map + (function + | l, None -> (l, None) + | l, Some f -> (l, Some (f ()))) (List.rev args), - instance env (result_type omitted ty_fun)) in - if List.length args < max_arity && uncurried then - (match (expand_head env ty_fun).desc with - | Tarrow (Optional l,t1,t2,_) -> - ignored := (Optional l,t1,ty_fun.level) :: !ignored; - let arg = Optional l, Some (fun () -> option_none (instance env t1) Location.none) in - type_unknown_args max_arity ~args:(arg::args) omitted t2 [] - | _ -> collect_args ()) - else - collect_args () + instance env (result_type omitted ty_fun) ) + in + if List.length args < max_arity && uncurried then + match (expand_head env ty_fun).desc with + | Tarrow (Optional l, t1, t2, _) -> + ignored := (Optional l, t1, ty_fun.level) :: !ignored; + let arg = + ( Optional l, + Some (fun () -> option_none (instance env t1) Location.none) ) + in + type_unknown_args max_arity ~args:(arg :: args) omitted t2 [] + | _ -> collect_args () + else collect_args () | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] - when uncurried && omitted = [] && args <> [] && List.length args = List.length !ignored -> + when uncurried && omitted = [] && args <> [] + && List.length args = List.length !ignored -> (* foo(. ) treated as empty application if all args are optional (hence ignored) *) - type_unknown_args max_arity ~args omitted ty_fun [] + type_unknown_args max_arity ~args omitted ty_fun [] | (l1, sarg1) :: sargl -> - let (ty1, ty2) = - let ty_fun = expand_head env ty_fun in - let arity_ok = List.length args < max_arity in - match ty_fun.desc with - Tvar _ -> - let t1 = newvar () and t2 = newvar () in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); - (t1, t2) - | Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1 && arity_ok - -> - (t1, t2) - | td -> - let ty_fun = - match td with Tarrow _ -> newty td | _ -> ty_fun in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - Tarrow _ -> - if not arity_ok then - raise (Error(sarg1.pexp_loc, env, - Apply_wrong_label(l1, funct.exp_type))) else - if (not (has_label l1 ty_fun)) then - raise (Error(sarg1.pexp_loc, env, - Apply_wrong_label(l1, ty_res))) - else - raise (Error(funct.exp_loc, env, Incoherent_label_order)) - | _ -> - raise(Error(funct.exp_loc, env, Apply_non_function - (expand_head env funct.exp_type))) - in - let optional = is_optional l1 in - let arg1 () = - let arg1 = type_expect env sarg1 ty1 in - if optional then - unify_exp env arg1 (type_option(newvar())); - arg1 - in - type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 sargl + let ty1, ty2 = + let ty_fun = expand_head env ty_fun in + let arity_ok = List.length args < max_arity in + match ty_fun.desc with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); + (t1, t2) + | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok -> + (t1, t2) + | td -> ( + let ty_fun = + match td with + | Tarrow _ -> newty td + | _ -> ty_fun + in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + | Tarrow _ -> + if not arity_ok then + raise + (Error + (sarg1.pexp_loc, env, Apply_wrong_label (l1, funct.exp_type))) + else if not (has_label l1 ty_fun) then + raise + (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) + else raise (Error (funct.exp_loc, env, Incoherent_label_order)) + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + in + let optional = is_optional l1 in + let arg1 () = + let arg1 = type_expect env sarg1 ty1 in + if optional then unify_exp env arg1 (type_option (newvar ())); + arg1 + in + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 + sargl in - let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) = - match expand_head env ty_fun, expand_head env ty_fun0 with - {desc=Tarrow (l, ty, ty_fun, com); level=lv} , - {desc=Tarrow (_, ty0, ty_fun0, _)} - when (sargs <> [] ) && commu_repr com = Cok && List.length args < max_arity -> - let name = label_name l - and optional = is_optional l in - let sargs, omitted, arg = - match extract_label name sargs with - | None -> - if optional && (uncurried || label_assoc Nolabel sargs) - then begin - ignored := (l,ty,lv) :: !ignored; - sargs, omitted , Some (fun () -> option_none (instance env ty) Location.none) - end else - sargs, (l,ty,lv) :: omitted , None - | Some (l', sarg0, sargs) -> - if not optional && is_optional l' then - Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label (Printtyp.string_of_label l)); - sargs, omitted , - Some ( - if not optional || is_optional l' then - (fun () -> type_argument ?type_clash_context:(type_clash_context_for_function_argument type_clash_context sarg0) env sarg0 ty ty0) - else - (fun () -> option_some (type_argument ?type_clash_context env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0)))) - in - type_args ?type_clash_context max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs + let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 + ~(sargs : sargs) = + match (expand_head env ty_fun, expand_head env ty_fun0) with + | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, + {desc = Tarrow (_, ty0, ty_fun0, _)} ) + when sargs <> [] && commu_repr com = Cok && List.length args < max_arity + -> + let name = label_name l and optional = is_optional l in + let sargs, omitted, arg = + match extract_label name sargs with + | None -> + if optional && (uncurried || label_assoc Nolabel sargs) then ( + ignored := (l, ty, lv) :: !ignored; + ( sargs, + omitted, + Some (fun () -> option_none (instance env ty) Location.none) )) + else (sargs, (l, ty, lv) :: omitted, None) + | Some (l', sarg0, sargs) -> + if (not optional) && is_optional l' then + Location.prerr_warning sarg0.pexp_loc + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); + ( sargs, + omitted, + Some + (if (not optional) || is_optional l' then fun () -> + type_argument + ?type_clash_context: + (type_clash_context_for_function_argument + type_clash_context sarg0) + env sarg0 ty ty0 + else fun () -> + option_some + (type_argument ?type_clash_context env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) ) + in + type_args ?type_clash_context max_arity ((l, arg) :: args) omitted ~ty_fun + ty_fun0 ~sargs | _ -> - type_unknown_args max_arity ~args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) + type_unknown_args max_arity ~args omitted ty_fun0 + sargs (* This is the hot path for non-labeled function*) in - let () = + let () = let ls, tvar = list_labels env funct.exp_type in if not tvar then - let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in - if Ext_list.same_length labels sargs && - List.for_all (fun (l,_) -> l = Nolabel) sargs && - List.exists (fun l -> l <> Nolabel) labels then - raise - (Error( - funct.exp_loc, env, - (Labels_omitted - (List.map Printtyp.string_of_label - (Ext_list.filter labels (fun x -> x <> Nolabel)))))) + let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in + if + Ext_list.same_length labels sargs + && List.for_all (fun (l, _) -> l = Nolabel) sargs + && List.exists (fun l -> l <> Nolabel) labels + then + raise + (Error + ( funct.exp_loc, + env, + Labels_omitted + (List.map Printtyp.string_of_label + (Ext_list.filter labels (fun x -> x <> Nolabel))) )) in match sargs with - (* Special case for ignore: avoid discarding warning *) - [Nolabel, sarg] when is_ignore funct env -> - let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel - in - let exp = type_expect env sarg ty_arg in - begin match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar _ -> - Delayed_checks.add_delayed_check (fun () -> check_application_result env false exp) - | _ -> () - end; - ([Nolabel, Some exp], ty_res, false) + (* Special case for ignore: avoid discarding warning *) + | [(Nolabel, sarg)] when is_ignore funct env -> + let ty_arg, ty_res = + filter_arrow env (instance env funct.exp_type) Nolabel + in + let exp = type_expect env sarg ty_arg in + (match (expand_head env exp.exp_type).desc with + | Tarrow _ -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tvar _ -> + Delayed_checks.add_delayed_check (fun () -> + check_application_result env false exp) + | _ -> ()); + ([(Nolabel, Some exp)], ty_res, false) | _ -> - if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in - let targs, ret_t = type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in - let fully_applied, ret_t = - update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in - targs, ret_t, fully_applied + if uncurried then force_uncurried_type funct; + let ty, max_arity = extract_uncurried_type funct.exp_type in + let targs, ret_t = + type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) + ~sargs + in + let fully_applied, ret_t = + update_uncurried_arity funct.exp_type + ~nargs:(List.length !ignored + List.length sargs) + ret_t + in + (targs, ret_t, fully_applied) and type_construct env loc lid sarg ty_expected attrs = let opath = try - let (p0, p,_) = extract_concrete_variant env ty_expected in - Some(p0, p) + let p0, p, _ = extract_concrete_variant env ty_expected in + Some (p0, p) with Not_found -> None in let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in let constr = wrap_disambiguate "This variant expression is expected to have" ty_expected - (Constructor.disambiguate lid env opath) constrs in + (Constructor.disambiguate lid env opath) + constrs + in Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; Builtin_attributes.check_deprecated loc constr.cstr_attributes constr.cstr_name; let sargs = match sarg with - None -> [] - | Some {pexp_desc = Pexp_tuple sel} when - constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs - -> sel - | Some se -> [se] in + | None -> [] + | Some {pexp_desc = Pexp_tuple sel} + when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs -> + sel + | Some se -> [se] + in if List.length sargs <> constr.cstr_arity then - raise(Error(loc, env, Constructor_arity_mismatch - (lid.txt, constr.cstr_arity, List.length sargs))); + raise + (Error + ( loc, + env, + Constructor_arity_mismatch + (lid.txt, constr.cstr_arity, List.length sargs) )); let separate = Env.has_local_constraints env in - if separate then (begin_def (); begin_def ()); - let (ty_args, ty_res) = instance_constructor constr in + if separate then ( + begin_def (); + begin_def ()); + let ty_args, ty_res = instance_constructor constr in let texp = - re { - exp_desc = Texp_construct(lid, constr, []); - exp_loc = loc; exp_extra = []; - exp_type = ty_res; - exp_attributes = attrs; - exp_env = env } in + re + { + exp_desc = Texp_construct (lid, constr, []); + exp_loc = loc; + exp_extra = []; + exp_type = ty_res; + exp_attributes = attrs; + exp_env = env; + } + in let type_clash_context = type_clash_context_maybe_option ty_expected ty_res in - if separate then begin + if separate then ( end_def (); generalize_structure ty_res; - unify_exp ?type_clash_context env {texp with exp_type = instance_def ty_res} - (instance env ty_expected); + unify_exp ?type_clash_context env + {texp with exp_type = instance_def ty_res} + (instance env ty_expected); end_def (); List.iter generalize_structure ty_args; - generalize_structure ty_res; - end; + generalize_structure ty_res); let ty_args0, ty_res = match instance_list env (ty_res :: ty_args) with - t :: tl -> tl, t + | t :: tl -> (tl, t) | _ -> assert false in let texp = {texp with exp_type = ty_res} in - if not separate then unify_exp ?type_clash_context env texp (instance env ty_expected); + if not separate then + unify_exp ?type_clash_context env texp (instance env ty_expected); let recarg = match constr.cstr_inlined with | None -> Rejected - | Some _ -> - begin match sargs with - | [{pexp_desc = - Pexp_ident _ | - Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> - Required - | _ -> - raise (Error(loc, env, Inlined_record_expected)) - end + | Some _ -> ( + match sargs with + | [ + { + pexp_desc = + ( Pexp_ident _ + | Pexp_record (_, (Some {pexp_desc = Pexp_ident _} | None)) ); + }; + ] -> + Required + | _ -> raise (Error (loc, env, Inlined_record_expected))) in let args = - List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs - (List.combine ty_args ty_args0) in + List.map2 + (fun e (t, t0) -> type_argument ~recarg env e t t0) + sargs + (List.combine ty_args ty_args0) + in if constr.cstr_private = Private then - raise(Error(loc, env, Private_type ty_res)); + raise (Error (loc, env, Private_type ty_res)); (* NOTE: shouldn't we call "re" on this final expression? -- AF *) - { texp with - exp_desc = Texp_construct(lid, constr, args) } + {texp with exp_desc = Texp_construct (lid, constr, args)} (* Typing of statements (expressions whose values are discarded) *) and type_statement env sexp = let loc = (final_subexpression sexp).pexp_loc in - begin_def(); + begin_def (); let exp = type_exp env sexp in - end_def(); - let ty = expand_head env exp.exp_type and tv = newvar() in + end_def (); + let ty = expand_head env exp.exp_type and tv = newvar () in if is_Tvar ty && ty.level > tv.level then - Location.prerr_warning loc Warnings.Nonreturning_statement; + Location.prerr_warning loc Warnings.Nonreturning_statement; let expected_ty = instance_def Predef.type_unit in let type_clash_context = type_clash_context_in_statement sexp in unify_exp ?type_clash_context env exp expected_ty; @@ -3451,29 +3897,29 @@ and type_statement env sexp = (* Typing of match cases *) -and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res partial_flag loc caselist : _ * Typedtree.partial = +and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res + partial_flag loc caselist : _ * Typedtree.partial = (* ty_arg is _fully_ generalized *) - let patterns = List.map (fun {pc_lhs=p} -> p) caselist in + let patterns = List.map (fun {pc_lhs = p} -> p) caselist in let contains_polyvars = List.exists contains_polymorphic_variant patterns in let erase_either = contains_polyvars && contains_variant_either ty_arg and has_gadts = List.exists (contains_gadt env) patterns in -(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) + (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) let ty_arg = - if (has_gadts || erase_either) - then correct_levels ty_arg else ty_arg + if has_gadts || erase_either then correct_levels ty_arg else ty_arg and ty_res, env = - if has_gadts then - correct_levels ty_res, duplicate_ident_types caselist env - else ty_res, env + if has_gadts then (correct_levels ty_res, duplicate_ident_types caselist env) + else (ty_res, env) in let rec is_var spat = match spat.ppat_desc with - Ppat_any | Ppat_var _ -> true + | Ppat_any | Ppat_var _ -> true | Ppat_alias (spat, _) -> is_var spat - | _ -> false in + | _ -> false + in let needs_exhaust_check = match caselist with - [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true + | [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true | [{pc_lhs}] when is_var pc_lhs -> false | _ -> true in @@ -3482,24 +3928,29 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res partial_f begin_def (); Ident.set_current_time (get_current_level ()); let lev = Ident.current_time () in - Ctype.init_def (lev+1000); (* up to 1000 existentials *) + Ctype.init_def (lev + 1000); + (* up to 1000 existentials *) (lev, Env.add_gadt_instance_level lev env) in let lev, env = if has_gadts then init_env () else (get_current_level (), env) in -(* if has_gadts then - Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) + (* if has_gadts then + Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) (* Do we need to propagate polymorphism *) let propagate = - has_gadts || (repr ty_arg).level = generic_level || + has_gadts + || (repr ty_arg).level = generic_level + || match caselist with - [{pc_lhs}] when is_var pc_lhs -> false - | _ -> true in - if propagate then begin_def (); (* propagation of the argument *) + | [{pc_lhs}] when is_var pc_lhs -> false + | _ -> true + in + if propagate then begin_def (); + (* propagation of the argument *) let pattern_force = ref [] in -(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) - Printtyp.raw_type_expr ty_arg; *) + (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) let pat_env_list = List.map (fun {pc_lhs; pc_guard; pc_rhs} -> @@ -3507,41 +3958,39 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res partial_f let open Location in match pc_guard with | None -> pc_rhs.pexp_loc - | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start} + | Some g -> {pc_rhs.pexp_loc with loc_start = g.pexp_loc.loc_start} in let scope = Some (Annot.Idef loc) in - let (pat, ext_env, force, unpacks) = - let partial = - if erase_either - then Some false else None in + let pat, ext_env, force, unpacks = + let partial = if erase_either then Some false else None in let ty_arg = instance ?partial env ty_arg in type_pattern ~lev env pc_lhs scope ty_arg in pattern_force := force @ !pattern_force; (pat, (ext_env, unpacks))) - caselist in + caselist + in (* Unify all cases (delayed to keep it order-free) *) let ty_arg' = newvar () in let unify_pats ty = - List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty) - pat_env_list in + List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty) pat_env_list + in unify_pats ty_arg'; (* Check for polymorphic variants to close *) let patl = List.map fst pat_env_list in - if List.exists has_variants patl then begin + if List.exists has_variants patl then ( Parmatch.pressure_variants env patl; - List.iter (iter_pattern finalize_variant) patl - end; + List.iter (iter_pattern finalize_variant) patl); (* `Contaminating' unifications start here *) - List.iter (fun f -> f()) !pattern_force; + List.iter (fun f -> f ()) !pattern_force; (* Post-processing and generalization *) if propagate || erase_either then unify_pats (instance env ty_arg); - if propagate then begin + if propagate then ( List.iter - (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl; + (iter_pattern (fun {pat_type = t} -> unify_var env t (newvar ()))) + patl; end_def (); - List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl; - end; + List.iter (iter_pattern (fun {pat_type = t} -> generalize t)) patl); (* type bodies *) let in_function = if List.length caselist = 1 then in_function else None in let cases = @@ -3549,34 +3998,40 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res partial_f (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} -> let sexp = wrap_unpacks pc_rhs unpacks in let ty_res' = - if contains_gadt env pc_lhs then correct_levels ty_res - else ty_res in -(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) - Printtyp.raw_type_expr ty_res'; *) + if contains_gadt env pc_lhs then correct_levels ty_res else ty_res + in + (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_res'; *) let guard = match pc_guard with | None -> None | Some scond -> - Some - (type_expect ?type_clash_context:(if Option.is_some root_type_clash_context then Some IfCondition else None) ext_env (wrap_unpacks scond unpacks) - Predef.type_bool) + Some + (type_expect + ?type_clash_context: + (if Option.is_some root_type_clash_context then + Some IfCondition + else None) + ext_env + (wrap_unpacks scond unpacks) + Predef.type_bool) + in + let exp = + type_expect ?type_clash_context:root_type_clash_context ?in_function + ext_env sexp ty_res' in - let exp = type_expect ?type_clash_context:root_type_clash_context ?in_function ext_env sexp ty_res' in { - c_lhs = pat; - c_guard = guard; - c_rhs = {exp with exp_type = instance env ty_res'} - } - ) + c_lhs = pat; + c_guard = guard; + c_rhs = {exp with exp_type = instance env ty_res'}; + }) pat_env_list caselist in - if has_gadts then begin - let ty_res' = instance env ty_res in - List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases - end; + (if has_gadts then + let ty_res' = instance env ty_res in + List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases); let do_init = has_gadts || needs_exhaust_check in - let lev, env = - if do_init && not has_gadts then init_env () else lev, env in + let lev, env = if do_init && not has_gadts then init_env () else (lev, env) in let ty_arg_check = if do_init then (* Hack: use for_saving to copy variables too *) @@ -3584,55 +4039,58 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res partial_f else ty_arg in let partial = - if partial_flag then - check_partial ~lev env ty_arg_check loc cases - else - Partial + if partial_flag then check_partial ~lev env ty_arg_check loc cases + else Partial in let unused_check () = - List.iter (fun (pat, (env, _)) -> check_absent_variant env pat) - pat_env_list; - check_unused ~lev env (instance env ty_arg_check) cases ; + List.iter (fun (pat, (env, _)) -> check_absent_variant env pat) pat_env_list; + check_unused ~lev env (instance env ty_arg_check) cases; Parmatch.check_ambiguous_bindings cases in if contains_polyvars || do_init then Delayed_checks.add_delayed_check unused_check - else - unused_check (); + else unused_check (); (* Check for unused cases, do not delay because of gadts *) - if do_init then begin + if do_init then ( end_def (); (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance env ty_res) (newvar ()) ; - end; - cases, partial + unify_exp_types loc env (instance env ty_res) (newvar ())); + (cases, partial) (* Typing of let bindings *) and type_let ?(check = fun s -> Warnings.Unused_var s) - ?(check_strict = fun s -> Warnings.Unused_var_strict s) - env rec_flag spat_sexp_list scope allow = - begin_def(); + ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag + spat_sexp_list scope allow = + begin_def (); let is_fake_let = match spat_sexp_list with - | [{pvb_expr={pexp_desc=Pexp_match( - {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] -> - true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) - | _ -> - false + | [ + { + pvb_expr = + { + pexp_desc = + Pexp_match + ({pexp_desc = Pexp_ident {txt = Longident.Lident "*opt*"}}, _); + }; + }; + ] -> + true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) + | _ -> false in let check = if is_fake_let then check_strict else check in let spatl = List.map - (fun {pvb_pat=spat; pvb_attributes=attrs} -> - attrs, spat) - spat_sexp_list in + (fun {pvb_pat = spat; pvb_attributes = attrs} -> (attrs, spat)) + spat_sexp_list + in let nvs = List.map (fun _ -> newvar ()) spatl in - let (pat_list, new_env, force, unpacks) = - type_pattern_list env spatl scope nvs allow in + let pat_list, new_env, force, unpacks = + type_pattern_list env spatl scope nvs allow + in let attrs_list = List.map fst spatl in - let is_recursive = (rec_flag = Recursive) in + let is_recursive = rec_flag = Recursive in (* If recursive, first unify with an approximation of the expression *) if is_recursive then List.iter2 @@ -3640,32 +4098,34 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let pat = match pat.pat_type.desc with | Tpoly (ty, tl) -> - {pat with pat_type = - snd (instance_poly ~keep_names:true false tl ty)} + { + pat with + pat_type = snd (instance_poly ~keep_names:true false tl ty); + } | _ -> pat - in unify_pat env pat (type_approx env binding.pvb_expr)) + in + unify_pat env pat (type_approx env binding.pvb_expr)) pat_list spat_sexp_list; (* Polymorphic variant processing *) List.iter (fun pat -> - if has_variants pat then begin + if has_variants pat then ( Parmatch.pressure_variants env [pat]; - iter_pattern finalize_variant pat - end) + iter_pattern finalize_variant pat)) pat_list; (* Only bind pattern variables after generalizing *) - List.iter (fun f -> f()) force; - let exp_env = - if is_recursive then new_env else env in + List.iter (fun f -> f ()) force; + let exp_env = if is_recursive then new_env else env in let current_slot = ref None in let rec_needed = ref false in let warn_about_unused_bindings = List.exists (fun attrs -> - Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - Warnings.is_active (check "") || Warnings.is_active (check_strict "") || - (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)))) + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + Warnings.is_active (check "") + || Warnings.is_active (check_strict "") + || (is_recursive && Warnings.is_active Warnings.Unused_rec_flag))) attrs_list in let pat_slot_list = @@ -3684,94 +4144,84 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) We also keep track of whether *all* variables in a given pattern are unused. If this is the case, for local declarations, the issued warning is 26, not 27. - *) + *) List.map2 (fun attrs pat -> - Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - if not warn_about_unused_bindings then pat, None - else - let some_used = ref false in - (* has one of the identifier of this pattern been used? *) - let slot = ref [] in - List.iter - (fun id -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + if not warn_about_unused_bindings then (pat, None) + else + let some_used = ref false in + (* has one of the identifier of this pattern been used? *) + let slot = ref [] in + List.iter + (fun id -> let vd = Env.find_value (Path.Pident id) new_env in (* note: Env.find_value does not trigger the value_used event *) let name = Ident.name id in let used = ref false in if not (name = "" || name.[0] = '_' || name.[0] = '#') then - Delayed_checks.add_delayed_check - (fun () -> - if not !used then - Location.prerr_warning vd.Types.val_loc - ((if !some_used then check_strict else check) name) - ); - Env.set_value_used_callback - name vd - (fun () -> - match !current_slot with - | Some slot -> - slot := (name, vd) :: !slot; rec_needed := true - | None -> - List.iter - (fun (name, vd) -> Env.mark_value_used env name vd) - (get_ref slot); - used := true; - some_used := true - ) - ) - (Typedtree.pat_bound_idents pat); - pat, Some slot - )) - attrs_list - pat_list + Delayed_checks.add_delayed_check (fun () -> + if not !used then + Location.prerr_warning vd.Types.val_loc + ((if !some_used then check_strict else check) name)); + Env.set_value_used_callback name vd (fun () -> + match !current_slot with + | Some slot -> + slot := (name, vd) :: !slot; + rec_needed := true + | None -> + List.iter + (fun (name, vd) -> Env.mark_value_used env name vd) + (get_ref slot); + used := true; + some_used := true)) + (Typedtree.pat_bound_idents pat); + (pat, Some slot))) + attrs_list pat_list in let exp_list = List.map2 - (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) -> + (fun {pvb_expr = sexp; pvb_attributes; _} (pat, slot) -> let sexp = - if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in + if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp + in if is_recursive then current_slot := slot; match pat.pat_type.desc with | Tpoly (ty, tl) -> - begin_def (); - let vars, ty' = instance_poly ~keep_names:true true tl ty in - let exp = - Builtin_attributes.warning_scope pvb_attributes - (fun () -> type_expect exp_env sexp ty') - in - end_def (); - check_univars env true "definition" exp pat.pat_type vars; - {exp with exp_type = instance env exp.exp_type} - | _ -> + begin_def (); + let vars, ty' = instance_poly ~keep_names:true true tl ty in + let exp = Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp ty') + in + end_def (); + check_univars env true "definition" exp pat.pat_type vars; + {exp with exp_type = instance env exp.exp_type} + | _ -> + Builtin_attributes.warning_scope pvb_attributes (fun () -> type_expect exp_env sexp pat.pat_type)) - spat_sexp_list pat_slot_list in + spat_sexp_list pat_slot_list + in current_slot := None; - if is_recursive && not !rec_needed - && Warnings.is_active Warnings.Unused_rec_flag then begin - let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in - (* See PR#6677 *) - Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes - (fun () -> - Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag - ) - end; + (if + is_recursive && (not !rec_needed) + && Warnings.is_active Warnings.Unused_rec_flag + then + let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in + (* See PR#6677 *) + Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes (fun () -> + Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag)); List.iter2 (fun pat (attrs, exp) -> - Builtin_attributes.warning_scope ~ppwarning:false attrs - (fun () -> - ignore(check_partial env pat.pat_type pat.pat_loc - [case pat exp]) - ) - ) + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + ignore (check_partial env pat.pat_type pat.pat_loc [case pat exp]))) pat_list - (List.map2 (fun (attrs, _) e -> attrs, e) spatl exp_list); - end_def(); + (List.map2 (fun (attrs, _) e -> (attrs, e)) spatl exp_list); + end_def (); List.iter2 (fun pat exp -> - if not (is_nonexpansive exp) then - iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat) + if not (is_nonexpansive exp) then + iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat) pat_list exp_list; List.iter (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat) @@ -3780,25 +4230,29 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let l = List.map2 (fun (p, e) pvb -> - {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; - vb_loc=pvb.pvb_loc; + { + vb_pat = p; + vb_expr = e; + vb_attributes = pvb.pvb_attributes; + vb_loc = pvb.pvb_loc; }) l spat_sexp_list in if is_recursive then - List.iter - (fun {vb_pat=pat} -> match pat.pat_desc with - Tpat_var _ -> () - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () - | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat))) + List.iter + (fun {vb_pat = pat} -> + match pat.pat_desc with + | Tpat_var _ -> () + | Tpat_alias ({pat_desc = Tpat_any}, _, _) -> () + | _ -> raise (Error (pat.pat_loc, env, Illegal_letrec_pat))) l; (l, new_env, unpacks) (* Typing of toplevel bindings *) let type_binding env rec_flag spat_sexp_list scope = - Typetexp.reset_type_variables(); - let (pat_exp_list, new_env, _unpacks) = + Typetexp.reset_type_variables (); + let pat_exp_list, new_env, _unpacks = type_let ~check:(fun s -> Warnings.Unused_value_declaration s) ~check_strict:(fun s -> Warnings.Unused_value_declaration s) @@ -3807,47 +4261,46 @@ let type_binding env rec_flag spat_sexp_list scope = (pat_exp_list, new_env) let type_let env rec_flag spat_sexp_list scope = - let (pat_exp_list, new_env, _unpacks) = - type_let env rec_flag spat_sexp_list scope false in + let pat_exp_list, new_env, _unpacks = + type_let env rec_flag spat_sexp_list scope false + in (pat_exp_list, new_env) (* Typing of toplevel expressions *) let type_expression env sexp = - Typetexp.reset_type_variables(); - begin_def(); + Typetexp.reset_type_variables (); + begin_def (); let exp = type_exp env sexp in - if Warnings.is_active (Bs_toplevel_expression_unit None) then - (try unify env exp.exp_type - (instance_def Predef.type_unit) with - | Unify _ -> - let buffer = Buffer.create 10 in - let formatter = Format.formatter_of_buffer buffer in - Printtyp.type_expr formatter exp.exp_type; - Format.pp_print_flush formatter (); - let return_type = Buffer.contents buffer in - Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit ( - match sexp.pexp_desc with - | Pexp_apply _ -> Some (return_type, FunctionCall) - | _ -> Some (return_type, Other) - )) - | Tags _ -> Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); - end_def(); + (if Warnings.is_active (Bs_toplevel_expression_unit None) then + try unify env exp.exp_type (instance_def Predef.type_unit) with + | Unify _ -> + let buffer = Buffer.create 10 in + let formatter = Format.formatter_of_buffer buffer in + Printtyp.type_expr formatter exp.exp_type; + Format.pp_print_flush formatter (); + let return_type = Buffer.contents buffer in + Location.prerr_warning sexp.pexp_loc + (Bs_toplevel_expression_unit + (match sexp.pexp_desc with + | Pexp_apply _ -> Some (return_type, FunctionCall) + | _ -> Some (return_type, Other))) + | Tags _ -> + Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); + end_def (); if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; generalize exp.exp_type; match sexp.pexp_desc with - Pexp_ident lid -> - (* Special case for keeping type variables when looking-up a variable *) - let (_path, desc) = Env.lookup_value lid.txt env in - {exp with exp_type = desc.val_type} + | Pexp_ident lid -> + (* Special case for keeping type variables when looking-up a variable *) + let _path, desc = Env.lookup_value lid.txt env in + {exp with exp_type = desc.val_type} | _ -> exp (* Error report *) let spellcheck ppf unbound_name valid_names = - Misc.did_you_mean ppf (fun () -> - Misc.spellcheck valid_names unbound_name - ) + Misc.did_you_mean ppf (fun () -> Misc.spellcheck valid_names unbound_name) let spellcheck_idents ppf unbound valid_idents = spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) @@ -3857,311 +4310,332 @@ let longident = Printtyp.longident let super_report_unification_error = Printtyp.super_report_unification_error let report_ambiguous_type_error = Printtyp.report_ambiguous_type_error let report_subtyping_error = Printtyp.report_subtyping_error -let type_expr ppf typ = (* print a type and avoid infinite loops *) +let type_expr ppf typ = + (* print a type and avoid infinite loops *) Printtyp.reset_and_mark_loops typ; Printtyp.type_expr ppf typ let report_error env ppf = function | Polymorphic_label lid -> - fprintf ppf "@[The record field %a is polymorphic.@ %s@]" - longident lid "You cannot instantiate it in a pattern." - | Constructor_arity_mismatch(lid, expected, provided) -> + fprintf ppf "@[The record field %a is polymorphic.@ %s@]" longident lid + "You cannot instantiate it in a pattern." + | Constructor_arity_mismatch (lid, expected, provided) -> (* modified *) fprintf ppf "@[This variant constructor, %a, expects %i %s; here, we've %sfound %i.@]" - longident lid expected (if expected == 1 then "argument" else "arguments") (if provided < expected then "only " else "") provided - | Label_mismatch(lid, trace) -> + longident lid expected + (if expected == 1 then "argument" else "arguments") + (if provided < expected then "only " else "") + provided + | Label_mismatch (lid, trace) -> (* modified *) super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The record field %a@ belongs to the type" - longident lid) - (function ppf -> - fprintf ppf "but is mixed here with fields of type") + (function + | ppf -> + fprintf ppf "The record field %a@ belongs to the type" longident lid) + (function + | ppf -> fprintf ppf "but is mixed here with fields of type") | Pattern_type_clash trace -> (* modified *) super_report_unification_error ppf env trace ~print_extra_info:Error_message_utils.print_contextual_unification_error - (function ppf -> - fprintf ppf "This pattern matches values of type") - (function ppf -> - fprintf ppf "but a pattern was expected which matches values of type") + (function + | ppf -> fprintf ppf "This pattern matches values of type") + (function + | ppf -> + fprintf ppf "but a pattern was expected which matches values of type") | Or_pattern_type_clash (id, trace) -> (* modified *) super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The variable %s on the left-hand side of this or-pattern has type" (Ident.name id)) - (function ppf -> - fprintf ppf "but on the right-hand side it has type") + (function + | ppf -> + fprintf ppf + "The variable %s on the left-hand side of this or-pattern has type" + (Ident.name id)) + (function + | ppf -> fprintf ppf "but on the right-hand side it has type") | Multiply_bound_variable name -> - fprintf ppf "Variable %s is bound several times in this matching" name + fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars (id, valid_idents) -> - fprintf ppf "Variable %s must occur on both sides of this | pattern" - (Ident.name id); - spellcheck_idents ppf id valid_idents - | Expr_type_clash (( - (_, {desc = Tarrow _}) :: - (_, {desc = Tconstr (Pident {name = "function$"},_,_)}) :: _ - ), _) -> - fprintf ppf "This function is a curried function where an uncurried function is expected" - | Expr_type_clash (( - (_, {desc = Tconstr (Pident {name = "function$"}, [{desc=Tvar _}; _],_)}) :: - (_, {desc = Tarrow _}) :: _ - ), _) -> - fprintf ppf "This function is an uncurried function where a curried function is expected" - | Expr_type_clash (( - (_, {desc = Tconstr (Pident {name = "function$"},[_; t_a],_)}) :: - (_, {desc = Tconstr (Pident {name = "function$"},[_; t_b],_)}) :: _ - ), _) when Ast_uncurried.type_to_arity t_a <> Ast_uncurried.type_to_arity t_b -> + fprintf ppf "Variable %s must occur on both sides of this | pattern" + (Ident.name id); + spellcheck_idents ppf id valid_idents + | Expr_type_clash + ( (_, {desc = Tarrow _}) + :: (_, {desc = Tconstr (Pident {name = "function$"}, _, _)}) + :: _, + _ ) -> + fprintf ppf + "This function is a curried function where an uncurried function is \ + expected" + | Expr_type_clash + ( ( _, + { + desc = Tconstr (Pident {name = "function$"}, [{desc = Tvar _}; _], _); + } ) + :: (_, {desc = Tarrow _}) + :: _, + _ ) -> + fprintf ppf + "This function is an uncurried function where a curried function is \ + expected" + | Expr_type_clash + ( (_, {desc = Tconstr (Pident {name = "function$"}, [_; t_a], _)}) + :: (_, {desc = Tconstr (Pident {name = "function$"}, [_; t_b], _)}) + :: _, + _ ) + when Ast_uncurried.type_to_arity t_a <> Ast_uncurried.type_to_arity t_b -> let arity_a = Ast_uncurried.type_to_arity t_a |> string_of_int in let arity_b = Ast_uncurried.type_to_arity t_b |> string_of_int in report_arity_mismatch ~arity_a ~arity_b ppf - | Expr_type_clash (( - (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),a,_),_,_)}) :: - (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),b,_),_,_)}) :: _ - ), _) when a <> b -> - fprintf ppf "This method has %s but was expected %s" a b - + | Expr_type_clash + ( ( _, + { + desc = + Tconstr + (Pdot (Pdot (Pident {name = "Js_OO"}, "Meth", _), a, _), _, _); + } ) + :: ( _, + { + desc = + Tconstr + (Pdot (Pdot (Pident {name = "Js_OO"}, "Meth", _), b, _), _, _); + } ) + :: _, + _ ) + when a <> b -> + fprintf ppf "This method has %s but was expected %s" a b | Expr_type_clash (trace, type_clash_context) -> (* modified *) fprintf ppf "@["; print_expr_type_clash ?type_clash_context env trace ppf; fprintf ppf "@]" - | Apply_non_function typ -> + | Apply_non_function typ -> ( (* modified *) - begin match (repr typ).desc with - Tarrow (_, _inputType, return_type, _) -> - let rec count_number_of_args count {Types.desc} = match desc with - | Tarrow (_, _inputType, return_type, _) -> count_number_of_args (count + 1) return_type - | _ -> count - in - let count_number_of_args = count_number_of_args 1 in - let accepts_count = count_number_of_args return_type in - fprintf ppf "@[@[<2>This function has type@ @{%a@}@]" - type_expr typ; - fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]" - accepts_count (if accepts_count == 1 then "argument" else "arguments") - | _ -> - fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" - type_expr typ - "It is not a function." - end - | Apply_wrong_label (l, ty) -> - let print_label ppf = function - | Nolabel -> fprintf ppf "without label" - | l -> - fprintf ppf "with label %s" (prefixed_label_name l) + match (repr typ).desc with + | Tarrow (_, _inputType, return_type, _) -> + let rec count_number_of_args count {Types.desc} = + match desc with + | Tarrow (_, _inputType, return_type, _) -> + count_number_of_args (count + 1) return_type + | _ -> count in - fprintf ppf - "@[@[<2>The function applied to this argument has type@ %a@]@.\ - This argument cannot be applied %a@]" - type_expr ty print_label l - | Label_multiply_defined {label; jsx_component_info = Some jsx_component_info} -> - fprintf ppf "The prop @{%s@} has already been passed to the component " label; - print_component_name ppf jsx_component_info.props_record_path; - fprintf ppf "@,@,You can't pass the same prop more than once."; + let count_number_of_args = count_number_of_args 1 in + let accepts_count = count_number_of_args return_type in + fprintf ppf "@[@[<2>This function has type@ @{%a@}@]" type_expr + typ; + fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]" + accepts_count + (if accepts_count == 1 then "argument" else "arguments") + | _ -> + fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" type_expr typ + "It is not a function.") + | Apply_wrong_label (l, ty) -> + let print_label ppf = function + | Nolabel -> fprintf ppf "without label" + | l -> fprintf ppf "with label %s" (prefixed_label_name l) + in + fprintf ppf + "@[@[<2>The function applied to this argument has type@ %a@]@.This \ + argument cannot be applied %a@]" + type_expr ty print_label l + | Label_multiply_defined {label; jsx_component_info = Some jsx_component_info} + -> + fprintf ppf + "The prop @{%s@} has already been passed to the component " label; + print_component_name ppf jsx_component_info.props_record_path; + fprintf ppf "@,@,You can't pass the same prop more than once." | Label_multiply_defined {label} -> fprintf ppf "The record field label %s is defined several times" label | Labels_missing {labels; jsx_component_info = Some jsx_component_info} -> print_component_labels_missing_error ppf labels jsx_component_info | Labels_missing {labels} -> - let print_labels ppf = - List.iter (fun lbl -> fprintf ppf "@ %s" ( lbl)) in - fprintf ppf "@[Some required record fields are missing:%a.@]" - print_labels labels + let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in + fprintf ppf "@[Some required record fields are missing:%a.@]" + print_labels labels | Label_not_mutable lid -> - fprintf ppf "The record field %a is not mutable" longident lid - | Wrong_name (eorp, ty, kind, p, name, valid_names) -> - (match get_jsx_component_props ~extract_concrete_typedecl env ty p with - | Some {fields} -> print_component_wrong_prop_error ppf p fields name; spellcheck ppf name valid_names; + fprintf ppf "The record field %a is not mutable" longident lid + | Wrong_name (eorp, ty, kind, p, name, valid_names) -> ( + match get_jsx_component_props ~extract_concrete_typedecl env ty p with + | Some {fields} -> + print_component_wrong_prop_error ppf p fields name; + spellcheck ppf name valid_names | None -> - (* modified *) - if Path.is_constructor_typath p then begin - fprintf ppf "@[The field %s is not part of the record \ - argument for the %a constructor@]" - name - Printtyp.path p; - end else begin - fprintf ppf "@["; - - fprintf ppf "@[<2>The %s @{%s@} does not belong to type @{%a@}@]@,@," - (label_of_kind kind) - name (*kind*) Printtyp.path p; - - fprintf ppf "@[<2>%s type@ @{%a@}@]" - eorp type_expr ty; - - fprintf ppf "@]"; - end; - spellcheck ppf name valid_names; - ) + (* modified *) + if Path.is_constructor_typath p then + fprintf ppf + "@[The field %s is not part of the record argument for the %a \ + constructor@]" + name Printtyp.path p + else ( + fprintf ppf "@["; + + fprintf ppf + "@[<2>The %s @{%s@} does not belong to type @{%a@}@]@,@," + (label_of_kind kind) name (*kind*) Printtyp.path p; + + fprintf ppf "@[<2>%s type@ @{%a@}@]" eorp type_expr ty; + + fprintf ppf "@]"); + spellcheck ppf name valid_names) | Name_type_mismatch (kind, lid, tp, tpl) -> - let name = label_of_kind kind in - report_ambiguous_type_error ppf env tp tpl - (function ppf -> - fprintf ppf "The %s %a@ belongs to the %s type" - name longident lid kind) - (function ppf -> - fprintf ppf "The %s %a@ belongs to one of the following %s types:" - name longident lid kind) - (function ppf -> - fprintf ppf "but a %s was expected belonging to the %s type" - name kind) - | Undefined_method (ty, me, valid_methods) -> - fprintf ppf - "@[@[This expression has type@;<1 2>%a@]@,\ - It has no field %s@]" type_expr ty me; - begin match valid_methods with - | None -> () - | Some valid_methods -> spellcheck ppf me valid_methods - end - | Not_subtype(tr1, tr2) -> - report_subtyping_error ppf env tr1 "is not a subtype of" tr2 - | Too_many_arguments (in_function, ty) -> - (* modified *) - if in_function then begin + let name = label_of_kind kind in + report_ambiguous_type_error ppf env tp tpl + (function + | ppf -> + fprintf ppf "The %s %a@ belongs to the %s type" name longident lid + kind) + (function + | ppf -> + fprintf ppf "The %s %a@ belongs to one of the following %s types:" + name longident lid kind) + (function + | ppf -> + fprintf ppf "but a %s was expected belonging to the %s type" name kind) + | Undefined_method (ty, me, valid_methods) -> ( + fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,It has no field %s@]" + type_expr ty me; + match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods) + | Not_subtype (tr1, tr2) -> + report_subtyping_error ppf env tr1 "is not a subtype of" tr2 + | Too_many_arguments (in_function, ty) -> ( + if (* modified *) + in_function then ( fprintf ppf "@[This function expects too many arguments,@ "; - fprintf ppf "it should have type@ %a@]" - type_expr ty - end else begin + fprintf ppf "it should have type@ %a@]" type_expr ty) + else match ty with - | {desc = Tconstr (Pident {name = "function$"},_,_)} -> + | {desc = Tconstr (Pident {name = "function$"}, _, _)} -> fprintf ppf "This expression is expected to have an uncurried function" | _ -> fprintf ppf "@[This expression should not be a function,@ "; - fprintf ppf "the expected type is@ %a@]" - type_expr ty - end + fprintf ppf "the expected type is@ %a@]" type_expr ty) | Abstract_wrong_label (l, ty) -> - let label_mark = function - | Nolabel -> "but its first argument is not labelled" - | l -> sprintf "but its first argument is labelled %s" - (prefixed_label_name l) in - fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" - type_expr ty (label_mark l) - | Scoping_let_module(id, ty) -> - fprintf ppf - "This `let module' expression has type@ %a@ " type_expr ty; - fprintf ppf - "In this type, the locally bound module name %s escapes its scope" id + let label_mark = function + | Nolabel -> "but its first argument is not labelled" + | l -> + sprintf "but its first argument is labelled %s" (prefixed_label_name l) + in + fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" type_expr + ty (label_mark l) + | Scoping_let_module (id, ty) -> + fprintf ppf "This `let module' expression has type@ %a@ " type_expr ty; + fprintf ppf + "In this type, the locally bound module name %s escapes its scope" id | Private_type ty -> - fprintf ppf "Cannot create values of the private type %a" type_expr ty + fprintf ppf "Cannot create values of the private type %a" type_expr ty | Private_label (lid, ty) -> - fprintf ppf "Cannot assign field %a of the private type %a" - longident lid type_expr ty + fprintf ppf "Cannot assign field %a of the private type %a" longident lid + type_expr ty | Not_a_variant_type lid -> - fprintf ppf "The type %a@ is not a variant type" longident lid + fprintf ppf "The type %a@ is not a variant type" longident lid | Incoherent_label_order -> - fprintf ppf "This labeled function is applied to arguments@ "; - fprintf ppf "in an order different from other calls.@ "; - fprintf ppf "This is only allowed when the real type is known." + fprintf ppf "This labeled function is applied to arguments@ "; + fprintf ppf "in an order different from other calls.@ "; + fprintf ppf "This is only allowed when the real type is known." | Less_general (kind, trace) -> (* modified *) super_report_unification_error ppf env trace (fun ppf -> fprintf ppf "This %s has type" kind) (fun ppf -> fprintf ppf "which is less general than") | Modules_not_allowed -> - fprintf ppf "Modules are not allowed in this pattern." + fprintf ppf "Modules are not allowed in this pattern." | Cannot_infer_signature -> - fprintf ppf - "The signature for this packaged module couldn't be inferred." + fprintf ppf "The signature for this packaged module couldn't be inferred." | Not_a_packed_module ty -> - fprintf ppf - "This expression is packed module, but the expected type is@ %a" - type_expr ty + fprintf ppf "This expression is packed module, but the expected type is@ %a" + type_expr ty | Recursive_local_constraint trace -> (* modified *) super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "Recursive local constraint when unifying") - (function ppf -> - fprintf ppf "with") - | Unexpected_existential -> - fprintf ppf - "Unexpected existential" + (function + | ppf -> fprintf ppf "Recursive local constraint when unifying") + (function + | ppf -> fprintf ppf "with") + | Unexpected_existential -> fprintf ppf "Unexpected existential" | Unqualified_gadt_pattern (tpath, name) -> - fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]" - name Printtyp.path tpath - "must be qualified in this pattern" + fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]" name Printtyp.path + tpath "must be qualified in this pattern" | Invalid_interval -> - fprintf ppf "@[Only character intervals are supported in patterns.@]" + fprintf ppf "@[Only character intervals are supported in patterns.@]" | Invalid_for_loop_index -> - fprintf ppf - "@[Invalid for-loop index: only variables and _ are allowed.@]" + fprintf ppf "@[Invalid for-loop index: only variables and _ are allowed.@]" | No_value_clauses -> - fprintf ppf - "None of the patterns in this 'match' expression match values." + fprintf ppf "None of the patterns in this 'match' expression match values." | Exception_pattern_below_toplevel -> - fprintf ppf - "@[Exception patterns must be at the top level of a match case.@]" + fprintf ppf + "@[Exception patterns must be at the top level of a match case.@]" | Inlined_record_escape -> - fprintf ppf - "@[This form is not allowed as the type of the inlined record could \ - escape.@]" + fprintf ppf + "@[This form is not allowed as the type of the inlined record could \ + escape.@]" | Inlined_record_expected -> - fprintf ppf - "@[This constructor expects an inlined record argument.@]" + fprintf ppf "@[This constructor expects an inlined record argument.@]" | Unrefuted_pattern pat -> - fprintf ppf - "@[%s@ %s@ %a@]" - "This match case could not be refuted." - "Here is an example of a value that would reach it:" - Parmatch.top_pretty pat + fprintf ppf "@[%s@ %s@ %a@]" "This match case could not be refuted." + "Here is an example of a value that would reach it:" Parmatch.top_pretty + pat | Invalid_extension_constructor_payload -> - fprintf ppf - "Invalid [%%extension_constructor] payload, a constructor is expected." + fprintf ppf + "Invalid [%%extension_constructor] payload, a constructor is expected." | Not_an_extension_constructor -> - fprintf ppf - "This constructor is not an extension constructor." + fprintf ppf "This constructor is not an extension constructor." | Literal_overflow ty -> - fprintf ppf "Integer literal exceeds the range of representable \ - integers of type %s" ty + fprintf ppf + "Integer literal exceeds the range of representable integers of type %s" + ty | Unknown_literal (n, m) -> - fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m + fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m | Illegal_letrec_pat -> - fprintf ppf - "Only variables are allowed as left-hand side of `let rec'" + fprintf ppf "Only variables are allowed as left-hand side of `let rec'" | Labels_omitted [label] -> - fprintf ppf "Label ~%s was omitted in the application of this labeled function." - label + fprintf ppf + "Label ~%s was omitted in the application of this labeled function." label | Labels_omitted labels -> - let labels_string = labels |> List.map(fun label -> "~" ^ label) |> String.concat ", " in - fprintf ppf "Labels %s were omitted in the application of this labeled function." - labels_string + let labels_string = + labels |> List.map (fun label -> "~" ^ label) |> String.concat ", " + in + fprintf ppf + "Labels %s were omitted in the application of this labeled function." + labels_string | Empty_record_literal -> - fprintf ppf "Empty record literal {} should be type annotated or used in a record context." + fprintf ppf + "Empty record literal {} should be type annotated or used in a record \ + context." | Uncurried_arity_mismatch (typ, arity, args) -> - fprintf ppf "@[@[<2>This function has type@ %a@]" - type_expr typ; - fprintf ppf "@ @[It is applied with @{%d@} argument%s but it requires @{%d@}.@]@]" - args (if args = 0 then "" else "s") arity - | Field_not_optional (name, typ) -> + fprintf ppf "@[@[<2>This function has type@ %a@]" type_expr typ; fprintf ppf - "Field @{%s@} is not optional in type %a. Use without ?" name - type_expr typ + "@ @[It is applied with @{%d@} argument%s but it requires \ + @{%d@}.@]@]" + args + (if args = 0 then "" else "s") + arity + | Field_not_optional (name, typ) -> + fprintf ppf "Field @{%s@} is not optional in type %a. Use without ?" + name type_expr typ | Type_params_not_supported lid -> - fprintf ppf "The type %a@ has type parameters, but type parameters is not supported here." longident lid + fprintf ppf + "The type %a@ has type parameters, but type parameters is not supported \ + here." + longident lid | Field_access_on_dict_type -> - fprintf ppf "Direct field access on a dict is not supported. Use Dict.get instead." - + fprintf ppf + "Direct field access on a dict is not supported. Use Dict.get instead." let super_report_error_no_wrap_printing_env = report_error - let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) - + Location.register_error_of_exn (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> Some err + | _ -> None) (* drop ?recarg argument from the external API *) let type_expect ?in_function env e ty = type_expect ?in_function env e ty diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 47d17a4336..35749847b0 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -19,58 +19,73 @@ open Asttypes open Types open Format -val is_nonexpansive: Typedtree.expression -> bool - -val type_binding: - Env.t -> rec_flag -> - Parsetree.value_binding list -> - Annot.ident option -> - Typedtree.value_binding list * Env.t -val type_let: - Env.t -> rec_flag -> - Parsetree.value_binding list -> - Annot.ident option -> - Typedtree.value_binding list * Env.t -val type_expression: - Env.t -> Parsetree.expression -> Typedtree.expression -val check_partial: - ?lev:int -> Env.t -> type_expr -> - Location.t -> Typedtree.case list -> Typedtree.partial -val type_expect: - ?in_function:(Location.t * type_expr) -> - Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression -val type_exp: - Env.t -> Parsetree.expression -> Typedtree.expression -val type_approx: - Env.t -> Parsetree.expression -> type_expr -val type_argument: - Env.t -> Parsetree.expression -> - type_expr -> type_expr -> Typedtree.expression - -val option_some: Typedtree.expression -> Typedtree.expression -val option_none: type_expr -> Location.t -> Typedtree.expression -val extract_option_type: Env.t -> type_expr -> type_expr -val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit -val generalizable: int -> type_expr -> bool - - +val is_nonexpansive : Typedtree.expression -> bool + +val type_binding : + Env.t -> + rec_flag -> + Parsetree.value_binding list -> + Annot.ident option -> + Typedtree.value_binding list * Env.t +val type_let : + Env.t -> + rec_flag -> + Parsetree.value_binding list -> + Annot.ident option -> + Typedtree.value_binding list * Env.t +val type_expression : Env.t -> Parsetree.expression -> Typedtree.expression +val check_partial : + ?lev:int -> + Env.t -> + type_expr -> + Location.t -> + Typedtree.case list -> + Typedtree.partial +val type_expect : + ?in_function:Location.t * type_expr -> + Env.t -> + Parsetree.expression -> + type_expr -> + Typedtree.expression +val type_exp : Env.t -> Parsetree.expression -> Typedtree.expression +val type_approx : Env.t -> Parsetree.expression -> type_expr +val type_argument : + Env.t -> + Parsetree.expression -> + type_expr -> + type_expr -> + Typedtree.expression + +val option_some : Typedtree.expression -> Typedtree.expression +val option_none : type_expr -> Location.t -> Typedtree.expression +val extract_option_type : Env.t -> type_expr -> type_expr +val iter_pattern : (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit +val generalizable : int -> type_expr -> bool val id_of_pattern : Typedtree.pattern -> Ident.t option val name_pattern : string -> Typedtree.case list -> Ident.t type error = - Polymorphic_label of Longident.t + | Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * (Error_message_utils.type_clash_context option) + | Expr_type_clash of + (type_expr * type_expr) list + * Error_message_utils.type_clash_context option | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr - | Label_multiply_defined of {label: string; jsx_component_info: Error_message_utils.jsx_prop_error_info option} - | Labels_missing of {labels: string list; jsx_component_info: Error_message_utils.jsx_prop_error_info option} + | Label_multiply_defined of { + label: string; + jsx_component_info: Error_message_utils.jsx_prop_error_info option; + } + | Labels_missing of { + labels: string list; + jsx_component_info: Error_message_utils.jsx_prop_error_info option; + } | Label_not_mutable of Longident.t | Wrong_name of string * type_expr * string * Path.t * string * string list | Name_type_mismatch of @@ -112,29 +127,38 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error +val super_report_error_no_wrap_printing_env : + Env.t -> formatter -> error -> unit -val super_report_error_no_wrap_printing_env: Env.t -> formatter -> error -> unit - - -val report_error: Env.t -> formatter -> error -> unit - (* Deprecated. Use Location.{error_of_exn, report_error}. *) +val report_error : Env.t -> formatter -> error -> unit +(* Deprecated. Use Location.{error_of_exn, report_error}. *) (* Forward declaration, to be filled in by Typemod.type_module *) -val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref +val type_module : (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref + (* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: - (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) - ref -(* Forward declaration, to be filled in by Typemod.type_package *) -val type_package: - (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> - Typedtree.module_expr * type_expr list) ref +val type_open : + (?used_slot:bool ref -> + override_flag -> + Env.t -> + Location.t -> + Longident.t loc -> + Path.t * Env.t) + ref -val create_package_type : Location.t -> Env.t -> +(* Forward declaration, to be filled in by Typemod.type_package *) +val type_package : + (Env.t -> + Parsetree.module_expr -> + Path.t -> + Longident.t list -> + Typedtree.module_expr * type_expr list) + ref + +val create_package_type : + Location.t -> + Env.t -> Longident.t * (Longident.t * Parsetree.core_type) list -> Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr -val constant: Parsetree.constant -> (Asttypes.constant, error) result - - +val constant : Parsetree.constant -> (Asttypes.constant, error) result diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index bddd81d685..95ff18b3a4 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -25,7 +25,7 @@ open Typetexp type native_repr_kind = Unboxed | Untagged type error = - Repeated_parameter + | Repeated_parameter | Duplicate_constructor of string | Duplicate_label of string * string option | Recursive_abbrev of string @@ -66,8 +66,8 @@ exception Error of Location.t * error let get_unboxed_from_attributes sdecl = let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in - match boxed, unboxed, !Clflags.unboxed_types with - | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed)) + match (boxed, unboxed, !Clflags.unboxed_types) with + | true, true, _ -> raise (Error (sdecl.ptype_loc, Boxed_and_unboxed)) | true, false, _ -> unboxed_false_default_false | false, true, _ -> unboxed_true_default_false | false, false, false -> unboxed_false_default_true @@ -79,112 +79,113 @@ let enter_type rec_flag env sdecl id = let needed = match rec_flag with | Asttypes.Nonrecursive -> - begin match sdecl.ptype_kind with - | Ptype_variant scds -> - List.iter (fun cd -> - if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt))) - scds - | _ -> () - end; - Btype.is_row_name (Ident.name id) + (match sdecl.ptype_kind with + | Ptype_variant scds -> + List.iter + (fun cd -> + if cd.pcd_res <> None then raise (Error (cd.pcd_loc, Nonrec_gadt))) + scds + | _ -> ()); + Btype.is_row_name (Ident.name id) | Asttypes.Recursive -> true in - if not needed then env else - let decl = - { type_params = - List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; - type_arity = List.length sdecl.ptype_params; - type_kind = Type_abstract; - type_private = sdecl.ptype_private; - type_manifest = - begin match sdecl.ptype_manifest with None -> None - | Some _ -> Some(Ctype.newvar ()) end; - type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params; - type_newtype_level = None; - type_loc = sdecl.ptype_loc; - type_attributes = sdecl.ptype_attributes; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - in - Env.add_type ~check:true id decl env + if not needed then env + else + let decl = + { + type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = List.length sdecl.ptype_params; + type_kind = Type_abstract; + type_private = sdecl.ptype_private; + type_manifest = + (match sdecl.ptype_manifest with + | None -> None + | Some _ -> Some (Ctype.newvar ())); + type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params; + type_newtype_level = None; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + } + in + Env.add_type ~check:true id decl env let update_type temp_env env id loc = let path = Path.Pident id in let decl = Env.find_type path temp_env in - match decl.type_manifest with None -> () - | Some ty -> - let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in - try Ctype.unify env (Ctype.newconstr path params) ty - with Ctype.Unify trace -> - raise (Error(loc, Type_clash (env, trace))) + match decl.type_manifest with + | None -> () + | Some ty -> ( + let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in + try Ctype.unify env (Ctype.newconstr path params) ty + with Ctype.Unify trace -> raise (Error (loc, Type_clash (env, trace)))) (* We use the Ctype.expand_head_opt version of expand_head to get access to the manifest type of private abbreviations. *) let rec get_unboxed_type_representation env ty fuel = - if fuel < 0 then None else - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in - match ty.desc with - | Tconstr (p, args, _) -> - begin match Env.find_type p env with - | exception Not_found -> Some ty - | {type_unboxed = {unboxed = false}} -> Some ty - | {type_params; type_kind = - Type_record ([{ld_type = ty2; _}], _) - | Type_variant [{cd_args = Cstr_tuple [ty2]; _}] - | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]} - - -> get_unboxed_type_representation env - (Ctype.apply env type_params ty2 args) (fuel - 1) - | {type_kind=Type_abstract} -> None - (* This case can occur when checking a recursive unboxed type - declaration. *) - | _ -> assert false (* only the above can be unboxed *) - end - | _ -> Some ty + if fuel < 0 then None + else + let ty = Ctype.repr (Ctype.expand_head_opt env ty) in + match ty.desc with + | Tconstr (p, args, _) -> ( + match Env.find_type p env with + | exception Not_found -> Some ty + | {type_unboxed = {unboxed = false}} -> Some ty + | { + type_params; + type_kind = + ( Type_record ([{ld_type = ty2; _}], _) + | Type_variant [{cd_args = Cstr_tuple [ty2]; _}] + | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}] ); + } -> + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) + (fuel - 1) + | {type_kind = Type_abstract} -> + None + (* This case can occur when checking a recursive unboxed type + declaration. *) + | _ -> assert false (* only the above can be unboxed *)) + | _ -> Some ty let get_unboxed_type_representation env ty = (* Do not give too much fuel: PR#7424 *) get_unboxed_type_representation env ty 100 -;; - (* Determine if a type definition defines a fixed type. (PW) *) let is_fixed_type sd = let rec has_row_var sty = match sty.ptyp_desc with - Ptyp_alias (sty, _) -> has_row_var sty + | Ptyp_alias (sty, _) -> has_row_var sty | Ptyp_class _ | Ptyp_object (_, Open) | Ptyp_variant (_, Open, _) - | Ptyp_variant (_, Closed, Some _) -> true + | Ptyp_variant (_, Closed, Some _) -> + true | _ -> false in match sd.ptype_manifest with - None -> false + | None -> false | Some sty -> - sd.ptype_kind = Ptype_abstract && - sd.ptype_private = Private && - has_row_var sty + sd.ptype_kind = Ptype_abstract + && sd.ptype_private = Private && has_row_var sty (* Set the row variable in a fixed type *) let set_fixed_row env loc p decl = let tm = match decl.type_manifest with - None -> assert false + | None -> assert false | Some t -> Ctype.expand_head env t in let rv = match tm.desc with - Tvariant row -> - let row = Btype.row_repr row in - tm.desc <- Tvariant {row with row_fixed = true}; - if Btype.static_row row then Btype.newgenty Tnil - else row.row_more - | Tobject (ty, _) -> - snd (Ctype.flatten_fields ty) - | _ -> - raise (Error (loc, Bad_fixed_type "is not an object or variant")) + | Tvariant row -> + let row = Btype.row_repr row in + tm.desc <- Tvariant {row with row_fixed = true}; + if Btype.static_row row then Btype.newgenty Tnil else row.row_more + | Tobject (ty, _) -> snd (Ctype.flatten_fields ty) + | _ -> raise (Error (loc, Bad_fixed_type "is not an object or variant")) in if not (Btype.is_Tvar rv) then raise (Error (loc, Bad_fixed_type "has no row variable")); @@ -192,89 +193,97 @@ let set_fixed_row env loc p decl = (* Translate one type declaration *) -module StringSet = - Set.Make(struct - type t = string - let compare (x:t) y = compare x y - end) +module StringSet = Set.Make (struct + type t = string + let compare (x : t) y = compare x y +end) let make_params env params = let make_param (sty, v) = - try - (transl_type_param env sty, v) - with Already_bound -> - raise(Error(sty.ptyp_loc, Repeated_parameter)) + try (transl_type_param env sty, v) + with Already_bound -> raise (Error (sty.ptyp_loc, Repeated_parameter)) in - List.map make_param params + List.map make_param params let transl_labels ?record_name env closed lbls = - (match !Builtin_attributes.check_duplicated_labels lbls with - | None -> () - | Some {loc;txt=name} -> raise (Error(loc,Duplicate_label (name, record_name)))); - let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc; - pld_attributes=attrs} = - Builtin_attributes.warning_scope attrs - (fun () -> - let arg = Ast_helper.Typ.force_poly arg in - let cty = transl_simple_type env closed arg in - {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; - ld_type = cty; ld_loc = loc; ld_attributes = attrs} - ) + (match !Builtin_attributes.check_duplicated_labels lbls with + | None -> () + | Some {loc; txt = name} -> + raise (Error (loc, Duplicate_label (name, record_name)))); + let mk + { + pld_name = name; + pld_mutable = mut; + pld_type = arg; + pld_loc = loc; + pld_attributes = attrs; + } = + Builtin_attributes.warning_scope attrs (fun () -> + let arg = Ast_helper.Typ.force_poly arg in + let cty = transl_simple_type env closed arg in + { + ld_id = Ident.create name.txt; + ld_name = name; + ld_mutable = mut; + ld_type = cty; + ld_loc = loc; + ld_attributes = attrs; + }) in let lbls = List.map mk lbls in let lbls' = List.map (fun ld -> - let ty = ld.ld_type.ctyp_type in - let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in - {Types.ld_id = ld.ld_id; + let ty = ld.ld_type.ctyp_type in + let ty = + match ty.desc with + | Tpoly (t, []) -> t + | _ -> ty + in + { + Types.ld_id = ld.ld_id; ld_mutable = ld.ld_mutable; ld_type = ty; ld_loc = ld.ld_loc; - ld_attributes = ld.ld_attributes - } - ) - lbls in - lbls, lbls' + ld_attributes = ld.ld_attributes; + }) + lbls + in + (lbls, lbls') let transl_constructor_arguments env closed = function | Pcstr_tuple l -> - let l = List.map (transl_simple_type env closed) l in - Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), - Cstr_tuple l + let l = List.map (transl_simple_type env closed) l in + (Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), Cstr_tuple l) | Pcstr_record l -> - let lbls, lbls' = transl_labels env closed l in - Types.Cstr_record lbls', - Cstr_record lbls + let lbls, lbls' = transl_labels env closed l in + (Types.Cstr_record lbls', Cstr_record lbls) let make_constructor env type_path type_params sargs sret_type = match sret_type with | None -> - let args, targs = - transl_constructor_arguments env true sargs - in - targs, None, args, None, type_params + let args, targs = transl_constructor_arguments env true sargs in + (targs, None, args, None, type_params) | Some sret_type -> - (* if it's a generalized constructor we must first narrow and - then widen so as to not introduce any new constraints *) - let z = narrow () in - reset_type_variables (); - let args, targs = - transl_constructor_arguments env false sargs - in - let tret_type = transl_simple_type env false sret_type in - let ret_type = tret_type.ctyp_type in - let params = - match (Ctype.repr ret_type).desc with - | Tconstr (p', params, _) when Path.same type_path p' -> - params - | _ -> - raise (Error (sret_type.ptyp_loc, Constraint_failed - (ret_type, Ctype.newconstr type_path type_params))) - in - widen z; - targs, Some tret_type, args, Some ret_type, params - + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + let z = narrow () in + reset_type_variables (); + let args, targs = transl_constructor_arguments env false sargs in + let tret_type = transl_simple_type env false sret_type in + let ret_type = tret_type.ctyp_type in + let params = + match (Ctype.repr ret_type).desc with + | Tconstr (p', params, _) when Path.same type_path p' -> params + | _ -> + raise + (Error + ( sret_type.ptyp_loc, + Constraint_failed + (ret_type, Ctype.newconstr type_path type_params) )) + in + widen z; + (targs, Some tret_type, args, Some ret_type, params) (* Check that all the variables found in [ty] are in [univ]. Because [ty] is the argument to an abstract type, the representation @@ -282,356 +291,449 @@ let make_constructor env type_path type_params sargs sret_type = any type variable present in [ty]. *) - let transl_declaration ~type_record_as_object env sdecl id = (* Bind type parameters *) - reset_type_variables(); + reset_type_variables (); Ctype.begin_def (); let tparams = make_params env sdecl.ptype_params in let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in - let cstrs = List.map - (fun (sty, sty', loc) -> - transl_simple_type env false sty, - transl_simple_type env false sty', loc) - sdecl.ptype_cstrs + let cstrs = + List.map + (fun (sty, sty', loc) -> + ( transl_simple_type env false sty, + transl_simple_type env false sty', + loc )) + sdecl.ptype_cstrs in let raw_status = get_unboxed_from_attributes sdecl in - let check_untagged_variant() = match sdecl.ptype_kind with - | Ptype_variant cds -> Ext_list.for_all cds (function - | {pcd_args = Pcstr_tuple ([] | [_])} -> - (* at most one payload allowed for untagged variants *) - true - | {pcd_args = Pcstr_tuple (_::_::_); pcd_name={txt=name}} -> - Ast_untagged_variants.report_constructor_more_than_one_arg ~loc:sdecl.ptype_loc ~name - | {pcd_args = Pcstr_record _} -> true - ) - | _ -> false + let check_untagged_variant () = + match sdecl.ptype_kind with + | Ptype_variant cds -> + Ext_list.for_all cds (function + | {pcd_args = Pcstr_tuple ([] | [_])} -> + (* at most one payload allowed for untagged variants *) + true + | {pcd_args = Pcstr_tuple (_ :: _ :: _); pcd_name = {txt = name}} -> + Ast_untagged_variants.report_constructor_more_than_one_arg + ~loc:sdecl.ptype_loc ~name + | {pcd_args = Pcstr_record _} -> true) + | _ -> false in - if raw_status.unboxed && not raw_status.default && not (check_untagged_variant()) then begin - match sdecl.ptype_kind with - | Ptype_abstract -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it is abstract")) - | Ptype_variant _ -> () - | Ptype_record [{pld_mutable=Immutable; _}] -> () - | Ptype_record [{pld_mutable=Mutable; _}] -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it is mutable")) - | Ptype_record _ -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it has more than one field")) - | Ptype_open -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "extensible variant types cannot be unboxed")) - end; + (if + raw_status.unboxed && (not raw_status.default) + && not (check_untagged_variant ()) + then + match sdecl.ptype_kind with + | Ptype_abstract -> + raise (Error (sdecl.ptype_loc, Bad_unboxed_attribute "it is abstract")) + | Ptype_variant _ -> () + | Ptype_record [{pld_mutable = Immutable; _}] -> () + | Ptype_record [{pld_mutable = Mutable; _}] -> + raise (Error (sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable")) + | Ptype_record _ -> + raise + (Error + (sdecl.ptype_loc, Bad_unboxed_attribute "it has more than one field")) + | Ptype_open -> + raise + (Error + ( sdecl.ptype_loc, + Bad_unboxed_attribute "extensible variant types cannot be unboxed" + ))); let unboxed_status = match sdecl.ptype_kind with | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> unboxed_false_default_false | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] - | Ptype_variant [{pcd_args = Pcstr_record - [{pld_mutable = Immutable; _}]; _}] - | Ptype_record [{pld_mutable = Immutable; _}] -> - raw_status - | _ -> (* The type is not unboxable, mark it as boxed *) + | Ptype_variant + [{pcd_args = Pcstr_record [{pld_mutable = Immutable; _}]; _}] + | Ptype_record [{pld_mutable = Immutable; _}] -> + raw_status + | _ -> + (* The type is not unboxable, mark it as boxed *) unboxed_false_default_false in let unbox = unboxed_status.unboxed in - let (tkind, kind, sdecl) = + let tkind, kind, sdecl = match sdecl.ptype_kind with - | Ptype_abstract -> Ttype_abstract, Type_abstract, sdecl - | Ptype_variant scstrs -> - assert (scstrs <> []); - if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin - match cstrs with - [] -> () - | (_,_,loc)::_ -> - Location.prerr_warning loc Warnings.Constraint_on_gadt - end; - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in - let scstrs = - Ext_list.map scstrs (fun ({pcd_args} as cstr) -> + | Ptype_abstract -> (Ttype_abstract, Type_abstract, sdecl) + | Ptype_variant scstrs -> + assert (scstrs <> []); + (if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then + match cstrs with + | [] -> () + | (_, _, loc) :: _ -> + Location.prerr_warning loc Warnings.Constraint_on_gadt); + let has_optional attrs = + Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.optional") + in + let scstrs = + Ext_list.map scstrs (fun ({pcd_args} as cstr) -> match pcd_args with | Pcstr_tuple _ -> cstr | Pcstr_record lds -> - {cstr with pcd_args = Pcstr_record (Ext_list.map lds (fun ld -> - if has_optional ld.pld_attributes then - let typ = ld.pld_type in - let typ = {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])} in - {ld with pld_type = typ} - else ld - ))} - ) in - let all_constrs = ref StringSet.empty in - List.iter - (fun {pcd_name = {txt = name}} -> - if StringSet.mem name !all_constrs then - raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); - all_constrs := StringSet.add name !all_constrs) - scstrs; - let copy_tag_attr_from_decl attr = - let tag_attrs = Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> txt = "tag" || txt = Ast_untagged_variants.untagged) in - if tag_attrs = [] then attr else tag_attrs @ attr in - let constructors_from_variant_spreads = Hashtbl.create 10 in - let make_cstr scstr = - let name = Ident.create scstr.pcd_name.txt in - let targs, tret_type, args, ret_type, _cstr_params = - make_constructor env (Path.Pident id) params - scstr.pcd_args scstr.pcd_res - in - if String.starts_with scstr.pcd_name.txt ~prefix:"..." then ( - (* Any constructor starting with "..." represents a variant type spread, and - will have the spread variant itself as a single argument. - - We pull that variant type out, and then track the type of each of its - constructors, so that we can replace our dummy constructors added before - type checking with the realtypes for each constructor. - *) - (match args with - | Cstr_tuple [spread_variant] -> ( - match Ctype.extract_concrete_typedecl env spread_variant with - | (_, _, {type_kind=Type_variant constructors}) -> ( - constructors |> List.iter(fun (c: Types.constructor_declaration) -> - Hashtbl.add constructors_from_variant_spreads c.cd_id.name c) - ) - | _ -> () - ) - | _ -> ()); - None) - else ( - (* Check if this constructor is from a variant spread. If so, we need to replace - its type with the right type we've pulled from the type checked spread variant - itself. *) - let tcstr, cstr = match Hashtbl.find_opt constructors_from_variant_spreads (Ident.name name) with - | Some cstr -> - let tcstr = { - cd_id = name; - cd_name = scstr.pcd_name; - cd_args = - (match cstr.cd_args with - | Cstr_tuple args -> - Cstr_tuple - (args - |> List.map (fun texpr : Typedtree.core_type -> - { - ctyp_attributes = cstr.cd_attributes; - ctyp_loc = cstr.cd_loc; - ctyp_env = env; - ctyp_type = texpr; - ctyp_desc = Ttyp_any; - (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *) - })) - | Cstr_record lbls -> - Cstr_record - (lbls - |> List.map - (fun (l : Types.label_declaration) : Typedtree.label_declaration - -> + cstr with + pcd_args = + Pcstr_record + (Ext_list.map lds (fun ld -> + if has_optional ld.pld_attributes then + let typ = ld.pld_type in + let typ = { - ld_id = l.ld_id; - ld_name = Location.mkloc (Ident.name l.ld_id) l.ld_loc; - ld_mutable = l.ld_mutable; - ld_type = - { - ctyp_desc = Ttyp_any; - ctyp_type = l.ld_type; - ctyp_env = env; - ctyp_loc = l.ld_loc; - ctyp_attributes = []; - }; - ld_loc = l.ld_loc; - ld_attributes = l.ld_attributes; - }))); - cd_res = tret_type; - (* This is also strictly wrong, but is fine because the type checker does not look at this field. *) - cd_loc = scstr.pcd_loc; - cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl; - } - in - tcstr, cstr - | None -> - let tcstr = - { cd_id = name; - cd_name = scstr.pcd_name; - cd_args = targs; - cd_res = tret_type; - cd_loc = scstr.pcd_loc; - cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl } - in - let cstr = - { Types.cd_id = name; - cd_args = args; - cd_res = ret_type; - cd_loc = scstr.pcd_loc; - cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl } - in - tcstr, cstr - in Some (tcstr, cstr) - ) + typ with + ptyp_desc = + Ptyp_constr + ( {txt = Lident "option"; loc = typ.ptyp_loc}, + [typ] ); + } + in + {ld with pld_type = typ} + else ld)); + }) + in + let all_constrs = ref StringSet.empty in + List.iter + (fun {pcd_name = {txt = name}} -> + if StringSet.mem name !all_constrs then + raise (Error (sdecl.ptype_loc, Duplicate_constructor name)); + all_constrs := StringSet.add name !all_constrs) + scstrs; + let copy_tag_attr_from_decl attr = + let tag_attrs = + Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> + txt = "tag" || txt = Ast_untagged_variants.untagged) in - let make_cstr scstr = - Builtin_attributes.warning_scope scstr.pcd_attributes - (fun () -> make_cstr scstr) + if tag_attrs = [] then attr else tag_attrs @ attr + in + let constructors_from_variant_spreads = Hashtbl.create 10 in + let make_cstr scstr = + let name = Ident.create scstr.pcd_name.txt in + let targs, tret_type, args, ret_type, _cstr_params = + make_constructor env (Path.Pident id) params scstr.pcd_args + scstr.pcd_res in - let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in - let is_untagged_def = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in - Ast_untagged_variants.check_well_formed ~env ~is_untagged_def cstrs; - Ttype_variant tcstrs, Type_variant cstrs, sdecl - | Ptype_record lbls_ -> - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in - let optional_labels = - Ext_list.filter_map lbls_ - (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in - let lbls = - if optional_labels = [] then lbls_ - else Ext_list.map lbls_ (fun lbl -> + if String.starts_with scstr.pcd_name.txt ~prefix:"..." then ( + (* Any constructor starting with "..." represents a variant type spread, and + will have the spread variant itself as a single argument. + + We pull that variant type out, and then track the type of each of its + constructors, so that we can replace our dummy constructors added before + type checking with the realtypes for each constructor. + *) + (match args with + | Cstr_tuple [spread_variant] -> ( + match Ctype.extract_concrete_typedecl env spread_variant with + | _, _, {type_kind = Type_variant constructors} -> + constructors + |> List.iter (fun (c : Types.constructor_declaration) -> + Hashtbl.add constructors_from_variant_spreads c.cd_id.name + c) + | _ -> ()) + | _ -> ()); + None) + else + (* Check if this constructor is from a variant spread. If so, we need to replace + its type with the right type we've pulled from the type checked spread variant + itself. *) + let tcstr, cstr = + match + Hashtbl.find_opt constructors_from_variant_spreads + (Ident.name name) + with + | Some cstr -> + let tcstr = + { + cd_id = name; + cd_name = scstr.pcd_name; + cd_args = + (match cstr.cd_args with + | Cstr_tuple args -> + Cstr_tuple + (args + |> List.map (fun texpr : Typedtree.core_type -> + { + ctyp_attributes = cstr.cd_attributes; + ctyp_loc = cstr.cd_loc; + ctyp_env = env; + ctyp_type = texpr; + ctyp_desc = Ttyp_any; + (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *) + })) + | Cstr_record lbls -> + Cstr_record + (lbls + |> List.map + (fun + (l : Types.label_declaration) + : + Typedtree.label_declaration + -> + { + ld_id = l.ld_id; + ld_name = + Location.mkloc (Ident.name l.ld_id) l.ld_loc; + ld_mutable = l.ld_mutable; + ld_type = + { + ctyp_desc = Ttyp_any; + ctyp_type = l.ld_type; + ctyp_env = env; + ctyp_loc = l.ld_loc; + ctyp_attributes = []; + }; + ld_loc = l.ld_loc; + ld_attributes = l.ld_attributes; + }))); + cd_res = tret_type; + (* This is also strictly wrong, but is fine because the type checker does not look at this field. *) + cd_loc = scstr.pcd_loc; + cd_attributes = + scstr.pcd_attributes |> copy_tag_attr_from_decl; + } + in + (tcstr, cstr) + | None -> + let tcstr = + { + cd_id = name; + cd_name = scstr.pcd_name; + cd_args = targs; + cd_res = tret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = + scstr.pcd_attributes |> copy_tag_attr_from_decl; + } + in + let cstr = + { + Types.cd_id = name; + cd_args = args; + cd_res = ret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = + scstr.pcd_attributes |> copy_tag_attr_from_decl; + } + in + (tcstr, cstr) + in + Some (tcstr, cstr) + in + let make_cstr scstr = + Builtin_attributes.warning_scope scstr.pcd_attributes (fun () -> + make_cstr scstr) + in + let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in + let is_untagged_def = + Ast_untagged_variants.has_untagged sdecl.ptype_attributes + in + Ast_untagged_variants.check_well_formed ~env ~is_untagged_def cstrs; + (Ttype_variant tcstrs, Type_variant cstrs, sdecl) + | Ptype_record lbls_ -> ( + let has_optional attrs = + Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.optional") + in + let optional_labels = + Ext_list.filter_map lbls_ (fun lbl -> + if has_optional lbl.pld_attributes then Some lbl.pld_name.txt + else None) + in + let lbls = + if optional_labels = [] then lbls_ + else + Ext_list.map lbls_ (fun lbl -> let typ = lbl.pld_type in let typ = if has_optional lbl.pld_attributes then - {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])} - else typ in - {lbl with pld_type = typ }) in - let lbls, lbls' = transl_labels ~record_name:(sdecl.ptype_name.txt) env true lbls in - let lbls_opt = match Record_type_spread.has_type_spread lbls with - | true -> - let rec extract t = match t.desc with - | Tpoly(t, []) -> extract t - | _ -> Ctype.repr t in - let mk_lbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration = - { - ld_id = l.ld_id; - ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; - ld_mutable = l.ld_mutable; - ld_type = {ld_type with ctyp_type = Record_type_spread.substitute_type_vars type_vars l.ld_type}; - ld_loc = l.ld_loc; - ld_attributes = l.ld_attributes; - } in - let rec process_lbls acc lbls lbls' = match lbls, lbls' with - | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> - (match Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) with - (_p0, _p, {type_kind=Type_record (fields, _repr); type_params}) -> - let type_vars = Record_type_spread.extract_type_vars type_params ld_type.ctyp_type in - process_lbls - ( fst acc - @ (Ext_list.map fields (fun l -> - mk_lbl l ld_type type_vars)) - , - snd acc - @ (Ext_list.map fields (fun l -> - { - l with - ld_type = - Record_type_spread.substitute_type_vars type_vars l.ld_type; - })) ) - rest rest' - | _ -> assert false - | exception _ -> None) - | lbl::rest, lbl'::rest' -> process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' - | _ -> Some acc + { + typ with + ptyp_desc = + Ptyp_constr + ({txt = Lident "option"; loc = typ.ptyp_loc}, [typ]); + } + else typ in - process_lbls ([], []) lbls lbls' - | false -> Some (lbls, lbls') in - let rec check_duplicates loc (lbls : Typedtree.label_declaration list) seen = match lbls with - | [] -> () - | lbl::rest -> - let name = lbl.ld_id.name in - if StringSet.mem name seen then raise(Error(loc, Duplicate_label (name, Some sdecl.ptype_name.txt))); - check_duplicates loc rest (StringSet.add name seen) in - (match lbls_opt with - | Some (lbls, lbls') -> - check_duplicates sdecl.ptype_loc lbls StringSet.empty; - let optional_labels = - Ext_list.filter_map lbls (fun lbl -> - if has_optional lbl.ld_attributes then Some lbl.ld_name.txt else None) - in - Ttype_record lbls, Type_record(lbls', if unbox then - Record_unboxed false - else if optional_labels <> [] then + {lbl with pld_type = typ}) + in + let lbls, lbls' = + transl_labels ~record_name:sdecl.ptype_name.txt env true lbls + in + let lbls_opt = + match Record_type_spread.has_type_spread lbls with + | true -> + let rec extract t = + match t.desc with + | Tpoly (t, []) -> extract t + | _ -> Ctype.repr t + in + let mk_lbl (l : Types.label_declaration) + (ld_type : Typedtree.core_type) + (type_vars : (string * Types.type_expr) list) : + Typedtree.label_declaration = + { + ld_id = l.ld_id; + ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; + ld_mutable = l.ld_mutable; + ld_type = + { + ld_type with + ctyp_type = + Record_type_spread.substitute_type_vars type_vars l.ld_type; + }; + ld_loc = l.ld_loc; + ld_attributes = l.ld_attributes; + } + in + let rec process_lbls acc lbls lbls' = + match (lbls, lbls') with + | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> ( + match + Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) + with + | _p0, _p, {type_kind = Type_record (fields, _repr); type_params} + -> + let type_vars = + Record_type_spread.extract_type_vars type_params + ld_type.ctyp_type + in + process_lbls + ( fst acc + @ Ext_list.map fields (fun l -> mk_lbl l ld_type type_vars), + snd acc + @ Ext_list.map fields (fun l -> + { + l with + ld_type = + Record_type_spread.substitute_type_vars type_vars + l.ld_type; + }) ) + rest rest' + | _ -> assert false + | exception _ -> None) + | lbl :: rest, lbl' :: rest' -> + process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' + | _ -> Some acc + in + process_lbls ([], []) lbls lbls' + | false -> Some (lbls, lbls') + in + let rec check_duplicates loc (lbls : Typedtree.label_declaration list) + seen = + match lbls with + | [] -> () + | lbl :: rest -> + let name = lbl.ld_id.name in + if StringSet.mem name seen then + raise + (Error (loc, Duplicate_label (name, Some sdecl.ptype_name.txt))); + check_duplicates loc rest (StringSet.add name seen) + in + match lbls_opt with + | Some (lbls, lbls') -> + check_duplicates sdecl.ptype_loc lbls StringSet.empty; + let optional_labels = + Ext_list.filter_map lbls (fun lbl -> + if has_optional lbl.ld_attributes then Some lbl.ld_name.txt + else None) + in + ( Ttype_record lbls, + Type_record + ( lbls', + if unbox then Record_unboxed false + else if optional_labels <> [] then Record_optional_labels optional_labels - else Record_regular), sdecl - | None -> - (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *) - type_record_as_object := true; - let fields = Ext_list.map lbls_ (fun ld -> + else Record_regular ), + sdecl ) + | None -> + (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *) + type_record_as_object := true; + let fields = + Ext_list.map lbls_ (fun ld -> match ld.pld_name.txt with | "..." -> Parsetree.Oinherit ld.pld_type - | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) in - let sdecl = - {sdecl with - ptype_kind = Ptype_abstract; - ptype_manifest = Some (Ast_helper.Typ.object_ ~loc:sdecl.ptype_loc fields Closed); - } in - (Ttype_abstract, Type_abstract, sdecl)) - | Ptype_open -> Ttype_open, Type_open, sdecl - in - let (tman, man) = match sdecl.ptype_manifest with - None -> None, None - | Some sty -> - let no_row = not (is_fixed_type sdecl) in - let cty = transl_simple_type env no_row sty in - Some cty, Some cty.ctyp_type - in - let decl = - { type_params = params; - type_arity = List.length params; - type_kind = kind; - type_private = sdecl.ptype_private; - type_manifest = man; - type_variance = List.map (fun _ -> Variance.full) params; - type_newtype_level = None; - type_loc = sdecl.ptype_loc; - type_attributes = sdecl.ptype_attributes; - type_immediate = false; - type_unboxed = unboxed_status; - } in + | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) + in + let sdecl = + { + sdecl with + ptype_kind = Ptype_abstract; + ptype_manifest = + Some (Ast_helper.Typ.object_ ~loc:sdecl.ptype_loc fields Closed); + } + in + (Ttype_abstract, Type_abstract, sdecl)) + | Ptype_open -> (Ttype_open, Type_open, sdecl) + in + let tman, man = + match sdecl.ptype_manifest with + | None -> (None, None) + | Some sty -> + let no_row = not (is_fixed_type sdecl) in + let cty = transl_simple_type env no_row sty in + (Some cty, Some cty.ctyp_type) + in + let decl = + { + type_params = params; + type_arity = List.length params; + type_kind = kind; + type_private = sdecl.ptype_private; + type_manifest = man; + type_variance = List.map (fun _ -> Variance.full) params; + type_newtype_level = None; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = false; + type_unboxed = unboxed_status; + } + in (* Check constraints *) - List.iter - (fun (cty, cty', loc) -> - let ty = cty.ctyp_type in - let ty' = cty'.ctyp_type in - try Ctype.unify env ty ty' with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint (env, tr)))) - cstrs; - Ctype.end_def (); + List.iter + (fun (cty, cty', loc) -> + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + try Ctype.unify env ty ty' + with Ctype.Unify tr -> + raise (Error (loc, Inconsistent_constraint (env, tr)))) + cstrs; + Ctype.end_def (); (* Add abstract row *) - if is_fixed_type sdecl then begin - let p = - try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env - with Not_found -> assert false in - set_fixed_row env sdecl.ptype_loc p decl - end; + (if is_fixed_type sdecl then + let p = + try Env.lookup_type (Longident.Lident (Ident.name id ^ "#row")) env + with Not_found -> assert false + in + set_fixed_row env sdecl.ptype_loc p decl); (* Check for cyclic abbreviations *) - begin match decl.type_manifest with None -> () - | Some ty -> - if Ctype.cyclic_abbrev env id ty then - raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt)); - end; - { - typ_id = id; - typ_name = sdecl.ptype_name; - typ_params = tparams; - typ_type = decl; - typ_cstrs = cstrs; - typ_loc = sdecl.ptype_loc; - typ_manifest = tman; - typ_kind = tkind; - typ_private = sdecl.ptype_private; - typ_attributes = sdecl.ptype_attributes; - } + (match decl.type_manifest with + | None -> () + | Some ty -> + if Ctype.cyclic_abbrev env id ty then + raise (Error (sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt))); + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } (* Generalize a type declaration *) let generalize_decl decl = List.iter Ctype.generalize decl.type_params; Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; - begin match decl.type_manifest with - | None -> () + match decl.type_manifest with + | None -> () | Some ty -> Ctype.generalize ty - end (* Check that all constraints are enforced *) @@ -640,96 +742,87 @@ module TypeMap = Btype.TypeMap let rec check_constraints_rec env loc visited ty = let ty = Ctype.repr ty in - if TypeSet.mem ty !visited then () else begin - visited := TypeSet.add ty !visited; - match ty.desc with - | Tconstr (path, args, _) -> + if TypeSet.mem ty !visited then () + else ( + visited := TypeSet.add ty !visited; + match ty.desc with + | Tconstr (path, args, _) -> let args' = List.map (fun _ -> Ctype.newvar ()) args in let ty' = Ctype.newconstr path args' in - begin try Ctype.enforce_constraints env ty' - with Ctype.Unify _ -> assert false - | Not_found -> raise (Error(loc, Unavailable_type_constructor path)) - end; + (try Ctype.enforce_constraints env ty' with + | Ctype.Unify _ -> assert false + | Not_found -> raise (Error (loc, Unavailable_type_constructor path))); if not (Ctype.matches env ty ty') then - raise (Error(loc, Constraint_failed (ty, ty'))); + raise (Error (loc, Constraint_failed (ty, ty'))); List.iter (check_constraints_rec env loc visited) args - | Tpoly (ty, tl) -> + | Tpoly (ty, tl) -> let _, ty = Ctype.instance_poly false tl ty in check_constraints_rec env loc visited ty - | _ -> - Btype.iter_type_expr (check_constraints_rec env loc visited) ty - end + | _ -> Btype.iter_type_expr (check_constraints_rec env loc visited) ty) -module SMap = Map.Make(String) +module SMap = Map.Make (String) let check_constraints_labels env visited l pl = let rec get_loc name = function - [] -> Location.none + | [] -> Location.none | pld :: tl -> - if name = pld.pld_name.txt then pld.pld_type.ptyp_loc - else get_loc name tl + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl in List.iter - (fun {Types.ld_id=name; ld_type=ty} -> - check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) + (fun {Types.ld_id = name; ld_type = ty} -> + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) l let check_constraints ~type_record_as_object env sdecl (_, decl) = let visited = ref TypeSet.empty in - begin match decl.type_kind with + (match decl.type_kind with | Type_abstract -> () | Type_variant l -> - let find_pl = function - Ptype_variant pl -> pl - | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false - in - let pl = find_pl sdecl.ptype_kind in - let pl_index = - let foldf acc x = - SMap.add x.pcd_name.txt x acc + let find_pl = function + | Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + let pl_index = + let foldf acc x = SMap.add x.pcd_name.txt x acc in + List.fold_left foldf SMap.empty pl + in + List.iter + (fun {Types.cd_id = name; cd_args; cd_res} -> + let {pcd_args; pcd_res; _} = + try SMap.find (Ident.name name) pl_index + with Not_found -> assert false in - List.fold_left foldf SMap.empty pl - in - List.iter - (fun {Types.cd_id=name; cd_args; cd_res} -> - let {pcd_args; pcd_res; _} = - try SMap.find (Ident.name name) pl_index - with Not_found -> assert false in - begin match cd_args, pcd_args with - | Cstr_tuple tyl, Pcstr_tuple styl -> - List.iter2 - (fun sty ty -> - check_constraints_rec env sty.ptyp_loc visited ty) - styl tyl - | Cstr_record tyl, Pcstr_record styl -> - check_constraints_labels env visited tyl styl - | _ -> assert false - end; - match pcd_res, cd_res with - | Some sr, Some r -> - check_constraints_rec env sr.ptyp_loc visited r - | _ -> - () ) - l + (match (cd_args, pcd_args) with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record tyl, Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | _ -> assert false); + match (pcd_res, cd_res) with + | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r + | _ -> ()) + l | Type_record (l, _) -> - let find_pl = function - Ptype_record pl -> pl - | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false - in - let pl = find_pl sdecl.ptype_kind in - check_constraints_labels env visited l pl - | Type_open -> () - end; - begin match decl.type_manifest with + let find_pl = function + | Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + check_constraints_labels env visited l pl + | Type_open -> ()); + match decl.type_manifest with | None -> () | Some ty -> - if not !type_record_as_object then + if not !type_record_as_object then let sty = - match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false + match sdecl.ptype_manifest with + | Some sty -> sty + | _ -> assert false in check_constraints_rec env sty.ptyp_loc visited ty - - end (* If both a variant/record definition and a type equation are given, @@ -738,32 +831,29 @@ let check_constraints ~type_record_as_object env sdecl (_, decl) = *) let check_coherence env loc id decl = match decl with - { type_kind = (Type_variant _ | Type_record _| Type_open); - type_manifest = Some ty } -> - begin match (Ctype.repr ty).desc with - Tconstr(path, args, _) -> - begin try - let decl' = Env.find_type path env in - let err = - if List.length args <> List.length decl.type_params - then [Includecore.Arity] - else if not (Ctype.equal env false args decl.type_params) - then [Includecore.Constraint] - else - Includecore.type_declarations ~loc ~equality:true env - (Path.last path) - decl' - id - (Subst.type_declaration - (Subst.add_type id path Subst.identity) decl) - in - if err <> [] then - raise(Error(loc, Definition_mismatch (ty, err))) - with Not_found -> - raise(Error(loc, Unavailable_type_constructor path)) - end - | _ -> raise(Error(loc, Definition_mismatch (ty, []))) - end + | { + type_kind = Type_variant _ | Type_record _ | Type_open; + type_manifest = Some ty; + } -> ( + match (Ctype.repr ty).desc with + | Tconstr (path, args, _) -> ( + try + let decl' = Env.find_type path env in + let err = + if List.length args <> List.length decl.type_params then + [Includecore.Arity] + else if not (Ctype.equal env false args decl.type_params) then + [Includecore.Constraint] + else + Includecore.type_declarations ~loc ~equality:true env + (Path.last path) decl' id + (Subst.type_declaration + (Subst.add_type id path Subst.identity) + decl) + in + if err <> [] then raise (Error (loc, Definition_mismatch (ty, err))) + with Not_found -> raise (Error (loc, Unavailable_type_constructor path))) + | _ -> raise (Error (loc, Definition_mismatch (ty, [])))) | _ -> () let check_abbrev env sdecl (id, decl) = @@ -775,53 +865,53 @@ let check_well_founded env loc path to_check ty = let visited = ref TypeMap.empty in let rec check ty0 parents ty = let ty = Btype.repr ty in - if TypeSet.mem ty parents then begin + if TypeSet.mem ty parents then (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) - if match ty0.desc with - | Tconstr (p, _, _) -> Path.same p path - | _ -> false + if + match ty0.desc with + | Tconstr (p, _, _) -> Path.same p path + | _ -> false then raise (Error (loc, Recursive_abbrev (Path.name path))) - else raise (Error (loc, Cycle_in_def (Path.name path, ty0))) - end; - let (fini, parents) = + else raise (Error (loc, Cycle_in_def (Path.name path, ty0))); + let fini, parents = try let prev = TypeMap.find ty !visited in - if TypeSet.subset parents prev then (true, parents) else - (false, TypeSet.union parents prev) - with Not_found -> - (false, parents) + if TypeSet.subset parents prev then (true, parents) + else (false, TypeSet.union parents prev) + with Not_found -> (false, parents) in - if fini then () else - let rec_ok = - match ty.desc with - Tconstr(_p,_,_) -> + if fini then () + else + let rec_ok = + match ty.desc with + | Tconstr (_p, _, _) -> false (*!Clflags.recursive_types && Ctype.is_contractive env p*) - | Tobject _ | Tvariant _ -> true - | _ -> false (* !Clflags.recursive_types*) - in - let visited' = TypeMap.add ty parents !visited in - let arg_exn = - try - visited := visited'; - let parents = - if rec_ok then TypeSet.empty else TypeSet.add ty parents in - Btype.iter_type_expr (check ty0 parents) ty; - None - with e -> - visited := visited'; Some e - in - match ty.desc with - | Tconstr(p, _, _) when arg_exn <> None || to_check p -> + | Tobject _ | Tvariant _ -> true + | _ -> false (* !Clflags.recursive_types*) + in + let visited' = TypeMap.add ty parents !visited in + let arg_exn = + try + visited := visited'; + let parents = + if rec_ok then TypeSet.empty else TypeSet.add ty parents + in + Btype.iter_type_expr (check ty0 parents) ty; + None + with e -> + visited := visited'; + Some e + in + match ty.desc with + | Tconstr (p, _, _) when arg_exn <> None || to_check p -> ( if to_check p then may raise arg_exn else Btype.iter_type_expr (check ty0 TypeSet.empty) ty; - begin try + try let ty' = Ctype.try_expand_once_opt env ty in let ty0 = if TypeSet.is_empty parents then ty else ty0 in check ty0 (TypeSet.add ty parents) ty' - with - Ctype.Cannot_expand -> may raise arg_exn - end - | _ -> may raise arg_exn + with Ctype.Cannot_expand -> may raise arg_exn) + | _ -> may raise arg_exn in let snap = Btype.snapshot () in try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty @@ -830,15 +920,19 @@ let check_well_founded env loc path to_check ty = Btype.backtrack snap let check_well_founded_manifest env loc path decl = - if decl.type_manifest = None then () else - let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in - check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) + if decl.type_manifest = None then () + else + let args = List.map (fun _ -> Ctype.newvar ()) decl.type_params in + check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) let check_well_founded_decl env loc path decl to_check = let open Btype in let it = - {type_iterators with - it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in + { + type_iterators with + it_type_expr = (fun _ -> check_well_founded env loc path to_check); + } + in it.it_type_declaration it (Ctype.instance_declaration decl) (* Check for ill-defined abbrevs *) @@ -846,58 +940,62 @@ let check_well_founded_decl env loc path decl to_check = let check_recursion env loc path decl to_check = (* to_check is true for potentially mutually recursive paths. (path, decl) is the type declaration to be checked. *) + if decl.type_params = [] then () + else + let visited = ref [] in - if decl.type_params = [] then () else - - let visited = ref [] in - - let rec check_regular cpath args prev_exp ty = - let ty = Ctype.repr ty in - if not (List.memq ty !visited) then begin - visited := ty :: !visited; - match ty.desc with - | Tconstr(path', args', _) -> - if Path.same path path' then begin - if not (Ctype.equal env false args args') then - raise (Error(loc, - Parameters_differ(cpath, ty, Ctype.newconstr path args))) - end - (* Attempt to expand a type abbreviation if: - 1- [to_check path'] holds - (otherwise the expansion cannot involve [path]); - 2- we haven't expanded this type constructor before - (otherwise we could loop if [path'] is itself - a non-regular abbreviation). *) - else if to_check path' && not (List.mem path' prev_exp) then begin - try - (* Attempt expansion *) - let (params0, body0, _) = Env.find_type_expansion path' env in - let (params, body) = - Ctype.instance_parameterized_type params0 body0 in - begin - try List.iter2 (Ctype.unify env) params args' + let rec check_regular cpath args prev_exp ty = + let ty = Ctype.repr ty in + if not (List.memq ty !visited) then ( + visited := ty :: !visited; + match ty.desc with + | Tconstr (path', args', _) -> + (if Path.same path path' then ( + if not (Ctype.equal env false args args') then + raise + (Error + ( loc, + Parameters_differ (cpath, ty, Ctype.newconstr path args) + ))) + else if + (* Attempt to expand a type abbreviation if: + 1- [to_check path'] holds + (otherwise the expansion cannot involve [path]); + 2- we haven't expanded this type constructor before + (otherwise we could loop if [path'] is itself + a non-regular abbreviation). *) + to_check path' && not (List.mem path' prev_exp) + then + try + (* Attempt expansion *) + let params0, body0, _ = Env.find_type_expansion path' env in + let params, body = + Ctype.instance_parameterized_type params0 body0 + in + (try List.iter2 (Ctype.unify env) params args' with Ctype.Unify _ -> - raise (Error(loc, Constraint_failed - (ty, Ctype.newconstr path' params0))); - end; - check_regular path' args (path' :: prev_exp) body - with Not_found -> () - end; + raise + (Error + ( loc, + Constraint_failed (ty, Ctype.newconstr path' params0) + ))); + check_regular path' args (path' :: prev_exp) body + with Not_found -> ()); List.iter (check_regular cpath args prev_exp) args' - | Tpoly (ty, tl) -> - let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in + | Tpoly (ty, tl) -> + let _, ty = Ctype.instance_poly ~keep_names:true false tl ty in check_regular cpath args prev_exp ty - | _ -> - Btype.iter_type_expr (check_regular cpath args prev_exp) ty - end in + | _ -> Btype.iter_type_expr (check_regular cpath args prev_exp) ty) + in - Misc.may - (fun body -> - let (args, body) = - Ctype.instance_parameterized_type - ~keep_names:true decl.type_params body in - check_regular path args [] body) - decl.type_manifest + Misc.may + (fun body -> + let args, body = + Ctype.instance_parameterized_type ~keep_names:true decl.type_params + body + in + check_regular path args [] body) + decl.type_manifest let check_abbrev_recursion env id_loc_list to_check tdecl = let decl = tdecl.typ_type in @@ -914,25 +1012,25 @@ let compute_variance env visited vari ty = (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) let ty = Ctype.repr ty in let vari' = get_variance ty visited in - if Variance.subset vari vari' then () else - let vari = Variance.union vari vari' in - visited := TypeMap.add ty vari !visited; - let compute_same = compute_variance_rec vari in - match ty.desc with - Tarrow (_, ty1, ty2, _) -> + if Variance.subset vari vari' then () + else + let vari = Variance.union vari vari' in + visited := TypeMap.add ty vari !visited; + let compute_same = compute_variance_rec vari in + match ty.desc with + | Tarrow (_, ty1, ty2, _) -> let open Variance in let v = conjugate vari in let v1 = - if mem May_pos v || mem May_neg v - then set May_weak true v else v + if mem May_pos v || mem May_neg v then set May_weak true v else v in compute_variance_rec v1 ty1; compute_same ty2 - | Ttuple tl -> - List.iter compute_same tl - | Tconstr (path, tl, _) -> + | Ttuple tl -> List.iter compute_same tl + | Tconstr (path, tl, _) -> ( let open Variance in - if tl = [] then () else begin + if tl = [] then () + else try let decl = Env.find_type path env in let cvari f = mem f vari in @@ -940,55 +1038,52 @@ let compute_variance env visited vari ty = (fun ty v -> let cv f = mem f v in let strict = - cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv + (cvari Inv && cv Inj) || ((cvari Pos || cvari Neg) && cv Inv) in - if strict then compute_variance_rec full ty else - let p1 = inter v vari - and n1 = inter v (conjugate vari) in - let v1 = - union (inter covariant (union p1 (conjugate p1))) - (inter (conjugate covariant) (union n1 (conjugate n1))) - and weak = - cvari May_weak && (cv May_pos || cv May_neg) || - (cvari May_pos || cvari May_neg) && cv May_weak - in - let v2 = set May_weak weak v1 in - compute_variance_rec v2 ty) + if strict then compute_variance_rec full ty + else + let p1 = inter v vari and n1 = inter v (conjugate vari) in + let v1 = + union + (inter covariant (union p1 (conjugate p1))) + (inter (conjugate covariant) (union n1 (conjugate n1))) + and weak = + (cvari May_weak && (cv May_pos || cv May_neg)) + || ((cvari May_pos || cvari May_neg) && cv May_weak) + in + let v2 = set May_weak weak v1 in + compute_variance_rec v2 ty) tl decl.type_variance - with Not_found -> - List.iter (compute_variance_rec may_inv) tl - end - | Tobject (ty, _) -> - compute_same ty - | Tfield (_, _, ty1, ty2) -> + with Not_found -> List.iter (compute_variance_rec may_inv) tl) + | Tobject (ty, _) -> compute_same ty + | Tfield (_, _, ty1, ty2) -> compute_same ty1; compute_same ty2 - | Tsubst ty -> - compute_same ty - | Tvariant row -> + | Tsubst ty -> compute_same ty + | Tvariant row -> let row = Btype.row_repr row in List.iter - (fun (_,f) -> + (fun (_, f) -> match Btype.row_field_repr f with - Rpresent (Some ty) -> - compute_same ty + | Rpresent (Some ty) -> compute_same ty | Reither (_, tyl, _, _) -> - let open Variance in - let upper = - List.fold_left (fun s f -> set f true s) - null [May_pos; May_neg; May_weak] - in - let v = inter vari upper in - (* cf PR#7269: - if List.length tyl > 1 then upper else inter vari upper *) - List.iter (compute_variance_rec v) tyl + let open Variance in + let upper = + List.fold_left + (fun s f -> set f true s) + null + [May_pos; May_neg; May_weak] + in + let v = inter vari upper in + (* cf PR#7269: + if List.length tyl > 1 then upper else inter vari upper *) + List.iter (compute_variance_rec v) tyl | _ -> ()) row.row_fields; compute_same row.row_more - | Tpoly (ty, _) -> - compute_same ty - | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () - | Tpackage (_, _, tyl) -> + | Tpoly (ty, _) -> compute_same ty + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, _, tyl) -> let v = Variance.(if mem Pos vari || mem Neg vari then full else may_inv) in @@ -1003,7 +1098,8 @@ let make p n i = let compute_variance_type env check (required, loc) decl tyl = (* Requirements *) let required = - List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i)) + List.map + (fun (c, n, i) -> if c || n then (c, n, i) else (true, true, i)) required in (* Prepare *) @@ -1012,81 +1108,89 @@ let compute_variance_type env check (required, loc) decl tyl = (* Compute occurrences in the body *) let open Variance in List.iter - (fun (cn,ty) -> + (fun (cn, ty) -> compute_variance env tvl (if cn then full else covariant) ty) tyl; - if check then begin + if check then ( (* Check variance of parameters *) let pos = ref 0 in List.iter2 (fun ty (c, n, i) -> incr pos; let var = get_variance ty tvl in - let (co,cn) = get_upper var and ij = mem Inj var in - if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i) - then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i))))) + let co, cn = get_upper var and ij = mem Inj var in + if + Btype.is_Tvar ty && ((co && not c) || (cn && not n) || ((not ij) && i)) + then raise (Error (loc, Bad_variance (!pos, (co, cn, ij), (c, n, i))))) params required; (* Check propagation from constrained parameters *) let args = Btype.newgenty (Ttuple params) in let fvl = Ctype.free_variables args in let fvl = Ext_list.filter fvl (fun v -> not (List.memq v params)) in (* If there are no extra variables there is nothing to do *) - if fvl = [] then () else - let tvl2 = ref TypeMap.empty in - List.iter2 - (fun ty (p,n,_) -> - if Btype.is_Tvar ty then () else - let v = - if p then if n then full else covariant else conjugate covariant in - compute_variance env tvl2 v ty) - params required; - let visited = ref TypeSet.empty in - let rec check ty = - let ty = Ctype.repr ty in - if TypeSet.mem ty !visited then () else - let visited' = TypeSet.add ty !visited in - visited := visited'; - let v1 = get_variance ty tvl in - let snap = Btype.snapshot () in - let v2 = - TypeMap.fold - (fun t vt v -> - if Ctype.equal env false [ty] [t] then union vt v else v) - !tvl2 null in - Btype.backtrack snap; - let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in - if c1 && not c2 || n1 && not n2 then - if List.memq ty fvl then - let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in - raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false)))) + if fvl = [] then () + else + let tvl2 = ref TypeMap.empty in + List.iter2 + (fun ty (p, n, _) -> + if Btype.is_Tvar ty then () + else + let v = + if p then if n then full else covariant else conjugate covariant + in + compute_variance env tvl2 v ty) + params required; + let visited = ref TypeSet.empty in + let rec check ty = + let ty = Ctype.repr ty in + if TypeSet.mem ty !visited then () else - Btype.iter_type_expr check ty - in - List.iter (fun (_,ty) -> check ty) tyl; - end; + let visited' = TypeSet.add ty !visited in + visited := visited'; + let v1 = get_variance ty tvl in + let snap = Btype.snapshot () in + let v2 = + TypeMap.fold + (fun t vt v -> + if Ctype.equal env false [ty] [t] then union vt v else v) + !tvl2 null + in + Btype.backtrack snap; + let c1, n1 = get_upper v1 and c2, n2, _, i2 = get_lower v2 in + if (c1 && not c2) || (n1 && not n2) then + if List.memq ty fvl then + let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in + raise + (Error + (loc, Bad_variance (code, (c1, n1, false), (c2, n2, false)))) + else Btype.iter_type_expr check ty + in + List.iter (fun (_, ty) -> check ty) tyl); List.map2 (fun ty (p, n, i) -> let v = get_variance ty tvl in let tr = decl.type_private in (* Use required variance where relevant *) let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in - let (p, n) = + let p, n = if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *) - else (false, false) (* only check *) - and i = concr || i && tr = Private in + else (false, false) + (* only check *) + and i = concr || (i && tr = Private) in let v = union v (make p n i) in let v = - if not concr then v else - if mem Pos v && mem Neg v then full else - if Btype.is_Tvar ty then v else - union v - (if p then if n then full else covariant else conjugate covariant) + if not concr then v + else if mem Pos v && mem Neg v then full + else if Btype.is_Tvar ty then v + else + union v + (if p then if n then full else covariant else conjugate covariant) in - if decl.type_kind = Type_abstract && tr = Public then v else - set May_weak (mem May_neg v) v) + if decl.type_kind = Type_abstract && tr = Public then v + else set May_weak (mem May_neg v) v) params required -let add_false = List.map (fun ty -> false, ty) +let add_false = List.map (fun ty -> (false, ty)) (* A parameter is constrained if it is either instantiated, or it is a variable appearing in another parameter *) @@ -1098,104 +1202,105 @@ let constrained vars ty = let for_constr = function | Types.Cstr_tuple l -> add_false l | Types.Cstr_record l -> - List.map - (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) - l + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l -let compute_variance_gadt env check (required, loc as rloc) decl +let compute_variance_gadt env check ((required, loc) as rloc) decl (tl, ret_type_opt) = match ret_type_opt with | None -> - compute_variance_type env check rloc {decl with type_private = Private} + compute_variance_type env check rloc + {decl with type_private = Private} + (for_constr tl) + | Some ret_type -> ( + match Ctype.repr ret_type with + | {desc = Tconstr (_, tyl, _)} -> + (* let tyl = List.map (Ctype.expand_head env) tyl in *) + let tyl = List.map Ctype.repr tyl in + let fvl = List.map (Ctype.free_variables ?env:None) tyl in + let _ = + List.fold_left2 + (fun (fv1, fv2) ty (c, n, _) -> + match fv2 with + | [] -> assert false + | fv :: fv2 -> + (* fv1 @ fv2 = free_variables of other parameters *) + if (c || n) && constrained (fv1 @ fv2) ty then + raise (Error (loc, Varying_anonymous)); + (fv :: fv1, fv2)) + ([], fvl) tyl required + in + compute_variance_type env check rloc + {decl with type_params = tyl; type_private = Private} (for_constr tl) - | Some ret_type -> - match Ctype.repr ret_type with - | {desc=Tconstr (_, tyl, _)} -> - (* let tyl = List.map (Ctype.expand_head env) tyl in *) - let tyl = List.map Ctype.repr tyl in - let fvl = List.map (Ctype.free_variables ?env:None) tyl in - let _ = - List.fold_left2 - (fun (fv1,fv2) ty (c,n,_) -> - match fv2 with [] -> assert false - | fv :: fv2 -> - (* fv1 @ fv2 = free_variables of other parameters *) - if (c||n) && constrained (fv1 @ fv2) ty then - raise (Error(loc, Varying_anonymous)); - (fv :: fv1, fv2)) - ([], fvl) tyl required - in - compute_variance_type env check rloc - {decl with type_params = tyl; type_private = Private} - (for_constr tl) - | _ -> assert false + | _ -> assert false) let compute_variance_extension env check decl ext rloc = compute_variance_gadt env check rloc {decl with type_params = ext.ext_type_params} (ext.ext_args, ext.ext_ret_type) -let compute_variance_decl env check decl (required, _ as rloc) = - if (decl.type_kind = Type_abstract || decl.type_kind = Type_open) - && decl.type_manifest = None then +let compute_variance_decl env check decl ((required, _) as rloc) = + if + (decl.type_kind = Type_abstract || decl.type_kind = Type_open) + && decl.type_manifest = None + then List.map (fun (c, n, i) -> make (not n) (not c) (decl.type_kind <> Type_abstract || i)) required else - let mn = - match decl.type_manifest with - None -> [] - | Some ty -> [false, ty] - in - match decl.type_kind with - Type_abstract | Type_open -> - compute_variance_type env check rloc decl mn - | Type_variant tll -> + let mn = + match decl.type_manifest with + | None -> [] + | Some ty -> [(false, ty)] + in + match decl.type_kind with + | Type_abstract | Type_open -> compute_variance_type env check rloc decl mn + | Type_variant tll -> ( if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env check rloc decl - (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) - tll)) - else begin - let mn = - List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in + (mn + @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) tll)) + else + let mn = List.map (fun (_, ty) -> (Types.Cstr_tuple [ty], None)) mn in let tll = - mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in + mn @ List.map (fun c -> (c.Types.cd_args, c.Types.cd_res)) tll + in match List.map (compute_variance_gadt env check rloc decl) tll with | vari :: rem -> - let varl = List.fold_left (List.map2 Variance.union) vari rem in - List.map - Variance.(fun v -> if mem Pos v && mem Neg v then full else v) - varl - | _ -> assert false - end - | Type_record (ftl, _) -> + let varl = List.fold_left (List.map2 Variance.union) vari rem in + List.map + Variance.(fun v -> if mem Pos v && mem Neg v then full else v) + varl + | _ -> assert false) + | Type_record (ftl, _) -> compute_variance_type env check rloc decl - (mn @ List.map (fun {Types.ld_mutable; ld_type} -> - (ld_mutable = Mutable, ld_type)) ftl) + (mn + @ List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + ftl) let is_hash id = let s = Ident.name id in String.length s > 0 && s.[0] = '#' -let marked_as_immediate decl = - Builtin_attributes.immediate decl.type_attributes +let marked_as_immediate decl = Builtin_attributes.immediate decl.type_attributes let compute_immediacy env tdecl = match (tdecl.type_kind, tdecl.type_manifest) with - | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _) - | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _) - | (Type_record ([{ld_type = arg; _}], _), _) - when tdecl.type_unboxed.unboxed -> - begin match get_unboxed_type_representation env arg with + | Type_variant [{cd_args = Cstr_tuple [arg]; _}], _ + | Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _ + | Type_record ([{ld_type = arg; _}], _), _ + when tdecl.type_unboxed.unboxed -> ( + match get_unboxed_type_representation env arg with | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) - | None -> false - end - | (Type_variant (_ :: _ as cstrs), _) -> + | None -> false) + | Type_variant (_ :: _ as cstrs), _ -> not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) - | (Type_abstract, Some(typ)) -> - not (Ctype.maybe_pointer_type env typ) - | (Type_abstract, None) -> marked_as_immediate tdecl + | Type_abstract, Some typ -> not (Ctype.maybe_pointer_type env typ) + | Type_abstract, None -> marked_as_immediate tdecl | _ -> false (* Computes the fixpoint for the variance and immediacy of type declarations *) @@ -1204,8 +1309,9 @@ let rec compute_properties_fixpoint env decls required variances immediacies = let new_decls = List.map2 (fun (id, decl) (variance, immediacy) -> - id, {decl with type_variance = variance; type_immediate = immediacy}) - decls (List.combine variances immediacies) + (id, {decl with type_variance = variance; type_immediate = immediacy})) + decls + (List.combine variances immediacies) in let new_env = List.fold_right @@ -1218,90 +1324,88 @@ let rec compute_properties_fixpoint env decls required variances immediacies = new_decls required in let new_variances = - List.map2 (List.map2 Variance.union) new_variances variances in + List.map2 (List.map2 Variance.union) new_variances variances + in let new_immediacies = - List.map - (fun (_id, decl) -> compute_immediacy new_env decl) - new_decls + List.map (fun (_id, decl) -> compute_immediacy new_env decl) new_decls in if new_variances <> variances || new_immediacies <> immediacies then compute_properties_fixpoint env decls required new_variances new_immediacies - else begin + else ( (* List.iter (fun (id, decl) -> - Printf.eprintf "%s:" (Ident.name id); - List.iter (fun (v : Variance.t) -> - Printf.eprintf " %x" (Obj.magic v : int)) - decl.type_variance; - prerr_endline "") - new_decls; *) - List.iter (fun (_, decl) -> - if (marked_as_immediate decl) && (not decl.type_immediate) then - raise (Error (decl.type_loc, Bad_immediate_attribute)) - else ()) + Printf.eprintf "%s:" (Ident.name id); + List.iter (fun (v : Variance.t) -> + Printf.eprintf " %x" (Obj.magic v : int)) + decl.type_variance; + prerr_endline "") + new_decls; *) + List.iter + (fun (_, decl) -> + if marked_as_immediate decl && not decl.type_immediate then + raise (Error (decl.type_loc, Bad_immediate_attribute)) + else ()) new_decls; List.iter2 - (fun (id, decl) req -> if not (is_hash id) then - ignore (compute_variance_decl new_env true decl req)) + (fun (id, decl) req -> + if not (is_hash id) then + ignore (compute_variance_decl new_env true decl req)) new_decls required; - new_decls, new_env - end + (new_decls, new_env)) let init_variance (_id, decl) = List.map (fun _ -> Variance.null) decl.type_params let add_injectivity = - List.map - (function - | Covariant -> (true, false, false) - | Contravariant -> (false, true, false) - | Invariant -> (false, false, false) - ) + List.map (function + | Covariant -> (true, false, false) + | Contravariant -> (false, true, false) + | Invariant -> (false, false, false)) (* Check multiple declarations of labels/constructors *) let check_duplicates sdecl_list = let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in List.iter - (fun sdecl -> match sdecl.ptype_kind with - Ptype_variant cl -> + (fun sdecl -> + match sdecl.ptype_kind with + | Ptype_variant cl -> List.iter (fun pcd -> try let name' = Hashtbl.find constrs pcd.pcd_name.txt in Location.prerr_warning pcd.pcd_loc (Warnings.Duplicate_definitions - ("constructor", pcd.pcd_name.txt, name', - sdecl.ptype_name.txt)) + ("constructor", pcd.pcd_name.txt, name', sdecl.ptype_name.txt)) with Not_found -> Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) cl - | Ptype_record fl -> + | Ptype_record fl -> List.iter - (fun {pld_name=cname;pld_loc=loc} -> + (fun {pld_name = cname; pld_loc = loc} -> try let name' = Hashtbl.find labels cname.txt in if cname.txt <> "..." then - Location.prerr_warning loc - (Warnings.Duplicate_definitions - ("label", cname.txt, name', sdecl.ptype_name.txt)) - with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt) + Location.prerr_warning loc + (Warnings.Duplicate_definitions + ("label", cname.txt, name', sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add labels cname.txt sdecl.ptype_name.txt) fl - | Ptype_abstract -> () - | Ptype_open -> ()) + | Ptype_abstract -> () + | Ptype_open -> ()) sdecl_list (* Force recursion to go through id for private types*) let name_recursion sdecl id decl = match decl with - | { type_kind = Type_abstract; - type_manifest = Some ty; - type_private = Private; } when is_fixed_type sdecl -> + | {type_kind = Type_abstract; type_manifest = Some ty; type_private = Private} + when is_fixed_type sdecl -> let ty = Ctype.repr ty in let ty' = Btype.newty2 ty.level ty.desc in - if Ctype.deep_occur ty ty' then - let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + if Ctype.deep_occur ty ty' then ( + let td = Tconstr (Path.Pident id, decl.type_params, ref Mnil) in Btype.link_type ty (Btype.newty2 ty.level td); - {decl with type_manifest = Some ty'} + {decl with type_manifest = Some ty'}) else decl | _ -> decl @@ -1313,16 +1417,22 @@ let transl_type_decl env rec_flag sdecl_list = List.map (fun sdecl -> let ptype_name = - mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in - {sdecl with - ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) + mkloc (sdecl.ptype_name.txt ^ "#row") sdecl.ptype_name.loc + in + { + sdecl with + ptype_name; + ptype_kind = Ptype_abstract; + ptype_manifest = None; + }) fixed_types - @ (try - sdecl_list |> Variant_type_spread.expand_variant_spreads env - with - | Variant_coercion.VariantConfigurationError ((VariantError {left_loc}) as err) -> raise(Error(left_loc, Variant_runtime_representation_mismatch err)) - | Variant_type_spread.VariantTypeSpreadError (loc, err) -> raise(Error(loc, Variant_spread_fail err)) - ) + @ + try sdecl_list |> Variant_type_spread.expand_variant_spreads env with + | Variant_coercion.VariantConfigurationError + (VariantError {left_loc} as err) -> + raise (Error (left_loc, Variant_runtime_representation_mismatch err)) + | Variant_type_spread.VariantTypeSpreadError (loc, err) -> + raise (Error (loc, Variant_spread_fail err)) in (* Create identifiers. *) @@ -1335,48 +1445,45 @@ let transl_type_decl env rec_flag sdecl_list = passing one of the recursively-defined type constrs as argument to an abbreviation may fail. *) - Ctype.init_def(Ident.current_time()); - Ctype.begin_def(); + Ctype.init_def (Ident.current_time ()); + Ctype.begin_def (); (* Enter types. *) - let temp_env = - List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in + let temp_env = List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in (* Translate each declaration. *) let current_slot = ref None in let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in let id_slots id = match rec_flag with | Asttypes.Recursive when warn_unused -> - (* See typecore.ml for a description of the algorithm used - to detect unused declarations in a set of recursive definitions. *) - let slot = ref [] in - let td = Env.find_type (Path.Pident id) temp_env in - let name = Ident.name id in - Env.set_type_used_callback - name td - (fun old_callback -> - match !current_slot with - | Some slot -> slot := (name, td) :: !slot - | None -> - List.iter (fun (name, d) -> Env.mark_type_used env name d) - (get_ref slot); - old_callback () - ); - id, Some slot - | Asttypes.Recursive | Asttypes.Nonrecursive -> - id, None + (* See typecore.ml for a description of the algorithm used + to detect unused declarations in a set of recursive definitions. *) + let slot = ref [] in + let td = Env.find_type (Path.Pident id) temp_env in + let name = Ident.name id in + Env.set_type_used_callback name td (fun old_callback -> + match !current_slot with + | Some slot -> slot := (name, td) :: !slot + | None -> + List.iter + (fun (name, d) -> Env.mark_type_used env name d) + (get_ref slot); + old_callback ()); + (id, Some slot) + | Asttypes.Recursive | Asttypes.Nonrecursive -> (id, None) in let type_record_as_object = ref false in let transl_declaration name_sdecl (id, slot) = current_slot := slot; - Builtin_attributes.warning_scope - name_sdecl.ptype_attributes - (fun () -> transl_declaration ~type_record_as_object temp_env name_sdecl id) + Builtin_attributes.warning_scope name_sdecl.ptype_attributes (fun () -> + transl_declaration ~type_record_as_object temp_env name_sdecl id) in let tdecls = - List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in - let decls = - List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in - let sdecl_list = Variant_type_spread.expand_dummy_constructor_args sdecl_list decls in + List.map2 transl_declaration sdecl_list (List.map id_slots id_list) + in + let decls = List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in + let sdecl_list = + Variant_type_spread.expand_dummy_constructor_args sdecl_list decls + in current_slot := None; (* Check for duplicates *) check_duplicates sdecl_list; @@ -1387,54 +1494,57 @@ let transl_type_decl env rec_flag sdecl_list = decls env in (* Update stubs *) - begin match rec_flag with - | Asttypes.Nonrecursive -> () - | Asttypes.Recursive -> - List.iter2 - (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc) - id_list sdecl_list - end; + (match rec_flag with + | Asttypes.Nonrecursive -> () + | Asttypes.Recursive -> + List.iter2 + (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc) + id_list sdecl_list); (* Generalize type declarations. *) - Ctype.end_def(); + Ctype.end_def (); List.iter (fun (_, decl) -> generalize_decl decl) decls; (* Check for ill-formed abbrevs *) let id_loc_list = - List.map2 (fun id sdecl -> (id, sdecl.ptype_loc)) - id_list sdecl_list + List.map2 (fun id sdecl -> (id, sdecl.ptype_loc)) id_list sdecl_list in - List.iter (fun (id, decl) -> - check_well_founded_manifest newenv (List.assoc id id_loc_list) - (Path.Pident id) decl) + List.iter + (fun (id, decl) -> + check_well_founded_manifest newenv + (List.assoc id id_loc_list) + (Path.Pident id) decl) decls; - let to_check = - function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in - List.iter (fun (id, decl) -> - check_well_founded_decl newenv (List.assoc id id_loc_list) (Path.Pident id) - decl to_check) + let to_check = function + | Path.Pident id -> List.mem_assoc id id_loc_list + | _ -> false + in + List.iter + (fun (id, decl) -> + check_well_founded_decl newenv + (List.assoc id id_loc_list) + (Path.Pident id) decl to_check) decls; List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls; (* Check that all type variables are closed *) List.iter2 (fun sdecl tdecl -> let decl = tdecl.typ_type in - match Ctype.closed_type_decl decl with - Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) - | None -> ()) + match Ctype.closed_type_decl decl with + | Some ty -> raise (Error (sdecl.ptype_loc, Unbound_type_var (ty, decl))) + | None -> ()) sdecl_list tdecls; (* Check that constraints are enforced *) List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) let decls = - List.map2 (fun sdecl (id, decl) -> id, name_recursion sdecl id decl) + List.map2 + (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl)) sdecl_list decls in (* Add variances to the environment *) let required = List.map (fun sdecl -> - add_injectivity (List.map snd sdecl.ptype_params), - sdecl.ptype_loc - ) + (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)) sdecl_list in let final_decls, final_env = @@ -1447,274 +1557,260 @@ let transl_type_decl env rec_flag sdecl_list = (* Keep original declaration *) let final_decls = List.map2 - (fun tdecl (_id2, decl) -> - { tdecl with typ_type = decl } - ) tdecls final_decls + (fun tdecl (_id2, decl) -> {tdecl with typ_type = decl}) + tdecls final_decls in (* Done *) (final_decls, final_env) (* Translating type extensions *) -let transl_extension_constructor env type_path type_params - typext_params priv sext = +let transl_extension_constructor env type_path type_params typext_params priv + sext = let id = Ident.create sext.pext_name.txt in let args, ret_type, kind = match sext.pext_kind with - Pext_decl(sargs, sret_type) -> - let targs, tret_type, args, ret_type, _ = - make_constructor env type_path typext_params - sargs sret_type - in - args, ret_type, Text_decl(targs, tret_type) + | Pext_decl (sargs, sret_type) -> + let targs, tret_type, args, ret_type, _ = + make_constructor env type_path typext_params sargs sret_type + in + (args, ret_type, Text_decl (targs, tret_type)) | Pext_rebind lid -> - let cdescr = Typetexp.find_constructor env lid.loc lid.txt in - let usage = - if cdescr.cstr_private = Private || priv = Public - then Env.Positive else Env.Privatize - in - Env.mark_constructor usage env (Longident.last lid.txt) cdescr; - let (args, cstr_res) = Ctype.instance_constructor cdescr in - let res, ret_type = - if cdescr.cstr_generalized then - let params = Ctype.instance_list env type_params in - let res = Ctype.newconstr type_path params in - let ret_type = Some (Ctype.newconstr type_path params) in - res, ret_type - else (Ctype.newconstr type_path typext_params), None - in - begin - try - Ctype.unify env cstr_res res - with Ctype.Unify trace -> - raise (Error(lid.loc, - Rebind_wrong_type(lid.txt, env, trace))) - end; - (* Remove "_" names from parameters used in the constructor *) - if not cdescr.cstr_generalized then begin - let vars = - Ctype.free_variables (Btype.newgenty (Ttuple args)) + let cdescr = Typetexp.find_constructor env lid.loc lid.txt in + let usage = + if cdescr.cstr_private = Private || priv = Public then Env.Positive + else Env.Privatize + in + Env.mark_constructor usage env (Longident.last lid.txt) cdescr; + let args, cstr_res = Ctype.instance_constructor cdescr in + let res, ret_type = + if cdescr.cstr_generalized then + let params = Ctype.instance_list env type_params in + let res = Ctype.newconstr type_path params in + let ret_type = Some (Ctype.newconstr type_path params) in + (res, ret_type) + else (Ctype.newconstr type_path typext_params, None) + in + (try Ctype.unify env cstr_res res + with Ctype.Unify trace -> + raise (Error (lid.loc, Rebind_wrong_type (lid.txt, env, trace)))); + (* Remove "_" names from parameters used in the constructor *) + (if not cdescr.cstr_generalized then + let vars = Ctype.free_variables (Btype.newgenty (Ttuple args)) in + List.iter + (function + | {desc = Tvar (Some "_")} as ty -> + if List.memq ty vars then ty.desc <- Tvar None + | _ -> ()) + typext_params); + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path, cstr_type_params = + match cdescr.cstr_res.desc with + | Tconstr (p, _, _) -> + let decl = Env.find_type p env in + (p, decl.type_params) + | _ -> assert false + in + let cstr_types = + Btype.newgenty (Tconstr (cstr_type_path, cstr_type_params, ref Mnil)) + :: cstr_type_params + in + let ext_types = + Btype.newgenty (Tconstr (type_path, type_params, ref Mnil)) + :: type_params + in + if not (Ctype.equal env true cstr_types ext_types) then + raise + (Error (lid.loc, Rebind_mismatch (lid.txt, cstr_type_path, type_path))); + (* Disallow rebinding private constructors to non-private *) + (match (cdescr.cstr_private, priv) with + | Private, Public -> raise (Error (lid.loc, Rebind_private lid.txt)) + | _ -> ()); + let path = + match cdescr.cstr_tag with + | Cstr_extension path -> path + | _ -> assert false + in + let args = + match cdescr.cstr_inlined with + | None -> Types.Cstr_tuple args + | Some decl -> + let tl = + match args with + | [{desc = Tconstr (_, tl, _)}] -> tl + | _ -> assert false in - List.iter - (function {desc = Tvar (Some "_")} as ty -> - if List.memq ty vars then ty.desc <- Tvar None - | _ -> ()) - typext_params - end; - (* Ensure that constructor's type matches the type being extended *) - let cstr_type_path, cstr_type_params = - match cdescr.cstr_res.desc with - Tconstr (p, _, _) -> - let decl = Env.find_type p env in - p, decl.type_params - | _ -> assert false - in - let cstr_types = - (Btype.newgenty - (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) - :: cstr_type_params - in - let ext_types = - (Btype.newgenty - (Tconstr(type_path, type_params, ref Mnil))) - :: type_params - in - if not (Ctype.equal env true cstr_types ext_types) then - raise (Error(lid.loc, - Rebind_mismatch(lid.txt, cstr_type_path, type_path))); - (* Disallow rebinding private constructors to non-private *) - begin - match cdescr.cstr_private, priv with - Private, Public -> - raise (Error(lid.loc, Rebind_private lid.txt)) - | _ -> () - end; - let path = - match cdescr.cstr_tag with - Cstr_extension(path) -> path - | _ -> assert false - in - let args = - match cdescr.cstr_inlined with - | None -> - Types.Cstr_tuple args - | Some decl -> - let tl = - match args with - | [ {desc=Tconstr(_, tl, _)} ] -> tl - | _ -> assert false - in - let decl = Ctype.instance_declaration decl in - assert (List.length decl.type_params = List.length tl); - List.iter2 (Ctype.unify env) decl.type_params tl; - let lbls = - match decl.type_kind with - | Type_record (lbls, Record_extension) -> lbls - | _ -> assert false - in - Types.Cstr_record lbls - in - args, ret_type, Text_rebind(path, lid) + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + (args, ret_type, Text_rebind (path, lid)) in let is_exception = Path.same type_path Predef.path_exn in let ext = - { Types.ext_type_path = type_path; + { + Types.ext_type_path = type_path; ext_type_params = typext_params; ext_args = args; ext_ret_type = ret_type; ext_private = priv; ext_loc = sext.pext_loc; ext_attributes = sext.pext_attributes; - ext_is_exception = is_exception; } + ext_is_exception = is_exception; + } in - { Typedtree.ext_id = id; - ext_name = sext.pext_name; - ext_type = ext; - ext_kind = kind; - ext_loc = sext.pext_loc; - ext_attributes = sext.pext_attributes; } + { + Typedtree.ext_id = id; + ext_name = sext.pext_name; + ext_type = ext; + ext_kind = kind; + ext_loc = sext.pext_loc; + ext_attributes = sext.pext_attributes; + } -let transl_extension_constructor env type_path type_params - typext_params priv sext = - Builtin_attributes.warning_scope sext.pext_attributes - (fun () -> transl_extension_constructor env type_path type_params - typext_params priv sext) +let transl_extension_constructor env type_path type_params typext_params priv + sext = + Builtin_attributes.warning_scope sext.pext_attributes (fun () -> + transl_extension_constructor env type_path type_params typext_params priv + sext) let transl_type_extension extend env loc styext = - reset_type_variables(); - Ctype.begin_def(); - let (type_path, type_decl) = + reset_type_variables (); + Ctype.begin_def (); + let type_path, type_decl = let lid = styext.ptyext_path in Typetexp.find_type env lid.loc lid.txt in - begin - match type_decl.type_kind with - | Type_open -> begin - match type_decl.type_private with - | Private when extend -> begin - match - List.find - (function {pext_kind = Pext_decl _} -> true - | {pext_kind = Pext_rebind _} -> false) - styext.ptyext_constructors - with - | {pext_loc} -> - raise (Error(pext_loc, Cannot_extend_private_type type_path)) - | exception Not_found -> () - end - | _ -> () - end - | _ -> - raise (Error(loc, Not_extensible_type type_path)) - end; + (match type_decl.type_kind with + | Type_open -> ( + match type_decl.type_private with + | Private when extend -> ( + match + List.find + (function + | {pext_kind = Pext_decl _} -> true + | {pext_kind = Pext_rebind _} -> false) + styext.ptyext_constructors + with + | {pext_loc} -> + raise (Error (pext_loc, Cannot_extend_private_type type_path)) + | exception Not_found -> ()) + | _ -> ()) + | _ -> raise (Error (loc, Not_extensible_type type_path))); let type_variance = - List.map (fun v -> - let (co, cn) = Variance.get_upper v in - (not cn, not co, false)) - type_decl.type_variance + List.map + (fun v -> + let co, cn = Variance.get_upper v in + (not cn, not co, false)) + type_decl.type_variance in let err = if type_decl.type_arity <> List.length styext.ptyext_params then [Includecore.Arity] - else - if List.for_all2 - (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1)) - type_variance - (add_injectivity (List.map snd styext.ptyext_params)) - then [] else [Includecore.Variance] + else if + List.for_all2 + (fun (c1, n1, _) (c2, n2, _) -> ((not c2) || c1) && ((not n2) || n1)) + type_variance + (add_injectivity (List.map snd styext.ptyext_params)) + then [] + else [Includecore.Variance] in - if err <> [] then - raise (Error(loc, Extension_mismatch (type_path, err))); + if err <> [] then raise (Error (loc, Extension_mismatch (type_path, err))); let ttype_params = make_params env styext.ptyext_params in let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in List.iter2 (Ctype.unify_var env) (Ctype.instance_list env type_decl.type_params) type_params; let constructors = - List.map (transl_extension_constructor env type_path - type_decl.type_params type_params styext.ptyext_private) + List.map + (transl_extension_constructor env type_path type_decl.type_params + type_params styext.ptyext_private) styext.ptyext_constructors in - Ctype.end_def(); + Ctype.end_def (); (* Generalize types *) List.iter Ctype.generalize type_params; List.iter (fun ext -> - Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; - may Ctype.generalize ext.ext_type.ext_ret_type) + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + may Ctype.generalize ext.ext_type.ext_ret_type) constructors; (* Check that all type variables are closed *) List.iter (fun ext -> - match Ctype.closed_extension_constructor ext.ext_type with - Some ty -> - raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) - | None -> ()) + match Ctype.closed_extension_constructor ext.ext_type with + | Some ty -> + raise (Error (ext.ext_loc, Unbound_type_var_ext (ty, ext.ext_type))) + | None -> ()) constructors; (* Check variances are correct *) List.iter - (fun ext-> - ignore (compute_variance_extension env true type_decl - ext.ext_type (type_variance, loc))) + (fun ext -> + ignore + (compute_variance_extension env true type_decl ext.ext_type + (type_variance, loc))) constructors; (* Add extension constructors to the environment *) let newenv = List.fold_left - (fun env ext -> - Env.add_extension ~check:true ext.ext_id ext.ext_type env) + (fun env ext -> Env.add_extension ~check:true ext.ext_id ext.ext_type env) env constructors in let tyext = - { tyext_path = type_path; + { + tyext_path = type_path; tyext_txt = styext.ptyext_path; tyext_params = ttype_params; tyext_constructors = constructors; tyext_private = styext.ptyext_private; - tyext_attributes = styext.ptyext_attributes; } + tyext_attributes = styext.ptyext_attributes; + } in - (tyext, newenv) + (tyext, newenv) let transl_type_extension extend env loc styext = - Builtin_attributes.warning_scope styext.ptyext_attributes - (fun () -> transl_type_extension extend env loc styext) + Builtin_attributes.warning_scope styext.ptyext_attributes (fun () -> + transl_type_extension extend env loc styext) let transl_exception env sext = - reset_type_variables(); - Ctype.begin_def(); + reset_type_variables (); + Ctype.begin_def (); let ext = - transl_extension_constructor env - Predef.path_exn [] [] Asttypes.Public sext + transl_extension_constructor env Predef.path_exn [] [] Asttypes.Public sext in - Ctype.end_def(); + Ctype.end_def (); (* Generalize types *) Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; may Ctype.generalize ext.ext_type.ext_ret_type; (* Check that all type variables are closed *) - begin match Ctype.closed_extension_constructor ext.ext_type with - Some ty -> - raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) - | None -> () - end; + (match Ctype.closed_extension_constructor ext.ext_type with + | Some ty -> + raise (Error (ext.ext_loc, Unbound_type_var_ext (ty, ext.ext_type))) + | None -> ()); let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in - ext, newenv - - + (ext, newenv) let rec arity_from_arrow_type env core_type ty = - match core_type.ptyp_desc, (Ctype.repr ty).desc - with + match (core_type.ptyp_desc, (Ctype.repr ty).desc) with | Ptyp_arrow (_, _, ct2), Tarrow (_, _, t2, _) -> - 1 + (arity_from_arrow_type env ct2 t2) + 1 + arity_from_arrow_type env ct2 t2 | Ptyp_arrow _, _ | _, Tarrow _ -> assert false | _ -> 0 - let parse_arity env core_type ty = match Ast_uncurried.uncurried_type_get_arity_opt ~env ty with | Some arity -> - let from_constructor = match ty.desc with - | Tconstr (_, _, _) -> not (Ast_uncurried_utils.type_is_uncurried_fun ty) - | _ -> false in + let from_constructor = + match ty.desc with + | Tconstr (_, _, _) -> not (Ast_uncurried_utils.type_is_uncurried_fun ty) + | _ -> false + in (arity, from_constructor) | None -> (arity_from_arrow_type env core_type ty, false) @@ -1723,95 +1819,108 @@ let transl_value_decl env loc valdecl = let cty = Typetexp.transl_type_scheme env valdecl.pval_type in let ty = cty.ctyp_type in let v = - match valdecl.pval_prim with - [] when Env.is_in_signature env -> - { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; - val_attributes = valdecl.pval_attributes } - | [] -> - raise (Error(valdecl.pval_loc, Val_in_structure)) - | _ -> - let arity, from_constructor = parse_arity env valdecl.pval_type ty - in + match valdecl.pval_prim with + | [] when Env.is_in_signature env -> + { + val_type = ty; + val_kind = Val_reg; + Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + } + | [] -> raise (Error (valdecl.pval_loc, Val_in_structure)) + | _ -> + let arity, from_constructor = parse_arity env valdecl.pval_type ty in let prim = Primitive.parse_declaration valdecl ~arity ~from_constructor in - let prim_native_name = prim.prim_native_name in - if prim.prim_arity = 0 && - not ( String.length prim_native_name >= 20 && - String.unsafe_get prim_native_name 0 = '\132' && - String.unsafe_get prim_native_name 1 = '\149' - ) && - (prim.prim_name = "" || (prim.prim_name.[0] <> '%' && prim.prim_name.[0] <> '#')) then - raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); - { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc; - val_attributes = valdecl.pval_attributes } + let prim_native_name = prim.prim_native_name in + if + prim.prim_arity = 0 + && (not + (String.length prim_native_name >= 20 + && String.unsafe_get prim_native_name 0 = '\132' + && String.unsafe_get prim_native_name 1 = '\149')) + && (prim.prim_name = "" + || (prim.prim_name.[0] <> '%' && prim.prim_name.[0] <> '#')) + then raise (Error (valdecl.pval_type.ptyp_loc, Null_arity_external)); + { + val_type = ty; + val_kind = Val_prim prim; + Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + } in - let (id, newenv) = - Env.enter_value valdecl.pval_name.txt v env - ~check:(fun s -> Warnings.Unused_value_declaration s) + let id, newenv = + Env.enter_value valdecl.pval_name.txt v env ~check:(fun s -> + Warnings.Unused_value_declaration s) in let desc = { - val_id = id; - val_name = valdecl.pval_name; - val_desc = cty; val_val = v; - val_prim = valdecl.pval_prim; - val_loc = valdecl.pval_loc; - val_attributes = valdecl.pval_attributes; + val_id = id; + val_name = valdecl.pval_name; + val_desc = cty; + val_val = v; + val_prim = valdecl.pval_prim; + val_loc = valdecl.pval_loc; + val_attributes = valdecl.pval_attributes; } in - desc, newenv + (desc, newenv) let transl_value_decl env loc valdecl = - Builtin_attributes.warning_scope valdecl.pval_attributes - (fun () -> transl_value_decl env loc valdecl) + Builtin_attributes.warning_scope valdecl.pval_attributes (fun () -> + transl_value_decl env loc valdecl) (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) let transl_with_constraint env id row_path orig_decl sdecl = Env.mark_type_used env (Ident.name id) orig_decl; - reset_type_variables(); - Ctype.begin_def(); + reset_type_variables (); + Ctype.begin_def (); let tparams = make_params env sdecl.ptype_params in let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in let orig_decl = Ctype.instance_declaration orig_decl in let arity_ok = List.length params = orig_decl.type_arity in - if arity_ok then - List.iter2 (Ctype.unify_var env) params orig_decl.type_params; - let constraints = List.map - (function (ty, ty', loc) -> - try - let cty = transl_simple_type env false ty in - let cty' = transl_simple_type env false ty' in - let ty = cty.ctyp_type in - let ty' = cty'.ctyp_type in - Ctype.unify env ty ty'; - (cty, cty', loc) - with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint (env, tr)))) - sdecl.ptype_cstrs + if arity_ok then List.iter2 (Ctype.unify_var env) params orig_decl.type_params; + let constraints = + List.map + (function + | ty, ty', loc -> ( + try + let cty = transl_simple_type env false ty in + let cty' = transl_simple_type env false ty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + Ctype.unify env ty ty'; + (cty, cty', loc) + with Ctype.Unify tr -> + raise (Error (loc, Inconsistent_constraint (env, tr))))) + sdecl.ptype_cstrs in let no_row = not (is_fixed_type sdecl) in - let (tman, man) = match sdecl.ptype_manifest with - None -> None, None + let tman, man = + match sdecl.ptype_manifest with + | None -> (None, None) | Some sty -> - let cty = transl_simple_type env no_row sty in - Some cty, Some cty.ctyp_type + let cty = transl_simple_type env no_row sty in + (Some cty, Some cty.ctyp_type) in let priv = - if sdecl.ptype_private = Private then Private else - if arity_ok && orig_decl.type_kind <> Type_abstract - then orig_decl.type_private else sdecl.ptype_private + if sdecl.ptype_private = Private then Private + else if arity_ok && orig_decl.type_kind <> Type_abstract then + orig_decl.type_private + else sdecl.ptype_private in - if arity_ok && orig_decl.type_kind <> Type_abstract - && sdecl.ptype_private = Private then - Location.deprecated sdecl.ptype_loc "spurious use of private"; + if + arity_ok + && orig_decl.type_kind <> Type_abstract + && sdecl.ptype_private = Private + then Location.deprecated sdecl.ptype_loc "spurious use of private"; let type_kind, type_unboxed = - if arity_ok && man <> None then - orig_decl.type_kind, orig_decl.type_unboxed - else - Type_abstract, unboxed_false_default_false + if arity_ok && man <> None then (orig_decl.type_kind, orig_decl.type_unboxed) + else (Type_abstract, unboxed_false_default_false) in let decl = - { type_params = params; + { + type_params = params; type_arity = List.length params; type_kind; type_private = priv; @@ -1824,12 +1933,12 @@ let transl_with_constraint env id row_path orig_decl sdecl = type_unboxed; } in - begin match row_path with None -> () - | Some p -> set_fixed_row env sdecl.ptype_loc p decl - end; - begin match Ctype.closed_type_decl decl with None -> () - | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) - end; + (match row_path with + | None -> () + | Some p -> set_fixed_row env sdecl.ptype_loc p decl); + (match Ctype.closed_type_decl decl with + | None -> () + | Some ty -> raise (Error (sdecl.ptype_loc, Unbound_type_var (ty, decl)))); let decl = name_recursion sdecl id decl in let type_variance = compute_variance_decl env true decl @@ -1837,7 +1946,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = in let type_immediate = compute_immediacy env decl in let decl = {decl with type_variance; type_immediate} in - Ctype.end_def(); + Ctype.end_def (); generalize_decl decl; { typ_id = id; @@ -1856,10 +1965,12 @@ let transl_with_constraint env id row_path orig_decl sdecl = let abstract_type_decl arity = let rec make_params n = - if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in - Ctype.begin_def(); + if n <= 0 then [] else Ctype.newvar () :: make_params (n - 1) + in + Ctype.begin_def (); let decl = - { type_params = make_params arity; + { + type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; type_private = Public; @@ -1870,16 +1981,17 @@ let abstract_type_decl arity = type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; - } in - Ctype.end_def(); + } + in + Ctype.end_def (); generalize_decl decl; decl let approx_type_decl sdecl_list = List.map (fun sdecl -> - (Ident.create sdecl.ptype_name.txt, - abstract_type_decl (List.length sdecl.ptype_params))) + ( Ident.create sdecl.ptype_name.txt, + abstract_type_decl (List.length sdecl.ptype_params) )) sdecl_list (* Variant of check_abbrev_recursion to check the well-formedness @@ -1888,12 +2000,10 @@ let approx_type_decl sdecl_list = let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) - let to_check path = - List.exists (fun id -> Path.isfree id path) recmod_ids in + let to_check path = List.exists (fun id -> Path.isfree id path) recmod_ids in check_well_founded_decl env loc path decl to_check; check_recursion env loc path decl to_check - (**** Error report ****) open Format @@ -1901,208 +2011,202 @@ open Format let explain_unbound_gen ppf tv tl typ kwd pr = try let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in - let ty0 = (* Hack to force aliasing when needed *) - Btype.newgenty (Tobject(tv, ref None)) in + let ty0 = + (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject (tv, ref None)) + in Printtyp.reset_and_mark_loops_list [typ ti; ty0]; - fprintf ppf - ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" - kwd pr ti Printtyp.type_expr tv + fprintf ppf ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" kwd + pr ti Printtyp.type_expr tv with Not_found -> () let explain_unbound ppf tv tl typ kwd lab = - explain_unbound_gen ppf tv tl typ kwd - (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) + explain_unbound_gen ppf tv tl typ kwd (fun ppf ti -> + fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) let explain_unbound_single ppf tv ty = let trivial ty = - explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in + explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") + in match (Ctype.repr ty).desc with - Tobject(fi,_) -> - let (tl, rv) = Ctype.flatten_fields fi in - if rv == tv then trivial ty else - explain_unbound ppf tv tl (fun (_,_,t) -> t) - "method" (fun (lab,_,_) -> lab ^ ": ") + | Tobject (fi, _) -> + let tl, rv = Ctype.flatten_fields fi in + if rv == tv then trivial ty + else + explain_unbound ppf tv tl + (fun (_, _, t) -> t) + "method" + (fun (lab, _, _) -> lab ^ ": ") | Tvariant row -> - let row = Btype.row_repr row in - if row.row_more == tv then trivial ty else + let row = Btype.row_repr row in + if row.row_more == tv then trivial ty + else explain_unbound ppf tv row.row_fields - (fun (_l,f) -> match Btype.row_field_repr f with - Rpresent (Some t) -> t - | Reither (_,[t],_,_) -> t - | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) - | _ -> Btype.newgenty (Ttuple[])) - "case" (fun (lab,_) -> "`" ^ lab ^ " of ") + (fun (_l, f) -> + match Btype.row_field_repr f with + | Rpresent (Some t) -> t + | Reither (_, [t], _, _) -> t + | Reither (_, tl, _, _) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple [])) + "case" + (fun (lab, _) -> "`" ^ lab ^ " of ") | _ -> trivial ty - let tys_of_constr_args = function | Types.Cstr_tuple tl -> tl | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls let report_error ppf = function - | Repeated_parameter -> - fprintf ppf "A type parameter occurs several times" - | Duplicate_constructor s -> - fprintf ppf "Two constructors are named %s" s + | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" + | Duplicate_constructor s -> fprintf ppf "Two constructors are named %s" s | Duplicate_label (s, None) -> - fprintf ppf "The field @{%s@} is defined several times in this record. Fields can only be added once to a record." s + fprintf ppf + "The field @{%s@} is defined several times in this record. Fields \ + can only be added once to a record." + s | Duplicate_label (s, Some record_name) -> - fprintf ppf "The field @{%s@} is defined several times in the record @{%s@}. Fields can only be added once to a record." s record_name - | Recursive_abbrev s -> - fprintf ppf "The type abbreviation %s is cyclic" s + fprintf ppf + "The field @{%s@} is defined several times in the record \ + @{%s@}. Fields can only be added once to a record." + s record_name + | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s | Cycle_in_def (s, ty) -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[The definition of %s contains a cycle:@ %a@]" - s Printtyp.type_expr ty + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[The definition of %s contains a cycle:@ %a@]" s + Printtyp.type_expr ty | Definition_mismatch (ty, errs) -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" - "This variant or record definition" "does not match that of type" - Printtyp.type_expr ty - (Includecore.report_type_mismatch "the original" "this" "definition") - errs + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This variant or record definition" "does not match that of type" + Printtyp.type_expr ty + (Includecore.report_type_mismatch "the original" "this" "definition") + errs | Constraint_failed (ty, ty') -> - Printtyp.reset_and_mark_loops ty; - Printtyp.mark_loops ty'; - fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" - "Constraints are not satisfied in this type." - Printtyp.type_expr ty Printtyp.type_expr ty' + Printtyp.reset_and_mark_loops ty; + Printtyp.mark_loops ty'; + fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" + "Constraints are not satisfied in this type." Printtyp.type_expr ty + Printtyp.type_expr ty' | Parameters_differ (path, ty, ty') -> - Printtyp.reset_and_mark_loops ty; - Printtyp.mark_loops ty'; - fprintf ppf - "@[In the definition of %s, type@ %a@ should be@ %a@]" - (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' + Printtyp.reset_and_mark_loops ty; + Printtyp.mark_loops ty'; + fprintf ppf "@[In the definition of %s, type@ %a@ should be@ %a@]" + (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' | Inconsistent_constraint (env, trace) -> - fprintf ppf "The type constraints are not consistent.@."; - Printtyp.report_unification_error ppf env trace - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") + fprintf ppf "The type constraints are not consistent.@."; + Printtyp.report_unification_error ppf env trace + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") | Type_clash (env, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This type constructor expands to type") - (function ppf -> - fprintf ppf "but is used here with type") - | Null_arity_external -> - fprintf ppf "External identifiers must be functions" - | Unbound_type_var (ty, decl) -> - fprintf ppf "A type variable is unbound in this type declaration"; - let ty = Ctype.repr ty in - begin match decl.type_kind, decl.type_manifest with - | Type_variant tl, _ -> - explain_unbound_gen ppf ty tl (fun c -> - let tl = tys_of_constr_args c.Types.cd_args in - Btype.newgenty (Ttuple tl) - ) - "case" (fun ppf c -> - fprintf ppf - "%s of %a" (Ident.name c.Types.cd_id) - Printtyp.constructor_arguments c.Types.cd_args) - | Type_record (tl, _), _ -> - explain_unbound ppf ty tl (fun l -> l.Types.ld_type) - "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") - | Type_abstract, Some ty' -> - explain_unbound_single ppf ty ty' - | _ -> () - end + Printtyp.report_unification_error ppf env trace + (function + | ppf -> fprintf ppf "This type constructor expands to type") + (function + | ppf -> fprintf ppf "but is used here with type") + | Null_arity_external -> fprintf ppf "External identifiers must be functions" + | Unbound_type_var (ty, decl) -> ( + fprintf ppf "A type variable is unbound in this type declaration"; + let ty = Ctype.repr ty in + match (decl.type_kind, decl.type_manifest) with + | Type_variant tl, _ -> + explain_unbound_gen ppf ty tl + (fun c -> + let tl = tys_of_constr_args c.Types.cd_args in + Btype.newgenty (Ttuple tl)) + "case" + (fun ppf c -> + fprintf ppf "%s of %a" (Ident.name c.Types.cd_id) + Printtyp.constructor_arguments c.Types.cd_args) + | Type_record (tl, _), _ -> + explain_unbound ppf ty tl + (fun l -> l.Types.ld_type) + "field" + (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' + | _ -> ()) | Unbound_type_var_ext (ty, ext) -> - fprintf ppf "A type variable is unbound in this extension constructor"; - let args = tys_of_constr_args ext.ext_args in - explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") + fprintf ppf "A type variable is unbound in this extension constructor"; + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") | Cannot_extend_private_type path -> - fprintf ppf "@[%s@ %a@]" - "Cannot extend private type definition" - Printtyp.path path + fprintf ppf "@[%s@ %a@]" "Cannot extend private type definition" + Printtyp.path path | Not_extensible_type path -> - fprintf ppf "@[%s@ %a@ %s@]" - "Type definition" - Printtyp.path path - "is not extensible" + fprintf ppf "@[%s@ %a@ %s@]" "Type definition" Printtyp.path path + "is not extensible" | Extension_mismatch (path, errs) -> - fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" - "This extension" "does not match the definition of type" - (Path.name path) - (Includecore.report_type_mismatch - "the type" "this extension" "definition") - errs + fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" "This extension" + "does not match the definition of type" (Path.name path) + (Includecore.report_type_mismatch "the type" "this extension" "definition") + errs | Rebind_wrong_type (lid, env, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The constructor %a@ has type" - Printtyp.longident lid) - (function ppf -> - fprintf ppf "but was expected to be of type") + Printtyp.report_unification_error ppf env trace + (function + | ppf -> + fprintf ppf "The constructor %a@ has type" Printtyp.longident lid) + (function + | ppf -> fprintf ppf "but was expected to be of type") | Rebind_mismatch (lid, p, p') -> - fprintf ppf - "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]" - "The constructor" Printtyp.longident lid - "extends type" (Path.name p) - "whose declaration does not match" - "the declaration of type" (Path.name p') + fprintf ppf "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]" "The constructor" + Printtyp.longident lid "extends type" (Path.name p) + "whose declaration does not match" "the declaration of type" + (Path.name p') | Rebind_private lid -> - fprintf ppf "@[%s@ %a@ %s@]" - "The constructor" - Printtyp.longident lid - "is private" + fprintf ppf "@[%s@ %a@ %s@]" "The constructor" Printtyp.longident lid + "is private" | Bad_variance (n, v1, v2) -> - let variance (p,n,i) = - let inj = if i then "injective " else "" in - match p, n with - true, true -> inj ^ "invariant" - | true, false -> inj ^ "covariant" - | false, true -> inj ^ "contravariant" - | false, false -> if inj = "" then "unrestricted" else inj - in - let suffix n = - let teen = (n mod 100)/10 = 1 in - match n mod 10 with - | 1 when not teen -> "st" - | 2 when not teen -> "nd" - | 3 when not teen -> "rd" - | _ -> "th" - in - if n = -1 then - fprintf ppf "@[%s@ %s@ It" - "In this definition, a type variable has a variance that" - "is not reflected by its occurrence in type parameters." - else if n = -2 then - fprintf ppf "@[%s@ %s@]" - "In this definition, a type variable cannot be deduced" - "from the type parameters." - else if n = -3 then - fprintf ppf "@[%s@ %s@ It" - "In this definition, a type variable has a variance that" - "cannot be deduced from the type parameters." - else - fprintf ppf "@[%s@ %s@ The %d%s type parameter" - "In this definition, expected parameter" - "variances are not satisfied." - n (suffix n); - if n <> -2 then - fprintf ppf " was expected to be %s,@ but it is %s.@]" - (variance v2) (variance v1) + let variance (p, n, i) = + let inj = if i then "injective " else "" in + match (p, n) with + | true, true -> inj ^ "invariant" + | true, false -> inj ^ "covariant" + | false, true -> inj ^ "contravariant" + | false, false -> if inj = "" then "unrestricted" else inj + in + let suffix n = + let teen = n mod 100 / 10 = 1 in + match n mod 10 with + | 1 when not teen -> "st" + | 2 when not teen -> "nd" + | 3 when not teen -> "rd" + | _ -> "th" + in + if n = -1 then + fprintf ppf "@[%s@ %s@ It" + "In this definition, a type variable has a variance that" + "is not reflected by its occurrence in type parameters." + else if n = -2 then + fprintf ppf "@[%s@ %s@]" + "In this definition, a type variable cannot be deduced" + "from the type parameters." + else if n = -3 then + fprintf ppf "@[%s@ %s@ It" + "In this definition, a type variable has a variance that" + "cannot be deduced from the type parameters." + else + fprintf ppf "@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" "variances are not satisfied." + n (suffix n); + if n <> -2 then + fprintf ppf " was expected to be %s,@ but it is %s.@]" (variance v2) + (variance v1) | Unavailable_type_constructor p -> - fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p - | Bad_fixed_type r -> - fprintf ppf "This fixed type %s" r + fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p + | Bad_fixed_type r -> fprintf ppf "This fixed type %s" r | Varying_anonymous -> - fprintf ppf "@[%s@ %s@ %s@]" - "In this GADT definition," "the variance of some parameter" - "cannot be checked" + fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," + "the variance of some parameter" "cannot be checked" | Val_in_structure -> - fprintf ppf "Value declarations are only allowed in signatures" + fprintf ppf "Value declarations are only allowed in signatures" | Bad_immediate_attribute -> - fprintf ppf "@[%s@ %s@]" - "Types marked with the immediate attribute must be" - "non-pointer types like int or bool" + fprintf ppf "@[%s@ %s@]" "Types marked with the immediate attribute must be" + "non-pointer types like int or bool" | Bad_unboxed_attribute msg -> - fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg + fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg | Boxed_and_unboxed -> - fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" + fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" | Nonrec_gadt -> - fprintf ppf - "@[GADT case syntax cannot be used in a 'nonrec' block.@]" + fprintf ppf "@[GADT case syntax cannot be used in a 'nonrec' block.@]" | Variant_runtime_representation_mismatch (Variant_coercion.VariantError {is_spread_context; error = Variant_coercion.Untagged {left_is_unboxed}}) @@ -2125,26 +2229,31 @@ let report_error ppf = function in fprintf ppf "@[%s.@]" ("The @tag attribute does not match for this variant and " - ^ other_variant_text - ^ ". Both variants must have the same @tag attribute configuration, or no \ + ^ other_variant_text + ^ ". Both variants must have the same @tag attribute configuration, or no \ @tag attribute at all") | Variant_spread_fail Variant_type_spread.InvalidType -> - fprintf ppf "@[This type is not a valid type to spread. It's only possible to spread other variants.@]" + fprintf ppf + "@[This type is not a valid type to spread. It's only possible to spread \ + other variants.@]" | Variant_spread_fail Variant_type_spread.CouldNotFindType -> - fprintf ppf "@[This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions.@]" + fprintf ppf + "@[This type could not be found. It's only possible to spread variants \ + that are known as the spread happens. This means for example that you \ + can't spread variants in recursive definitions.@]" | Variant_spread_fail Variant_type_spread.HasTypeParams -> fprintf ppf "@[Type parameters are not supported in variant type spreads.@]" - | Variant_spread_fail Variant_type_spread.DuplicateConstructor - {variant_with_overlapping_constructor; overlapping_constructor_name} -> - fprintf ppf "@[Variant %s has a constructor named %s, but a constructor named %s already exists in the variant it's spread into.@ You cannot spread variants with overlapping constructors.@]" - variant_with_overlapping_constructor overlapping_constructor_name overlapping_constructor_name - + | Variant_spread_fail + (Variant_type_spread.DuplicateConstructor + {variant_with_overlapping_constructor; overlapping_constructor_name}) -> + fprintf ppf + "@[Variant %s has a constructor named %s, but a constructor named %s \ + already exists in the variant it's spread into.@ You cannot spread \ + variants with overlapping constructors.@]" + variant_with_overlapping_constructor overlapping_constructor_name + overlapping_constructor_name let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer loc report_error err) - | _ -> - None - ) + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) diff --git a/compiler/ml/typedecl.mli b/compiler/ml/typedecl.mli index 7e76d3e32f..5b8f6b7030 100644 --- a/compiler/ml/typedecl.mli +++ b/compiler/ml/typedecl.mli @@ -18,46 +18,55 @@ open Types open Format -val transl_type_decl: - Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> - Typedtree.type_declaration list * Env.t - -val transl_exception: - Env.t -> - Parsetree.extension_constructor -> Typedtree.extension_constructor * Env.t - -val transl_type_extension: - bool -> Env.t -> Location.t -> Parsetree.type_extension -> - Typedtree.type_extension * Env.t - -val transl_value_decl: - Env.t -> Location.t -> - Parsetree.value_description -> Typedtree.value_description * Env.t - -val transl_with_constraint: - Env.t -> Ident.t -> Path.t option -> Types.type_declaration -> - Parsetree.type_declaration -> Typedtree.type_declaration - -val abstract_type_decl: int -> type_declaration -val approx_type_decl: - Parsetree.type_declaration list -> - (Ident.t * type_declaration) list -val check_recmod_typedecl: - Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit -val check_coherence: - Env.t -> Location.t -> Ident.t -> type_declaration -> unit +val transl_type_decl : + Env.t -> + Asttypes.rec_flag -> + Parsetree.type_declaration list -> + Typedtree.type_declaration list * Env.t + +val transl_exception : + Env.t -> + Parsetree.extension_constructor -> + Typedtree.extension_constructor * Env.t + +val transl_type_extension : + bool -> + Env.t -> + Location.t -> + Parsetree.type_extension -> + Typedtree.type_extension * Env.t + +val transl_value_decl : + Env.t -> + Location.t -> + Parsetree.value_description -> + Typedtree.value_description * Env.t + +val transl_with_constraint : + Env.t -> + Ident.t -> + Path.t option -> + Types.type_declaration -> + Parsetree.type_declaration -> + Typedtree.type_declaration + +val abstract_type_decl : int -> type_declaration +val approx_type_decl : + Parsetree.type_declaration list -> (Ident.t * type_declaration) list +val check_recmod_typedecl : + Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +val check_coherence : Env.t -> Location.t -> Ident.t -> type_declaration -> unit (* for fixed types *) val is_fixed_type : Parsetree.type_declaration -> bool (* for typeopt.ml *) -val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option - +val get_unboxed_type_representation : Env.t -> type_expr -> type_expr option type native_repr_kind = Unboxed | Untagged -type error +type error exception Error of Location.t * error -val report_error: formatter -> error -> unit +val report_error : formatter -> error -> unit diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 3cc1b9bbc4..82b447d63e 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -26,14 +26,14 @@ type partial = Partial | Total type attribute = Parsetree.attribute type attributes = attribute list -type pattern = - { pat_desc: pattern_desc; - pat_loc: Location.t; - pat_extra : (pat_extra * Location.t * attribute list) list; - pat_type: type_expr; - mutable pat_env: Env.t; - pat_attributes: attribute list; - } +type pattern = { + pat_desc: pattern_desc; + pat_loc: Location.t; + pat_extra: (pat_extra * Location.t * attribute list) list; + pat_type: type_expr; + mutable pat_env: Env.t; + pat_attributes: attribute list; +} and pat_extra = | Tpat_constraint of core_type @@ -42,29 +42,27 @@ and pat_extra = | Tpat_unpack and pattern_desc = - Tpat_any + | Tpat_any | Tpat_var of Ident.t * string loc | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list - | Tpat_construct of - Longident.t loc * constructor_description * pattern list + | Tpat_construct of Longident.t loc * constructor_description * pattern list | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of - (Longident.t loc * label_description * pattern) list * - closed_flag + (Longident.t loc * label_description * pattern) list * closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern -and expression = - { exp_desc: expression_desc; - exp_loc: Location.t; - exp_extra: (exp_extra * Location.t * attribute list) list; - exp_type: type_expr; - exp_env: Env.t; - exp_attributes: attribute list; - } +and expression = { + exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attribute list) list; + exp_type: type_expr; + exp_env: Env.t; + exp_attributes: attribute list; +} and exp_extra = | Texp_constraint of core_type @@ -74,11 +72,15 @@ and exp_extra = | Texp_newtype of string and expression_desc = - Texp_ident of Path.t * Longident.t loc * Types.value_description + | Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * value_binding list * expression - | Texp_function of { arg_label : arg_label; param : Ident.t; - cases : case list; partial : partial; } + | Texp_function of { + arg_label: arg_label; + param: Ident.t; + cases: case list; + partial: partial; + } | Texp_apply of expression * (arg_label * expression option) list | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list @@ -87,9 +89,9 @@ and expression_desc = Longident.t loc * constructor_description * expression list | Texp_variant of label * expression option | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; - representation : Types.record_representation; - extended_expression : expression option; + fields: (Types.label_description * record_label_definition) array; + representation: Types.record_representation; + extended_expression: expression option; } | Texp_field of expression * Longident.t loc * label_description | Texp_setfield of @@ -99,8 +101,12 @@ and expression_desc = | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of - Ident.t * Parsetree.pattern * expression * expression * direction_flag * - expression + Ident.t + * Parsetree.pattern + * expression + * expression + * direction_flag + * expression | Texp_send of expression * meth * expression option | Texp_new of unit | Texp_instvar of unit @@ -115,15 +121,9 @@ and expression_desc = | Texp_unreachable | Texp_extension_constructor of Longident.t loc * Path.t -and meth = - Tmeth_name of string +and meth = Tmeth_name of string -and case = - { - c_lhs: pattern; - c_guard: expression option; - c_rhs: expression; - } +and case = {c_lhs: pattern; c_guard: expression option; c_rhs: expression} and record_label_definition = | Kept of Types.type_expr @@ -131,26 +131,21 @@ and record_label_definition = (* Value expressions for the class language *) - - - - (* Value expressions for the module language *) - -and module_expr = - { mod_desc: module_expr_desc; - mod_loc: Location.t; - mod_type: Types.module_type; - mod_env: Env.t; - mod_attributes: attribute list; - } +and module_expr = { + mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attribute list; +} and module_type_constraint = - Tmodtype_implicit -| Tmodtype_explicit of module_type + | Tmodtype_implicit + | Tmodtype_explicit of module_type and module_expr_desc = - Tmod_ident of Path.t * Longident.t loc + | Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure | Tmod_functor of Ident.t * string loc * module_type option * module_expr | Tmod_apply of module_expr * module_expr * module_coercion @@ -159,19 +154,19 @@ and module_expr_desc = | Tmod_unpack of expression * Types.module_type and structure = { - str_items : structure_item list; - str_type : Types.signature; - str_final_env : Env.t; + str_items: structure_item list; + str_type: Types.signature; + str_final_env: Env.t; } -and structure_item = - { str_desc : structure_item_desc; - str_loc : Location.t; - str_env : Env.t - } +and structure_item = { + str_desc: structure_item_desc; + str_loc: Location.t; + str_env: Env.t; +} and structure_item_desc = - Tstr_eval of expression * attributes + | Tstr_eval of expression * attributes | Tstr_value of rec_flag * value_binding list | Tstr_primitive of value_description | Tstr_type of rec_flag * type_declaration list @@ -186,42 +181,41 @@ and structure_item_desc = | Tstr_include of include_declaration | Tstr_attribute of attribute -and module_binding = - { - mb_id: Ident.t; - mb_name: string loc; - mb_expr: module_expr; - mb_attributes: attribute list; - mb_loc: Location.t; - } +and module_binding = { + mb_id: Ident.t; + mb_name: string loc; + mb_expr: module_expr; + mb_attributes: attribute list; + mb_loc: Location.t; +} -and value_binding = - { - vb_pat: pattern; - vb_expr: expression; - vb_attributes: attributes; - vb_loc: Location.t; - } +and value_binding = { + vb_pat: pattern; + vb_expr: expression; + vb_attributes: attributes; + vb_loc: Location.t; +} and module_coercion = - Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list * - (Ident.t * int * module_coercion) list * - string list (* runtime fields *) + | Tcoerce_none + | Tcoerce_structure of + (int * module_coercion) list + * (Ident.t * int * module_coercion) list + * string list (* runtime fields *) | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of primitive_coercion | Tcoerce_alias of Path.t * module_coercion -and module_type = - { mty_desc: module_type_desc; - mty_type : Types.module_type; - mty_env : Env.t; - mty_loc: Location.t; - mty_attributes: attribute list; - } +and module_type = { + mty_desc: module_type_desc; + mty_type: Types.module_type; + mty_env: Env.t; + mty_loc: Location.t; + mty_attributes: attribute list; +} and module_type_desc = - Tmty_ident of Path.t * Longident.t loc + | Tmty_ident of Path.t * Longident.t loc | Tmty_signature of signature | Tmty_functor of Ident.t * string loc * module_type option * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list @@ -229,28 +223,28 @@ and module_type_desc = | Tmty_alias of Path.t * Longident.t loc (* Keep primitive type information for type-based lambda-code specialization *) -and primitive_coercion = - { - pc_desc: Primitive.description; - pc_type: type_expr; - pc_env: Env.t; - pc_loc : Location.t; - pc_id : Ident.t; (*RE:Added *) - } +and primitive_coercion = { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc: Location.t; + pc_id: Ident.t; (*RE:Added *) +} and signature = { - sig_items : signature_item list; - sig_type : Types.signature; - sig_final_env : Env.t; + sig_items: signature_item list; + sig_type: Types.signature; + sig_final_env: Env.t; } -and signature_item = - { sig_desc: signature_item_desc; - sig_env : Env.t; (* BINANNOT ADDED *) - sig_loc: Location.t } +and signature_item = { + sig_desc: signature_item_desc; + sig_env: Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t; +} and signature_item_desc = - Tsig_value of value_description + | Tsig_value of value_description | Tsig_type of rec_flag * type_declaration list | Tsig_typext of type_extension | Tsig_exception of extension_constructor @@ -263,62 +257,58 @@ and signature_item_desc = | Tsig_class_type of unit | Tsig_attribute of attribute -and module_declaration = - { - md_id: Ident.t; - md_name: string loc; - md_type: module_type; - md_attributes: attribute list; - md_loc: Location.t; - } +and module_declaration = { + md_id: Ident.t; + md_name: string loc; + md_type: module_type; + md_attributes: attribute list; + md_loc: Location.t; +} -and module_type_declaration = - { - mtd_id: Ident.t; - mtd_name: string loc; - mtd_type: module_type option; - mtd_attributes: attribute list; - mtd_loc: Location.t; - } +and module_type_declaration = { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_type: module_type option; + mtd_attributes: attribute list; + mtd_loc: Location.t; +} -and open_description = - { - open_path: Path.t; - open_txt: Longident.t loc; - open_override: override_flag; - open_loc: Location.t; - open_attributes: attribute list; - } +and open_description = { + open_path: Path.t; + open_txt: Longident.t loc; + open_override: override_flag; + open_loc: Location.t; + open_attributes: attribute list; +} -and 'a include_infos = - { - incl_mod: 'a; - incl_type: Types.signature; - incl_loc: Location.t; - incl_attributes: attribute list; - } +and 'a include_infos = { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; +} and include_description = module_type include_infos and include_declaration = module_expr include_infos and with_constraint = - Twith_type of type_declaration + | Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc -and core_type = -(* mutable because of [Typeclass.declare_method] *) - { mutable ctyp_desc : core_type_desc; - mutable ctyp_type : type_expr; - ctyp_env : Env.t; (* BINANNOT ADDED *) - ctyp_loc : Location.t; - ctyp_attributes: attribute list; - } +and core_type = { + (* mutable because of [Typeclass.declare_method] *) + mutable ctyp_desc: core_type_desc; + mutable ctyp_type: type_expr; + ctyp_env: Env.t; (* BINANNOT ADDED *) + ctyp_loc: Location.t; + ctyp_attributes: attribute list; +} and core_type_desc = - Ttyp_any + | Ttyp_any | Ttyp_var of string | Ttyp_arrow of arg_label * core_type * core_type | Ttyp_tuple of core_type list @@ -331,147 +321,135 @@ and core_type_desc = | Ttyp_package of package_type and package_type = { - pack_path : Path.t; - pack_fields : (Longident.t loc * core_type) list; - pack_type : Types.module_type; - pack_txt : Longident.t loc; + pack_path: Path.t; + pack_fields: (Longident.t loc * core_type) list; + pack_type: Types.module_type; + pack_txt: Longident.t loc; } and row_field = - Ttag of string loc * attributes * bool * core_type list + | Ttag of string loc * attributes * bool * core_type list | Tinherit of core_type and object_field = | OTtag of string loc * attributes * core_type | OTinherit of core_type -and value_description = - { val_id: Ident.t; - val_name: string loc; - val_desc: core_type; - val_val: Types.value_description; - val_prim: string list; - val_loc: Location.t; - val_attributes: attribute list; - } +and value_description = { + val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attribute list; +} -and type_declaration = - { typ_id: Ident.t; - typ_name: string loc; - typ_params: (core_type * variance) list; - typ_type: Types.type_declaration; - typ_cstrs: (core_type * core_type * Location.t) list; - typ_kind: type_kind; - typ_private: private_flag; - typ_manifest: core_type option; - typ_loc: Location.t; - typ_attributes: attribute list; - } +and type_declaration = { + typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * variance) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attribute list; +} and type_kind = - Ttype_abstract + | Ttype_abstract | Ttype_variant of constructor_declaration list | Ttype_record of label_declaration list | Ttype_open -and label_declaration = - { - ld_id: Ident.t; - ld_name: string loc; - ld_mutable: mutable_flag; - ld_type: core_type; - ld_loc: Location.t; - ld_attributes: attribute list; - } +and label_declaration = { + ld_id: Ident.t; + ld_name: string loc; + ld_mutable: mutable_flag; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attribute list; +} -and constructor_declaration = - { - cd_id: Ident.t; - cd_name: string loc; - cd_args: constructor_arguments; - cd_res: core_type option; - cd_loc: Location.t; - cd_attributes: attribute list; - } +and constructor_declaration = { + cd_id: Ident.t; + cd_name: string loc; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attribute list; +} and constructor_arguments = | Cstr_tuple of core_type list | Cstr_record of label_declaration list -and type_extension = - { - tyext_path: Path.t; - tyext_txt: Longident.t loc; - tyext_params: (core_type * variance) list; - tyext_constructors: extension_constructor list; - tyext_private: private_flag; - tyext_attributes: attribute list; - } - -and extension_constructor = - { - ext_id: Ident.t; - ext_name: string loc; - ext_type: Types.extension_constructor; - ext_kind: extension_constructor_kind; - ext_loc: Location.t; - ext_attributes: attribute list; - } +and type_extension = { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * variance) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_attributes: attribute list; +} + +and extension_constructor = { + ext_id: Ident.t; + ext_name: string loc; + ext_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; + ext_attributes: attribute list; +} and extension_constructor_kind = - Text_decl of constructor_arguments * core_type option + | Text_decl of constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc (* Auxiliary functions over the a.s.t. *) let iter_pattern_desc f = function - | Tpat_alias(p, _, _) -> f p + | Tpat_alias (p, _, _) -> f p | Tpat_tuple patl -> List.iter f patl - | Tpat_construct(_, _, patl) -> List.iter f patl - | Tpat_variant(_, pat, _) -> may f pat + | Tpat_construct (_, _, patl) -> List.iter f patl + | Tpat_variant (_, pat, _) -> may f pat | Tpat_record (lbl_pat_list, _) -> - List.iter (fun (_, _, pat) -> f pat) lbl_pat_list + List.iter (fun (_, _, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl - | Tpat_or(p1, p2, _) -> f p1; f p2 + | Tpat_or (p1, p2, _) -> + f p1; + f p2 | Tpat_lazy p -> f p - | Tpat_any - | Tpat_var _ - | Tpat_constant _ -> () + | Tpat_any | Tpat_var _ | Tpat_constant _ -> () let map_pattern_desc f d = match d with - | Tpat_alias (p1, id, s) -> - Tpat_alias (f p1, id, s) - | Tpat_tuple pats -> - Tpat_tuple (List.map f pats) + | Tpat_alias (p1, id, s) -> Tpat_alias (f p1, id, s) + | Tpat_tuple pats -> Tpat_tuple (List.map f pats) | Tpat_record (lpats, closed) -> - Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed) - | Tpat_construct (lid, c,pats) -> - Tpat_construct (lid, c, List.map f pats) - | Tpat_array pats -> - Tpat_array (List.map f pats) + Tpat_record (List.map (fun (lid, l, p) -> (lid, l, f p)) lpats, closed) + | Tpat_construct (lid, c, pats) -> Tpat_construct (lid, c, List.map f pats) + | Tpat_array pats -> Tpat_array (List.map f pats) | Tpat_lazy p1 -> Tpat_lazy (f p1) - | Tpat_variant (x1, Some p1, x2) -> - Tpat_variant (x1, Some (f p1), x2) - | Tpat_or (p1,p2,path) -> - Tpat_or (f p1, f p2, path) - | Tpat_var _ - | Tpat_constant _ - | Tpat_any - | Tpat_variant (_,None,_) -> d + | Tpat_variant (x1, Some p1, x2) -> Tpat_variant (x1, Some (f p1), x2) + | Tpat_or (p1, p2, path) -> Tpat_or (f p1, f p2, path) + | Tpat_var _ | Tpat_constant _ | Tpat_any | Tpat_variant (_, None, _) -> d (* List the identifiers bound by a pattern or a let *) -let idents = ref([]: (Ident.t * string loc) list) +let idents = ref ([] : (Ident.t * string loc) list) let rec bound_idents pat = match pat.pat_desc with - | Tpat_var (id,s) -> idents := (id,s) :: !idents - | Tpat_alias(p, id, s ) -> - bound_idents p; idents := (id,s) :: !idents - | Tpat_or(p1, _, _) -> - (* Invariant : both arguments binds the same variables *) - bound_idents p1 + | Tpat_var (id, s) -> idents := (id, s) :: !idents + | Tpat_alias (p, id, s) -> + bound_idents p; + idents := (id, s) :: !idents + | Tpat_or (p1, _, _) -> + (* Invariant : both arguments binds the same variables *) + bound_idents p1 | d -> iter_pattern_desc bound_idents d let pat_bound_idents pat = @@ -484,30 +462,32 @@ let pat_bound_idents pat = let rev_let_bound_idents_with_loc bindings = idents := []; List.iter (fun vb -> bound_idents vb.vb_pat) bindings; - let res = !idents in idents := []; res + let res = !idents in + idents := []; + res let let_bound_idents_with_loc pat_expr_list = - List.rev(rev_let_bound_idents_with_loc pat_expr_list) + List.rev (rev_let_bound_idents_with_loc pat_expr_list) let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat) -let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) +let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) let alpha_var env id = List.assoc id env -let rec alpha_pat env p = match p.pat_desc with -| Tpat_var (id, s) -> (* note the ``Not_found'' case *) - {p with pat_desc = - try Tpat_var (alpha_var env id, s) with - | Not_found -> Tpat_any} -| Tpat_alias (p1, id, s) -> - let new_p = alpha_pat env p1 in - begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} - with - | Not_found -> new_p - end -| d -> - {p with pat_desc = map_pattern_desc (alpha_pat env) d} +let rec alpha_pat env p = + match p.pat_desc with + | Tpat_var (id, s) -> + (* note the ``Not_found'' case *) + { + p with + pat_desc = + (try Tpat_var (alpha_var env id, s) with Not_found -> Tpat_any); + } + | Tpat_alias (p1, id, s) -> ( + let new_p = alpha_pat env p1 in + try {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} + with Not_found -> new_p) + | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d} let mkloc = Location.mkloc let mknoloc = Location.mknoloc diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 60eea19bc4..97d546dccf 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -15,7 +15,6 @@ (** Abstract syntax tree after typing *) - (** By comparison with {!Parsetree}: - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. @@ -35,22 +34,22 @@ type attributes = attribute list (** {1 Core language} *) -type pattern = - { pat_desc: pattern_desc; - pat_loc: Location.t; - pat_extra : (pat_extra * Location.t * attributes) list; - pat_type: type_expr; - mutable pat_env: Env.t; - pat_attributes: attributes; - } +type pattern = { + pat_desc: pattern_desc; + pat_loc: Location.t; + pat_extra: (pat_extra * Location.t * attributes) list; + pat_type: type_expr; + mutable pat_env: Env.t; + pat_attributes: attributes; +} and pat_extra = | Tpat_constraint of core_type - (** P : T { pat_desc = P + (** P : T { pat_desc = P ; pat_extra = (Tpat_constraint T, _, _) :: ... } *) | Tpat_type of Path.t * Longident.t loc - (** #tconst { pat_desc = disjunction + (** #tconst { pat_desc = disjunction ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...} where [disjunction] is a [Tpat_or _] representing the @@ -58,93 +57,85 @@ and pat_extra = *) | Tpat_open of Path.t * Longident.t loc * Env.t | Tpat_unpack - (** (module P) { pat_desc = Tpat_var "P" + (** (module P) { pat_desc = Tpat_var "P" ; pat_extra = (Tpat_unpack, _, _) :: ... } *) and pattern_desc = - Tpat_any - (** _ *) - | Tpat_var of Ident.t * string loc - (** x *) - | Tpat_alias of pattern * Ident.t * string loc - (** P as a *) - | Tpat_constant of constant - (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Tpat_any (** _ *) + | Tpat_var of Ident.t * string loc (** x *) + | Tpat_alias of pattern * Ident.t * string loc (** P as a *) + | Tpat_constant of constant (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Tpat_tuple of pattern list - (** (P1, ..., Pn) + (** (P1, ..., Pn) Invariant: n >= 2 *) - | Tpat_construct of - Longident.t loc * constructor_description * pattern list - (** C [] + | Tpat_construct of Longident.t loc * constructor_description * pattern list + (** C [] C P [P] C (P1, ..., Pn) [P1; ...; Pn] *) | Tpat_variant of label * pattern option * row_desc ref - (** `A (None) + (** `A (None) `A P (Some P) See {!Types.row_desc} for an explanation of the last parameter. *) | Tpat_record of - (Longident.t loc * label_description * pattern) list * - closed_flag - (** { l1=P1; ...; ln=Pn } (flag = Closed) + (Longident.t loc * label_description * pattern) list * closed_flag + (** { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) Invariant: n > 0 *) - | Tpat_array of pattern list - (** [| P1; ...; Pn |] *) + | Tpat_array of pattern list (** [| P1; ...; Pn |] *) | Tpat_or of pattern * pattern * row_desc option - (** P1 | P2 + (** P1 | P2 [row_desc] = [Some _] when translating [Ppat_type _], [None] otherwise. *) - | Tpat_lazy of pattern - (** lazy P *) - -and expression = - { exp_desc: expression_desc; - exp_loc: Location.t; - exp_extra: (exp_extra * Location.t * attributes) list; - exp_type: type_expr; - exp_env: Env.t; - exp_attributes: attributes; - } + | Tpat_lazy of pattern (** lazy P *) + +and expression = { + exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attributes) list; + exp_type: type_expr; + exp_env: Env.t; + exp_attributes: attributes; +} and exp_extra = - | Texp_constraint of core_type - (** E : T *) + | Texp_constraint of core_type (** E : T *) | Texp_coerce of unit * core_type - (** E :> T [Texp_coerce T] + (** E :> T [Texp_coerce T] *) | Texp_open of override_flag * Path.t * Longident.t loc * Env.t - (** let open[!] M in [Texp_open (!, P, M, env)] + (** let open[!] M in [Texp_open (!, P, M, env)] where [env] is the environment after opening [P] *) - | Texp_poly of core_type option - (** Used for method bodies. *) - | Texp_newtype of string - (** fun (type t) -> *) + | Texp_poly of core_type option (** Used for method bodies. *) + | Texp_newtype of string (** fun (type t) -> *) and expression_desc = - Texp_ident of Path.t * Longident.t loc * Types.value_description - (** x + | Texp_ident of Path.t * Longident.t loc * Types.value_description + (** x M.x *) - | Texp_constant of constant - (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Texp_constant of constant (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Texp_let of rec_flag * value_binding list * expression - (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) *) - | Texp_function of { arg_label : arg_label; param : Ident.t; - cases : case list; partial : partial; } - (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. + | Texp_function of { + arg_label: arg_label; + param: Ident.t; + cases: case list; + partial: partial; + } + (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. See {!Parsetree} for more details. [param] is the identifier that is to be used to name the @@ -155,7 +146,7 @@ and expression_desc = [Total] otherwise. *) | Texp_apply of expression * (arg_label * expression option) list - (** E0 ~l1:E1 ... ~ln:En + (** E0 ~l1:E1 ... ~ln:En The expression can be None if the expression is abstracted over this argument. It currently appears when a label is applied. @@ -171,7 +162,7 @@ and expression_desc = ]) *) | Texp_match of expression * case list * case list * partial - (** match E0 with + (** match E0 with | P1 -> E1 | P2 -> E2 | exception P3 -> E3 @@ -179,22 +170,21 @@ and expression_desc = [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)] *) | Texp_try of expression * case list - (** try E with P1 -> E1 | ... | PN -> EN *) - | Texp_tuple of expression list - (** (E1, ..., EN) *) + (** try E with P1 -> E1 | ... | PN -> EN *) + | Texp_tuple of expression list (** (E1, ..., EN) *) | Texp_construct of Longident.t loc * constructor_description * expression list - (** C [] + (** C [] C E [E] C (E1, ..., En) [E1;...;En] *) | Texp_variant of label * expression option | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; - representation : Types.record_representation; - extended_expression : expression option; + fields: (Types.label_description * record_label_definition) array; + representation: Types.record_representation; + extended_expression: expression option; } - (** { l1=P1; ...; ln=Pn } (extended_expression = None) + (** { l1=P1; ...; ln=Pn } (extended_expression = None) { E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) Invariant: n > 0 @@ -213,8 +203,12 @@ and expression_desc = | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of - Ident.t * Parsetree.pattern * expression * expression * direction_flag * - expression + Ident.t + * Parsetree.pattern + * expression + * expression + * direction_flag + * expression | Texp_send of expression * meth * expression option | Texp_new of unit | Texp_instvar of unit @@ -229,65 +223,56 @@ and expression_desc = | Texp_unreachable | Texp_extension_constructor of Longident.t loc * Path.t -and meth = - Tmeth_name of string +and meth = Tmeth_name of string -and case = - { - c_lhs: pattern; - c_guard: expression option; - c_rhs: expression; - } +and case = {c_lhs: pattern; c_guard: expression option; c_rhs: expression} and record_label_definition = | Kept of Types.type_expr | Overridden of Longident.t loc * expression - - (* Value expressions for the module language *) - -and module_expr = - { mod_desc: module_expr_desc; - mod_loc: Location.t; - mod_type: Types.module_type; - mod_env: Env.t; - mod_attributes: attributes; - } +and module_expr = { + mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attributes; +} (** Annotations for [Tmod_constraint]. *) and module_type_constraint = | Tmodtype_implicit - (** The module type constraint has been synthesized during typechecking. *) + (** The module type constraint has been synthesized during typechecking. *) | Tmodtype_explicit of module_type - (** The module type was in the source file. *) + (** The module type was in the source file. *) and module_expr_desc = - Tmod_ident of Path.t * Longident.t loc + | Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure | Tmod_functor of Ident.t * string loc * module_type option * module_expr | Tmod_apply of module_expr * module_expr * module_coercion | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion - (** ME (constraint = Tmodtype_implicit) + (** ME (constraint = Tmodtype_implicit) (ME : MT) (constraint = Tmodtype_explicit MT) *) | Tmod_unpack of expression * Types.module_type and structure = { - str_items : structure_item list; - str_type : Types.signature; - str_final_env : Env.t; + str_items: structure_item list; + str_type: Types.signature; + str_final_env: Env.t; } -and structure_item = - { str_desc : structure_item_desc; - str_loc : Location.t; - str_env : Env.t - } +and structure_item = { + str_desc: structure_item_desc; + str_loc: Location.t; + str_env: Env.t; +} and structure_item_desc = - Tstr_eval of expression * attributes + | Tstr_eval of expression * attributes | Tstr_value of rec_flag * value_binding list | Tstr_primitive of value_description | Tstr_type of rec_flag * type_declaration list @@ -302,70 +287,69 @@ and structure_item_desc = | Tstr_include of include_declaration | Tstr_attribute of attribute -and module_binding = - { - mb_id: Ident.t; - mb_name: string loc; - mb_expr: module_expr; - mb_attributes: attributes; - mb_loc: Location.t; - } +and module_binding = { + mb_id: Ident.t; + mb_name: string loc; + mb_expr: module_expr; + mb_attributes: attributes; + mb_loc: Location.t; +} -and value_binding = - { - vb_pat: pattern; - vb_expr: expression; - vb_attributes: attributes; - vb_loc: Location.t; - } +and value_binding = { + vb_pat: pattern; + vb_expr: expression; + vb_attributes: attributes; + vb_loc: Location.t; +} and module_coercion = - Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list * - (Ident.t * int * module_coercion) list * - string list (* runtime fields *) + | Tcoerce_none + | Tcoerce_structure of + (int * module_coercion) list + * (Ident.t * int * module_coercion) list + * string list (* runtime fields *) | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of primitive_coercion | Tcoerce_alias of Path.t * module_coercion -and module_type = - { mty_desc: module_type_desc; - mty_type : Types.module_type; - mty_env : Env.t; - mty_loc: Location.t; - mty_attributes: attributes; - } +and module_type = { + mty_desc: module_type_desc; + mty_type: Types.module_type; + mty_env: Env.t; + mty_loc: Location.t; + mty_attributes: attributes; +} and module_type_desc = - Tmty_ident of Path.t * Longident.t loc + | Tmty_ident of Path.t * Longident.t loc | Tmty_signature of signature | Tmty_functor of Ident.t * string loc * module_type option * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr | Tmty_alias of Path.t * Longident.t loc -and primitive_coercion = - { - pc_desc: Primitive.description; - pc_type: type_expr; - pc_env: Env.t; - pc_loc : Location.t; - pc_id : Ident.t; - } +and primitive_coercion = { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc: Location.t; + pc_id: Ident.t; +} and signature = { - sig_items : signature_item list; - sig_type : Types.signature; - sig_final_env : Env.t; + sig_items: signature_item list; + sig_type: Types.signature; + sig_final_env: Env.t; } -and signature_item = - { sig_desc: signature_item_desc; - sig_env : Env.t; (* BINANNOT ADDED *) - sig_loc: Location.t } +and signature_item = { + sig_desc: signature_item_desc; + sig_env: Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t; +} and signature_item_desc = - Tsig_value of value_description + | Tsig_value of value_description | Tsig_type of rec_flag * type_declaration list | Tsig_typext of type_extension | Tsig_exception of extension_constructor @@ -378,63 +362,59 @@ and signature_item_desc = | Tsig_class_type of unit | Tsig_attribute of attribute -and module_declaration = - { - md_id: Ident.t; - md_name: string loc; - md_type: module_type; - md_attributes: attributes; - md_loc: Location.t; - } +and module_declaration = { + md_id: Ident.t; + md_name: string loc; + md_type: module_type; + md_attributes: attributes; + md_loc: Location.t; +} -and module_type_declaration = - { - mtd_id: Ident.t; - mtd_name: string loc; - mtd_type: module_type option; - mtd_attributes: attributes; - mtd_loc: Location.t; - } +and module_type_declaration = { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_type: module_type option; + mtd_attributes: attributes; + mtd_loc: Location.t; +} -and open_description = - { - open_path: Path.t; - open_txt: Longident.t loc; - open_override: override_flag; - open_loc: Location.t; - open_attributes: attribute list; - } +and open_description = { + open_path: Path.t; + open_txt: Longident.t loc; + open_override: override_flag; + open_loc: Location.t; + open_attributes: attribute list; +} -and 'a include_infos = - { - incl_mod: 'a; - incl_type: Types.signature; - incl_loc: Location.t; - incl_attributes: attribute list; - } +and 'a include_infos = { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; +} and include_description = module_type include_infos and include_declaration = module_expr include_infos and with_constraint = - Twith_type of type_declaration + | Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc -and core_type = - { mutable ctyp_desc : core_type_desc; +and core_type = { + mutable ctyp_desc: core_type_desc; (** mutable because of [Typeclass.declare_method] *) - mutable ctyp_type : type_expr; + mutable ctyp_type: type_expr; (** mutable because of [Typeclass.declare_method] *) - ctyp_env : Env.t; (* BINANNOT ADDED *) - ctyp_loc : Location.t; - ctyp_attributes: attributes; - } + ctyp_env: Env.t; (* BINANNOT ADDED *) + ctyp_loc: Location.t; + ctyp_attributes: attributes; +} and core_type_desc = - Ttyp_any + | Ttyp_any | Ttyp_var of string | Ttyp_arrow of arg_label * core_type * core_type | Ttyp_tuple of core_type list @@ -447,111 +427,105 @@ and core_type_desc = | Ttyp_package of package_type and package_type = { - pack_path : Path.t; - pack_fields : (Longident.t loc * core_type) list; - pack_type : Types.module_type; - pack_txt : Longident.t loc; + pack_path: Path.t; + pack_fields: (Longident.t loc * core_type) list; + pack_type: Types.module_type; + pack_txt: Longident.t loc; } and row_field = - Ttag of string loc * attributes * bool * core_type list + | Ttag of string loc * attributes * bool * core_type list | Tinherit of core_type and object_field = | OTtag of string loc * attributes * core_type | OTinherit of core_type -and value_description = - { val_id: Ident.t; - val_name: string loc; - val_desc: core_type; - val_val: Types.value_description; - val_prim: string list; - val_loc: Location.t; - val_attributes: attributes; - } +and value_description = { + val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attributes; +} -and type_declaration = - { - typ_id: Ident.t; - typ_name: string loc; - typ_params: (core_type * variance) list; - typ_type: Types.type_declaration; - typ_cstrs: (core_type * core_type * Location.t) list; - typ_kind: type_kind; - typ_private: private_flag; - typ_manifest: core_type option; - typ_loc: Location.t; - typ_attributes: attributes; - } +and type_declaration = { + typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * variance) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attributes; +} and type_kind = - Ttype_abstract + | Ttype_abstract | Ttype_variant of constructor_declaration list | Ttype_record of label_declaration list | Ttype_open -and label_declaration = - { - ld_id: Ident.t; - ld_name: string loc; - ld_mutable: mutable_flag; - ld_type: core_type; - ld_loc: Location.t; - ld_attributes: attributes; - } +and label_declaration = { + ld_id: Ident.t; + ld_name: string loc; + ld_mutable: mutable_flag; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attributes; +} -and constructor_declaration = - { - cd_id: Ident.t; - cd_name: string loc; - cd_args: constructor_arguments; - cd_res: core_type option; - cd_loc: Location.t; - cd_attributes: attributes; - } +and constructor_declaration = { + cd_id: Ident.t; + cd_name: string loc; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attributes; +} and constructor_arguments = | Cstr_tuple of core_type list | Cstr_record of label_declaration list -and type_extension = - { - tyext_path: Path.t; - tyext_txt: Longident.t loc; - tyext_params: (core_type * variance) list; - tyext_constructors: extension_constructor list; - tyext_private: private_flag; - tyext_attributes: attributes; - } - -and extension_constructor = - { - ext_id: Ident.t; - ext_name: string loc; - ext_type : Types.extension_constructor; - ext_kind : extension_constructor_kind; - ext_loc : Location.t; - ext_attributes: attributes; - } +and type_extension = { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * variance) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_attributes: attributes; +} + +and extension_constructor = { + ext_id: Ident.t; + ext_name: string loc; + ext_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; + ext_attributes: attributes; +} and extension_constructor_kind = - Text_decl of constructor_arguments * core_type option + | Text_decl of constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc (* Auxiliary functions over the a.s.t. *) -val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit -val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc - -val let_bound_idents: value_binding list -> Ident.t list -val rev_let_bound_idents: value_binding list -> Ident.t list +val iter_pattern_desc : (pattern -> unit) -> pattern_desc -> unit +val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc +val let_bound_idents : value_binding list -> Ident.t list +val rev_let_bound_idents : value_binding list -> Ident.t list +val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern (** Alpha conversion of patterns *) -val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern -val mknoloc: 'a -> 'a Asttypes.loc -val mkloc: 'a -> Location.t -> 'a Asttypes.loc +val mknoloc : 'a -> 'a Asttypes.loc +val mkloc : 'a -> Location.t -> 'a Asttypes.loc -val pat_bound_idents: pattern -> Ident.t list +val pat_bound_idents : pattern -> Ident.t list diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index 5c5c0de70e..52e5fcca22 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -23,502 +23,435 @@ open Asttypes open Typedtree module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit + + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit +end - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit - - end - -module MakeIterator(Iter : IteratorArgument) : sig - - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - - end = struct - - let may_iter f v = - match v with - None -> () - | Some x -> f x - - - let rec iter_structure str = - Iter.enter_structure str; - List.iter iter_structure_item str.str_items; - Iter.leave_structure str - - - and iter_binding vb = - Iter.enter_binding vb; - iter_pattern vb.vb_pat; - iter_expression vb.vb_expr; - Iter.leave_binding vb - - and iter_bindings rec_flag list = - Iter.enter_bindings rec_flag; - List.iter iter_binding list; - Iter.leave_bindings rec_flag - - and iter_case {c_lhs; c_guard; c_rhs} = - iter_pattern c_lhs; - may_iter iter_expression c_guard; - iter_expression c_rhs - - and iter_cases cases = - List.iter iter_case cases - - and iter_structure_item item = - Iter.enter_structure_item item; - begin - match item.str_desc with - Tstr_eval (exp, _attrs) -> iter_expression exp - | Tstr_value (rec_flag, list) -> - iter_bindings rec_flag list - | Tstr_primitive vd -> iter_value_description vd - | Tstr_type (rf, list) -> iter_type_declarations rf list - | Tstr_typext tyext -> iter_type_extension tyext - | Tstr_exception ext -> iter_extension_constructor ext - | Tstr_module x -> iter_module_binding x - | Tstr_recmodule list -> List.iter iter_module_binding list - | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open _ -> () - | Tstr_class () -> () - | Tstr_class_type () -> () - | Tstr_include incl -> iter_module_expr incl.incl_mod - | Tstr_attribute _ -> - () - end; - Iter.leave_structure_item item - - and iter_module_binding x = - iter_module_expr x.mb_expr - - and iter_value_description v = - Iter.enter_value_description v; - iter_core_type v.val_desc; - Iter.leave_value_description v - - and iter_constructor_arguments = function - | Cstr_tuple l -> List.iter iter_core_type l - | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l - - and iter_constructor_declaration cd = - iter_constructor_arguments cd.cd_args; - option iter_core_type cd.cd_res; - - and iter_type_parameter (ct, _v) = - iter_core_type ct - - and iter_type_declaration decl = - Iter.enter_type_declaration decl; - List.iter iter_type_parameter decl.typ_params; - List.iter (fun (ct1, ct2, _loc) -> - iter_core_type ct1; - iter_core_type ct2 - ) decl.typ_cstrs; - begin match decl.typ_kind with - Ttype_abstract -> () - | Ttype_variant list -> - List.iter iter_constructor_declaration list - | Ttype_record list -> - List.iter - (fun ld -> - iter_core_type ld.ld_type - ) list - | Ttype_open -> () - end; - option iter_core_type decl.typ_manifest; - Iter.leave_type_declaration decl - - and iter_type_declarations rec_flag decls = - Iter.enter_type_declarations rec_flag; - List.iter iter_type_declaration decls; - Iter.leave_type_declarations rec_flag - - and iter_extension_constructor ext = - Iter.enter_extension_constructor ext; - begin match ext.ext_kind with - Text_decl(args, ret) -> - iter_constructor_arguments args; - option iter_core_type ret - | Text_rebind _ -> () - end; - Iter.leave_extension_constructor ext; - - and iter_type_extension tyext = - Iter.enter_type_extension tyext; - List.iter iter_type_parameter tyext.tyext_params; - List.iter iter_extension_constructor tyext.tyext_constructors; - Iter.leave_type_extension tyext - - and iter_pattern pat = - Iter.enter_pattern pat; - List.iter (fun (cstr, _, _attrs) -> match cstr with - | Tpat_type _ -> () - | Tpat_unpack -> () - | Tpat_open _ -> () - | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; - begin - match pat.pat_desc with - Tpat_any -> () - | Tpat_var _ -> () - | Tpat_alias (pat1, _, _) -> iter_pattern pat1 - | Tpat_constant _ -> () - | Tpat_tuple list -> - List.iter iter_pattern list - | Tpat_construct (_, _, args) -> - List.iter iter_pattern args - | Tpat_variant (_, pato, _) -> - begin match pato with - None -> () - | Some pat -> iter_pattern pat - end - | Tpat_record (list, _closed) -> - List.iter (fun (_, _, pat) -> iter_pattern pat) list - | Tpat_array list -> List.iter iter_pattern list - | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 - | Tpat_lazy p -> iter_pattern p - end; - Iter.leave_pattern pat - - and option f x = match x with None -> () | Some e -> f e - - and iter_expression exp = - Iter.enter_expression exp; - List.iter (function (cstr, _, _attrs) -> - match cstr with - Texp_constraint ct -> - iter_core_type ct - | Texp_coerce ((), cty2) -> - iter_core_type cty2 - | Texp_open _ -> () - | Texp_poly cto -> option iter_core_type cto - | Texp_newtype _ -> ()) - exp.exp_extra; - begin - match exp.exp_desc with - Texp_ident _ -> () - | Texp_constant _ -> () - | Texp_let (rec_flag, list, exp) -> - iter_bindings rec_flag list; - iter_expression exp - | Texp_function { cases; _ } -> - iter_cases cases - | Texp_apply (exp, list) -> - iter_expression exp; - List.iter (fun (_label, expo) -> - match expo with - None -> () - | Some exp -> iter_expression exp - ) list - | Texp_match (exp, list1, list2, _) -> - iter_expression exp; - iter_cases list1; - iter_cases list2; - | Texp_try (exp, list) -> - iter_expression exp; - iter_cases list - | Texp_tuple list -> - List.iter iter_expression list - | Texp_construct (_, _, args) -> - List.iter iter_expression args - | Texp_variant (_label, expo) -> - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_record { fields; extended_expression; _ } -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> iter_expression exp) - fields; - begin match extended_expression with - None -> () - | Some exp -> iter_expression exp - end - | Texp_field (exp, _, _label) -> - iter_expression exp - | Texp_setfield (exp1, _, _label, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_array list -> - List.iter iter_expression list - | Texp_ifthenelse (exp1, exp2, expo) -> - iter_expression exp1; - iter_expression exp2; - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_sequence (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_while (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> - iter_expression exp1; - iter_expression exp2; - iter_expression exp3 - | Texp_send (exp, _meth, expo) -> - iter_expression exp; - begin - match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> () - | Texp_letmodule (_id, _, mexpr, exp) -> - iter_module_expr mexpr; - iter_expression exp - | Texp_letexception (cd, exp) -> - iter_extension_constructor cd; - iter_expression exp - | Texp_assert exp -> iter_expression exp - | Texp_lazy exp -> iter_expression exp - | Texp_object () -> - () - | Texp_pack (mexpr) -> - iter_module_expr mexpr - | Texp_unreachable -> - () - | Texp_extension_constructor _ -> - () - end; - Iter.leave_expression exp; - - and iter_package_type pack = - Iter.enter_package_type pack; - List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; - Iter.leave_package_type pack; - - and iter_signature sg = - Iter.enter_signature sg; - List.iter iter_signature_item sg.sig_items; - Iter.leave_signature sg; - - and iter_signature_item item = - Iter.enter_signature_item item; - begin - match item.sig_desc with - Tsig_value vd -> - iter_value_description vd - | Tsig_type (rf, list) -> - iter_type_declarations rf list - | Tsig_exception ext -> - iter_extension_constructor ext - | Tsig_typext tyext -> - iter_type_extension tyext - | Tsig_module md -> - iter_module_type md.md_type - | Tsig_recmodule list -> - List.iter (fun md -> iter_module_type md.md_type) list - | Tsig_modtype mtd -> - iter_module_type_declaration mtd - | Tsig_open _ -> () - | Tsig_include incl -> iter_module_type incl.incl_mod - | Tsig_class () -> () - | Tsig_class_type () -> () - | Tsig_attribute _ -> () - end; - Iter.leave_signature_item item; - - and iter_module_type_declaration mtd = - Iter.enter_module_type_declaration mtd; - begin - match mtd.mtd_type with - | None -> () - | Some mtype -> iter_module_type mtype - end; - Iter.leave_module_type_declaration mtd - - - and iter_module_type mty = - Iter.enter_module_type mty; - begin - match mty.mty_desc with - Tmty_ident _ -> () - | Tmty_alias _ -> () - | Tmty_signature sg -> iter_signature sg - | Tmty_functor (_, _, mtype1, mtype2) -> - Misc.may iter_module_type mtype1; iter_module_type mtype2 - | Tmty_with (mtype, list) -> - iter_module_type mtype; - List.iter (fun (_path, _, withc) -> - iter_with_constraint withc - ) list - | Tmty_typeof mexpr -> - iter_module_expr mexpr - end; - Iter.leave_module_type mty; - - and iter_with_constraint cstr = - Iter.enter_with_constraint cstr; - begin +module MakeIterator (Iter : IteratorArgument) : sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit +end = struct + let may_iter f v = + match v with + | None -> () + | Some x -> f x + + let rec iter_structure str = + Iter.enter_structure str; + List.iter iter_structure_item str.str_items; + Iter.leave_structure str + + and iter_binding vb = + Iter.enter_binding vb; + iter_pattern vb.vb_pat; + iter_expression vb.vb_expr; + Iter.leave_binding vb + + and iter_bindings rec_flag list = + Iter.enter_bindings rec_flag; + List.iter iter_binding list; + Iter.leave_bindings rec_flag + + and iter_case {c_lhs; c_guard; c_rhs} = + iter_pattern c_lhs; + may_iter iter_expression c_guard; + iter_expression c_rhs + + and iter_cases cases = List.iter iter_case cases + + and iter_structure_item item = + Iter.enter_structure_item item; + (match item.str_desc with + | Tstr_eval (exp, _attrs) -> iter_expression exp + | Tstr_value (rec_flag, list) -> iter_bindings rec_flag list + | Tstr_primitive vd -> iter_value_description vd + | Tstr_type (rf, list) -> iter_type_declarations rf list + | Tstr_typext tyext -> iter_type_extension tyext + | Tstr_exception ext -> iter_extension_constructor ext + | Tstr_module x -> iter_module_binding x + | Tstr_recmodule list -> List.iter iter_module_binding list + | Tstr_modtype mtd -> iter_module_type_declaration mtd + | Tstr_open _ -> () + | Tstr_class () -> () + | Tstr_class_type () -> () + | Tstr_include incl -> iter_module_expr incl.incl_mod + | Tstr_attribute _ -> ()); + Iter.leave_structure_item item + + and iter_module_binding x = iter_module_expr x.mb_expr + + and iter_value_description v = + Iter.enter_value_description v; + iter_core_type v.val_desc; + Iter.leave_value_description v + + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + + and iter_constructor_declaration cd = + iter_constructor_arguments cd.cd_args; + option iter_core_type cd.cd_res + + and iter_type_parameter (ct, _v) = iter_core_type ct + + and iter_type_declaration decl = + Iter.enter_type_declaration decl; + List.iter iter_type_parameter decl.typ_params; + List.iter + (fun (ct1, ct2, _loc) -> + iter_core_type ct1; + iter_core_type ct2) + decl.typ_cstrs; + (match decl.typ_kind with + | Ttype_abstract -> () + | Ttype_variant list -> List.iter iter_constructor_declaration list + | Ttype_record list -> List.iter (fun ld -> iter_core_type ld.ld_type) list + | Ttype_open -> ()); + option iter_core_type decl.typ_manifest; + Iter.leave_type_declaration decl + + and iter_type_declarations rec_flag decls = + Iter.enter_type_declarations rec_flag; + List.iter iter_type_declaration decls; + Iter.leave_type_declarations rec_flag + + and iter_extension_constructor ext = + Iter.enter_extension_constructor ext; + (match ext.ext_kind with + | Text_decl (args, ret) -> + iter_constructor_arguments args; + option iter_core_type ret + | Text_rebind _ -> ()); + Iter.leave_extension_constructor ext + + and iter_type_extension tyext = + Iter.enter_type_extension tyext; + List.iter iter_type_parameter tyext.tyext_params; + List.iter iter_extension_constructor tyext.tyext_constructors; + Iter.leave_type_extension tyext + + and iter_pattern pat = + Iter.enter_pattern pat; + List.iter + (fun (cstr, _, _attrs) -> match cstr with - Twith_type decl -> iter_type_declaration decl - | Twith_module _ -> () - | Twith_typesubst decl -> iter_type_declaration decl - | Twith_modsubst _ -> () - end; - Iter.leave_with_constraint cstr; - - and iter_module_expr mexpr = - Iter.enter_module_expr mexpr; - begin - match mexpr.mod_desc with - Tmod_ident _ -> () - | Tmod_structure st -> iter_structure st - | Tmod_functor (_, _, mtype, mexpr) -> - Misc.may iter_module_type mtype; - iter_module_expr mexpr - | Tmod_apply (mexp1, mexp2, _) -> - iter_module_expr mexp1; - iter_module_expr mexp2 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> - iter_module_expr mexpr - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - iter_module_expr mexpr; - iter_module_type mtype - | Tmod_unpack (exp, _mty) -> - iter_expression exp -(* iter_module_type mty *) - end; - Iter.leave_module_expr mexpr; - - - and iter_core_type ct = - Iter.enter_core_type ct; - begin - match ct.ctyp_desc with - Ttyp_any -> () - | Ttyp_var _ -> () - | Ttyp_arrow (_label, ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Ttyp_tuple list -> List.iter iter_core_type list - | Ttyp_constr (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_object (list, _o) -> - List.iter iter_object_field list - | Ttyp_class () -> () - | Ttyp_alias (ct, _s) -> - iter_core_type ct - | Ttyp_variant (list, _bool, _labels) -> - List.iter iter_row_field list - | Ttyp_poly (_list, ct) -> iter_core_type ct - | Ttyp_package pack -> iter_package_type pack - end; - Iter.leave_core_type ct - - and iter_row_field rf = - match rf with - Ttag (_label, _attrs, _bool, list) -> - List.iter iter_core_type list - | Tinherit ct -> iter_core_type ct - - and iter_object_field ofield = - match ofield with - OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct - - end + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_open _ -> () + | Tpat_constraint ct -> iter_core_type ct) + pat.pat_extra; + (match pat.pat_desc with + | Tpat_any -> () + | Tpat_var _ -> () + | Tpat_alias (pat1, _, _) -> iter_pattern pat1 + | Tpat_constant _ -> () + | Tpat_tuple list -> List.iter iter_pattern list + | Tpat_construct (_, _, args) -> List.iter iter_pattern args + | Tpat_variant (_, pato, _) -> ( + match pato with + | None -> () + | Some pat -> iter_pattern pat) + | Tpat_record (list, _closed) -> + List.iter (fun (_, _, pat) -> iter_pattern pat) list + | Tpat_array list -> List.iter iter_pattern list + | Tpat_or (p1, p2, _) -> + iter_pattern p1; + iter_pattern p2 + | Tpat_lazy p -> iter_pattern p); + Iter.leave_pattern pat + + and option f x = + match x with + | None -> () + | Some e -> f e + + and iter_expression exp = + Iter.enter_expression exp; + List.iter + (function + | cstr, _, _attrs -> ( + match cstr with + | Texp_constraint ct -> iter_core_type ct + | Texp_coerce ((), cty2) -> iter_core_type cty2 + | Texp_open _ -> () + | Texp_poly cto -> option iter_core_type cto + | Texp_newtype _ -> ())) + exp.exp_extra; + (match exp.exp_desc with + | Texp_ident _ -> () + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + iter_bindings rec_flag list; + iter_expression exp + | Texp_function {cases; _} -> iter_cases cases + | Texp_apply (exp, list) -> + iter_expression exp; + List.iter + (fun (_label, expo) -> + match expo with + | None -> () + | Some exp -> iter_expression exp) + list + | Texp_match (exp, list1, list2, _) -> + iter_expression exp; + iter_cases list1; + iter_cases list2 + | Texp_try (exp, list) -> + iter_expression exp; + iter_cases list + | Texp_tuple list -> List.iter iter_expression list + | Texp_construct (_, _, args) -> List.iter iter_expression args + | Texp_variant (_label, expo) -> ( + match expo with + | None -> () + | Some exp -> iter_expression exp) + | Texp_record {fields; extended_expression; _} -> ( + Array.iter + (function + | _, Kept _ -> () + | _, Overridden (_, exp) -> iter_expression exp) + fields; + match extended_expression with + | None -> () + | Some exp -> iter_expression exp) + | Texp_field (exp, _, _label) -> iter_expression exp + | Texp_setfield (exp1, _, _label, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_array list -> List.iter iter_expression list + | Texp_ifthenelse (exp1, exp2, expo) -> ( + iter_expression exp1; + iter_expression exp2; + match expo with + | None -> () + | Some exp -> iter_expression exp) + | Texp_sequence (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_while (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> + iter_expression exp1; + iter_expression exp2; + iter_expression exp3 + | Texp_send (exp, _meth, expo) -> ( + iter_expression exp; + match expo with + | None -> () + | Some exp -> iter_expression exp) + | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ -> () + | Texp_letmodule (_id, _, mexpr, exp) -> + iter_module_expr mexpr; + iter_expression exp + | Texp_letexception (cd, exp) -> + iter_extension_constructor cd; + iter_expression exp + | Texp_assert exp -> iter_expression exp + | Texp_lazy exp -> iter_expression exp + | Texp_object () -> () + | Texp_pack mexpr -> iter_module_expr mexpr + | Texp_unreachable -> () + | Texp_extension_constructor _ -> ()); + Iter.leave_expression exp + + and iter_package_type pack = + Iter.enter_package_type pack; + List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; + Iter.leave_package_type pack + + and iter_signature sg = + Iter.enter_signature sg; + List.iter iter_signature_item sg.sig_items; + Iter.leave_signature sg + + and iter_signature_item item = + Iter.enter_signature_item item; + (match item.sig_desc with + | Tsig_value vd -> iter_value_description vd + | Tsig_type (rf, list) -> iter_type_declarations rf list + | Tsig_exception ext -> iter_extension_constructor ext + | Tsig_typext tyext -> iter_type_extension tyext + | Tsig_module md -> iter_module_type md.md_type + | Tsig_recmodule list -> + List.iter (fun md -> iter_module_type md.md_type) list + | Tsig_modtype mtd -> iter_module_type_declaration mtd + | Tsig_open _ -> () + | Tsig_include incl -> iter_module_type incl.incl_mod + | Tsig_class () -> () + | Tsig_class_type () -> () + | Tsig_attribute _ -> ()); + Iter.leave_signature_item item + + and iter_module_type_declaration mtd = + Iter.enter_module_type_declaration mtd; + (match mtd.mtd_type with + | None -> () + | Some mtype -> iter_module_type mtype); + Iter.leave_module_type_declaration mtd + + and iter_module_type mty = + Iter.enter_module_type mty; + (match mty.mty_desc with + | Tmty_ident _ -> () + | Tmty_alias _ -> () + | Tmty_signature sg -> iter_signature sg + | Tmty_functor (_, _, mtype1, mtype2) -> + Misc.may iter_module_type mtype1; + iter_module_type mtype2 + | Tmty_with (mtype, list) -> + iter_module_type mtype; + List.iter (fun (_path, _, withc) -> iter_with_constraint withc) list + | Tmty_typeof mexpr -> iter_module_expr mexpr); + Iter.leave_module_type mty + + and iter_with_constraint cstr = + Iter.enter_with_constraint cstr; + (match cstr with + | Twith_type decl -> iter_type_declaration decl + | Twith_module _ -> () + | Twith_typesubst decl -> iter_type_declaration decl + | Twith_modsubst _ -> ()); + Iter.leave_with_constraint cstr + + and iter_module_expr mexpr = + Iter.enter_module_expr mexpr; + (match mexpr.mod_desc with + | Tmod_ident _ -> () + | Tmod_structure st -> iter_structure st + | Tmod_functor (_, _, mtype, mexpr) -> + Misc.may iter_module_type mtype; + iter_module_expr mexpr + | Tmod_apply (mexp1, mexp2, _) -> + iter_module_expr mexp1; + iter_module_expr mexp2 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) -> iter_module_expr mexpr + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + iter_module_expr mexpr; + iter_module_type mtype + | Tmod_unpack (exp, _mty) -> iter_expression exp) + (* iter_module_type mty *); + Iter.leave_module_expr mexpr + + and iter_core_type ct = + Iter.enter_core_type ct; + (match ct.ctyp_desc with + | Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (_label, ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Ttyp_tuple list -> List.iter iter_core_type list + | Ttyp_constr (_path, _, list) -> List.iter iter_core_type list + | Ttyp_object (list, _o) -> List.iter iter_object_field list + | Ttyp_class () -> () + | Ttyp_alias (ct, _s) -> iter_core_type ct + | Ttyp_variant (list, _bool, _labels) -> List.iter iter_row_field list + | Ttyp_poly (_list, ct) -> iter_core_type ct + | Ttyp_package pack -> iter_package_type pack); + Iter.leave_core_type ct + + and iter_row_field rf = + match rf with + | Ttag (_label, _attrs, _bool, list) -> List.iter iter_core_type list + | Tinherit ct -> iter_core_type ct + + and iter_object_field ofield = + match ofield with + | OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct +end module DefaultIteratorArgument = struct - - let enter_structure _ = () - let enter_value_description _ = () - let enter_type_extension _ = () - let enter_extension_constructor _ = () - let enter_pattern _ = () - let enter_expression _ = () - let enter_package_type _ = () - let enter_signature _ = () - let enter_signature_item _ = () - let enter_module_type_declaration _ = () - let enter_module_type _ = () - let enter_module_expr _ = () - let enter_with_constraint _ = () - - let enter_core_type _ = () - let enter_structure_item _ = () - - - let leave_structure _ = () - let leave_value_description _ = () - let leave_type_extension _ = () - let leave_extension_constructor _ = () - let leave_pattern _ = () - let leave_expression _ = () - let leave_package_type _ = () - let leave_signature _ = () - let leave_signature_item _ = () - let leave_module_type_declaration _ = () - let leave_module_type _ = () - let leave_module_expr _ = () - let leave_with_constraint _ = () - - let leave_core_type _ = () - let leave_structure_item _ = () - - let enter_binding _ = () - let leave_binding _ = () - - let enter_bindings _ = () - let leave_bindings _ = () - - let enter_type_declaration _ = () - let leave_type_declaration _ = () - - let enter_type_declarations _ = () - let leave_type_declarations _ = () + let enter_structure _ = () + let enter_value_description _ = () + let enter_type_extension _ = () + let enter_extension_constructor _ = () + let enter_pattern _ = () + let enter_expression _ = () + let enter_package_type _ = () + let enter_signature _ = () + let enter_signature_item _ = () + let enter_module_type_declaration _ = () + let enter_module_type _ = () + let enter_module_expr _ = () + let enter_with_constraint _ = () + + let enter_core_type _ = () + let enter_structure_item _ = () + + let leave_structure _ = () + let leave_value_description _ = () + let leave_type_extension _ = () + let leave_extension_constructor _ = () + let leave_pattern _ = () + let leave_expression _ = () + let leave_package_type _ = () + let leave_signature _ = () + let leave_signature_item _ = () + let leave_module_type_declaration _ = () + let leave_module_type _ = () + let leave_module_expr _ = () + let leave_with_constraint _ = () + + let leave_core_type _ = () + let leave_structure_item _ = () + + let enter_binding _ = () + let leave_binding _ = () + + let enter_bindings _ = () + let leave_bindings _ = () + + let enter_type_declaration _ = () + let leave_type_declaration _ = () + + let enter_type_declarations _ = () + let leave_type_declarations _ = () end diff --git a/compiler/ml/typedtreeIter.mli b/compiler/ml/typedtreeIter.mli index 0d7461c0d8..17adaa67f5 100644 --- a/compiler/ml/typedtreeIter.mli +++ b/compiler/ml/typedtreeIter.mli @@ -16,63 +16,59 @@ open Asttypes open Typedtree - module type IteratorArgument = sig - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit - + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit end -module [@warning "-67"] MakeIterator : - functor (Iter : IteratorArgument) -> - sig - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - end +module MakeIterator : functor (Iter : IteratorArgument) -> sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit +end +[@@warning "-67"] module DefaultIteratorArgument : IteratorArgument diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index d87b1ccd31..8ff9cb44c5 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -22,7 +22,7 @@ open Types open Format type error = - Cannot_apply of module_type + | Cannot_apply of module_type | Not_included of Includemod.error list | Cannot_eliminate_dependency of module_type | Signature_expected @@ -48,27 +48,24 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error - - -let rescript_hide_attributes (x : Typedtree.attributes) = - match x with +let rescript_hide_attributes (x : Typedtree.attributes) = + match x with | [] -> false - | ({txt = "internal.local";_},_) :: _ -> true - | _ :: rest -> - Ext_list.exists rest (fun (x,_) -> x.txt = "internal.local") + | ({txt = "internal.local"; _}, _) :: _ -> true + | _ :: rest -> Ext_list.exists rest (fun (x, _) -> x.txt = "internal.local") -let rescript_hide (x : Typedtree.structure_item_desc) = - match x with +let rescript_hide (x : Typedtree.structure_item_desc) = + match x with | Tstr_module {mb_attributes} -> rescript_hide_attributes mb_attributes | _ -> false - + open Typedtree -let fst3 (x,_,_) = x +let fst3 (x, _, _) = x let rec path_concat head p = match p with - Pident tail -> Pdot (Pident head, Ident.name tail, 0) + | Pident tail -> Pdot (Pident head, Ident.name tail, 0) | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) | Papply _ -> assert false @@ -76,36 +73,31 @@ let rec path_concat head p = let extract_sig env loc mty = match Env.scrape_alias env mty with - Mty_signature sg -> sg - | Mty_alias(_, path) -> - raise(Error(loc, env, Cannot_scrape_alias path)) - | _ -> raise(Error(loc, env, Signature_expected)) + | Mty_signature sg -> sg + | Mty_alias (_, path) -> raise (Error (loc, env, Cannot_scrape_alias path)) + | _ -> raise (Error (loc, env, Signature_expected)) let extract_sig_open env loc mty = match Env.scrape_alias env mty with - Mty_signature sg -> sg - | Mty_alias(_, path) -> - raise(Error(loc, env, Cannot_scrape_alias path)) - | mty -> raise(Error(loc, env, Structure_expected mty)) + | Mty_signature sg -> sg + | Mty_alias (_, path) -> raise (Error (loc, env, Cannot_scrape_alias path)) + | mty -> raise (Error (loc, env, Structure_expected mty)) (* Compute the environment after opening a module *) let type_open_ ?used_slot ?toplevel ovf env loc lid = let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with - | Some env -> path, env + | Some env -> (path, env) | None -> - let md = Env.find_module path env in - ignore (extract_sig_open env lid.loc md.md_type); - assert false + let md = Env.find_module path env in + ignore (extract_sig_open env lid.loc md.md_type); + assert false let type_open ?toplevel env sod = - let (path, newenv) = - Builtin_attributes.warning_scope sod.popen_attributes - (fun () -> - type_open_ ?toplevel sod.popen_override env sod.popen_loc - sod.popen_lid - ) + let path, newenv = + Builtin_attributes.warning_scope sod.popen_attributes (fun () -> + type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid) in let od = { @@ -125,15 +117,17 @@ let rm node = (* Forward declaration, to be filled in by type_module_type_of *) let type_module_type_of_fwd : - (Env.t -> Parsetree.module_expr -> - Typedtree.module_expr * Types.module_type) ref - = ref (fun _env _m -> assert false) + (Env.t -> + Parsetree.module_expr -> + Typedtree.module_expr * Types.module_type) + ref = + ref (fun _env _m -> assert false) (* Merge one "with" constraint in a signature *) let rec add_rec_types env = function - Sig_type(id, decl, Trec_next) :: rem -> - add_rec_types (Env.add_type ~check:true id decl env) rem + | Sig_type (id, decl, Trec_next) :: rem -> + add_rec_types (Env.add_type ~check:true id decl env) rem | _ -> env let check_type_decl env loc id row_id newdecl decl rs rem = @@ -149,14 +143,12 @@ let check_type_decl env loc id row_id newdecl decl rs rem = let update_rec_next rs rem = match rs with - Trec_next -> rem - | Trec_first | Trec_not -> - match rem with - Sig_type (id, decl, Trec_next) :: rem -> - Sig_type (id, decl, rs) :: rem - | Sig_module (id, mty, Trec_next) :: rem -> - Sig_module (id, mty, rs) :: rem - | _ -> rem + | Trec_next -> rem + | Trec_first | Trec_not -> ( + match rem with + | Sig_type (id, decl, Trec_next) :: rem -> Sig_type (id, decl, rs) :: rem + | Sig_module (id, mty, Trec_next) :: rem -> Sig_module (id, mty, rs) :: rem + | _ -> rem) let make p n i = let open Variance in @@ -167,49 +159,50 @@ let rec iter_path_apply p ~f = | Pident _ -> () | Pdot (p, _, _) -> iter_path_apply p ~f | Papply (p1, p2) -> - iter_path_apply p1 ~f; - iter_path_apply p2 ~f; - f p1 p2 (* after recursing, so we know both paths are well typed *) + iter_path_apply p1 ~f; + iter_path_apply p2 ~f; + f p1 p2 (* after recursing, so we know both paths are well typed *) let path_is_strict_prefix = let rec list_is_strict_prefix l ~prefix = - match l, prefix with + match (l, prefix) with | [], [] -> false | _ :: _, [] -> true | [], _ :: _ -> false | s1 :: t1, s2 :: t2 -> - String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2 + String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2 in fun path ~prefix -> - match Path.flatten path, Path.flatten prefix with + match (Path.flatten path, Path.flatten prefix) with | `Contains_apply, _ | _, `Contains_apply -> false | `Ok (ident1, l1), `Ok (ident2, l2) -> - Ident.same ident1 ident2 - && list_is_strict_prefix l1 ~prefix:l2 + Ident.same ident1 ident2 && list_is_strict_prefix l1 ~prefix:l2 let iterator_with_env env = let env = ref env in let super = Btype.type_iterators in - env, { super with - Btype.it_signature = (fun self sg -> - (* add all items to the env before recursing down, to handle recursive - definitions *) - let env_before = !env in - List.iter (fun i -> env := Env.add_item i !env) sg; - super.Btype.it_signature self sg; - env := env_before - ); - Btype.it_module_type = (fun self -> function - | Mty_functor (param, mty_arg, mty_body) -> - may (self.Btype.it_module_type self) mty_arg; - let env_before = !env in - env := Env.add_module ~arg:true param (Btype.default_mty mty_arg) !env; - self.Btype.it_module_type self mty_body; - env := env_before; - | mty -> - super.Btype.it_module_type self mty - ) - } + ( env, + { + super with + Btype.it_signature = + (fun self sg -> + (* add all items to the env before recursing down, to handle recursive + definitions *) + let env_before = !env in + List.iter (fun i -> env := Env.add_item i !env) sg; + super.Btype.it_signature self sg; + env := env_before); + Btype.it_module_type = + (fun self -> function + | Mty_functor (param, mty_arg, mty_body) -> + may (self.Btype.it_module_type self) mty_arg; + let env_before = !env in + env := + Env.add_module ~arg:true param (Btype.default_mty mty_arg) !env; + self.Btype.it_module_type self mty_body; + env := env_before + | mty -> super.Btype.it_module_type self mty); + } ) let retype_applicative_functor_type ~loc env funct arg = let mty_functor = (Env.find_module funct env).md_type in @@ -220,8 +213,10 @@ let retype_applicative_functor_type ~loc env funct arg = | _ -> assert false (* could trigger due to MPR#7611 *) in let aliasable = not (Env.is_functor_arg arg env) in - ignore(Includemod.modtypes ~loc env - (Mtype.strengthen ~aliasable env mty_arg arg) mty_param) + ignore + (Includemod.modtypes ~loc env + (Mtype.strengthen ~aliasable env mty_arg arg) + mty_param) (* When doing a deep destructive substitution with type M.N.t := .., we change M and M.N and so we have to check that uses of the modules other than just @@ -234,72 +229,75 @@ let retype_applicative_functor_type ~loc env funct arg = let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid = let iterator = let env, super = iterator_with_env env in - { super with - Btype.it_signature_item = (fun self -> function - | Sig_module (id, { md_type = Mty_alias (_, aliased_path); _ }, _) - when List.exists - (fun path -> path_is_strict_prefix path ~prefix:aliased_path) - paths - -> - let e = With_changes_module_alias (lid.txt, id, aliased_path) in - raise(Error(loc, !env, e)) - | sig_item -> - super.Btype.it_signature_item self sig_item - ); - Btype.it_path = (fun referenced_path -> - iter_path_apply referenced_path ~f:(fun funct arg -> - if List.exists - (fun path -> path_is_strict_prefix path ~prefix:arg) - paths - then - let env = !env in - try retype_applicative_functor_type ~loc env funct arg - with Includemod.Error explanation -> - raise(Error(loc, env, - With_makes_applicative_functor_ill_typed - (lid.txt, referenced_path, explanation))) - ) - ); + { + super with + Btype.it_signature_item = + (fun self -> function + | Sig_module (id, {md_type = Mty_alias (_, aliased_path); _}, _) + when List.exists + (fun path -> path_is_strict_prefix path ~prefix:aliased_path) + paths -> + let e = With_changes_module_alias (lid.txt, id, aliased_path) in + raise (Error (loc, !env, e)) + | sig_item -> super.Btype.it_signature_item self sig_item); + Btype.it_path = + (fun referenced_path -> + iter_path_apply referenced_path ~f:(fun funct arg -> + if + List.exists + (fun path -> path_is_strict_prefix path ~prefix:arg) + paths + then + let env = !env in + try retype_applicative_functor_type ~loc env funct arg + with Includemod.Error explanation -> + raise + (Error + ( loc, + env, + With_makes_applicative_functor_ill_typed + (lid.txt, referenced_path, explanation) )))); } in iterator.Btype.it_signature iterator signature; Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature -let type_decl_is_alias sdecl = (* assuming no explicit constraint *) +let type_decl_is_alias sdecl = + (* assuming no explicit constraint *) match sdecl.ptype_manifest with | Some {ptyp_desc = Ptyp_constr (lid, stl)} - when List.length stl = List.length sdecl.ptype_params -> - begin - match - List.iter2 (fun x (y, _) -> - match x, y with - {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy} - when sx = sy -> () - | _, _ -> raise Exit) - stl sdecl.ptype_params; - with - | exception Exit -> None - | () -> Some lid - end + when List.length stl = List.length sdecl.ptype_params -> ( + match + List.iter2 + (fun x (y, _) -> + match (x, y) with + | {ptyp_desc = Ptyp_var sx}, {ptyp_desc = Ptyp_var sy} when sx = sy -> + () + | _, _ -> raise Exit) + stl sdecl.ptype_params + with + | exception Exit -> None + | () -> Some lid) | _ -> None -;; let params_are_constrained = let rec loop = function | [] -> false - | hd :: tl -> - match (Btype.repr hd).desc with - | Tvar _ -> List.memq hd tl || loop tl - | _ -> true + | hd :: tl -> ( + match (Btype.repr hd).desc with + | Tvar _ -> List.memq hd tl || loop tl + | _ -> true) in loop -;; let merge_constraint initial_env loc sg constr = let lid = match constr with - | Pwith_type (lid, _) | Pwith_module (lid, _) - | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid + | Pwith_type (lid, _) + | Pwith_module (lid, _) + | Pwith_typesubst (lid, _) + | Pwith_modsubst (lid, _) -> + lid in let destructive_substitution = match constr with @@ -309,157 +307,155 @@ let merge_constraint initial_env loc sg constr = let real_ids = ref [] in let rec merge env sg namelist row_id = match (sg, namelist, constr) with - ([], _, _) -> - raise(Error(loc, env, With_no_component lid.txt)) - | (Sig_type(id, decl, rs) :: rem, [s], - Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl))) + | [], _, _ -> raise (Error (loc, env, With_no_component lid.txt)) + | ( Sig_type (id, decl, rs) :: rem, + [s], + Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)) ) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> - let decl_row = - { type_params = - List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; - type_arity = List.length sdecl.ptype_params; - type_kind = Type_abstract; - type_private = Private; - type_manifest = None; - type_variance = - List.map - (fun (_, v) -> - let (c, n) = - match v with - | Covariant -> true, false - | Contravariant -> false, true - | Invariant -> false, false - in - make (not n) (not c) false - ) - sdecl.ptype_params; - type_loc = sdecl.ptype_loc; - type_newtype_level = None; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - and id_row = Ident.create (s^"#row") in - let initial_env = - Env.add_type ~check:false id_row decl_row initial_env - in - let tdecl = Typedecl.transl_with_constraint - initial_env id (Some(Pident id_row)) decl sdecl in - let newdecl = tdecl.typ_type in - check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; - let decl_row = {decl_row with type_params = newdecl.type_params} in - let rs' = if rs = Trec_first then Trec_not else rs in - (Pident id, lid, Twith_type tdecl), - Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem - | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type (_, sdecl)) + let decl_row = + { + type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = List.length sdecl.ptype_params; + type_kind = Type_abstract; + type_private = Private; + type_manifest = None; + type_variance = + List.map + (fun (_, v) -> + let c, n = + match v with + | Covariant -> (true, false) + | Contravariant -> (false, true) + | Invariant -> (false, false) + in + make (not n) (not c) false) + sdecl.ptype_params; + type_loc = sdecl.ptype_loc; + type_newtype_level = None; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + } + and id_row = Ident.create (s ^ "#row") in + let initial_env = Env.add_type ~check:false id_row decl_row initial_env in + let tdecl = + Typedecl.transl_with_constraint initial_env id (Some (Pident id_row)) + decl sdecl + in + let newdecl = tdecl.typ_type in + check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; + let decl_row = {decl_row with type_params = newdecl.type_params} in + let rs' = if rs = Trec_first then Trec_not else rs in + ( (Pident id, lid, Twith_type tdecl), + Sig_type (id_row, decl_row, rs') :: Sig_type (id, newdecl, rs) :: rem ) + | Sig_type (id, decl, rs) :: rem, [s], Pwith_type (_, sdecl) when Ident.name id = s -> - let tdecl = - Typedecl.transl_with_constraint initial_env id None decl sdecl in - let newdecl = tdecl.typ_type in - check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; - (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem - | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) + let tdecl = + Typedecl.transl_with_constraint initial_env id None decl sdecl + in + let newdecl = tdecl.typ_type in + check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; + ((Pident id, lid, Twith_type tdecl), Sig_type (id, newdecl, rs) :: rem) + | Sig_type (id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _) when Ident.name id = s ^ "#row" -> - merge env rem namelist (Some id) - | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst (_, sdecl)) - when Ident.name id = s -> - (* Check as for a normal with constraint, but discard definition *) - let tdecl = - Typedecl.transl_with_constraint initial_env id None decl sdecl in - let newdecl = tdecl.typ_type in - check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; - real_ids := [Pident id]; - (Pident id, lid, Twith_typesubst tdecl), - update_rec_next rs rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid')) + merge env rem namelist (Some id) + | Sig_type (id, decl, rs) :: rem, [s], Pwith_typesubst (_, sdecl) 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 newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in - ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); - (Pident id, lid, Twith_module (path, lid')), - Sig_module(id, newmd, rs) :: rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) + (* Check as for a normal with constraint, but discard definition *) + let tdecl = + Typedecl.transl_with_constraint initial_env id None decl sdecl + in + let newdecl = tdecl.typ_type in + check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; + real_ids := [Pident id]; + ((Pident id, lid, Twith_typesubst tdecl), update_rec_next rs rem) + | Sig_module (id, md, rs) :: rem, [s], Pwith_module (_, lid') when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid'.txt in - let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in - ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); - real_ids := [Pident id]; - (Pident id, lid, Twith_modsubst (path, lid')), - update_rec_next rs rem - | (Sig_module(id, md, rs) :: rem, s :: namelist, _) + 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 newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in + ignore (Includemod.modtypes ~loc env newmd.md_type md.md_type); + ( (Pident id, lid, Twith_module (path, lid')), + Sig_module (id, newmd, rs) :: rem ) + | Sig_module (id, md, rs) :: rem, [s], Pwith_modsubst (_, lid') when Ident.name id = s -> - let ((path, _path_loc, tcstr), newsg) = - merge env (extract_sig env loc md.md_type) namelist None in - let path = path_concat id path in - real_ids := path :: !real_ids; - let item = Sig_module(id, {md with md_type=Mty_signature newsg}, rs) in - (path, lid, tcstr), - item :: rem - | (item :: rem, _, _) -> - let (cstr, items) = merge (Env.add_item item env) rem namelist row_id - in - cstr, item :: items + let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in + ignore (Includemod.modtypes ~loc env newmd.md_type md.md_type); + real_ids := [Pident id]; + ((Pident id, lid, Twith_modsubst (path, lid')), update_rec_next rs rem) + | Sig_module (id, md, rs) :: rem, s :: namelist, _ when Ident.name id = s -> + let (path, _path_loc, tcstr), newsg = + merge env (extract_sig env loc md.md_type) namelist None + in + let path = path_concat id path in + real_ids := path :: !real_ids; + let item = Sig_module (id, {md with md_type = Mty_signature newsg}, rs) in + ((path, lid, tcstr), item :: rem) + | item :: rem, _, _ -> + let cstr, items = merge (Env.add_item item env) rem namelist row_id in + (cstr, item :: items) in try let names = Longident.flatten lid.txt in - let (tcstr, sg) = merge initial_env sg names None in - if destructive_substitution then ( - match List.rev !real_ids with - | [] -> assert false - | last :: rest -> - (* The last item is the one that's removed. We don't need to check how - it's used since it's replaced by a more specific type/module. *) - assert (match last with Pident _ -> true | _ -> false); - match rest with - | [] -> () - | _ :: _ -> - check_usage_of_path_of_substituted_item - rest initial_env sg ~loc ~lid; - ); + let tcstr, sg = merge initial_env sg names None in + (if destructive_substitution then + match List.rev !real_ids with + | [] -> assert false + | last :: rest -> ( + (* The last item is the one that's removed. We don't need to check how + it's used since it's replaced by a more specific type/module. *) + assert ( + match last with + | Pident _ -> true + | _ -> false); + match rest with + | [] -> () + | _ :: _ -> + check_usage_of_path_of_substituted_item rest initial_env sg ~loc ~lid + )); let sg = - match tcstr with - | (_, _, Twith_typesubst tdecl) -> - let how_to_extend_subst = - let sdecl = - match constr with - | Pwith_typesubst (_, sdecl) -> sdecl - | _ -> assert false - in - match type_decl_is_alias sdecl with - | Some lid -> + match tcstr with + | _, _, Twith_typesubst tdecl -> + let how_to_extend_subst = + let sdecl = + match constr with + | Pwith_typesubst (_, sdecl) -> sdecl + | _ -> assert false + in + match type_decl_is_alias sdecl with + | Some lid -> let replacement = try Env.lookup_type lid.txt initial_env with Not_found -> assert false in fun s path -> Subst.add_type_path path replacement s - | None -> + | None -> let body = match tdecl.typ_type.type_manifest with | None -> assert false | Some x -> x in let params = tdecl.typ_type.type_params in - if params_are_constrained params - then raise(Error(loc, initial_env, With_cannot_remove_constrained_type)); + if params_are_constrained params then + raise + (Error (loc, initial_env, With_cannot_remove_constrained_type)); fun s path -> Subst.add_type_function path ~params ~body s - in - let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in - Subst.signature sub sg - | (_, _, Twith_modsubst (real_path, _)) -> - let sub = - List.fold_left - (fun s path -> Subst.add_module_path path real_path s) - Subst.identity - !real_ids - in - Subst.signature sub sg - | _ -> - sg + in + let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in + Subst.signature sub sg + | _, _, Twith_modsubst (real_path, _) -> + let sub = + List.fold_left + (fun s path -> Subst.add_module_path path real_path s) + Subst.identity !real_ids + in + Subst.signature sub sg + | _ -> sg in (tcstr, sg) with Includemod.Error explanation -> - raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) + raise (Error (loc, initial_env, With_mismatch (lid.txt, explanation))) (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -473,21 +469,20 @@ let map_rec_type ~rec_flag fn decls rem = match decls with | [] -> rem | d1 :: dl -> - let first = - match rec_flag with - | Recursive -> Trec_first - | Nonrecursive -> Trec_not - in - fn first d1 :: map_end (fn Trec_next) dl rem + let first = + match rec_flag with + | Recursive -> Trec_first + | Nonrecursive -> Trec_not + in + fn first d1 :: map_end (fn Trec_next) dl rem let rec map_rec_type_with_row_types ~rec_flag fn decls rem = match decls with | [] -> rem | d1 :: dl -> - if Btype.is_row_name (Ident.name d1.typ_id) then - fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem - else - map_rec_type ~rec_flag fn decls rem + if Btype.is_row_name (Ident.name d1.typ_id) then + fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem + else map_rec_type ~rec_flag fn decls rem (* Add type extension flags to extension constructors *) let map_ext fn exts rem = @@ -503,27 +498,26 @@ let map_ext fn exts rem = let rec approx_modtype env smty = match smty.pmty_desc with - Pmty_ident lid -> - let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in - Mty_ident path + | Pmty_ident lid -> + let path, _info = Typetexp.find_modtype env smty.pmty_loc lid.txt in + Mty_ident path | Pmty_alias lid -> - let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in - Mty_alias(Mta_absent, path) - | Pmty_signature ssg -> - Mty_signature(approx_sig env ssg) - | Pmty_functor(param, sarg, sres) -> - let arg = may_map (approx_modtype env) sarg in - let (id, newenv) = - Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in - let res = approx_modtype newenv sres in - Mty_functor(id, arg, res) - | Pmty_with(sbody, _constraints) -> - approx_modtype env sbody + let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in + Mty_alias (Mta_absent, path) + | Pmty_signature ssg -> Mty_signature (approx_sig env ssg) + | Pmty_functor (param, sarg, sres) -> + let arg = may_map (approx_modtype env) sarg in + let id, newenv = + Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env + in + let res = approx_modtype newenv sres in + Mty_functor (id, arg, res) + | Pmty_with (sbody, _constraints) -> approx_modtype env sbody | Pmty_typeof smod -> - let (_, mty) = !type_module_type_of_fwd env smod in - mty + let _, mty = !type_module_type_of_fwd env smod in + mty | Pmty_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) and approx_module_declaration env pmd = { @@ -534,64 +528,64 @@ and approx_module_declaration env pmd = and approx_sig env ssg = match ssg with - [] -> [] - | item :: srem -> - match item.psig_desc with - | Psig_type (rec_flag, sdecls) -> - let decls = Typedecl.approx_type_decl sdecls in - let rem = approx_sig env srem in - map_rec_type ~rec_flag - (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem - | Psig_module pmd -> - let id = Ident.create pmd.pmd_name.txt in - let md = approx_module_declaration env pmd in - let newenv = Env.enter_module_declaration id md env in - Sig_module(id, md, Trec_not) :: approx_sig newenv srem - | Psig_recmodule sdecls -> - let decls = - List.map - (fun pmd -> - (Ident.create pmd.pmd_name.txt, - approx_module_declaration env pmd) - ) - sdecls - in - let newenv = - List.fold_left - (fun env (id, md) -> Env.add_module_declaration ~check:false - id md env) - env decls in - map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls - (approx_sig newenv srem) - | Psig_modtype d -> - let info = approx_modtype_info env d in - let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in - Sig_modtype(id, info) :: approx_sig newenv srem - | Psig_open sod -> - let (_path, mty, _od) = type_open env sod in - approx_sig mty srem - | Psig_include sincl -> - let smty = sincl.pincl_mod in - let mty = approx_modtype env smty in - let sg = Subst.signature Subst.identity - (extract_sig env smty.pmty_loc mty) in - let newenv = Env.add_signature sg env in - sg @ approx_sig newenv srem - | Psig_class_type () -> assert false - | Psig_class () -> assert false - | _ -> - approx_sig env srem + | [] -> [] + | item :: srem -> ( + match item.psig_desc with + | Psig_type (rec_flag, sdecls) -> + let decls = Typedecl.approx_type_decl sdecls in + let rem = approx_sig env srem in + map_rec_type ~rec_flag + (fun rs (id, info) -> Sig_type (id, info, rs)) + decls rem + | Psig_module pmd -> + let id = Ident.create pmd.pmd_name.txt in + let md = approx_module_declaration env pmd in + let newenv = Env.enter_module_declaration id md env in + Sig_module (id, md, Trec_not) :: approx_sig newenv srem + | Psig_recmodule sdecls -> + let decls = + List.map + (fun pmd -> + (Ident.create pmd.pmd_name.txt, approx_module_declaration env pmd)) + sdecls + in + let newenv = + List.fold_left + (fun env (id, md) -> + Env.add_module_declaration ~check:false id md env) + env decls + in + map_rec + (fun rs (id, md) -> Sig_module (id, md, rs)) + decls (approx_sig newenv srem) + | Psig_modtype d -> + let info = approx_modtype_info env d in + let id, newenv = Env.enter_modtype d.pmtd_name.txt info env in + Sig_modtype (id, info) :: approx_sig newenv srem + | Psig_open sod -> + let _path, mty, _od = type_open env sod in + approx_sig mty srem + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let mty = approx_modtype env smty in + let sg = + Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) + in + let newenv = Env.add_signature sg env in + sg @ approx_sig newenv srem + | Psig_class_type () -> assert false + | Psig_class () -> assert false + | _ -> approx_sig env srem) and approx_modtype_info env sinfo = { - mtd_type = may_map (approx_modtype env) sinfo.pmtd_type; - mtd_attributes = sinfo.pmtd_attributes; - mtd_loc = sinfo.pmtd_loc; + mtd_type = may_map (approx_modtype env) sinfo.pmtd_type; + mtd_attributes = sinfo.pmtd_attributes; + mtd_loc = sinfo.pmtd_loc; } let approx_modtype env smty = - Warnings.without_warnings - (fun () -> approx_modtype env smty) + Warnings.without_warnings (fun () -> approx_modtype env smty) (* Additional validity checks on type definitions arising from recursive modules *) @@ -600,54 +594,53 @@ let check_recmod_typedecls env sdecls decls = let recmod_ids = List.map fst3 decls in List.iter2 (fun pmd (id, _, mty) -> - let mty = mty.mty_type in + let mty = mty.mty_type in List.iter (fun path -> Typedecl.check_recmod_typedecl env pmd.pmd_type.pmty_loc recmod_ids - path (Env.find_type path env)) + path (Env.find_type path env)) (Mtype.type_paths env (Pident id) mty)) sdecls decls (* Auxiliaries for checking uniqueness of names in signatures and structures *) -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = String.compare x y end) +module StringSet = Set.Make (struct + type t = string + let compare (x : t) y = String.compare x y +end) let check cl loc tbl name = match Hashtbl.find_opt tbl name with | Some repeated_loc -> - raise(Error(loc, Env.empty, Repeated_name(cl, name, repeated_loc))) + raise (Error (loc, Env.empty, Repeated_name (cl, name, repeated_loc))) | None -> Hashtbl.add tbl name loc -type names = - { - types: (string, Warnings.loc) Hashtbl.t; - modules: (string, Warnings.loc) Hashtbl.t; - modtypes: (string, Warnings.loc) Hashtbl.t; - typexts: (string, Warnings.loc) Hashtbl.t; - } +type names = { + types: (string, Warnings.loc) Hashtbl.t; + modules: (string, Warnings.loc) Hashtbl.t; + modtypes: (string, Warnings.loc) Hashtbl.t; + typexts: (string, Warnings.loc) Hashtbl.t; +} let new_names () = { - types = (Hashtbl.create 10); - modules = (Hashtbl.create 10); - modtypes = (Hashtbl.create 10); - typexts = (Hashtbl.create 10); + types = Hashtbl.create 10; + modules = Hashtbl.create 10; + modtypes = Hashtbl.create 10; + typexts = Hashtbl.create 10; } - 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_typext names loc s = check "extension constructor" loc names.typexts 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) - | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id) + | 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) + | Sig_typext (id, _, _) -> check_typext names loc (Ident.name id) | _ -> () (* Simplify multiple specifications of a value or an extension in a signature. @@ -657,240 +650,247 @@ let check_sig_item names loc = function let simplify_signature sg = let rec aux = function - | [] -> [], StringSet.empty - | (Sig_value(id, _descr) as component) :: sg -> - let (sg, val_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) + | [] -> ([], StringSet.empty) + | (Sig_value (id, _descr) as component) :: sg -> + let ((sg, val_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) | component :: sg -> - let (sg, val_names) = aux sg in - (component :: sg, val_names) + let sg, val_names = aux sg in + (component :: sg, val_names) in - let (sg, _) = aux sg in + let sg, _ = aux sg in sg (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = - let (path, _info) = Typetexp.find_modtype env loc lid in + let path, _info = Typetexp.find_modtype env loc lid in path -let transl_module_alias loc env lid = - Typetexp.lookup_module env loc lid +let transl_module_alias loc env lid = Typetexp.lookup_module env loc lid let mkmty desc typ env loc attrs = - let mty = { - mty_desc = desc; - mty_type = typ; - mty_loc = loc; - mty_env = env; - mty_attributes = attrs; - } in + let mty = + { + mty_desc = desc; + mty_type = typ; + mty_loc = loc; + mty_env = env; + mty_attributes = attrs; + } + in Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); mty let mksig desc env loc = - let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in + let sg = {sig_desc = desc; sig_loc = loc; sig_env = env} in Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); sg (* let signature sg = List.map (fun item -> item.sig_type) sg *) let rec transl_modtype env smty = - Builtin_attributes.warning_scope smty.pmty_attributes - (fun () -> transl_modtype_aux env smty) + Builtin_attributes.warning_scope smty.pmty_attributes (fun () -> + transl_modtype_aux env smty) and transl_modtype_aux env smty = let loc = smty.pmty_loc in match smty.pmty_desc with - Pmty_ident lid -> - let path = transl_modtype_longident loc env lid.txt in - mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc - smty.pmty_attributes + | Pmty_ident lid -> + let path = transl_modtype_longident loc env lid.txt in + mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc smty.pmty_attributes | Pmty_alias lid -> - let path = transl_module_alias loc env lid.txt in - mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc - smty.pmty_attributes + let path = transl_module_alias loc env lid.txt in + mkmty + (Tmty_alias (path, lid)) + (Mty_alias (Mta_absent, path)) + env loc smty.pmty_attributes | Pmty_signature ssg -> - let sg = transl_signature env ssg in - mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc - smty.pmty_attributes - | Pmty_functor(param, sarg, sres) -> - let arg = Misc.may_map (transl_modtype env) sarg in - let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in - let (id, newenv) = - Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in - Ctype.init_def(Ident.current_time()); (* PR#6513 *) - let res = transl_modtype newenv sres in - mkmty (Tmty_functor (id, param, arg, res)) - (Mty_functor(id, ty_arg, res.mty_type)) env loc - smty.pmty_attributes - | Pmty_with(sbody, constraints) -> - let body = transl_modtype env sbody in - let init_sg = extract_sig env sbody.pmty_loc body.mty_type in - let (rev_tcstrs, final_sg) = - List.fold_left - (fun (rev_tcstrs,sg) sdecl -> - let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl - in - (tcstr :: rev_tcstrs, sg) - ) - ([],init_sg) constraints in - mkmty (Tmty_with ( body, List.rev rev_tcstrs)) - (Mtype.freshen (Mty_signature final_sg)) env loc - smty.pmty_attributes + let sg = transl_signature env ssg in + mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc + smty.pmty_attributes + | Pmty_functor (param, sarg, sres) -> + let arg = Misc.may_map (transl_modtype env) sarg in + let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in + let id, newenv = + Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env + in + Ctype.init_def (Ident.current_time ()); + (* PR#6513 *) + let res = transl_modtype newenv sres in + mkmty + (Tmty_functor (id, param, arg, res)) + (Mty_functor (id, ty_arg, res.mty_type)) + env loc smty.pmty_attributes + | Pmty_with (sbody, constraints) -> + let body = transl_modtype env sbody in + let init_sg = extract_sig env sbody.pmty_loc body.mty_type in + let rev_tcstrs, final_sg = + List.fold_left + (fun (rev_tcstrs, sg) sdecl -> + let tcstr, sg = merge_constraint env smty.pmty_loc sg sdecl in + (tcstr :: rev_tcstrs, sg)) + ([], init_sg) constraints + in + mkmty + (Tmty_with (body, List.rev rev_tcstrs)) + (Mtype.freshen (Mty_signature final_sg)) + env loc smty.pmty_attributes | Pmty_typeof smod -> - let env = Env.in_signature false env in - let tmty, mty = !type_module_type_of_fwd env smod in - mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes + let env = Env.in_signature false env in + let tmty, mty = !type_module_type_of_fwd env smod in + mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes | Pmty_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) and transl_signature env sg = let names = new_names () in let rec transl_sig env sg = - Ctype.init_def(Ident.current_time()); + Ctype.init_def (Ident.current_time ()); match sg with - [] -> [], [], env - | item :: srem -> - let loc = item.psig_loc in - match item.psig_desc with - | Psig_value sdesc -> - let (tdesc, newenv) = - Typedecl.transl_value_decl env item.psig_loc sdesc - in - let (trem,rem, final_env) = transl_sig newenv srem in - mksig (Tsig_value tdesc) env loc :: trem, - Sig_value(tdesc.val_id, tdesc.val_val) :: rem, - final_env - | Psig_type (rec_flag, sdecls) -> - List.iter - (fun decl -> check_name check_type names decl.ptype_name) - sdecls; - let (decls, newenv) = - Typedecl.transl_type_decl env rec_flag sdecls - in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_type (rec_flag, decls)) env loc :: trem, - map_rec_type_with_row_types ~rec_flag - (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem, - final_env - | Psig_typext styext -> - List.iter - (fun pext -> check_name check_typext names pext.pext_name) - styext.ptyext_constructors; - let (tyext, newenv) = - Typedecl.transl_type_extension false env item.psig_loc styext - in - let (trem, rem, final_env) = transl_sig newenv srem in - let constructors = tyext.tyext_constructors in - mksig (Tsig_typext tyext) env loc :: trem, - map_ext (fun es ext -> - Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem, - final_env - | Psig_exception sext -> - check_name check_typext names sext.pext_name; - let (ext, newenv) = Typedecl.transl_exception env sext in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_exception ext) env loc :: trem, - Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem, - final_env - | Psig_module pmd -> - check_name check_module names pmd.pmd_name; - let id = Ident.create pmd.pmd_name.txt in - let tmty = - Builtin_attributes.warning_scope pmd.pmd_attributes - (fun () -> transl_modtype env pmd.pmd_type) - in - let md = { - md_type=tmty.mty_type; - md_attributes=pmd.pmd_attributes; - md_loc=pmd.pmd_loc; - } - in - let newenv = Env.enter_module_declaration id md env in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty; - md_loc=pmd.pmd_loc; - md_attributes=pmd.pmd_attributes}) - env loc :: trem, - Sig_module(id, md, Trec_not) :: rem, - final_env - | Psig_recmodule sdecls -> - List.iter - (fun pmd -> check_name check_module names pmd.pmd_name) - sdecls; - let (decls, newenv) = - transl_recmodule_modtypes env sdecls in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_recmodule decls) env loc :: trem, - map_rec (fun rs md -> - let d = {Types.md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; - } in - Sig_module(md.md_id, d, rs)) - decls rem, - final_env - | Psig_modtype pmtd -> - let newenv, mtd, sg = - transl_modtype_decl names env pmtd - in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_modtype mtd) env loc :: trem, - sg :: rem, - final_env - | Psig_open sod -> - let (_path, newenv, od) = type_open env sod in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_open od) env loc :: trem, - rem, final_env - | Psig_include sincl -> - let smty = sincl.pincl_mod in - let tmty = - Builtin_attributes.warning_scope sincl.pincl_attributes - (fun () -> transl_modtype env smty) - in - 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 names item.psig_loc) sg; - let newenv = Env.add_signature sg env in - let incl = - { incl_mod = tmty; - incl_type = sg; - incl_attributes = sincl.pincl_attributes; - incl_loc = sincl.pincl_loc; - } - in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_include incl) env loc :: trem, - sg @ rem, - final_env - | Psig_class _ -> assert false - | Psig_class_type _ -> assert false - | Psig_attribute x -> - Builtin_attributes.warning_attribute x; - let (trem,rem, final_env) = transl_sig env srem in - mksig (Tsig_attribute x) env loc :: trem, rem, final_env - | Psig_extension (ext, _attrs) -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | [] -> ([], [], env) + | item :: srem -> ( + let loc = item.psig_loc in + match item.psig_desc with + | Psig_value sdesc -> + let tdesc, newenv = + Typedecl.transl_value_decl env item.psig_loc sdesc + in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_value tdesc) env loc :: trem, + Sig_value (tdesc.val_id, tdesc.val_val) :: rem, + final_env ) + | Psig_type (rec_flag, sdecls) -> + List.iter + (fun decl -> check_name check_type names decl.ptype_name) + sdecls; + let decls, newenv = Typedecl.transl_type_decl env rec_flag sdecls in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_type (rec_flag, decls)) env loc :: trem, + map_rec_type_with_row_types ~rec_flag + (fun rs td -> Sig_type (td.typ_id, td.typ_type, rs)) + decls rem, + final_env ) + | Psig_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let tyext, newenv = + Typedecl.transl_type_extension false env item.psig_loc styext + in + let trem, rem, final_env = transl_sig newenv srem in + let constructors = tyext.tyext_constructors in + ( mksig (Tsig_typext tyext) env loc :: trem, + map_ext + (fun es ext -> Sig_typext (ext.ext_id, ext.ext_type, es)) + constructors rem, + final_env ) + | Psig_exception sext -> + check_name check_typext names sext.pext_name; + let ext, newenv = Typedecl.transl_exception env sext in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_exception ext) env loc :: trem, + Sig_typext (ext.ext_id, ext.ext_type, Text_exception) :: rem, + final_env ) + | Psig_module pmd -> + check_name check_module names pmd.pmd_name; + let id = Ident.create pmd.pmd_name.txt in + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes (fun () -> + transl_modtype env pmd.pmd_type) + in + let md = + { + md_type = tmty.mty_type; + md_attributes = pmd.pmd_attributes; + md_loc = pmd.pmd_loc; + } + in + let newenv = Env.enter_module_declaration id md env in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig + (Tsig_module + { + md_id = id; + md_name = pmd.pmd_name; + md_type = tmty; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + }) + env loc + :: trem, + Sig_module (id, md, Trec_not) :: rem, + final_env ) + | Psig_recmodule sdecls -> + List.iter (fun pmd -> check_name check_module names pmd.pmd_name) sdecls; + let decls, newenv = transl_recmodule_modtypes env sdecls in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_recmodule decls) env loc :: trem, + map_rec + (fun rs md -> + let d = + { + Types.md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Sig_module (md.md_id, d, rs)) + decls rem, + final_env ) + | Psig_modtype pmtd -> + let newenv, mtd, sg = transl_modtype_decl names env pmtd in + let trem, rem, final_env = transl_sig newenv srem in + (mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env) + | Psig_open sod -> + let _path, newenv, od = type_open env sod in + let trem, rem, final_env = transl_sig newenv srem in + (mksig (Tsig_open od) env loc :: trem, rem, final_env) + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let tmty = + Builtin_attributes.warning_scope sincl.pincl_attributes (fun () -> + transl_modtype env smty) + in + 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 names item.psig_loc) sg; + let newenv = Env.add_signature sg env in + let incl = + { + incl_mod = tmty; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + let trem, rem, final_env = transl_sig newenv srem in + (mksig (Tsig_include incl) env loc :: trem, sg @ rem, final_env) + | Psig_class _ -> assert false + | Psig_class_type _ -> assert false + | Psig_attribute x -> + Builtin_attributes.warning_attribute x; + let trem, rem, final_env = transl_sig env srem in + (mksig (Tsig_attribute x) env loc :: trem, rem, final_env) + | Psig_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext))) in let previous_saved_types = Cmt_format.get_saved_types () in - Builtin_attributes.warning_scope [] - (fun () -> - let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in - let rem = simplify_signature rem in - let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in - Cmt_format.set_saved_types - ((Cmt_format.Partial_signature sg) :: previous_saved_types); - sg - ) + Builtin_attributes.warning_scope [] (fun () -> + let trem, rem, final_env = transl_sig (Env.in_signature true env) sg in + let rem = simplify_signature rem in + let sg = {sig_items = trem; sig_type = rem; sig_final_env = final_env} in + Cmt_format.set_saved_types + (Cmt_format.Partial_signature sg :: previous_saved_types); + sg) and transl_modtype_decl names env pmtd = - Builtin_attributes.warning_scope pmtd.pmtd_attributes - (fun () -> transl_modtype_decl_aux names env pmtd) + Builtin_attributes.warning_scope pmtd.pmtd_attributes (fun () -> + transl_modtype_decl_aux names env pmtd) and transl_modtype_decl_aux names env {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = @@ -898,41 +898,44 @@ and transl_modtype_decl_aux names env let tmty = Misc.may_map (transl_modtype env) pmtd_type in let decl = { - Types.mtd_type=may_map (fun t -> t.mty_type) tmty; - mtd_attributes=pmtd_attributes; - mtd_loc=pmtd_loc; + Types.mtd_type = may_map (fun t -> t.mty_type) tmty; + mtd_attributes = pmtd_attributes; + mtd_loc = pmtd_loc; } in - let (id, newenv) = Env.enter_modtype pmtd_name.txt decl env in + let id, newenv = Env.enter_modtype pmtd_name.txt decl env in let mtd = { - mtd_id=id; - mtd_name=pmtd_name; - mtd_type=tmty; - mtd_attributes=pmtd_attributes; - mtd_loc=pmtd_loc; + mtd_id = id; + mtd_name = pmtd_name; + mtd_type = tmty; + mtd_attributes = pmtd_attributes; + mtd_loc = pmtd_loc; } in - newenv, mtd, Sig_modtype(id, decl) + (newenv, mtd, Sig_modtype (id, decl)) and transl_recmodule_modtypes env sdecls = let make_env curr = List.fold_left (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env) - env curr in + env curr + in let make_env2 curr = List.fold_left (fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env) - env curr in + env curr + in let transition env_c curr = List.map2 (fun pmd (id, id_loc, _mty) -> let tmty = - Builtin_attributes.warning_scope pmd.pmd_attributes - (fun () -> transl_modtype env_c pmd.pmd_type) + Builtin_attributes.warning_scope pmd.pmd_attributes (fun () -> + transl_modtype env_c pmd.pmd_type) in (id, id_loc, tmty)) - sdecls curr in + sdecls curr + in let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in let approx_env = (* @@ -943,27 +946,23 @@ and transl_recmodule_modtypes env sdecls = *) List.fold_left (fun env id -> - let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in - Env.add_module ~arg:true id dummy env - ) + let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in + Env.add_module ~arg:true id dummy env) env ids in - Ctype.init_def(Ident.current_time()); (* PR#7082 *) + Ctype.init_def (Ident.current_time ()); + (* PR#7082 *) let init = List.map2 - (fun id pmd -> - (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type)) + (fun id pmd -> (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type)) ids sdecls in let env0 = make_env init in - let dcl1 = - Warnings.without_warnings - (fun () -> transition env0 init) - in + let dcl1 = Warnings.without_warnings (fun () -> transition env0 init) in let env1 = make_env2 dcl1 in check_recmod_typedecls env1 sdecls dcl1; let dcl2 = transition env1 dcl1 in -(* + (* List.iter (fun (id, mty) -> Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) @@ -974,9 +973,13 @@ and transl_recmodule_modtypes env sdecls = let dcl2 = List.map2 (fun pmd (id, id_loc, mty) -> - {md_id=id; md_name=id_loc; md_type=mty; - md_loc=pmd.pmd_loc; - md_attributes=pmd.pmd_attributes}) + { + md_id = id; + md_name = id_loc; + md_type = mty; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + }) sdecls dcl2 in (dcl2, env2) @@ -987,71 +990,71 @@ exception Not_a_path let rec path_of_module mexp = match mexp.mod_desc with - Tmod_ident (p,_) -> p - | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors -> - Papply(path_of_module funct, path_of_module arg) - | Tmod_constraint (mexp, _, _, _) -> - path_of_module mexp + | Tmod_ident (p, _) -> p + | Tmod_apply (funct, arg, _coercion) when !Clflags.applicative_functors -> + Papply (path_of_module funct, path_of_module arg) + | Tmod_constraint (mexp, _, _, _) -> path_of_module mexp | _ -> raise Not_a_path let path_of_module mexp = - try Some (path_of_module mexp) with Not_a_path -> None + try Some (path_of_module mexp) with Not_a_path -> None (* Check that all core type schemes in a structure are closed *) let rec closed_modtype env = function - Mty_ident _ -> true + | Mty_ident _ -> true | Mty_alias _ -> true | Mty_signature sg -> - let env = Env.add_signature sg env in - List.for_all (closed_signature_item env) sg - | Mty_functor(id, param, body) -> - let env = Env.add_module ~arg:true id (Btype.default_mty param) env in - closed_modtype env body + let env = Env.add_signature sg env in + List.for_all (closed_signature_item env) sg + | Mty_functor (id, param, body) -> + let env = Env.add_module ~arg:true id (Btype.default_mty param) env in + closed_modtype env body and closed_signature_item env = function - Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type - | Sig_module(_id, md, _) -> closed_modtype env md.md_type + | Sig_value (_id, desc) -> Ctype.closed_schema env desc.val_type + | Sig_module (_id, md, _) -> closed_modtype env md.md_type | _ -> true let check_nongen_scheme env sig_item = match sig_item with - Sig_value(_id, vd) -> - if not (Ctype.closed_schema env vd.val_type) then - raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) + | Sig_value (_id, vd) -> + if not (Ctype.closed_schema env vd.val_type) then + raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) | Sig_module (_id, md, _) -> - if not (closed_modtype env md.md_type) then - raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) + if not (closed_modtype env md.md_type) then + raise (Error (md.md_loc, env, Non_generalizable_module md.md_type)) | _ -> () -let check_nongen_schemes env sg = - List.iter (check_nongen_scheme env) sg +let check_nongen_schemes env sg = List.iter (check_nongen_scheme env) sg (* Helpers for typing recursive modules *) let anchor_submodule name anchor = - match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos)) -let anchor_recmodule id = - Some (Pident id) + match anchor with + | None -> None + | Some p -> Some (Pdot (p, name, nopos)) +let anchor_recmodule id = Some (Pident id) let enrich_type_decls anchor decls oldenv newenv = match anchor with - None -> newenv + | None -> newenv | Some p -> - List.fold_left - (fun e info -> - let id = info.typ_id in - let info' = - Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) - info.typ_type - in - Env.add_type ~check:true id info' e) - oldenv decls + List.fold_left + (fun e info -> + let id = info.typ_id in + let info' = + Mtype.enrich_typedecl oldenv + (Pdot (p, Ident.name id, nopos)) + info.typ_type + in + Env.add_type ~check:true id info' e) + oldenv decls let enrich_module_type anchor name mty env = match anchor with - None -> mty - | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty + | None -> mty + | Some p -> Mtype.enrich_modtype env (Pdot (p, name, nopos)) mty let check_recmodule_inclusion env bindings = (* PR#4450, PR#4470: consider @@ -1073,280 +1076,315 @@ let check_recmodule_inclusion env bindings = N can be chosen arbitrarily; larger values of N result in more recursive definitions being accepted. A good choice appears to be the number of mutually recursive declarations. *) - let subst_and_strengthen env s id mty = Mtype.strengthen ~aliasable:false env (Subst.modtype s mty) - (Subst.module_path s (Pident id)) in + (Subst.module_path s (Pident id)) + in let rec check_incl first_time n env s = - if n > 0 then begin + if n > 0 then (* Generate fresh names Y_i for the rec. bound module idents X_i *) let bindings1 = List.map (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) -> - (id, Ident.rename id, mty_actual)) - bindings in + (id, Ident.rename id, mty_actual)) + bindings + in (* Enter the Y_i in the environment with their actual types substituted by the input substitution s *) let env' = List.fold_left (fun env (id, id', mty_actual) -> - let mty_actual' = - if first_time - then mty_actual - else subst_and_strengthen env s id mty_actual in - Env.add_module ~arg:false id' mty_actual' env) - env bindings1 in + let mty_actual' = + if first_time then mty_actual + else subst_and_strengthen env s id mty_actual + in + Env.add_module ~arg:false id' mty_actual' env) + env bindings1 + in (* Build the output substitution Y_i <- X_i *) let s' = List.fold_left - (fun s (id, id', _mty_actual) -> - Subst.add_module id (Pident id') s) - Subst.identity bindings1 in + (fun s (id, id', _mty_actual) -> Subst.add_module id (Pident id') s) + Subst.identity bindings1 + in (* Recurse with env' and s' *) - check_incl false (n-1) env' s' - end else begin + check_incl false (n - 1) env' s' + else (* Base case: check inclusion of s(mty_actual) in s(mty_decl) and insert coercion if needed *) let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) = let mty_decl' = Subst.modtype s mty_decl.mty_type and mty_actual' = subst_and_strengthen env s id mty_actual in let coercion = - try - Includemod.modtypes ~loc:modl.mod_loc env mty_actual' mty_decl' + try Includemod.modtypes ~loc:modl.mod_loc env mty_actual' mty_decl' with Includemod.Error msg -> - raise(Error(modl.mod_loc, env, Not_included msg)) in + raise (Error (modl.mod_loc, env, Not_included msg)) + in let modl' = - { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, - Tmodtype_explicit mty_decl, coercion); - mod_type = mty_decl.mty_type; - mod_env = env; - mod_loc = modl.mod_loc; - mod_attributes = []; - } in + { + mod_desc = + Tmod_constraint + (modl, mty_decl.mty_type, Tmodtype_explicit mty_decl, coercion); + mod_type = mty_decl.mty_type; + mod_env = env; + mod_loc = modl.mod_loc; + mod_attributes = []; + } + in { - mb_id = id; - mb_name = id_loc; - mb_expr = modl'; - mb_attributes = attrs; - mb_loc = loc; + mb_id = id; + mb_name = id_loc; + mb_expr = modl'; + mb_attributes = attrs; + mb_loc = loc; } in List.map check_inclusion bindings - end - in check_incl true (List.length bindings) env Subst.identity + in + check_incl true (List.length bindings) env Subst.identity (* Helper for unpack *) let rec package_constraints env loc mty constrs = if constrs = [] then mty - else let sg = extract_sig env loc mty in - let sg' = - List.map - (function - | Sig_type (id, ({type_params=[]} as td), rs) - when List.mem_assoc [Ident.name id] constrs -> + else + let sg = extract_sig env loc mty in + let sg' = + List.map + (function + | Sig_type (id, ({type_params = []} as td), rs) + when List.mem_assoc [Ident.name id] constrs -> let ty = List.assoc [Ident.name id] constrs in Sig_type (id, {td with type_manifest = Some ty}, rs) - | Sig_module (id, md, rs) -> + | Sig_module (id, md, rs) -> let rec aux = function - | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> - (l, t) :: aux rest + | (m :: (_ :: _ as l), t) :: rest when m = Ident.name id -> + (l, t) :: aux rest | _ :: rest -> aux rest | [] -> [] in let md = - {md with - md_type = package_constraints env loc md.md_type (aux constrs) + { + md with + md_type = package_constraints env loc md.md_type (aux constrs); } in Sig_module (id, md, rs) - | item -> item - ) - sg - in - Mty_signature sg' + | item -> item) + sg + in + Mty_signature sg' let modtype_of_package env loc p nl tl = - try match (Env.find_modtype p env).mtd_type with - | Some mty when nl <> [] -> + try + match (Env.find_modtype p env).mtd_type with + | Some mty when nl <> [] -> package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl) - | _ -> + | _ -> if nl = [] then Mty_ident p - else raise(Error(loc, env, Signature_expected)) + else raise (Error (loc, env, Signature_expected)) with Not_found -> let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in - raise(Typetexp.Error(loc, env, error)) + raise (Typetexp.Error (loc, env, error)) let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = let mkmty p nl tl = let ntl = - Ext_list.filter (List.combine nl tl) (fun (_n,t) -> Ctype.free_variables t = []) + Ext_list.filter (List.combine nl tl) (fun (_n, t) -> + Ctype.free_variables t = []) in - let (nl, tl) = List.split ntl in + let nl, tl = List.split ntl in modtype_of_package env Location.none p nl tl in let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in try Includemod.modtypes ~loc:Location.none env mty1 mty2 = Tcoerce_none with Includemod.Error _msg -> false - (* raise(Error(Location.none, env, Not_included msg)) *) +(* raise(Error(Location.none, env, Not_included msg)) *) let () = Ctype.package_subtype := package_subtype let wrap_constraint env arg mty explicit = let coercion = - try - Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty + try Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty with Includemod.Error msg -> - raise(Error(arg.mod_loc, env, Not_included msg)) in - { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + raise (Error (arg.mod_loc, env, Not_included msg)) + in + { + mod_desc = Tmod_constraint (arg, mty, explicit, coercion); mod_type = mty; mod_env = env; mod_attributes = []; - mod_loc = arg.mod_loc } + mod_loc = arg.mod_loc; + } (* Type a module value expression *) -let rec type_module ?(alias=false) sttn funct_body anchor env smod = - Builtin_attributes.warning_scope smod.pmod_attributes - (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) +let rec type_module ?(alias = false) sttn funct_body anchor env smod = + Builtin_attributes.warning_scope smod.pmod_attributes (fun () -> + type_module_aux ~alias sttn funct_body anchor env smod) and type_module_aux ~alias sttn funct_body anchor env smod = match smod.pmod_desc with - Pmod_ident lid -> - let path = - Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in - let md = { mod_desc = Tmod_ident (path, lid); - mod_type = Mty_alias(Mta_absent, path); - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } in - let aliasable = not (Env.is_functor_arg path env) in - let md = - if alias && aliasable then - md - else match (Env.find_module path env).md_type with - Mty_alias(_, p1) when not alias -> - let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in - let mty = Includemod.expand_module_alias env [] p1 in - { md with - mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit, - Tcoerce_alias (p1, Tcoerce_none)); - mod_type = - if sttn then Mtype.strengthen ~aliasable:true env mty p1 - else mty } + | Pmod_ident lid -> + let path = + Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt + in + let md = + { + mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias (Mta_absent, path); + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + in + let aliasable = not (Env.is_functor_arg path env) in + let md = + if alias && aliasable then md + else + match (Env.find_module path env).md_type with + | Mty_alias (_, p1) when not alias -> + let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias env [] p1 in + { + md with + mod_desc = + Tmod_constraint + (md, mty, Tmodtype_implicit, Tcoerce_alias (p1, Tcoerce_none)); + mod_type = + (if sttn then Mtype.strengthen ~aliasable:true env mty p1 else mty); + } | mty -> - let mty = - if sttn then Mtype.strengthen ~aliasable env mty path - else mty - in - { md with mod_type = mty } - in rm md + let mty = + if sttn then Mtype.strengthen ~aliasable env mty path else mty + in + {md with mod_type = mty} + in + rm md | Pmod_structure sstr -> - let (str, sg, _finalenv) = - type_structure funct_body anchor env sstr smod.pmod_loc in - let md = - rm { mod_desc = Tmod_structure str; - mod_type = Mty_signature sg; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } + let str, sg, _finalenv = + type_structure funct_body anchor env sstr smod.pmod_loc + in + let md = + rm + { + mod_desc = Tmod_structure str; + mod_type = Mty_signature sg; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + in + let sg' = simplify_signature sg in + if List.length sg' = List.length sg then md + else + wrap_constraint + (Env.implicit_coercion env) + md (Mty_signature sg') Tmodtype_implicit + | Pmod_functor (name, smty, sbody) -> + let mty = may_map (transl_modtype env) smty in + let ty_arg = may_map (fun m -> m.mty_type) mty in + let (id, newenv), funct_body = + match ty_arg with + | None -> ((Ident.create "*", env), false) + | Some mty -> (Env.enter_module ~arg:true name.txt mty env, true) + in + Ctype.init_def (Ident.current_time ()); + (* PR#6981 *) + let body = type_module sttn funct_body None newenv sbody in + rm + { + mod_desc = Tmod_functor (id, name, mty, body); + mod_type = Mty_functor (id, ty_arg, body.mod_type); + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + | Pmod_apply (sfunct, sarg) -> ( + let arg = type_module true funct_body None env sarg in + let path = path_of_module arg in + let funct = type_module (sttn && path <> None) funct_body None env sfunct in + match Env.scrape_alias env funct.mod_type with + | Mty_functor (param, mty_param, mty_res) as mty_functor -> + let generative, mty_param = + (mty_param = None, Btype.default_mty mty_param) in - let sg' = simplify_signature sg in - if List.length sg' = List.length sg then md else - wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg') - Tmodtype_implicit - | Pmod_functor(name, smty, sbody) -> - let mty = may_map (transl_modtype env) smty in - let ty_arg = may_map (fun m -> m.mty_type) mty in - let (id, newenv), funct_body = - match ty_arg with None -> (Ident.create "*", env), false - | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in - Ctype.init_def(Ident.current_time()); (* PR#6981 *) - let body = type_module sttn funct_body None newenv sbody in - rm { mod_desc = Tmod_functor(id, name, mty, body); - mod_type = Mty_functor(id, ty_arg, body.mod_type); - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Pmod_apply(sfunct, sarg) -> - let arg = type_module true funct_body None env sarg in - let path = path_of_module arg in - let funct = - type_module (sttn && path <> None) funct_body None env sfunct in - begin match Env.scrape_alias env funct.mod_type with - Mty_functor(param, mty_param, mty_res) as mty_functor -> - let generative, mty_param = - (mty_param = None, Btype.default_mty mty_param) in - if generative then begin - if sarg.pmod_desc <> Pmod_structure [] then - raise (Error (sfunct.pmod_loc, env, Apply_generative)); - if funct_body && Mtype.contains_type env funct.mod_type then - raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); - end; - let coercion = + if generative then ( + if sarg.pmod_desc <> Pmod_structure [] then + raise (Error (sfunct.pmod_loc, env, Apply_generative)); + if funct_body && Mtype.contains_type env funct.mod_type then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body))); + let coercion = + try Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param + with Includemod.Error msg -> + raise (Error (sarg.pmod_loc, env, Not_included msg)) + in + let mty_appl = + match path with + | Some path -> + Subst.modtype (Subst.add_module param path Subst.identity) mty_res + | None -> ( + if generative then mty_res + else try - Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param - with Includemod.Error msg -> - raise(Error(sarg.pmod_loc, env, Not_included msg)) in - let mty_appl = - match path with - Some path -> - Subst.modtype (Subst.add_module param path Subst.identity) - mty_res - | None -> - if generative then mty_res else - try - Mtype.nondep_supertype - (Env.add_module ~arg:true param arg.mod_type env) - param mty_res - with Not_found -> - raise(Error(smod.pmod_loc, env, - Cannot_eliminate_dependency mty_functor)) - in - rm { mod_desc = Tmod_apply(funct, arg, coercion); - mod_type = mty_appl; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Mty_alias(_, path) -> - raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path)) - | _ -> - raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type)) - end - | Pmod_constraint(sarg, smty) -> - let arg = type_module ~alias true funct_body anchor env sarg in - let mty = transl_modtype env smty in - rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with - mod_loc = smod.pmod_loc; + Mtype.nondep_supertype + (Env.add_module ~arg:true param arg.mod_type env) + param mty_res + with Not_found -> + raise + (Error + (smod.pmod_loc, env, Cannot_eliminate_dependency mty_functor)) + ) + in + rm + { + mod_desc = Tmod_apply (funct, arg, coercion); + mod_type = mty_appl; + mod_env = env; mod_attributes = smod.pmod_attributes; - } - + mod_loc = smod.pmod_loc; + } + | Mty_alias (_, path) -> + raise (Error (sfunct.pmod_loc, env, Cannot_scrape_alias path)) + | _ -> raise (Error (sfunct.pmod_loc, env, Cannot_apply funct.mod_type))) + | Pmod_constraint (sarg, smty) -> + let arg = type_module ~alias true funct_body anchor env sarg in + let mty = transl_modtype env smty in + rm + { + (wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + } | Pmod_unpack sexp -> - let exp = Typecore.type_exp env sexp in - let mty = - match Ctype.expand_head env exp.exp_type with - {desc = Tpackage (p, nl, tl)} -> - if List.exists (fun t -> Ctype.free_variables t <> []) tl then - raise (Error (smod.pmod_loc, env, - Incomplete_packed_module exp.exp_type)); - modtype_of_package env smod.pmod_loc p nl tl - | {desc = Tvar _} -> - raise (Typecore.Error - (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) - | _ -> - raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) - in - if funct_body && Mtype.contains_type env mty then - raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); - rm { mod_desc = Tmod_unpack(exp, mty); - mod_type = mty; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } + let exp = Typecore.type_exp env sexp in + let mty = + match Ctype.expand_head env exp.exp_type with + | {desc = Tpackage (p, nl, tl)} -> + if List.exists (fun t -> Ctype.free_variables t <> []) tl then + raise + (Error (smod.pmod_loc, env, Incomplete_packed_module exp.exp_type)); + modtype_of_package env smod.pmod_loc p nl tl + | {desc = Tvar _} -> + raise + (Typecore.Error (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) + | _ -> + raise (Error (smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) + in + if funct_body && Mtype.contains_type env mty then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); + rm + { + mod_desc = Tmod_unpack (exp, mty); + mod_type = mty; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } | Pmod_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let names = new_names () in @@ -1354,235 +1392,244 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = match desc with | Pstr_eval (sexpr, attrs) -> - let expr = - Builtin_attributes.warning_scope attrs - (fun () -> Typecore.type_expression env sexpr) - in - Tstr_eval (expr, attrs), [], env - | Pstr_value(rec_flag, sdefs) -> - let scope = - match rec_flag with - | Recursive -> - Some (Annot.Idef {scope with - Location.loc_start = loc.Location.loc_start}) - | Nonrecursive -> - let start = - match srem with - | [] -> loc.Location.loc_end - | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start - in - Some (Annot.Idef {scope with Location.loc_start = start}) - in - let (defs, newenv) = - Typecore.type_binding env rec_flag sdefs scope in - let () = if rec_flag = Recursive then - Rec_check.check_recursive_bindings defs - in - (* Note: Env.find_value does not trigger the value_used event. Values - will be marked as being used during the signature inclusion test. *) - Tstr_value(rec_flag, defs), - List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv)) + let expr = + Builtin_attributes.warning_scope attrs (fun () -> + Typecore.type_expression env sexpr) + in + (Tstr_eval (expr, attrs), [], env) + | Pstr_value (rec_flag, sdefs) -> + let scope = + match rec_flag with + | Recursive -> + Some + (Annot.Idef {scope with Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> + let start = + match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start + in + Some (Annot.Idef {scope with Location.loc_start = start}) + in + let defs, newenv = Typecore.type_binding env rec_flag sdefs scope in + let () = + if rec_flag = Recursive then Rec_check.check_recursive_bindings defs + in + (* Note: Env.find_value does not trigger the value_used event. Values + will be marked as being used during the signature inclusion test. *) + ( Tstr_value (rec_flag, defs), + List.map + (fun id -> Sig_value (id, Env.find_value (Pident id) newenv)) (let_bound_idents defs), - newenv + newenv ) | Pstr_primitive sdesc -> - let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in - Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv + let desc, newenv = Typedecl.transl_value_decl env loc sdesc in + (Tstr_primitive desc, [Sig_value (desc.val_id, desc.val_val)], newenv) | Pstr_type (rec_flag, sdecls) -> - List.iter - (fun decl -> check_name check_type names decl.ptype_name) - sdecls; - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in - Tstr_type (rec_flag, decls), + List.iter (fun decl -> check_name check_type names decl.ptype_name) sdecls; + let decls, newenv = Typedecl.transl_type_decl env rec_flag sdecls in + ( Tstr_type (rec_flag, decls), map_rec_type_with_row_types ~rec_flag - (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) + (fun rs info -> Sig_type (info.typ_id, info.typ_type, rs)) decls [], - enrich_type_decls anchor decls env newenv + enrich_type_decls anchor decls env newenv ) | Pstr_typext styext -> - List.iter - (fun pext -> check_name check_typext names pext.pext_name) - styext.ptyext_constructors; - let (tyext, newenv) = - Typedecl.transl_type_extension true env loc styext - in - (Tstr_typext tyext, - map_ext - (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) - tyext.tyext_constructors [], - newenv) + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let tyext, newenv = Typedecl.transl_type_extension true env loc styext in + ( Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext (ext.ext_id, ext.ext_type, es)) + tyext.tyext_constructors [], + newenv ) | Pstr_exception sext -> - check_name check_typext names sext.pext_name; - let (ext, newenv) = Typedecl.transl_exception env sext in - Tstr_exception ext, - [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], - newenv - | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; - pmb_loc; - } -> - check_name check_module names name; - let id = Ident.create name.txt in (* create early for PR#6752 *) - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module ~alias:true true funct_body - (anchor_submodule name.txt anchor) env smodl - ) - in - let md = - { md_type = enrich_module_type anchor name.txt modl.mod_type env; - md_attributes = attrs; - md_loc = pmb_loc; - } - in - (*prerr_endline (Ident.unique_toplevel_name id);*) - Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; - let newenv = Env.enter_module_declaration id md env in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_attributes=attrs; mb_loc=pmb_loc; - }, - [Sig_module(id, - {md_type = modl.mod_type; - md_attributes = attrs; - md_loc = pmb_loc; - }, Trec_not)], - newenv + check_name check_typext names sext.pext_name; + let ext, newenv = Typedecl.transl_exception env sext in + ( Tstr_exception ext, + [Sig_typext (ext.ext_id, ext.ext_type, Text_exception)], + newenv ) + | Pstr_module + {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc} -> + check_name check_module names name; + let id = Ident.create name.txt in + (* create early for PR#6752 *) + let modl = + Builtin_attributes.warning_scope attrs (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) + env smodl) + in + let md = + { + md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + md_loc = pmb_loc; + } + in + (*prerr_endline (Ident.unique_toplevel_name id);*) + Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; + let newenv = Env.enter_module_declaration id md env in + ( Tstr_module + { + mb_id = id; + mb_name = name; + mb_expr = modl; + mb_attributes = attrs; + mb_loc = pmb_loc; + }, + [ + Sig_module + ( id, + {md_type = modl.mod_type; md_attributes = attrs; md_loc = pmb_loc}, + Trec_not ); + ], + newenv ) | Pstr_recmodule sbind -> - let sbind = - List.map - (function - | {pmb_name = name; - pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; - pmb_attributes = attrs; - pmb_loc = loc; - } -> - name, typ, expr, attrs, loc - | mb -> - raise (Error (mb.pmb_expr.pmod_loc, env, - Recursive_module_require_explicit_type)) - ) - sbind - in - List.iter - (fun (name, _, _, _, _) -> check_name check_module names name) - sbind; - let (decls, newenv) = - transl_recmodule_modtypes env - (List.map (fun (name, smty, _smodl, attrs, loc) -> - {pmd_name=name; pmd_type=smty; - pmd_attributes=attrs; pmd_loc=loc}) sbind - ) in - let bindings1 = - List.map2 - (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module true funct_body (anchor_recmodule id) - newenv smodl - ) - in - let mty' = - enrich_module_type anchor (Ident.name id) modl.mod_type newenv - in - (id, name, mty, modl, mty', attrs, loc)) - decls sbind in - let newenv = (* allow aliasing recursive modules from outside *) - List.fold_left - (fun env md -> - let mdecl = - { - md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; - } - in - Env.add_module_declaration ~check:true md.md_id mdecl env - ) - env decls - in - let bindings2 = - check_recmodule_inclusion newenv bindings1 in - Tstr_recmodule bindings2, - map_rec (fun rs mb -> - Sig_module(mb.mb_id, { - md_type=mb.mb_expr.mod_type; - md_attributes=mb.mb_attributes; - md_loc=mb.mb_loc; - }, rs)) - bindings2 [], - newenv + let sbind = + List.map + (function + | { + pmb_name = name; + pmb_expr = {pmod_desc = Pmod_constraint (expr, typ)}; + pmb_attributes = attrs; + pmb_loc = loc; + } -> + (name, typ, expr, attrs, loc) + | mb -> + raise + (Error + ( mb.pmb_expr.pmod_loc, + env, + Recursive_module_require_explicit_type ))) + sbind + in + List.iter + (fun (name, _, _, _, _) -> check_name check_module names name) + sbind; + let decls, newenv = + transl_recmodule_modtypes env + (List.map + (fun (name, smty, _smodl, attrs, loc) -> + { + pmd_name = name; + pmd_type = smty; + pmd_attributes = attrs; + pmd_loc = loc; + }) + sbind) + in + let bindings1 = + List.map2 + (fun {md_id = id; md_type = mty} (name, _, smodl, attrs, loc) -> + let modl = + Builtin_attributes.warning_scope attrs (fun () -> + type_module true funct_body (anchor_recmodule id) newenv smodl) + in + let mty' = + enrich_module_type anchor (Ident.name id) modl.mod_type newenv + in + (id, name, mty, modl, mty', attrs, loc)) + decls sbind + in + let newenv = + (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env md -> + let mdecl = + { + md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Env.add_module_declaration ~check:true md.md_id mdecl env) + env decls + in + let bindings2 = check_recmodule_inclusion newenv bindings1 in + ( Tstr_recmodule bindings2, + map_rec + (fun rs mb -> + Sig_module + ( mb.mb_id, + { + md_type = mb.mb_expr.mod_type; + md_attributes = mb.mb_attributes; + md_loc = mb.mb_loc; + }, + rs )) + bindings2 [], + newenv ) | Pstr_modtype pmtd -> - (* check that it is non-abstract *) - let newenv, mtd, sg = - transl_modtype_decl names env pmtd - in - Tstr_modtype mtd, [sg], newenv + (* check that it is non-abstract *) + let newenv, mtd, sg = transl_modtype_decl names env pmtd in + (Tstr_modtype mtd, [sg], newenv) | Pstr_open sod -> - let (_path, newenv, od) = type_open ~toplevel env sod in - Tstr_open od, [], newenv - | Pstr_class () -> - assert false - | Pstr_class_type () -> - assert false + let _path, newenv, od = type_open ~toplevel env sod in + (Tstr_open od, [], newenv) + | Pstr_class () -> assert false + | Pstr_class_type () -> assert false | Pstr_include sincl -> - let smodl = sincl.pincl_mod in - let modl = - Builtin_attributes.warning_scope sincl.pincl_attributes - (fun () -> type_module true funct_body None env smodl) - in - (* 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 - List.iter (check_sig_item names loc) sg; - let new_env = Env.add_signature sg env in - let incl = - { incl_mod = modl; - incl_type = sg; - incl_attributes = sincl.pincl_attributes; - incl_loc = sincl.pincl_loc; - } - in - Tstr_include incl, sg, new_env + let smodl = sincl.pincl_mod in + let modl = + Builtin_attributes.warning_scope sincl.pincl_attributes (fun () -> + type_module true funct_body None env smodl) + in + (* 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 + List.iter (check_sig_item names loc) sg; + let new_env = Env.add_signature sg env in + let incl = + { + incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + (Tstr_include incl, sg, new_env) | Pstr_extension (ext, _attrs) -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute x -> - Builtin_attributes.warning_attribute x; - Tstr_attribute x, [], env + Builtin_attributes.warning_attribute x; + (Tstr_attribute x, [], env) in let rec type_struct env sstr = - Ctype.init_def(Ident.current_time()); + Ctype.init_def (Ident.current_time ()); match sstr with | [] -> ([], [], env) | pstr :: srem -> - let previous_saved_types = Cmt_format.get_saved_types () in - let desc, sg, new_env = type_str_item env srem pstr in - let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in - Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str - :: previous_saved_types); - let (str_rem, sig_rem, final_env) = type_struct new_env srem in - let new_sg = - if rescript_hide desc then sig_rem - else - sg @ sig_rem in - (str :: str_rem, new_sg, final_env) + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, new_env = type_str_item env srem pstr in + let str = {str_desc = desc; str_loc = pstr.pstr_loc; str_env = env} in + Cmt_format.set_saved_types + (Cmt_format.Partial_structure_item str :: previous_saved_types); + let str_rem, sig_rem, final_env = type_struct new_env srem in + let new_sg = if rescript_hide desc then sig_rem else sg @ sig_rem in + (str :: str_rem, new_sg, final_env) in if !Clflags.annotations then (* moved to genannot *) - List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; + List.iter + (function + | {pstr_loc = l} -> Stypes.record_phrase l) + sstr; let previous_saved_types = Cmt_format.get_saved_types () in let run () = - let (items, sg, final_env) = type_struct env sstr in - let str = { str_items = items; str_type = sg; str_final_env = final_env } in + let items, sg, final_env = type_struct env sstr in + let str = {str_items = items; str_type = sg; str_final_env = final_env} in Cmt_format.set_saved_types (Cmt_format.Partial_structure str :: previous_saved_types); - str, sg, final_env + (str, sg, final_env) in - if toplevel then run () - else Builtin_attributes.warning_scope [] run + if toplevel then run () else Builtin_attributes.warning_scope [] run let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none - let type_module_alias = type_module ~alias:true true false None let type_module = type_module true false None let type_structure = type_structure false None @@ -1590,16 +1637,15 @@ let type_structure = type_structure false None (* Normalize types in a signature *) let rec normalize_modtype env = function - Mty_ident _ - | Mty_alias _ -> () + | Mty_ident _ | Mty_alias _ -> () | Mty_signature sg -> normalize_signature env sg - | Mty_functor(_id, _param, body) -> normalize_modtype env body + | Mty_functor (_id, _param, body) -> normalize_modtype env body and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function - Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type - | Sig_module(_id, md, _) -> normalize_modtype env md.md_type + | Sig_value (_id, desc) -> Ctype.normalize_type env desc.val_type + | Sig_module (_id, md, _) -> normalize_modtype env md.md_type | _ -> () (* Extract the module type of a module expression *) @@ -1607,21 +1653,26 @@ and normalize_signature_item env = function let type_module_type_of env smod = let tmty = match smod.pmod_desc with - | Pmod_ident lid -> (* turn off strengthening in this case *) - let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in - rm { mod_desc = Tmod_ident (path, lid); - mod_type = md.md_type; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | _ -> type_module env smod in + | Pmod_ident lid -> + (* turn off strengthening in this case *) + let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in + rm + { + mod_desc = Tmod_ident (path, lid); + mod_type = md.md_type; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + | _ -> type_module env smod + in let mty = tmty.mod_type in (* PR#6307: expand aliases at root and submodules *) let mty = Mtype.remove_aliases env mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype env mty) then - raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); - tmty, mty + raise (Error (smod.pmod_loc, env, Non_generalizable_module mty)); + (tmty, mty) (* For Typecore *) @@ -1633,40 +1684,42 @@ let type_package env m p nl = Ident.set_current_time lv; let context = Typetexp.narrow () in let modl = type_module env m in - Ctype.init_def(Ident.current_time()); + Ctype.init_def (Ident.current_time ()); Typetexp.widen context; - let (mp, env) = + let mp, env = match modl.mod_desc with - Tmod_ident (mp,_) -> (mp, env) - | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) - -> (mp, env) (* PR#6982 *) + | Tmod_ident (mp, _) -> (mp, env) + | Tmod_constraint ({mod_desc = Tmod_ident (mp, _)}, _, Tmodtype_implicit, _) + -> + (mp, env) (* PR#6982 *) | _ -> - let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in + let id, new_env = Env.enter_module ~arg:true "%M" modl.mod_type env in (Pident id, new_env) in let rec mkpath mp = function - | Lident name -> Pdot(mp, name, nopos) - | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos) + | Lident name -> Pdot (mp, name, nopos) + | Ldot (m, name) -> Pdot (mkpath mp m, name, nopos) | _ -> assert false in let tl' = List.map - (fun name -> Btype.newgenty (Tconstr (mkpath mp name,[],ref Mnil))) + (fun name -> Btype.newgenty (Tconstr (mkpath mp name, [], ref Mnil))) (* beware of interactions with Printtyp and short-path: mp.name may have an arity > 0, cf. PR#7534 *) - nl in + nl + in (* go back to original level *) Ctype.end_def (); - if nl = [] then - (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) - else let mty = modtype_of_package env modl.mod_loc p nl tl' in - List.iter2 - (fun n ty -> - try Ctype.unify env ty (Ctype.newvar ()) - with Ctype.Unify _ -> - raise (Error(m.pmod_loc, env, Scoping_pack (n,ty)))) - nl tl'; - (wrap_constraint env modl mty Tmodtype_implicit, tl') + if nl = [] then (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) + else + let mty = modtype_of_package env modl.mod_loc p nl tl' in + List.iter2 + (fun n ty -> + try Ctype.unify env ty (Ctype.newvar ()) + with Ctype.Unify _ -> + raise (Error (m.pmod_loc, env, Scoping_pack (n, ty)))) + nl tl'; + (wrap_constraint env modl mty Tmodtype_implicit, tl') (* Fill in the forward declarations *) let () = @@ -1677,30 +1730,35 @@ let () = Typecore.type_package := type_package; type_module_type_of_fwd := type_module_type_of - (* Typecheck an implementation file *) -let type_implementation_more ?check_exists sourcefile outputprefix modulename initial_env ast = +let type_implementation_more ?check_exists sourcefile outputprefix modulename + initial_env ast = Cmt_format.clear (); try - Delayed_checks.reset_delayed_checks (); - let (str, sg, finalenv) = - type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in - begin - let mli_status = !Clflags.assume_no_mli in - if mli_status = Clflags.Mli_exists then begin + Delayed_checks.reset_delayed_checks (); + let str, sg, finalenv = + type_structure initial_env ast (Location.in_file sourcefile) + in + let simple_sg = simplify_signature sg in + let mli_status = !Clflags.assume_no_mli in + if mli_status = Clflags.Mli_exists then ( let intf_file = - try - find_in_path_uncap !Config.load_path (modulename ^ ".cmi") + try find_in_path_uncap !Config.load_path (modulename ^ ".cmi") with Not_found -> let sourceintf = - Filename.remove_extension sourcefile ^ Literals.suffix_resi in - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf)) in + Filename.remove_extension sourcefile ^ Literals.suffix_resi + in + raise + (Error + ( Location.in_file sourcefile, + Env.empty, + Interface_not_compiled sourceintf )) + in let dclsig = Env.read_signature modulename intf_file in let coercion = - Includemod.compunit initial_env sourcefile sg intf_file dclsig in + Includemod.compunit initial_env sourcefile sg intf_file dclsig + in Delayed_checks.force_delayed_checks (); (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported @@ -1708,11 +1766,12 @@ let type_implementation_more ?check_exists sourcefile outputprefix modulename in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Implementation str) (Some sourcefile) initial_env None; (str, coercion, finalenv, dclsig) - (* identifier is useless might read from serialized cmi files*) - end else begin + (* identifier is useless might read from serialized cmi files*)) + else let coercion = - Includemod.compunit initial_env sourcefile sg - "(inferred signature)" simple_sg in + Includemod.compunit initial_env sourcefile sg "(inferred signature)" + simple_sg + in check_nongen_schemes finalenv simple_sg; normalize_signature finalenv simple_sg; Delayed_checks.force_delayed_checks (); @@ -1720,40 +1779,35 @@ let type_implementation_more ?check_exists sourcefile outputprefix modulename in the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) - if not !Clflags.dont_write_files then begin - let deprecated = Builtin_attributes.deprecated_of_str ast in - let cmi = - Env.save_signature ?check_exists ~deprecated - simple_sg modulename (outputprefix ^ ".cmi") - in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) - (Some sourcefile) initial_env (Some cmi); - end; + (if not !Clflags.dont_write_files then + let deprecated = Builtin_attributes.deprecated_of_str ast in + let cmi = + Env.save_signature ?check_exists ~deprecated simple_sg modulename + (outputprefix ^ ".cmi") + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env + (Some cmi)); (str, coercion, finalenv, simple_sg) - end - end with e -> - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Partial_implementation (Array.of_list (Cmt_format.get_saved_types ()))) (Some sourcefile) initial_env None; raise e let type_implementation sourcefile outputprefix modulename initial_env ast = - let (a,b,_,_) = - type_implementation_more sourcefile outputprefix modulename initial_env ast in - a,b - + let a, b, _, _ = + type_implementation_more sourcefile outputprefix modulename initial_env ast + in + (a, b) let save_signature modname tsg outputprefix source_file initial_env cmi = - Cmt_format.save_cmt (outputprefix ^ ".cmti") modname + Cmt_format.save_cmt (outputprefix ^ ".cmti") modname (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) - (* "Packaging" of several compilation units into one unit - having them as sub-modules. *) - + having them as sub-modules. *) (* Error report *) @@ -1761,126 +1815,105 @@ open Printtyp let non_generalizable_msg ppf print_fallback_msg = fprintf ppf - "%a@,@,\ - @[This happens when the type system senses there's a mutation/side-effect,@ in combination with a polymorphic value.@,\ + "%a@,\ + @,\ + @[This happens when the type system senses there's a \ + mutation/side-effect,@ in combination with a polymorphic value.@,\ @{Using or annotating that value usually solves it.@}@]" print_fallback_msg () let report_error ppf = function - Cannot_apply mty -> - fprintf ppf - "@[This module is not a functor; it has type@ %a@]" modtype mty + | Cannot_apply mty -> + fprintf ppf "@[This module is not a functor; it has type@ %a@]" modtype mty | Not_included errs -> - fprintf ppf - "@[Signature mismatch:@ %a@]" Includemod.report_error errs + fprintf ppf "@[Signature mismatch:@ %a@]" Includemod.report_error errs | Cannot_eliminate_dependency mty -> - fprintf ppf - "@[This functor has type@ %a@ \ - The parameter cannot be eliminated in the result type.@ \ - Please bind the argument to a module identifier.@]" modtype mty + fprintf ppf + "@[This functor has type@ %a@ The parameter cannot be eliminated in the \ + result type.@ Please bind the argument to a module identifier.@]" + modtype mty | Signature_expected -> fprintf ppf "This module type is not a signature" | Structure_expected mty -> - fprintf ppf - "@[This module is not a structure; it has type@ %a" modtype mty + fprintf ppf "@[This module is not a structure; it has type@ %a" modtype mty | With_no_component lid -> - fprintf ppf - "@[The signature constrained by `with' has no component named %a@]" - longident lid - | With_mismatch(lid, explanation) -> - fprintf ppf - "@[\ - @[In this `with' constraint, the new definition of %a@ \ - does not match its original definition@ \ - in the constrained signature:@]@ \ - %a@]" - longident lid Includemod.report_error explanation - | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> - fprintf ppf - "@[\ - @[This `with' constraint on %a makes the applicative functor @ \ - type %s ill-typed in the constrained signature:@]@ \ - %a@]" - longident lid (Path.name path) Includemod.report_error explanation - | With_changes_module_alias(lid, id, path) -> - fprintf ppf - "@[\ - @[This `with' constraint on %a changes %s, which is aliased @ \ - in the constrained signature (as %s)@].@]" - longident lid (Path.name path) (Ident.name id) + fprintf ppf + "@[The signature constrained by `with' has no component named %a@]" + longident lid + | With_mismatch (lid, explanation) -> + fprintf ppf + "@[@[In this `with' constraint, the new definition of %a@ does not \ + match its original definition@ in the constrained signature:@]@ %a@]" + longident lid Includemod.report_error explanation + | With_makes_applicative_functor_ill_typed (lid, path, explanation) -> + fprintf ppf + "@[@[This `with' constraint on %a makes the applicative functor @ \ + type %s ill-typed in the constrained signature:@]@ %a@]" + longident lid (Path.name path) Includemod.report_error explanation + | With_changes_module_alias (lid, id, path) -> + fprintf ppf + "@[@[This `with' constraint on %a changes %s, which is aliased @ in \ + the constrained signature (as %s)@].@]" + longident lid (Path.name path) (Ident.name id) | With_cannot_remove_constrained_type -> - fprintf ppf - "@[Destructive substitutions are not supported for constrained @ \ - types (other than when replacing a type constructor with @ \ - a type constructor with the same arguments).@]" - | Repeated_name(kind, name, repeated_loc) -> - fprintf ppf - "@[Multiple definition of the %s name %s @ \ - at @{%a@}@ @ \ - Names must be unique in a given structure or signature.@]" kind name Location.print_loc repeated_loc + fprintf ppf + "@[Destructive substitutions are not supported for constrained @ \ + types (other than when replacing a type constructor with @ a type \ + constructor with the same arguments).@]" + | Repeated_name (kind, name, repeated_loc) -> + fprintf ppf + "@[Multiple definition of the %s name %s @ at @{%a@}@ @ Names must \ + be unique in a given structure or signature.@]" + kind name Location.print_loc repeated_loc | Non_generalizable typ -> (* modified *) fprintf ppf "@["; - non_generalizable_msg - ppf - (fun ppf () -> - fprintf ppf - "@[This expression's type contains type variables that cannot be generalized:@,@{%a@}@]" - type_scheme typ); + non_generalizable_msg ppf (fun ppf () -> + fprintf ppf + "@[This expression's type contains type variables that cannot be \ + generalized:@,\ + @{%a@}@]" + type_scheme typ); fprintf ppf "@]" | Non_generalizable_module mty -> (* modified *) fprintf ppf "@["; - non_generalizable_msg - ppf - (fun ppf () -> - fprintf ppf - "@[The type of this module contains type variables that cannot be generalized:@,@{%a@}@]" - modtype mty); + non_generalizable_msg ppf (fun ppf () -> + fprintf ppf + "@[The type of this module contains type variables that cannot be \ + generalized:@,\ + @{%a@}@]" + modtype mty); fprintf ppf "@]" | Interface_not_compiled intf_name -> - fprintf ppf - "@[Could not find the .cmi file for interface@ %a.@]" - Location.print_filename intf_name + fprintf ppf "@[Could not find the .cmi file for interface@ %a.@]" + Location.print_filename intf_name | Not_allowed_in_functor_body -> - fprintf ppf - "@[This expression creates fresh types.@ %s@]" - "It is not allowed inside applicative functors." + fprintf ppf "@[This expression creates fresh types.@ %s@]" + "It is not allowed inside applicative functors." | Not_a_packed_module ty -> - fprintf ppf - "This expression is not a packed module. It has type@ %a" - type_expr ty + fprintf ppf "This expression is not a packed module. It has type@ %a" + type_expr ty | Incomplete_packed_module ty -> - fprintf ppf - "The type of this packed module contains variables:@ %a" - type_expr ty + fprintf ppf "The type of this packed module contains variables:@ %a" + type_expr ty | Scoping_pack (lid, ty) -> - fprintf ppf - "The type %a in this module cannot be exported.@ " longident lid; - fprintf ppf - "Its type contains local dependencies:@ %a" type_expr ty + fprintf ppf "The type %a in this module cannot be exported.@ " longident lid; + fprintf ppf "Its type contains local dependencies:@ %a" type_expr ty | Recursive_module_require_explicit_type -> - fprintf ppf "Recursive modules require an explicit module type." + fprintf ppf "Recursive modules require an explicit module type." | Apply_generative -> - fprintf ppf "This is a generative functor. It can only be applied to ()" + fprintf ppf "This is a generative functor. It can only be applied to ()" | Cannot_scrape_alias p -> - fprintf ppf - "This is an alias for module %a, which is missing" - path p - + fprintf ppf "This is an alias for module %a, which is missing" path p let super_report_error_no_wrap_printing_env = report_error - let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error ppf err) let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) + Location.register_error_of_exn (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> Some err + | _ -> None) diff --git a/compiler/ml/typemod.mli b/compiler/ml/typemod.mli index e7bcecec5f..8bef382fbe 100644 --- a/compiler/ml/typemod.mli +++ b/compiler/ml/typemod.mli @@ -18,43 +18,59 @@ open Types open Format -val type_module: - Env.t -> Parsetree.module_expr -> Typedtree.module_expr -val type_structure: - Env.t -> Parsetree.structure -> Location.t -> - Typedtree.structure * Types.signature * Env.t -val type_toplevel_phrase: - Env.t -> Parsetree.structure -> - Typedtree.structure * Types.signature * Env.t - +val type_module : Env.t -> Parsetree.module_expr -> Typedtree.module_expr +val type_structure : + Env.t -> + Parsetree.structure -> + Location.t -> + Typedtree.structure * Types.signature * Env.t +val type_toplevel_phrase : + Env.t -> Parsetree.structure -> Typedtree.structure * Types.signature * Env.t val rescript_hide : Typedtree.structure_item_desc -> bool -val type_implementation_more: ?check_exists:unit -> - string -> string -> string -> Env.t -> Parsetree.structure -> +val type_implementation_more : + ?check_exists:unit -> + string -> + string -> + string -> + Env.t -> + Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion * Env.t * Types.signature -val type_implementation: - string -> string -> string -> Env.t -> Parsetree.structure -> +val type_implementation : + string -> + string -> + string -> + Env.t -> + Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion - -val transl_signature: - Env.t -> Parsetree.signature -> Typedtree.signature -val check_nongen_schemes: - Env.t -> Types.signature -> unit -val type_open_: - ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> - Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t -val simplify_signature: signature -> signature + +val transl_signature : Env.t -> Parsetree.signature -> Typedtree.signature +val check_nongen_schemes : Env.t -> Types.signature -> unit +val type_open_ : + ?used_slot:bool ref -> + ?toplevel:bool -> + Asttypes.override_flag -> + Env.t -> + Location.t -> + Longident.t Asttypes.loc -> + Path.t * Env.t +val simplify_signature : signature -> signature val path_of_module : Typedtree.module_expr -> Path.t option -val save_signature: - string -> Typedtree.signature -> string -> string -> - Env.t -> Cmi_format.cmi_infos -> unit +val save_signature : + string -> + Typedtree.signature -> + string -> + string -> + Env.t -> + Cmi_format.cmi_infos -> + unit type error = - Cannot_apply of module_type + | Cannot_apply of module_type | Not_included of Includemod.error list | Cannot_eliminate_dependency of module_type | Signature_expected @@ -80,10 +96,6 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error +val super_report_error_no_wrap_printing_env : formatter -> error -> unit -val super_report_error_no_wrap_printing_env: formatter -> error -> unit - - -val report_error: Env.t -> formatter -> error -> unit - - +val report_error : Env.t -> formatter -> error -> unit diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index bd9f74d638..d4b3a038a2 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -15,7 +15,6 @@ (* Auxiliaries for type-based optimizations, e.g. array kinds *) - open Types open Asttypes open Typedtree @@ -24,21 +23,17 @@ open Lambda let scrape_ty env ty = let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in match ty.desc with - | Tconstr (p, _, _) -> - begin match Env.find_type p env with - | {type_unboxed = {unboxed = true; _}; _} -> - begin match Typedecl.get_unboxed_type_representation env ty with - | None -> ty - | Some ty2 -> ty2 - end - | _ -> ty - | exception Not_found -> ty - end + | Tconstr (p, _, _) -> ( + match Env.find_type p env with + | {type_unboxed = {unboxed = true; _}; _} -> ( + match Typedecl.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2) + | _ -> ty + | exception Not_found -> ty) | _ -> ty -let scrape env ty = - (scrape_ty env ty).desc - +let scrape env ty = (scrape_ty env ty).desc (** [Types.constructor_description] records the type at the definition type so for ['a option] @@ -46,64 +41,59 @@ let scrape env ty = *) let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = match scrape env typ with - | Tconstr(p, _,_) -> - (* all built in types could not inhabit none-like values: - int, char, float, bool, unit, exn, array, list, nativeint, - int32, int64, lazy_t, bytes - *) - (match Predef.type_is_builtin_path_but_option p with - | For_sure_yes -> true - | For_sure_no -> false - | NA -> - let untagged = ref false in - begin match + | Tconstr (p, _, _) -> ( + (* all built in types could not inhabit none-like values: + int, char, float, bool, unit, exn, array, list, nativeint, + int32, int64, lazy_t, bytes + *) + match Predef.type_is_builtin_path_but_option p with + | For_sure_yes -> true + | For_sure_no -> false + | NA -> ( + let untagged = ref false in + match let decl = Env.find_type p env in let () = - if Ast_untagged_variants.has_untagged decl.type_attributes - then untagged := true in - decl.type_kind with - | exception _ -> - false - | Type_abstract | Type_open -> false - | Type_record _ -> true - | Type_variant - ([{cd_id = {name="None"}; cd_args = Cstr_tuple [] }; - {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}] - | - [{cd_id = {name="Some"}; cd_args = Cstr_tuple [_] }; - {cd_id = {name = "None"}; cd_args = Cstr_tuple []}] - | [{cd_id= {name = "()"}; cd_args = Cstr_tuple []}] - ) - -> false (* conservative *) - | Type_variant cdecls -> - Ext_list.for_all cdecls (fun cd -> - if Ast_untagged_variants.has_undefined_literal cd.cd_attributes - then false - else if !untagged then - match cd.cd_args with - | Cstr_tuple [t] -> - Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env - | Cstr_tuple [] -> true - | Cstr_tuple (_::_::_) -> true (* Not actually possible for untagged *) - | Cstr_record [{ld_type=t}] -> - Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env - | Cstr_record ([] | _::_::_) -> true - else - true) - end) - | Ttuple _ - | Tvariant _ - | Tpackage _ - | Tarrow _ -> true - | Tfield _ - | Tpoly _ - | Tunivar _ - | Tlink _ - | Tsubst _ - | Tnil - | Tvar _ - | Tobject _ - -> false + if Ast_untagged_variants.has_untagged decl.type_attributes then + untagged := true + in + decl.type_kind + with + | exception _ -> false + | Type_abstract | Type_open -> false + | Type_record _ -> true + | Type_variant + ( [ + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; + ] + | [ + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; + ] + | [{cd_id = {name = "()"}; cd_args = Cstr_tuple []}] ) -> + false (* conservative *) + | Type_variant cdecls -> + Ext_list.for_all cdecls (fun cd -> + if Ast_untagged_variants.has_undefined_literal cd.cd_attributes then + false + else if !untagged then + match cd.cd_args with + | Cstr_tuple [t] -> + Ast_untagged_variants.type_is_builtin_object t + || type_cannot_contain_undefined t env + | Cstr_tuple [] -> true + | Cstr_tuple (_ :: _ :: _) -> + true (* Not actually possible for untagged *) + | Cstr_record [{ld_type = t}] -> + Ast_untagged_variants.type_is_builtin_object t + || type_cannot_contain_undefined t env + | Cstr_record ([] | _ :: _ :: _) -> true + else true))) + | Ttuple _ | Tvariant _ | Tpackage _ | Tarrow _ -> true + | Tfield _ | Tpoly _ | Tunivar _ | Tlink _ | Tsubst _ | Tnil | Tvar _ + | Tobject _ -> + false let is_function_type env ty = match scrape env ty with @@ -112,14 +102,11 @@ let is_function_type env ty = let is_base_type env ty base_ty_path = match scrape env ty with - | Tconstr(p, _, _) -> Path.same p base_ty_path + | Tconstr (p, _, _) -> Path.same p base_ty_path | _ -> false let maybe_pointer_type env ty = - if Ctype.maybe_pointer_type env ty then - Pointer - else - Immediate + if Ctype.maybe_pointer_type env ty then Pointer else Immediate let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type @@ -127,72 +114,59 @@ type classification = | Int | Float | Lazy - | Addr (* anything except a float or a lazy *) + | Addr (* anything except a float or a lazy *) | Any let classify env ty = let ty = scrape_ty env ty in if maybe_pointer_type env ty = Immediate then Int - else match ty.desc with - | Tvar _ | Tunivar _ -> - Any - | Tconstr (p, _args, _abbrev) -> + else + match ty.desc with + | Tvar _ | Tunivar _ -> Any + | Tconstr (p, _args, _abbrev) -> ( if Path.same p Predef.path_float then Float else if Path.same p Predef.path_lazy_t then Lazy - else if Path.same p Predef.path_string - || Path.same p Predef.path_array then Addr - else begin + else if Path.same p Predef.path_string || Path.same p Predef.path_array + then Addr + else try match (Env.find_type p env).type_kind with - | Type_abstract -> - Any - | Type_record _ | Type_variant _ | Type_open -> - Addr + | Type_abstract -> Any + | Type_record _ | Type_variant _ | Type_open -> Addr with Not_found -> (* This can happen due to e.g. missing -I options, causing some .cmi files to be unavailable. Maybe we should emit a warning. *) - Any - end - | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> - Addr - | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> - assert false - - - - - - + Any) + | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> Addr + | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> assert false (** Whether a forward block is needed for a lazy thunk on a value, i.e. if the value can be represented as a float/forward/lazy *) let lazy_val_requires_forward env ty = match classify env ty with | Any | Lazy -> true - | Float (*-> Config.flat_float_array*) - | Addr | Int -> false + | Float (*-> Config.flat_float_array*) | Addr | Int -> false (** The compilation of the expression [lazy e] depends on the form of e: constants, floats and identifiers are optimized. The optimization must be taken into account when determining whether a recursive binding is safe. *) -let classify_lazy_argument : Typedtree.expression -> - [`Constant_or_function - |`Float - |`Identifier of [`Forward_value|`Other] - |`Other] = - fun e -> match e.exp_desc with - | Texp_constant - ( Const_int _ | Const_char _ | Const_string _ - | Const_int32 _ | Const_int64 _ | Const_bigint _ ) - | Texp_function _ - | Texp_construct (_, {cstr_arity = 0}, _) -> - `Constant_or_function - | Texp_constant(Const_float _) -> - `Float - | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type -> - `Identifier `Forward_value - | Texp_ident _ -> - `Identifier `Other - | _ -> - `Other +let classify_lazy_argument : + Typedtree.expression -> + [ `Constant_or_function + | `Float + | `Identifier of [`Forward_value | `Other] + | `Other ] = + fun e -> + match e.exp_desc with + | Texp_constant + ( Const_int _ | Const_char _ | Const_string _ | Const_int32 _ + | Const_int64 _ | Const_bigint _ ) + | Texp_function _ + | Texp_construct (_, {cstr_arity = 0}, _) -> + `Constant_or_function + | Texp_constant (Const_float _) -> `Float + | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type -> + `Identifier `Forward_value + | Texp_ident _ -> `Identifier `Other + | _ -> `Other diff --git a/compiler/ml/typeopt.mli b/compiler/ml/typeopt.mli index d0d5dffcc4..eb4a795a6d 100644 --- a/compiler/ml/typeopt.mli +++ b/compiler/ml/typeopt.mli @@ -16,26 +16,17 @@ (* Auxiliaries for type-based optimizations, e.g. array kinds *) val is_function_type : - Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option + Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool -val maybe_pointer_type : Env.t -> Types.type_expr - -> Lambda.immediate_or_pointer +val maybe_pointer_type : Env.t -> Types.type_expr -> Lambda.immediate_or_pointer val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer +val classify_lazy_argument : + Typedtree.expression -> + [ `Constant_or_function + | `Float + | `Identifier of [`Forward_value | `Other] + | `Other ] - - - - -val classify_lazy_argument : Typedtree.expression -> - [ `Constant_or_function - | `Float - | `Identifier of [`Forward_value | `Other] - | `Other] - -val type_cannot_contain_undefined: - Types.type_expr -> - Env.t -> - bool - +val type_cannot_contain_undefined : Types.type_expr -> Env.t -> bool diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 3ec0bd46af..f778faa3da 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -19,13 +19,10 @@ open Asttypes (* Type expressions for the core language *) -type type_expr = - { mutable desc: type_desc; - mutable level: int; - id: int } +type type_expr = {mutable desc: type_desc; mutable level: int; id: int} and type_desc = - Tvar of string option + | Tvar of string option | Tarrow of arg_label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref @@ -33,42 +30,37 @@ and type_desc = | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr - | Tsubst of type_expr (* for copying *) + | Tsubst of type_expr (* for copying *) | Tvariant of row_desc | Tunivar of string option | Tpoly of type_expr * type_expr list | Tpackage of Path.t * Longident.t list * type_expr list -and row_desc = - { row_fields: (label * row_field) list; - row_more: type_expr; - row_bound: unit; - row_closed: bool; - row_fixed: bool; - row_name: (Path.t * type_expr list) option } +and row_desc = { + row_fields: (label * row_field) list; + row_more: type_expr; + row_bound: unit; + row_closed: bool; + row_fixed: bool; + row_name: (Path.t * type_expr list) option; +} and row_field = - Rpresent of type_expr option + | Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref - (* 1st true denotes a constant constructor *) - (* 2nd true denotes a tag in a pattern matching, and - is erased later *) + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) | Rabsent and abbrev_memo = - Mnil + | Mnil | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref -and field_kind = - Fvar of field_kind option ref - | Fpresent - | Fabsent +and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent -and commutable = - Cok - | Cunknown - | Clink of commutable ref +and commutable = Cok | Cunknown | Clink of commutable ref module TypeOps = struct type t = type_expr @@ -79,23 +71,25 @@ end (* Maps of methods and instance variables *) -module OrderedString = - struct type t = string let compare (x:t) y = compare x y end -module Meths = Map.Make(OrderedString) +module OrderedString = struct + type t = string + let compare (x : t) y = compare x y +end +module Meths = Map.Make (OrderedString) module Vars = Meths (* Value descriptions *) -type value_description = - { val_type: type_expr; (* Type of the value *) - val_kind: value_kind; - val_loc: Location.t; - val_attributes: Parsetree.attributes; - } +type value_description = { + val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; +} and value_kind = - Val_reg (* Regular value *) - | Val_prim of Primitive.description (* Primitive *) + | Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) (* Variance *) @@ -112,16 +106,16 @@ module Variance = struct | Inv -> 64 let union v1 v2 = v1 lor v2 let inter v1 v2 = v1 land v2 - let subset v1 v2 = (v1 land v2 = v1) - let set x b v = - if b then v lor single x else v land (lnot (single x)) + let subset v1 v2 = v1 land v2 = v1 + let set x b v = if b then v lor single x else v land lnot (single x) let mem x = subset (single x) let null = 0 let may_inv = 7 let full = 127 let covariant = single May_pos lor single Pos lor single Inj let swap f1 f2 v = - let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v' + let v' = set f1 (mem f2 v) v in + set f2 (mem f1 v) v' let conjugate v = swap May_pos May_neg (swap Pos Neg v) let get_upper v = (mem May_pos v, mem May_neg v) let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v) @@ -129,103 +123,106 @@ end (* Type definitions *) -type type_declaration = - { type_params: type_expr list; - type_arity: int; - type_kind: type_kind; - type_private: private_flag; - type_manifest: type_expr option; - type_variance: Variance.t list; - type_newtype_level: (int * int) option; - type_loc: Location.t; - type_attributes: Parsetree.attributes; - type_immediate: bool; - type_unboxed: unboxed_status; - } +type type_declaration = { + type_params: type_expr list; + type_arity: int; + type_kind: type_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + type_newtype_level: (int * int) option; + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: bool; + type_unboxed: unboxed_status; +} and type_kind = - Type_abstract - | Type_record of label_declaration list * record_representation + | Type_abstract + | Type_record of label_declaration list * record_representation | Type_variant of constructor_declaration list | Type_open and record_representation = - | Record_regular (* All fields are boxed / tagged *) - | Record_float_unused (* Was: all fields are floats. Now: unused *) - | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) - | Record_inlined of (* Inlined record *) - { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes} - | Record_extension (* Inlined record under extension *) + | Record_regular (* All fields are boxed / tagged *) + | Record_float_unused (* Was: all fields are floats. Now: unused *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of + (* Inlined record *) + { + tag: int; + name: string; + num_nonconsts: int; + optional_labels: string list; + attrs: Parsetree.attributes; + } + | Record_extension (* Inlined record under extension *) | Record_optional_labels of string list (* List of optional labels *) -and label_declaration = - { - ld_id: Ident.t; - ld_mutable: mutable_flag; - ld_type: type_expr; - ld_loc: Location.t; - ld_attributes: Parsetree.attributes; - } - -and constructor_declaration = - { - cd_id: Ident.t; - cd_args: constructor_arguments; - cd_res: type_expr option; - cd_loc: Location.t; - cd_attributes: Parsetree.attributes; - } +and label_declaration = { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; +} + +and constructor_declaration = { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; +} and constructor_arguments = | Cstr_tuple of type_expr list | Cstr_record of label_declaration list -and unboxed_status = - { - unboxed: bool; - default: bool; (* False if the unboxed field was set from an attribute. *) - } +and unboxed_status = { + unboxed: bool; + default: bool; (* False if the unboxed field was set from an attribute. *) +} let unboxed_false_default_false = {unboxed = false; default = false} let unboxed_false_default_true = {unboxed = false; default = true} let unboxed_true_default_false = {unboxed = true; default = false} let unboxed_true_default_true = {unboxed = true; default = true} -type extension_constructor = - { ext_type_path: Path.t; - ext_type_params: type_expr list; - ext_args: constructor_arguments; - ext_ret_type: type_expr option; - ext_private: private_flag; - ext_loc: Location.t; - ext_attributes: Parsetree.attributes; - ext_is_exception: bool; } +type extension_constructor = { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_is_exception: bool; +} and type_transparence = - Type_public (* unrestricted expansion *) - | Type_new (* "new" type *) - | Type_private (* private type *) + | Type_public (* unrestricted expansion *) + | Type_new (* "new" type *) + | Type_private (* private type *) (* Type expressions for the class language *) -module Concr = Set.Make(OrderedString) +module Concr = Set.Make (OrderedString) (* Type expressions for the module language *) type module_type = - Mty_ident of Path.t + | Mty_ident of Path.t | Mty_signature of signature | Mty_functor of Ident.t * module_type option * module_type | Mty_alias of alias_presence * Path.t -and alias_presence = - | Mta_present - | Mta_absent +and alias_presence = Mta_present | Mta_absent and signature = signature_item list and signature_item = - Sig_value of Ident.t * value_description + | Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_typext of Ident.t * extension_constructor * ext_status | Sig_module of Ident.t * module_declaration * rec_status @@ -233,94 +230,98 @@ and signature_item = | Sig_class of unit | Sig_class_type of unit (* Dummy AST node *) -and module_declaration = - { - md_type: module_type; - md_attributes: Parsetree.attributes; - md_loc: Location.t; - } +and module_declaration = { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; +} -and modtype_declaration = - { - mtd_type: module_type option; (* Note: abstract *) - mtd_attributes: Parsetree.attributes; - mtd_loc: Location.t; - } +and modtype_declaration = { + mtd_type: module_type option; (* Note: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; +} and rec_status = - Trec_not (* first in a nonrecursive group *) - | Trec_first (* first in a recursive group *) - | Trec_next (* not first in a recursive/nonrecursive group *) + | Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) and ext_status = - Text_first (* first constructor of an extension *) - | Text_next (* not first constructor of an extension *) - | Text_exception (* an exception *) - + | Text_first (* first constructor of an extension *) + | Text_next (* not first constructor of an extension *) + | Text_exception (* an exception *) (* Constructor and record label descriptions inserted held in typing environments *) -type constructor_description = - { cstr_name: string; (* Constructor name *) - cstr_res: type_expr; (* Type of the result *) - cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) - cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag; (* Read-only constructor? *) - cstr_loc: Location.t; - cstr_attributes: Parsetree.attributes; - cstr_inlined: type_declaration option; - } +type constructor_description = { + cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_normal: int; (* Number of non generalized constrs *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; +} and constructor_tag = - Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_unboxed (* Constructor of an unboxed type *) - | Cstr_extension of Path.t (* Extension constructor *) + | Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t (* Extension constructor *) -let equal_tag t1 t2 = +let equal_tag t1 t2 = match (t1, t2) with | Cstr_constant i1, Cstr_constant i2 -> i2 = i1 | Cstr_block i1, Cstr_block i2 -> i2 = i1 | Cstr_unboxed, Cstr_unboxed -> true - | Cstr_extension (path1), Cstr_extension (path2) -> - Path.same path1 path2 - | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false - -let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with -| Cstr_extension _,Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity -| tag1,tag2 -> equal_tag tag1 tag2 - -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - lbl_arg: type_expr; (* Type of the argument *) - lbl_mut: mutable_flag; (* Is this a mutable field? *) - lbl_pos: int; (* Position in block *) - mutable lbl_all: label_description array; (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) - lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - } + | Cstr_extension path1, Cstr_extension path2 -> Path.same path1 path2 + | (Cstr_constant _ | Cstr_block _ | Cstr_unboxed | Cstr_extension _), _ -> + false + +let may_equal_constr c1 c2 = + match (c1.cstr_tag, c2.cstr_tag) with + | Cstr_extension _, Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity + | tag1, tag2 -> equal_tag tag1 tag2 + +type label_description = { + lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + mutable lbl_all: label_description array; + (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; +} let same_record_representation x y = match x with | Record_regular -> y = Record_regular | Record_float_unused -> y = Record_float_unused | Record_optional_labels lbls -> ( - match y with - | Record_optional_labels lbls2 -> lbls = lbls2 - | _ -> false) + match y with + | Record_optional_labels lbls2 -> lbls = lbls2 + | _ -> false) | Record_inlined {tag; name; num_nonconsts; optional_labels} -> ( - match y with - | Record_inlined y -> - tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts && optional_labels = y.optional_labels - | _ -> false) + match y with + | Record_inlined y -> + tag = y.tag && name = y.name + && num_nonconsts = y.num_nonconsts + && optional_labels = y.optional_labels + | _ -> false) | Record_extension -> y = Record_extension - | Record_unboxed x -> ( match y with Record_unboxed y -> x = y | _ -> false) + | Record_unboxed x -> ( + match y with + | Record_unboxed y -> x = y + | _ -> false) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index c7e8f48f82..99f05038eb 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -21,9 +21,10 @@ CMI files are made of marshalled types. *) -(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) open Asttypes +(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) +type type_expr = {mutable desc: type_desc; mutable level: int; id: int} (** Type expressions for the core language. The [type_desc] variant defines all the possible type expressions one can @@ -55,32 +56,23 @@ open Asttypes Note on mutability: TBD. *) -type type_expr = - { mutable desc: type_desc; - mutable level: int; - id: int } and type_desc = | Tvar of string option - (** [Tvar (Some "a")] ==> ['a] or ['_a] + (** [Tvar (Some "a")] ==> ['a] or ['_a] [Tvar None] ==> [_] *) - | Tarrow of arg_label * type_expr * type_expr * commutable - (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] + (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] See [commutable] for the last argument. *) - - | Ttuple of type_expr list - (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) - + | Ttuple of type_expr list (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) | Tconstr of Path.t * type_expr list * abbrev_memo ref - (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] + (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] The last parameter keep tracks of known expansions, see [abbrev_memo]. *) - | Tobject of type_expr * (Path.t * type_expr list) option ref - (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] + (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] f1, fn are represented as a linked list of types using Tfield and Tnil constructors. @@ -97,37 +89,35 @@ and type_desc = where [rv] is the hidden row variable. *) - | Tfield of string * field_kind * type_expr * type_expr - (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) - - | Tnil - (** [Tnil] ==> [<...; >] *) - - | Tlink of type_expr - (** Indirection used by unification engine. *) - - | Tsubst of type_expr (* for copying *) - (** [Tsubst] is used temporarily to store information in low-level + (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) + | Tnil (** [Tnil] ==> [<...; >] *) + | Tlink of type_expr (** Indirection used by unification engine. *) + | Tsubst of type_expr (* for copying *) + (** [Tsubst] is used temporarily to store information in low-level functions manipulating representation of types, such as instantiation or copy. This constructor should not appear outside of these cases. *) - | Tvariant of row_desc - (** Representation of polymorphic variants, see [row_desc]. *) - + (** Representation of polymorphic variants, see [row_desc]. *) | Tunivar of string option - (** Occurrence of a type variable introduced by a + (** Occurrence of a type variable introduced by a forall quantifier / [Tpoly]. *) - | Tpoly of type_expr * type_expr list - (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], + (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], where 'a1 ... 'an are names given to types in tyl and occurrences of those types in ty. *) - | Tpackage of Path.t * Longident.t list * type_expr list - (** Type of a first-class module (a.k.a package). *) - + (** Type of a first-class module (a.k.a package). *) + +and row_desc = { + row_fields: (label * row_field) list; + row_more: type_expr; + row_bound: unit; (* kept for compatibility *) + row_closed: bool; + row_fixed: bool; + row_name: (Path.t * type_expr list) option; +} (** [ `X | `Y ] (row_closed = true) [< `X | `Y ] (row_closed = true) [> `X | `Y ] (row_closed = false) @@ -154,20 +144,13 @@ and type_desc = } *) -and row_desc = - { row_fields: (label * row_field) list; - row_more: type_expr; - row_bound: unit; (* kept for compatibility *) - row_closed: bool; - row_fixed: bool; - row_name: (Path.t * type_expr list) option } and row_field = - Rpresent of type_expr option + | Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref - (* 1st true denotes a constant constructor *) - (* 2nd true denotes a tag in a pattern matching, and - is erased later *) + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) | Rabsent (** [abbrev_memo] allows one to keep track of different expansions of a type @@ -186,21 +169,16 @@ and row_field = removing abbreviations. *) and abbrev_memo = - | Mnil (** No known abbreviation *) - + | Mnil (** No known abbreviation *) | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo - (** Found one abbreviation. + (** Found one abbreviation. A valid abbreviation should be at least as visible and reachable by the same path. The first expression is the abbreviation and the second the expansion. *) - | Mlink of abbrev_memo ref - (** Abbreviations can be found after this indirection *) + (** Abbreviations can be found after this indirection *) -and field_kind = - Fvar of field_kind option ref - | Fpresent - | Fabsent +and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent (** [commutable] is a flag appended to every arrow type. @@ -223,10 +201,7 @@ and field_kind = in an order different from other calls. This is only allowed when the real type is known. *) -and commutable = - Cok - | Cunknown - | Clink of commutable ref +and commutable = Cok | Cunknown | Clink of commutable ref module TypeOps : sig type t = type_expr @@ -238,125 +213,129 @@ end (* Maps of methods and instance variables *) module Meths : Map.S with type key = string -module Vars : Map.S with type key = string +module Vars : Map.S with type key = string (* Value descriptions *) -type value_description = - { val_type: type_expr; (* Type of the value *) - val_kind: value_kind; - val_loc: Location.t; - val_attributes: Parsetree.attributes; - } +type value_description = { + val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; +} and value_kind = - Val_reg (* Regular value *) - | Val_prim of Primitive.description (* Primitive *) + | Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) (* Variance *) module Variance : sig type t type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv - val null : t (* no occurrence *) - val full : t (* strictly invariant *) - val covariant : t (* strictly covariant *) - val may_inv : t (* maybe invariant *) - val union : t -> t -> t - val inter : t -> t -> t + val null : t (* no occurrence *) + val full : t (* strictly invariant *) + val covariant : t (* strictly covariant *) + val may_inv : t (* maybe invariant *) + val union : t -> t -> t + val inter : t -> t -> t val subset : t -> t -> bool val set : f -> bool -> t -> t val mem : f -> t -> bool - val conjugate : t -> t (* exchange positive and negative *) - val get_upper : t -> bool * bool (* may_pos, may_neg *) - val get_lower : t -> bool * bool * bool * bool (* pos, neg, inv, inj *) + val conjugate : t -> t (* exchange positive and negative *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool * bool (* pos, neg, inv, inj *) end (* Type definitions *) -type type_declaration = - { type_params: type_expr list; - type_arity: int; - type_kind: type_kind; - type_private: private_flag; - type_manifest: type_expr option; - type_variance: Variance.t list; - (* covariant, contravariant, weakly contravariant, injective *) - type_newtype_level: (int * int) option; - (* definition level * expansion level *) - type_loc: Location.t; - type_attributes: Parsetree.attributes; - type_immediate: bool; (* true iff type should not be a pointer *) - type_unboxed: unboxed_status; - } +type type_declaration = { + type_params: type_expr list; + type_arity: int; + type_kind: type_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + (* covariant, contravariant, weakly contravariant, injective *) + type_newtype_level: (int * int) option; + (* definition level * expansion level *) + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: bool; (* true iff type should not be a pointer *) + type_unboxed: unboxed_status; +} and type_kind = - Type_abstract - | Type_record of label_declaration list * record_representation + | Type_abstract + | Type_record of label_declaration list * record_representation | Type_variant of constructor_declaration list | Type_open and record_representation = - | Record_regular (* All fields are boxed / tagged *) - | Record_float_unused (* Was: all fields are floats. Now: unused *) - | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) - | Record_inlined of (* Inlined record *) - { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes } - | Record_extension (* Inlined record under extension *) + | Record_regular (* All fields are boxed / tagged *) + | Record_float_unused (* Was: all fields are floats. Now: unused *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of + (* Inlined record *) + { + tag: int; + name: string; + num_nonconsts: int; + optional_labels: string list; + attrs: Parsetree.attributes; + } + | Record_extension (* Inlined record under extension *) | Record_optional_labels of string list (* List of optional labels *) -and label_declaration = - { - ld_id: Ident.t; - ld_mutable: mutable_flag; - ld_type: type_expr; - ld_loc: Location.t; - ld_attributes: Parsetree.attributes; - } - -and constructor_declaration = - { - cd_id: Ident.t; - cd_args: constructor_arguments; - cd_res: type_expr option; - cd_loc: Location.t; - cd_attributes: Parsetree.attributes; - } +and label_declaration = { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; +} + +and constructor_declaration = { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; +} and constructor_arguments = | Cstr_tuple of type_expr list | Cstr_record of label_declaration list -and unboxed_status = private +and unboxed_status = + private (* This type must be private in order to ensure perfect sharing of the four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce - different executables. *) - { - unboxed: bool; - default: bool; (* True for unannotated unboxable types. *) - } + different executables. *) { + unboxed: bool; + default: bool; (* True for unannotated unboxable types. *) +} val unboxed_false_default_false : unboxed_status val unboxed_false_default_true : unboxed_status val unboxed_true_default_false : unboxed_status val unboxed_true_default_true : unboxed_status -type extension_constructor = - { - ext_type_path: Path.t; - ext_type_params: type_expr list; - ext_args: constructor_arguments; - ext_ret_type: type_expr option; - ext_private: private_flag; - ext_loc: Location.t; - ext_attributes: Parsetree.attributes; - ext_is_exception: bool; - } +type extension_constructor = { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_is_exception: bool; +} and type_transparence = - Type_public (* unrestricted expansion *) - | Type_new (* "new" type *) - | Type_private (* private type *) + | Type_public (* unrestricted expansion *) + | Type_new (* "new" type *) + | Type_private (* private type *) (* Type expressions for the class language *) @@ -365,19 +344,17 @@ module Concr : Set.S with type elt = string (* Type expressions for the module language *) type module_type = - Mty_ident of Path.t + | Mty_ident of Path.t | Mty_signature of signature | Mty_functor of Ident.t * module_type option * module_type | Mty_alias of alias_presence * Path.t -and alias_presence = - | Mta_present - | Mta_absent +and alias_presence = Mta_present | Mta_absent and signature = signature_item list and signature_item = - Sig_value of Ident.t * value_description + | Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_typext of Ident.t * extension_constructor * ext_status | Sig_module of Ident.t * module_declaration * rec_status @@ -385,74 +362,74 @@ and signature_item = | Sig_class of unit | Sig_class_type of unit (* Dummy AST node *) -and module_declaration = - { - md_type: module_type; - md_attributes: Parsetree.attributes; - md_loc: Location.t; - } +and module_declaration = { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; +} -and modtype_declaration = - { - mtd_type: module_type option; (* None: abstract *) - mtd_attributes: Parsetree.attributes; - mtd_loc: Location.t; - } +and modtype_declaration = { + mtd_type: module_type option; (* None: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; +} and rec_status = - Trec_not (* first in a nonrecursive group *) - | Trec_first (* first in a recursive group *) - | Trec_next (* not first in a recursive/nonrecursive group *) + | Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) and ext_status = - Text_first (* first constructor in an extension *) - | Text_next (* not first constructor in an extension *) + | Text_first (* first constructor in an extension *) + | Text_next (* not first constructor in an extension *) | Text_exception - (* Constructor and record label descriptions inserted held in typing environments *) -type constructor_description = - { cstr_name: string; (* Constructor name *) - cstr_res: type_expr; (* Type of the result *) - cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) - cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag; (* Read-only constructor? *) - cstr_loc: Location.t; - cstr_attributes: Parsetree.attributes; - cstr_inlined: type_declaration option; - } +type constructor_description = { + cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_normal: int; (* Number of non generalized constrs *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; +} and constructor_tag = - Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_unboxed (* Constructor of an unboxed type *) - | Cstr_extension of Path.t (* Extension constructor *) + | Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t (* Extension constructor *) (* Constructors are the same *) -val equal_tag : constructor_tag -> constructor_tag -> bool +val equal_tag : constructor_tag -> constructor_tag -> bool (* Constructors may be the same, given potential rebinding *) val may_equal_constr : - constructor_description -> constructor_description -> bool - -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - lbl_arg: type_expr; (* Type of the argument *) - lbl_mut: mutable_flag; (* Is this a mutable field? *) - lbl_pos: int; (* Position in block *) - mutable lbl_all: label_description array; (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - } - -val same_record_representation : record_representation -> record_representation -> bool \ No newline at end of file + constructor_description -> constructor_description -> bool + +type label_description = { + lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + mutable lbl_all: label_description array; + (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; +} + +val same_record_representation : + record_representation -> record_representation -> bool diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index aa8cdf6d5d..0dda845547 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -26,7 +26,7 @@ open Ctype exception Already_bound type error = - Unbound_type_variable of string + | Unbound_type_variable of string | Unbound_type_constructor of Longident.t | Unbound_type_constructor_2 of Path.t | Type_arity_mismatch of Longident.t * int * int @@ -60,7 +60,6 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error - type variable_context = int * (string, type_expr) Tbl.t (* Local definitions *) @@ -70,62 +69,57 @@ let instance_list = Ctype.instance_list Env.empty (* Narrowing unbound identifier errors. *) let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = - fun env loc lid make_error -> + fun env loc lid make_error -> let check_module mlid = try ignore (Env.lookup_module ~load:true mlid env) with | Not_found -> - narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) + narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) | Env.Recmodule -> - raise (Error (loc, env, Illegal_reference_to_recursive_module)) + raise (Error (loc, env, Illegal_reference_to_recursive_module)) in - begin match lid with + (match lid with | Longident.Lident _ -> () - | Longident.Ldot (mlid, _) -> - check_module mlid; - let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in - begin match Env.scrape_alias env md.md_type with - | Mty_functor _ -> - raise (Error (loc, env, Access_functor_as_structure mlid)) - | Mty_alias(_, p) -> - raise (Error (loc, env, Cannot_scrape_alias(mlid, p))) - | _ -> () - end - | Longident.Lapply (flid, mlid) -> - check_module flid; - let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in - begin match Env.scrape_alias env fmd.md_type with - | Mty_signature _ -> - raise (Error (loc, env, Apply_structure_as_functor flid)) - | Mty_alias(_, p) -> - raise (Error (loc, env, Cannot_scrape_alias(flid, p))) - | _ -> () - end; - check_module mlid; - let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in - begin match Env.scrape_alias env mmd.md_type with - | Mty_alias(_, p) -> - raise (Error (loc, env, Cannot_scrape_alias(mlid, p))) - | _ -> - raise (Error (loc, env, Ill_typed_functor_application lid)) - end - end; + | Longident.Ldot (mlid, _) -> ( + check_module mlid; + let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in + match Env.scrape_alias env md.md_type with + | Mty_functor _ -> + raise (Error (loc, env, Access_functor_as_structure mlid)) + | Mty_alias (_, p) -> + raise (Error (loc, env, Cannot_scrape_alias (mlid, p))) + | _ -> ()) + | Longident.Lapply (flid, mlid) -> ( + check_module flid; + let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in + (match Env.scrape_alias env fmd.md_type with + | Mty_signature _ -> + raise (Error (loc, env, Apply_structure_as_functor flid)) + | Mty_alias (_, p) -> + raise (Error (loc, env, Cannot_scrape_alias (flid, p))) + | _ -> ()); + check_module mlid; + let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in + match Env.scrape_alias env mmd.md_type with + | Mty_alias (_, p) -> + raise (Error (loc, env, Cannot_scrape_alias (mlid, p))) + | _ -> raise (Error (loc, env, Ill_typed_functor_application lid)))); raise (Error (loc, env, make_error lid)) let find_component (lookup : ?loc:_ -> _) make_error env loc lid = try match lid with | Longident.Ldot (Longident.Lident "*predef*", s) -> - lookup ~loc (Longident.Lident s) Env.initial_safe_string - | _ -> - lookup ~loc lid env - with Not_found -> - narrow_unbound_lid_error env loc lid make_error + lookup ~loc (Longident.Lident s) Env.initial_safe_string + | _ -> lookup ~loc lid env + with + | Not_found -> narrow_unbound_lid_error env loc lid make_error | Env.Recmodule -> raise (Error (loc, env, Illegal_reference_to_recursive_module)) let find_type env loc lid = let path = - find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) + find_component Env.lookup_type + (fun lid -> Unbound_type_constructor lid) env loc lid in let decl = Env.find_type path env in @@ -135,25 +129,25 @@ let find_type env loc lid = let find_constructor = find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) let find_all_constructors = - find_component Env.lookup_all_constructors - (fun lid -> Unbound_constructor lid) -let find_label = - find_component Env.lookup_label (fun lid -> Unbound_label lid) + find_component Env.lookup_all_constructors (fun lid -> + Unbound_constructor lid) +let find_label = find_component Env.lookup_label (fun lid -> Unbound_label lid) let find_all_labels = find_component Env.lookup_all_labels (fun lid -> Unbound_label lid) - let find_value env loc lid = Env.check_value_name (Longident.last lid) loc; - let (path, decl) as r = + let ((path, decl) as r) = find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid in Builtin_attributes.check_deprecated loc decl.val_attributes (Path.name path); r -let lookup_module ?(load=false) env loc lid = - find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env)) - (fun lid -> Unbound_module lid) env loc lid +let lookup_module ?(load = false) env loc lid = + find_component + (fun ?loc lid env -> Env.lookup_module ~load ?loc lid env) + (fun lid -> Unbound_module lid) + env loc lid let find_module env loc lid = let path = lookup_module ~load:true env loc lid in @@ -162,20 +156,20 @@ let find_module env loc lid = (path, decl) let find_modtype env loc lid = - let (path, decl) as r = - find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) + let ((path, decl) as r) = + find_component Env.lookup_modtype + (fun lid -> Unbound_modtype lid) env loc lid in Builtin_attributes.check_deprecated loc decl.mtd_attributes (Path.name path); r let unbound_constructor_error env lid = - narrow_unbound_lid_error env lid.loc lid.txt - (fun lid -> Unbound_constructor lid) + narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> + Unbound_constructor lid) let unbound_label_error env lid = - narrow_unbound_lid_error env lid.loc lid.txt - (fun lid -> Unbound_label lid) + narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> Unbound_label lid) (* Support for first-class modules. *) @@ -186,33 +180,36 @@ let create_package_mty fake loc env (p, l) = let l = List.sort (fun (s1, _t1) (s2, _t2) -> - if s1.txt = s2.txt then - raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); - compare s1.txt s2.txt) + if s1.txt = s2.txt then + raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); + compare s1.txt s2.txt) l in - l, - List.fold_left - (fun mty (s, t) -> - let d = {ptype_name = mkloc (Longident.last s.txt) s.loc; - ptype_params = []; - ptype_cstrs = []; - ptype_kind = Ptype_abstract; - ptype_private = Asttypes.Public; - ptype_manifest = if fake then None else Some t; - ptype_attributes = []; - ptype_loc = loc} in - Ast_helper.Mty.mk ~loc - (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ])) - ) - (Ast_helper.Mty.mk ~loc (Pmty_ident p)) - l + ( l, + List.fold_left + (fun mty (s, t) -> + let d = + { + ptype_name = mkloc (Longident.last s.txt) s.loc; + ptype_params = []; + ptype_cstrs = []; + ptype_kind = Ptype_abstract; + ptype_private = Asttypes.Public; + ptype_manifest = (if fake then None else Some t); + ptype_attributes = []; + ptype_loc = loc; + } + in + Ast_helper.Mty.mk ~loc + (Pmty_with (mty, [Pwith_type ({txt = s.txt; loc}, d)]))) + (Ast_helper.Mty.mk ~loc (Pmty_ident p)) + l ) (* Translation of type expressions *) let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) -let univars = ref ([] : (string * type_expr) list) -let pre_univars = ref ([] : type_expr list) +let univars = ref ([] : (string * type_expr) list) +let pre_univars = ref ([] : type_expr list) let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t) let reset_type_variables () = @@ -220,339 +217,365 @@ let reset_type_variables () = Ctype.reset_reified_var_counter (); type_variables := Tbl.empty -let narrow () = - (increase_global_level (), !type_variables) +let narrow () = (increase_global_level (), !type_variables) let widen (gl, tv) = restore_global_level gl; type_variables := tv -let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') +let strict_ident c = c = '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') let validate_name = function - None -> None - | Some name as s -> - if name <> "" && strict_ident name.[0] then s else None + | None -> None + | Some name as s -> if name <> "" && strict_ident name.[0] then s else None -let new_global_var ?name () = - new_global_var ?name:(validate_name name) () -let newvar ?name () = - newvar ?name:(validate_name name) () +let new_global_var ?name () = new_global_var ?name:(validate_name name) () +let newvar ?name () = newvar ?name:(validate_name name) () let type_variable loc name = - try - Tbl.find name !type_variables + try Tbl.find name !type_variables with Not_found -> - raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name))) + raise (Error (loc, Env.empty, Unbound_type_variable ("'" ^ name))) let transl_type_param env styp = let loc = styp.ptyp_loc in match styp.ptyp_desc with - Ptyp_any -> - let ty = new_global_var ~name:"_" () in - { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env; - ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | Ptyp_any -> + let ty = new_global_var ~name:"_" () in + { + ctyp_desc = Ttyp_any; + ctyp_type = ty; + ctyp_env = env; + ctyp_loc = loc; + ctyp_attributes = styp.ptyp_attributes; + } | Ptyp_var name -> - let ty = - try - if name <> "" && name.[0] = '_' then - raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); - ignore (Tbl.find name !type_variables); - raise Already_bound - with Not_found -> - let v = new_global_var ~name () in - type_variables := Tbl.add name v !type_variables; - v - in - { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env; - ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + let ty = + try + if name <> "" && name.[0] = '_' then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + ignore (Tbl.find name !type_variables); + raise Already_bound + with Not_found -> + let v = new_global_var ~name () in + type_variables := Tbl.add name v !type_variables; + v + in + { + ctyp_desc = Ttyp_var name; + ctyp_type = ty; + ctyp_env = env; + ctyp_loc = loc; + ctyp_attributes = styp.ptyp_attributes; + } | _ -> assert false let transl_type_param env styp = (* Currently useless, since type parameters cannot hold attributes (but this could easily be lifted in the future). *) - Builtin_attributes.warning_scope styp.ptyp_attributes - (fun () -> transl_type_param env styp) - + Builtin_attributes.warning_scope styp.ptyp_attributes (fun () -> + transl_type_param env styp) let new_pre_univar ?name () = - let v = newvar ?name () in pre_univars := v :: !pre_univars; v + let v = newvar ?name () in + pre_univars := v :: !pre_univars; + v let rec swap_list = function - x :: y :: l -> y :: x :: swap_list l + | x :: y :: l -> y :: x :: swap_list l | l -> l type policy = Fixed | Extensible | Univars let rec transl_type env policy styp = - Builtin_attributes.warning_scope styp.ptyp_attributes - (fun () -> transl_type_aux env policy styp) + Builtin_attributes.warning_scope styp.ptyp_attributes (fun () -> + transl_type_aux env policy styp) and transl_type_aux env policy styp = let loc = styp.ptyp_loc in let ctyp ctyp_desc ctyp_type = - { ctyp_desc; ctyp_type; ctyp_env = env; - ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes } + { + ctyp_desc; + ctyp_type; + ctyp_env = env; + ctyp_loc = loc; + ctyp_attributes = styp.ptyp_attributes; + } in match styp.ptyp_desc with - Ptyp_any -> - let ty = - if policy = Univars then new_pre_univar () else - if policy = Fixed then - raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_")) - else newvar () - in - ctyp Ttyp_any ty + | Ptyp_any -> + let ty = + if policy = Univars then new_pre_univar () + else if policy = Fixed then + raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_")) + else newvar () + in + ctyp Ttyp_any ty | Ptyp_var name -> let ty = if name <> "" && name.[0] = '_' then raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); - begin try - instance env (List.assoc name !univars) - with Not_found -> try - instance env (fst(Tbl.find name !used_variables)) - with Not_found -> - let v = - if policy = Univars then new_pre_univar ~name () else newvar ~name () - in - used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; - v - end + try instance env (List.assoc name !univars) + with Not_found -> ( + try instance env (fst (Tbl.find name !used_variables)) + with Not_found -> + let v = + if policy = Univars then new_pre_univar ~name () + else newvar ~name () + in + used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; + v) in ctyp (Ttyp_var name) ty - | Ptyp_arrow(l, st1, st2) -> + | Ptyp_arrow (l, st1, st2) -> let cty1 = transl_type env policy st1 in let cty2 = transl_type env policy st2 in let ty1 = cty1.ctyp_type in let ty1 = - if Btype.is_optional l - then newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) - else ty1 in - let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in + if Btype.is_optional l then + newty (Tconstr (Predef.path_option, [ty1], ref Mnil)) + else ty1 + in + let ty = newty (Tarrow (l, ty1, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty | Ptyp_tuple stl -> assert (List.length stl >= 2); let ctys = List.map (transl_type env policy) stl in let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty - | Ptyp_constr(lid, stl) -> - let (path, decl) = find_type env lid.loc lid.txt in - let stl = - match stl with - | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> - List.map (fun _ -> t) decl.type_params - | _ -> stl - in - if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, env, - Type_arity_mismatch(lid.txt, decl.type_arity, - List.length stl))); - let args = List.map (transl_type env policy) stl in - let params = instance_list decl.type_params in - let unify_param = - match decl.type_manifest with - None -> unify_var - | Some ty -> - if (repr ty).level = Btype.generic_level then unify_var else unify - in - List.iter2 - (fun (sty, cty) ty' -> - try unify_param env ty' cty.ctyp_type with Unify trace -> - raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) - (List.combine stl args) params; - let constr = - newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in - begin try - Ctype.enforce_constraints env constr - with Unify trace -> - raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) - end; - ctyp (Ttyp_constr (path, lid, args)) constr + | Ptyp_constr (lid, stl) -> + let path, decl = find_type env lid.loc lid.txt in + let stl = + match stl with + | [({ptyp_desc = Ptyp_any} as t)] when decl.type_arity > 1 -> + List.map (fun _ -> t) decl.type_params + | _ -> stl + in + if List.length stl <> decl.type_arity then + raise + (Error + ( styp.ptyp_loc, + env, + Type_arity_mismatch (lid.txt, decl.type_arity, List.length stl) )); + let args = List.map (transl_type env policy) stl in + let params = instance_list decl.type_params in + let unify_param = + match decl.type_manifest with + | None -> unify_var + | Some ty -> + if (repr ty).level = Btype.generic_level then unify_var else unify + in + List.iter2 + (fun (sty, cty) ty' -> + try unify_param env ty' cty.ctyp_type + with Unify trace -> + raise (Error (sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) + (List.combine stl args) params; + let constr = newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in + (try Ctype.enforce_constraints env constr + with Unify trace -> + raise (Error (styp.ptyp_loc, env, Type_mismatch trace))); + ctyp (Ttyp_constr (path, lid, args)) constr | Ptyp_object (fields, o) -> - let ty, fields = transl_fields env policy o fields in - ctyp (Ttyp_object (fields, o)) (newobj ty) - | Ptyp_class() -> assert false - | Ptyp_alias(st, alias) -> - let cty = - try - let t = - try List.assoc alias !univars - with Not_found -> - instance env (fst(Tbl.find alias !used_variables)) - in - let ty = transl_type env policy st in - begin try unify_var env t ty.ctyp_type with Unify trace -> - let trace = swap_list trace in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) - end; - ty - with Not_found -> - let t = newvar () in - used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; - let ty = transl_type env policy st in - begin try unify_var env t ty.ctyp_type with Unify trace -> - let trace = swap_list trace in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) - end; - let t = instance env t in - let px = Btype.proxy t in - begin match px.desc with - | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) - | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) - | _ -> () - end; - { ty with ctyp_type = t } - in - ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type - | Ptyp_variant(fields, closed, present) -> - let name = ref None in - let mkfield l f = - newty (Tvariant {row_fields=[l,f]; row_more=newvar(); - row_bound=(); row_closed=true; - row_fixed=false; row_name=None}) in - let hfields = Hashtbl.create 17 in - let add_typed_field loc l f = - try - let (_,f') = Hashtbl.find hfields l in - let ty = mkfield l f and ty' = mkfield l f' in - if equal env false [ty] [ty'] then () else + let ty, fields = transl_fields env policy o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_class () -> assert false + | Ptyp_alias (st, alias) -> + let cty = + try + let t = + try List.assoc alias !univars + with Not_found -> + instance env (fst (Tbl.find alias !used_variables)) + in + let ty = transl_type env policy st in + (try unify_var env t ty.ctyp_type + with Unify trace -> + let trace = swap_list trace in + raise (Error (styp.ptyp_loc, env, Alias_type_mismatch trace))); + ty + with Not_found -> + let t = newvar () in + used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; + let ty = transl_type env policy st in + (try unify_var env t ty.ctyp_type + with Unify trace -> + let trace = swap_list trace in + raise (Error (styp.ptyp_loc, env, Alias_type_mismatch trace))); + let t = instance env t in + let px = Btype.proxy t in + (match px.desc with + | Tvar None -> + Btype.log_type px; + px.desc <- Tvar (Some alias) + | Tunivar None -> + Btype.log_type px; + px.desc <- Tunivar (Some alias) + | _ -> ()); + {ty with ctyp_type = t} + in + ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type + | Ptyp_variant (fields, closed, present) -> + let name = ref None in + let mkfield l f = + newty + (Tvariant + { + row_fields = [(l, f)]; + row_more = newvar (); + row_bound = (); + row_closed = true; + row_fixed = false; + row_name = None; + }) + in + let hfields = Hashtbl.create 17 in + let add_typed_field loc l f = + try + let _, f' = Hashtbl.find hfields l in + let ty = mkfield l f and ty' = mkfield l f' in + if equal env false [ty] [ty'] then () + else try unify env ty ty' with Unify _trace -> - raise(Error(loc, env, Constructor_mismatch (ty,ty'))) - with Not_found -> - Hashtbl.add hfields l (l,f) - in - let add_field = function - Rtag (l, attrs, c, stl) -> - name := None; - let tl = - Builtin_attributes.warning_scope attrs - (fun () -> List.map (transl_type env policy) stl) - in - let f = match present with - Some present when not (List.mem l.txt present) -> - let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in - Reither(c, ty_tl, false, ref None) - | _ -> - if List.length stl > 1 || c && stl <> [] then - raise(Error(styp.ptyp_loc, env, - Present_has_conjunction l.txt)); - match tl with [] -> Rpresent None - | st :: _ -> - Rpresent (Some st.ctyp_type) - in - add_typed_field styp.ptyp_loc l.txt f; - Ttag (l,attrs,c,tl) - | Rinherit sty -> - let cty = transl_type env policy sty in - let ty = cty.ctyp_type in - let nm = - match repr cty.ctyp_type with - {desc=Tconstr(p, tl, _)} -> Some(p, tl) - | _ -> None - in - begin - (* Set name if there are no fields yet *) - if Hashtbl.length hfields <> 0 then name := None - else name := nm - end; - let fl = match expand_head env cty.ctyp_type, nm with - {desc=Tvariant row}, _ when Btype.static_row row -> - let row = Btype.row_repr row in - row.row_fields - | {desc=Tvar _}, Some(p, _) -> - raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p)) - | _ -> - raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) + raise (Error (loc, env, Constructor_mismatch (ty, ty'))) + with Not_found -> Hashtbl.add hfields l (l, f) + in + let add_field = function + | Rtag (l, attrs, c, stl) -> + name := None; + let tl = + Builtin_attributes.warning_scope attrs (fun () -> + List.map (transl_type env policy) stl) + in + let f = + match present with + | Some present when not (List.mem l.txt present) -> + let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in + Reither (c, ty_tl, false, ref None) + | _ -> ( + if List.length stl > 1 || (c && stl <> []) then + raise (Error (styp.ptyp_loc, env, Present_has_conjunction l.txt)); + match tl with + | [] -> Rpresent None + | st :: _ -> Rpresent (Some st.ctyp_type)) + in + add_typed_field styp.ptyp_loc l.txt f; + Ttag (l, attrs, c, tl) + | Rinherit sty -> + let cty = transl_type env policy sty in + let ty = cty.ctyp_type in + let nm = + match repr cty.ctyp_type with + | {desc = Tconstr (p, tl, _)} -> Some (p, tl) + | _ -> None + in + (* Set name if there are no fields yet *) + if Hashtbl.length hfields <> 0 then name := None else name := nm; + let fl = + match (expand_head env cty.ctyp_type, nm) with + | {desc = Tvariant row}, _ when Btype.static_row row -> + let row = Btype.row_repr row in + row.row_fields + | {desc = Tvar _}, Some (p, _) -> + raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) + | _ -> raise (Error (sty.ptyp_loc, env, Not_a_variant ty)) + in + List.iter + (fun (l, f) -> + let f = + match present with + | Some present when not (List.mem l present) -> ( + match f with + | Rpresent (Some ty) -> Reither (false, [ty], false, ref None) + | Rpresent None -> Reither (true, [], false, ref None) + | _ -> assert false) + | _ -> f in - List.iter - (fun (l, f) -> - let f = match present with - Some present when not (List.mem l present) -> - begin match f with - Rpresent(Some ty) -> - Reither(false, [ty], false, ref None) - | Rpresent None -> - Reither(true, [], false, ref None) - | _ -> - assert false - end - | _ -> f - in - add_typed_field sty.ptyp_loc l f) - fl; - Tinherit cty - in - let tfields = List.map add_field fields in - let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in - begin match present with None -> () - | Some present -> - List.iter - (fun l -> if not (List.mem_assoc l fields) then - raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) - present - end; - let row = - { row_fields = List.rev fields; row_more = newvar (); - row_bound = (); row_closed = (closed = Closed); - row_fixed = false; row_name = !name } in - let static = Btype.static_row row in - let row = - if static then { row with row_more = newty Tnil } - else if policy <> Univars then row - else { row with row_more = new_pre_univar () } - in - let ty = newty (Tvariant row) in - ctyp (Ttyp_variant (tfields, closed, present)) ty - | Ptyp_poly(vars, st) -> - let vars = List.map (fun v -> v.txt) vars in - begin_def(); - let new_univars = List.map (fun name -> name, newvar ~name ()) vars in - let old_univars = !univars in - univars := new_univars @ !univars; - let cty = transl_type env policy st in - let ty = cty.ctyp_type in - univars := old_univars; - end_def(); - generalize ty; - let ty_list = - List.fold_left - (fun tyl (name, ty1) -> - let v = Btype.proxy ty1 in - if deep_occur v ty then begin - match v.desc with - Tvar name when v.level = Btype.generic_level -> - v.desc <- Tunivar name; - v :: tyl - | _ -> - raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) - end else tyl) - [] new_univars - in - let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in - unify_var env (newvar()) ty'; - ctyp (Ttyp_poly (vars, cty)) ty' + add_typed_field sty.ptyp_loc l f) + fl; + Tinherit cty + in + let tfields = List.map add_field fields in + let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in + (match present with + | None -> () + | Some present -> + List.iter + (fun l -> + if not (List.mem_assoc l fields) then + raise (Error (styp.ptyp_loc, env, Present_has_no_type l))) + present); + let row = + { + row_fields = List.rev fields; + row_more = newvar (); + row_bound = (); + row_closed = closed = Closed; + row_fixed = false; + row_name = !name; + } + in + let static = Btype.static_row row in + let row = + if static then {row with row_more = newty Tnil} + else if policy <> Univars then row + else {row with row_more = new_pre_univar ()} + in + let ty = newty (Tvariant row) in + ctyp (Ttyp_variant (tfields, closed, present)) ty + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + begin_def (); + let new_univars = List.map (fun name -> (name, newvar ~name ())) vars in + let old_univars = !univars in + univars := new_univars @ !univars; + let cty = transl_type env policy st in + let ty = cty.ctyp_type in + univars := old_univars; + end_def (); + generalize ty; + let ty_list = + List.fold_left + (fun tyl (name, ty1) -> + let v = Btype.proxy ty1 in + if deep_occur v ty then + match v.desc with + | Tvar name when v.level = Btype.generic_level -> + v.desc <- Tunivar name; + v :: tyl + | _ -> raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) + else tyl) + [] new_univars + in + let ty' = Btype.newgenty (Tpoly (ty, List.rev ty_list)) in + unify_var env (newvar ()) ty'; + ctyp (Ttyp_poly (vars, cty)) ty' | Ptyp_package (p, l) -> - let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in - let z = narrow () in - let mty = !transl_modtype env mty in - widen z; - let ptys = List.map (fun (s, pty) -> - s, transl_type env policy pty - ) l in - let path = !transl_modtype_longident styp.ptyp_loc env p.txt in - let ty = newty (Tpackage (path, - List.map (fun (s, _pty) -> s.txt) l, - List.map (fun (_,cty) -> cty.ctyp_type) ptys)) - in - ctyp (Ttyp_package { - pack_path = path; - pack_type = mty.mty_type; - pack_fields = ptys; - pack_txt = p; - }) ty + let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in + let z = narrow () in + let mty = !transl_modtype env mty in + widen z; + let ptys = List.map (fun (s, pty) -> (s, transl_type env policy pty)) l in + let path = !transl_modtype_longident styp.ptyp_loc env p.txt in + let ty = + newty + (Tpackage + ( path, + List.map (fun (s, _pty) -> s.txt) l, + List.map (fun (_, cty) -> cty.ctyp_type) ptys )) + in + ctyp + (Ttyp_package + { + pack_path = path; + pack_type = mty.mty_type; + pack_fields = ptys; + pack_txt = p; + }) + ty | Ptyp_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) and transl_poly_type env policy t = transl_type env policy (Ast_helper.Typ.force_poly t) @@ -562,79 +585,86 @@ and transl_fields env policy o fields = let add_typed_field loc l ty = try let ty' = Hashtbl.find hfields l in - if equal env false [ty] [ty'] then () else + if equal env false [ty] [ty'] then () + else try unify env ty ty' with Unify _trace -> - raise(Error(loc, env, Method_mismatch (l, ty, ty'))) - with Not_found -> - Hashtbl.add hfields l ty in + raise (Error (loc, env, Method_mismatch (l, ty, ty'))) + with Not_found -> Hashtbl.add hfields l ty + in let add_field = function - | Otag (s, a, ty1) -> begin - let ty1 = - Builtin_attributes.warning_scope a - (fun () -> transl_poly_type env policy ty1) + | Otag (s, a, ty1) -> + let ty1 = + Builtin_attributes.warning_scope a (fun () -> + transl_poly_type env policy ty1) + in + let field = OTtag (s, a, ty1) in + add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; + field + | Oinherit sty -> ( + let cty = transl_type env policy sty in + let nm = + match repr cty.ctyp_type with + | {desc = Tconstr (p, _, _)} -> Some p + | _ -> None + in + let t = expand_head env cty.ctyp_type in + match (t, nm) with + | {desc = Tobject ({desc = (Tfield _ | Tnil) as tf}, _)}, _ -> + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add = function + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2.desc + | Tnil -> () + | _ -> assert false in - let field = OTtag (s, a, ty1) in - add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; - field - end - | Oinherit sty -> begin - let cty = transl_type env policy sty in - let nm = - match repr cty.ctyp_type with - {desc=Tconstr(p, _, _)} -> Some p - | _ -> None in - let t = expand_head env cty.ctyp_type in - match t, nm with - {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin - if opened_object t then - raise (Error (sty.ptyp_loc, env, Opened_object nm)); - let rec iter_add = function - | Tfield (s, _k, ty1, ty2) -> begin - add_typed_field sty.ptyp_loc s ty1; - iter_add ty2.desc - end - | Tnil -> () - | _ -> assert false in - iter_add tf; - OTinherit cty - end - | {desc=Tvar _}, Some p -> - raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) - | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) - end in + iter_add tf; + OTinherit cty + | {desc = Tvar _}, Some p -> + raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) + | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))) + in let object_fields = List.map add_field fields in let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in let ty_init = - match o, policy with - | Closed, _ -> newty Tnil - | Open, Univars -> new_pre_univar () - | Open, _ -> newvar () in - let ty = List.fold_left (fun ty (s, ty') -> - newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in - ty, object_fields - + match (o, policy) with + | Closed, _ -> newty Tnil + | Open, Univars -> new_pre_univar () + | Open, _ -> newvar () + in + let ty = + List.fold_left + (fun ty (s, ty') -> newty (Tfield (s, Fpresent, ty', ty))) + ty_init fields + in + (ty, object_fields) (* Make the rows "fixed" in this type, to make universal check easier *) let rec make_fixed_univars ty = let ty = repr ty in - if ty.level >= Btype.lowest_level then begin + if ty.level >= Btype.lowest_level then ( Btype.mark_type_node ty; match ty.desc with | Tvariant row -> - let row = Btype.row_repr row in - if Btype.is_Tunivar (Btype.row_more row) then - ty.desc <- Tvariant - {row with row_fixed=true; - row_fields = List.map - (fun (s,f as p) -> match Btype.row_field_repr f with - Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r) - | _ -> p) - row.row_fields}; - Btype.iter_row make_fixed_univars row - | _ -> - Btype.iter_type_expr make_fixed_univars ty - end + let row = Btype.row_repr row in + if Btype.is_Tunivar (Btype.row_more row) then + ty.desc <- + Tvariant + { + row with + row_fixed = true; + row_fields = + List.map + (fun ((s, f) as p) -> + match Btype.row_field_repr f with + | Reither (c, tl, _m, r) -> (s, Reither (c, tl, true, r)) + | _ -> p) + row.row_fields; + }; + Btype.iter_row make_fixed_univars row + | _ -> Btype.iter_type_expr make_fixed_univars ty) let make_fixed_univars ty = make_fixed_univars ty; @@ -648,33 +678,43 @@ let globalize_used_variables env fixed = (fun name (ty, loc) -> let v = new_global_var () in let snap = Btype.snapshot () in - if try unify env v ty; true with _ -> Btype.backtrack snap; false - then try - r := (loc, v, Tbl.find name !type_variables) :: !r - with Not_found -> - if fixed && Btype.is_Tvar (repr ty) then - raise(Error(loc, env, Unbound_type_variable ("'"^name))); - let v2 = new_global_var () in - r := (loc, v, v2) :: !r; - type_variables := Tbl.add name v2 !type_variables) + if + try + unify env v ty; + true + with _ -> + Btype.backtrack snap; + false + then ( + try r := (loc, v, Tbl.find name !type_variables) :: !r + with Not_found -> + if fixed && Btype.is_Tvar (repr ty) then + raise (Error (loc, env, Unbound_type_variable ("'" ^ name))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + type_variables := Tbl.add name v2 !type_variables)) !used_variables; used_variables := Tbl.empty; fun () -> List.iter - (function (loc, t1, t2) -> - try unify env t1 t2 with Unify trace -> - raise (Error(loc, env, Type_mismatch trace))) + (function + | loc, t1, t2 -> ( + try unify env t1 t2 + with Unify trace -> raise (Error (loc, env, Type_mismatch trace)))) !r let transl_simple_type env fixed styp = - univars := []; used_variables := Tbl.empty; + univars := []; + used_variables := Tbl.empty; let typ = transl_type env (if fixed then Fixed else Extensible) styp in globalize_used_variables env fixed (); make_fixed_univars typ.ctyp_type; typ let transl_simple_type_univars env styp = - univars := []; used_variables := Tbl.empty; pre_univars := []; + univars := []; + used_variables := Tbl.empty; + pre_univars := []; begin_def (); let typ = transl_type env Univars styp in (* Only keep already global variables in used_variables *) @@ -693,42 +733,45 @@ let transl_simple_type_univars env styp = (fun acc v -> let v = repr v in match v.desc with - Tvar name when v.level = Btype.generic_level -> - v.desc <- Tunivar name; v :: acc + | Tvar name when v.level = Btype.generic_level -> + v.desc <- Tunivar name; + v :: acc | _ -> acc) [] !pre_univars in make_fixed_univars typ.ctyp_type; - { typ with ctyp_type = - instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } + { + typ with + ctyp_type = instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))); + } let transl_simple_type_delayed env styp = - univars := []; used_variables := Tbl.empty; + univars := []; + used_variables := Tbl.empty; let typ = transl_type env Extensible styp in make_fixed_univars typ.ctyp_type; (typ, globalize_used_variables env false) let transl_type_scheme env styp = - reset_type_variables(); - begin_def(); + reset_type_variables (); + begin_def (); let typ = transl_simple_type env false styp in - end_def(); + end_def (); generalize typ.ctyp_type; typ - (* Error report *) open Format open Printtyp -let did_you_mean ppf choices : bool = +let did_you_mean ppf choices : bool = (* flush now to get the error report early, in the (unheard of) case where the linear search would take a bit of time; in the worst case, the user has seen the error, she can interrupt the process before the spell-checking terminates. *) - Format.fprintf ppf "@?"; - match choices () with + Format.fprintf ppf "@?"; + match choices () with | [] -> false | last :: rev_rest -> Format.fprintf ppf "@[@,@,@{Hint: Did you mean %s%s%s?@}@]" @@ -738,26 +781,25 @@ let did_you_mean ppf choices : bool = true let super_spellcheck ppf fold env lid = - let choices path name : string list = - let env : string list = fold (fun x _ _ xs -> x ::xs ) path env [] in - Misc.spellcheck env name in + let choices path name : string list = + let env : string list = fold (fun x _ _ xs -> x :: xs) path env [] in + Misc.spellcheck env name + in match lid with | Longident.Lapply _ -> false - | Longident.Lident s -> - did_you_mean ppf (fun _ -> choices None s) - | Longident.Ldot (r, s) -> - did_you_mean ppf (fun _ -> choices (Some r) s) + | Longident.Lident s -> did_you_mean ppf (fun _ -> choices None s) + | Longident.Ldot (r, s) -> did_you_mean ppf (fun _ -> choices (Some r) s) let spellcheck ppf fold env lid = let choices ~path name = - let env = fold (fun x xs -> x::xs) path env [] in - Misc.spellcheck env name in + let env = fold (fun x xs -> x :: xs) path env [] in + Misc.spellcheck env name + in match lid with - | Longident.Lapply _ -> () - | Longident.Lident s -> - Misc.did_you_mean ppf (fun () -> choices ~path:None s) - | Longident.Ldot (r, s) -> - Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + | Longident.Lapply _ -> () + | Longident.Lident s -> Misc.did_you_mean ppf (fun () -> choices ~path:None s) + | Longident.Ldot (r, s) -> + Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc) let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc) @@ -768,190 +810,179 @@ let fold_modtypes = fold_simple Env.fold_modtypes let report_error env ppf = function | Unbound_type_variable name -> - (* we don't use "spellcheck" here: the function that raises this - error seems not to be called anywhere, so it's unclear how it - should be handled *) + (* we don't use "spellcheck" here: the function that raises this + error seems not to be called anywhere, so it's unclear how it + should be handled *) fprintf ppf "Unbound type parameter %s@." name | Unbound_type_constructor lid -> (* modified *) - Format.fprintf ppf "@[This type constructor, `%a`, can't be found.@ " Printtyp.longident lid; + Format.fprintf ppf "@[This type constructor, `%a`, can't be found.@ " + Printtyp.longident lid; let has_candidate = super_spellcheck ppf Env.fold_types env lid in - if not has_candidate then - Format.fprintf ppf "If you wanted to write a recursive type, don't forget the `rec` in `type rec`@]" + if not has_candidate then + Format.fprintf ppf + "If you wanted to write a recursive type, don't forget the `rec` in \ + `type rec`@]" | Unbound_type_constructor_2 p -> - fprintf ppf "The type constructor@ %a@ is not yet completely defined" - path p - | Type_arity_mismatch(lid, expected, provided) -> - if expected==0 then + fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p + | Type_arity_mismatch (lid, expected, provided) -> + if expected == 0 then fprintf ppf - "@[The type %a is not generic so expects no arguments,@ \ - but is here applied to %i argument(s).@ \ - Have you tried removing the angular brackets `<` and `>` and the@ \ - arguments within them and just writing `%a` instead? @]" + "@[The type %a is not generic so expects no arguments,@ but is here \ + applied to %i argument(s).@ Have you tried removing the angular \ + brackets `<` and `>` and the@ arguments within them and just writing \ + `%a` instead? @]" longident lid provided longident lid - else + else fprintf ppf - "@[The type constructor %a@ expects %i argument(s),@ \ - but is here applied to %i argument(s)@]" + "@[The type constructor %a@ expects %i argument(s),@ but is here \ + applied to %i argument(s)@]" longident lid expected provided | Bound_type_variable name -> fprintf ppf "Already bound type parameter '%s" name - | Recursive_type -> - fprintf ppf "This type is recursive" + | Recursive_type -> fprintf ppf "This type is recursive" | Unbound_row_variable lid -> - (* we don't use "spellcheck" here: this error is not raised - anywhere so it's unclear how it should be handled *) - fprintf ppf "Unbound row variable in #%a" longident lid + (* we don't use "spellcheck" here: this error is not raised + anywhere so it's unclear how it should be handled *) + fprintf ppf "Unbound row variable in #%a" longident lid | Type_mismatch trace -> - Printtyp.report_unification_error ppf Env.empty trace - (function ppf -> - fprintf ppf "This type") - (function ppf -> - fprintf ppf "should be an instance of type") + Printtyp.report_unification_error ppf Env.empty trace + (function + | ppf -> fprintf ppf "This type") + (function + | ppf -> fprintf ppf "should be an instance of type") | Alias_type_mismatch trace -> - Printtyp.report_unification_error ppf Env.empty trace - (function ppf -> - fprintf ppf "This alias is bound to type") - (function ppf -> - fprintf ppf "but is used as an instance of type") + Printtyp.report_unification_error ppf Env.empty trace + (function + | ppf -> fprintf ppf "This alias is bound to type") + (function + | ppf -> fprintf ppf "but is used as an instance of type") | Present_has_conjunction l -> - fprintf ppf "The present constructor %s has a conjunctive type" l + fprintf ppf "The present constructor %s has a conjunctive type" l | Present_has_no_type l -> - fprintf ppf "The present constructor %s has no type" l + fprintf ppf "The present constructor %s has no type" l | Constructor_mismatch (ty, ty') -> - wrap_printing_env env (fun () -> + wrap_printing_env env (fun () -> Printtyp.reset_and_mark_loops_list [ty; ty']; fprintf ppf "@[%s %a@ %s@ %a@]" - "This variant type contains a constructor" - Printtyp.type_expr ty - "which should be" - Printtyp.type_expr ty') - | Not_a_variant ty -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf - "@[The type %a@ does not expand to a polymorphic variant type@]" - Printtyp.type_expr ty; - begin match ty.desc with - | Tvar (Some s) -> - (* PR#7012: help the user that wrote 'Foo instead of `Foo *) - Misc.did_you_mean ppf (fun () -> ["`" ^ s]) - | _ -> () - end + "This variant type contains a constructor" Printtyp.type_expr ty + "which should be" Printtyp.type_expr ty') + | Not_a_variant ty -> ( + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[The type %a@ does not expand to a polymorphic variant type@]" + Printtyp.type_expr ty; + match ty.desc with + | Tvar (Some s) -> + (* PR#7012: help the user that wrote 'Foo instead of `Foo *) + Misc.did_you_mean ppf (fun () -> ["`" ^ s]) + | _ -> ()) | Variant_tags (lab1, lab2) -> - fprintf ppf - "@[Variant tags %s@ and %s have the same hash value.@ %s@]" - (!Printtyp.print_res_poly_identifier lab1) (!Printtyp.print_res_poly_identifier lab2) "Change one of them." + fprintf ppf "@[Variant tags %s@ and %s have the same hash value.@ %s@]" + (!Printtyp.print_res_poly_identifier lab1) + (!Printtyp.print_res_poly_identifier lab2) + "Change one of them." | Invalid_variable_name name -> - fprintf ppf "The type variable name %s is not allowed in programs" name + fprintf ppf "The type variable name %s is not allowed in programs" name | Cannot_quantify (name, v) -> - fprintf ppf - "@[The universal type variable '%s cannot be generalized:@ %s.@]" - name - (if Btype.is_Tvar v then "it escapes its scope" else - if Btype.is_Tunivar v then "it is already bound to another variable" - else "it is not a variable") + fprintf ppf + "@[The universal type variable '%s cannot be generalized:@ %s.@]" + name + (if Btype.is_Tvar v then "it escapes its scope" + else if Btype.is_Tunivar v then "it is already bound to another variable" + else "it is not a variable") | Multiple_constraints_on_type s -> - fprintf ppf "Multiple constraints for type %a" longident s + fprintf ppf "Multiple constraints for type %a" longident s | Method_mismatch (l, ty, ty') -> - wrap_printing_env env (fun () -> + wrap_printing_env env (fun () -> Printtyp.reset_and_mark_loops_list [ty; ty']; - fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" - l Printtyp.type_expr ty Printtyp.type_expr ty') + fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" l + Printtyp.type_expr ty Printtyp.type_expr ty') | Unbound_value lid -> (* modified *) - begin - match lid with - | Ldot (outer, inner) -> - Format.fprintf ppf "The value %s can't be found in %a" - inner - Printtyp.longident outer; - | other_ident -> Format.fprintf ppf "The value %a can't be found" Printtyp.longident other_ident - end; + (match lid with + | Ldot (outer, inner) -> + Format.fprintf ppf "The value %s can't be found in %a" inner + Printtyp.longident outer + | other_ident -> + Format.fprintf ppf "The value %a can't be found" Printtyp.longident + other_ident); super_spellcheck ppf Env.fold_values env lid |> ignore | Unbound_module lid -> (* modified *) - begin match lid with - | Lident "Str" -> - begin - Format.fprintf ppf "@[\ - @{The module or file %a can't be found.@}@,@,\ - Are you trying to use the standard library's Str?@ \ - If you're compiling to JavaScript,@ use @{Js.Re@} instead.@ \ - Otherwise, add str.cma to your ocamlc/ocamlopt command.\ - @]" - Printtyp.longident lid - end - | lid -> - begin - Format.fprintf ppf "@[\ - @{The module or file %a can't be found.@}@,\ - @[- If it's a third-party dependency:@,\ - - Did you add it to the \"bs-dependencies\" or \"bs-dev-dependencies\" in bsconfig.json?@]@,\ - - Did you include the file's directory to the \"sources\" in bsconfig.json?@,\ - " - Printtyp.longident lid - end - end; + (match lid with + | Lident "Str" -> + Format.fprintf ppf + "@[@{The module or file %a can't be found.@}@,\ + @,\ + Are you trying to use the standard library's Str?@ If you're \ + compiling to JavaScript,@ use @{Js.Re@} instead.@ Otherwise, \ + add str.cma to your ocamlc/ocamlopt command.@]" + Printtyp.longident lid + | lid -> + Format.fprintf ppf + "@[@{The module or file %a can't be found.@}@,\ + @[- If it's a third-party dependency:@,\ + - Did you add it to the \"bs-dependencies\" or \ + \"bs-dev-dependencies\" in bsconfig.json?@]@,\ + - Did you include the file's directory to the \"sources\" in \ + bsconfig.json?@," + Printtyp.longident lid); super_spellcheck ppf Env.fold_modules env lid |> ignore | Unbound_constructor lid -> (* modified *) - Format.fprintf ppf "@[\ - @{The variant constructor %a can't be found.@}@,@,\ - @[- If it's defined in another module or file, bring it into scope by:@,\ - @[- Prefixing it with said module name:@ @{TheModule.%a@}@]@,\ - @[- Or specifying its type:@ @{let theValue: TheModule.theType = %a@}@]\ - @]@,\ - - @[Constructors and modules are both capitalized.@ Did you want the latter?@ Then instead of @{let foo = Bar@}, try @{module Foo = Bar@}.@]\ - @]" - Printtyp.longident lid - Printtyp.longident lid - Printtyp.longident lid; + Format.fprintf ppf + "@[@{The variant constructor %a can't be found.@}@,\ + @,\ + @[- If it's defined in another module or file, bring it into scope \ + by:@,\ + @[- Prefixing it with said module name:@ @{TheModule.%a@}@]@,\ + @[- Or specifying its type:@ @{let theValue: TheModule.theType = \ + %a@}@]@]@,\ + - @[Constructors and modules are both capitalized.@ Did you want the \ + latter?@ Then instead of @{let foo = Bar@}, try @{module Foo \ + = Bar@}.@]@]" + Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid; spellcheck ppf fold_constructors env lid | Unbound_label lid -> (* modified *) - Format.fprintf ppf "@[\ - @{%a@} refers to a record field, but no corresponding record type is in scope.@,@,\ - If it's defined in another module or file, bring it into scope by:@,\ - @[- Prefixing the field name with the module name:@ @{TheModule.%a@}@]@,\ - @[- Or specifying the record type explicitly:@ @{let theValue: TheModule.theType = {%a: VALUE}@}@]\ - @]" - Printtyp.longident lid - Printtyp.longident lid - Printtyp.longident lid; - spellcheck ppf fold_labels env lid; + Format.fprintf ppf + "@[@{%a@} refers to a record field, but no corresponding record \ + type is in scope.@,\ + @,\ + If it's defined in another module or file, bring it into scope by:@,\ + @[- Prefixing the field name with the module name:@ \ + @{TheModule.%a@}@]@,\ + @[- Or specifying the record type explicitly:@ @{let theValue: \ + TheModule.theType = {%a: VALUE}@}@]@]" + Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid; + spellcheck ppf fold_labels env lid | Unbound_modtype lid -> - fprintf ppf "Unbound module type %a" longident lid; - spellcheck ppf fold_modtypes env lid; + fprintf ppf "Unbound module type %a" longident lid; + spellcheck ppf fold_modtypes env lid | Ill_typed_functor_application lid -> - fprintf ppf "Ill-typed functor application %a" longident lid + fprintf ppf "Ill-typed functor application %a" longident lid | Illegal_reference_to_recursive_module -> - fprintf ppf "Illegal recursive module reference" + fprintf ppf "Illegal recursive module reference" | Access_functor_as_structure lid -> - fprintf ppf "The module %a is a functor, not a structure" longident lid + fprintf ppf "The module %a is a functor, not a structure" longident lid | Apply_structure_as_functor lid -> - fprintf ppf "The module %a is a structure, not a functor" longident lid - | Cannot_scrape_alias(lid, p) -> - fprintf ppf - "The module %a is an alias for module %a, which is missing" - longident lid path p + fprintf ppf "The module %a is a structure, not a functor" longident lid + | Cannot_scrape_alias (lid, p) -> + fprintf ppf "The module %a is an alias for module %a, which is missing" + longident lid path p | Opened_object nm -> - fprintf ppf - "Illegal open object type%a" - (fun ppf -> function - Some p -> fprintf ppf "@ %a" path p - | None -> fprintf ppf "") nm + fprintf ppf "Illegal open object type%a" + (fun ppf -> function + | Some p -> fprintf ppf "@ %a" path p + | None -> fprintf ppf "") + nm | Not_an_object ty -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[The type %a@ is not an object type@]" - Printtyp.type_expr ty + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[The type %a@ is not an object type@]" Printtyp.type_expr ty let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) + Location.register_error_of_exn (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> Some err + | _ -> None) diff --git a/compiler/ml/typetexp.mli b/compiler/ml/typetexp.mli index 6b60749dc8..be9a9302cd 100644 --- a/compiler/ml/typetexp.mli +++ b/compiler/ml/typetexp.mli @@ -17,29 +17,28 @@ open Types -val transl_simple_type: - Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type -val transl_simple_type_univars: - Env.t -> Parsetree.core_type -> Typedtree.core_type -val transl_simple_type_delayed: - Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) - (* Translate a type, but leave type variables unbound. Returns - the type and a function that binds the type variable. *) -val transl_type_scheme: - Env.t -> Parsetree.core_type -> Typedtree.core_type -val reset_type_variables: unit -> unit -val type_variable: Location.t -> string -> type_expr -val transl_type_param: +val transl_simple_type : + Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_univars : Env.t -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_delayed : + Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) +(* Translate a type, but leave type variables unbound. Returns + the type and a function that binds the type variable. *) + +val transl_type_scheme : Env.t -> Parsetree.core_type -> Typedtree.core_type +val reset_type_variables : unit -> unit +val type_variable : Location.t -> string -> type_expr +val transl_type_param : Env.t -> Parsetree.core_type -> Typedtree.core_type type variable_context -val narrow: unit -> variable_context -val widen: variable_context -> unit +val narrow : unit -> variable_context +val widen : variable_context -> unit exception Already_bound type error = - Unbound_type_variable of string + | Unbound_type_variable of string | Unbound_type_constructor of Longident.t | Unbound_type_constructor_2 of Path.t | Type_arity_mismatch of Longident.t * int * int @@ -72,45 +71,53 @@ type error = exception Error of Location.t * Env.t * error -val report_error: Env.t -> Format.formatter -> error -> unit +val report_error : Env.t -> Format.formatter -> error -> unit (* Support for first-class modules. *) -val transl_modtype_longident: (* from Typemod *) - (Location.t -> Env.t -> Longident.t -> Path.t) ref -val transl_modtype: (* from Typemod *) - (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref -val create_package_mty: - Location.t -> Env.t -> Parsetree.package_type -> - (Longident.t Asttypes.loc * Parsetree.core_type) list * - Parsetree.module_type - -val find_type: - Env.t -> Location.t -> Longident.t -> Path.t * type_declaration -val find_constructor: - Env.t -> Location.t -> Longident.t -> constructor_description -val find_all_constructors: - Env.t -> Location.t -> Longident.t -> - (constructor_description * (unit -> unit)) list -val find_label: - Env.t -> Location.t -> Longident.t -> label_description -val find_all_labels: - Env.t -> Location.t -> Longident.t -> - (label_description * (unit -> unit)) list -val find_value: - Env.t -> Location.t -> Longident.t -> Path.t * value_description -val find_module: - Env.t -> Location.t -> Longident.t -> Path.t * module_declaration -val lookup_module: - ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t -val find_modtype: - Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration +val transl_modtype_longident : + (* from Typemod *) + (Location.t -> Env.t -> Longident.t -> Path.t) ref +val transl_modtype : + (* from Typemod *) + (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref +val create_package_mty : + Location.t -> + Env.t -> + Parsetree.package_type -> + (Longident.t Asttypes.loc * Parsetree.core_type) list * Parsetree.module_type -val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a -val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a +val find_type : Env.t -> Location.t -> Longident.t -> Path.t * type_declaration +val find_constructor : + Env.t -> Location.t -> Longident.t -> constructor_description +val find_all_constructors : + Env.t -> + Location.t -> + Longident.t -> + (constructor_description * (unit -> unit)) list +val find_label : Env.t -> Location.t -> Longident.t -> label_description +val find_all_labels : + Env.t -> + Location.t -> + Longident.t -> + (label_description * (unit -> unit)) list +val find_value : + Env.t -> Location.t -> Longident.t -> Path.t * value_description +val find_module : + Env.t -> Location.t -> Longident.t -> Path.t * module_declaration +val lookup_module : ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t +val find_modtype : + Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration +val unbound_constructor_error : Env.t -> Longident.t Location.loc -> 'a +val unbound_label_error : Env.t -> Longident.t Location.loc -> 'a -val spellcheck: +val spellcheck : Format.formatter -> (('a -> 'a list -> 'a list) -> - Longident.t option -> 'b -> 'c list -> string list) -> - 'b -> Longident.t -> unit + Longident.t option -> + 'b -> + 'c list -> + string list) -> + 'b -> + Longident.t -> + unit diff --git a/compiler/ml/untypeast.ml b/compiler/ml/untypeast.ml index 74fb0d1dba..8684240afb 100644 --- a/compiler/ml/untypeast.ml +++ b/compiler/ml/untypeast.ml @@ -25,11 +25,11 @@ type mapper = { attributes: mapper -> T.attribute list -> attribute list; case: mapper -> T.case -> case; cases: mapper -> T.case list -> case list; - constructor_declaration: mapper -> T.constructor_declaration - -> constructor_declaration; + constructor_declaration: + mapper -> T.constructor_declaration -> constructor_declaration; expr: mapper -> T.expression -> expression; - extension_constructor: mapper -> T.extension_constructor - -> extension_constructor; + extension_constructor: + mapper -> T.extension_constructor -> extension_constructor; include_declaration: mapper -> T.include_declaration -> include_declaration; include_description: mapper -> T.include_description -> include_description; label_declaration: mapper -> T.label_declaration -> label_declaration; @@ -56,8 +56,9 @@ type mapper = { value_binding: mapper -> T.value_binding -> value_binding; value_description: mapper -> T.value_description -> value_description; with_constraint: - mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) - -> with_constraint; + mapper -> + Path.t * Longident.t Location.loc * T.with_constraint -> + with_constraint; } open T @@ -75,17 +76,17 @@ Some notes: *) - (** Utility functions. *) - -let map_opt f = function None -> None | Some e -> Some (f e) +let map_opt f = function + | None -> None + | Some e -> Some (f e) let rec lident_of_path = function | Path.Pident id -> Longident.Lident (Ident.name id) | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) + Longident.Lapply (lident_of_path p1, lident_of_path p2) let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} @@ -96,8 +97,7 @@ let fresh_name s env = try let _ = Env.lookup_value (Lident name) env in name - with - | Not_found -> aux (i+1) + with Not_found -> aux (i + 1) in aux 0 @@ -105,75 +105,58 @@ let fresh_name s env = let constant = function | Const_char c -> Pconst_char c - | Const_string (s,d) -> Pconst_string (s,d) + | Const_string (s, d) -> Pconst_string (s, d) | Const_int i -> Pconst_integer (string_of_int i, None) | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') - | Const_bigint (sign, i) -> + | Const_bigint (sign, i) -> Pconst_integer (Bigint_utils.to_string sign i, Some 'n') - | Const_float f -> Pconst_float (f,None) + | Const_float f -> Pconst_float (f, None) let attribute sub (s, p) = (map_loc sub s, p) let attributes sub l = List.map (sub.attribute sub) l -let structure sub str = - List.map (sub.structure_item sub) str.str_items +let structure sub str = List.map (sub.structure_item sub) str.str_items let open_description sub od = let loc = sub.location sub od.open_loc in let attrs = sub.attributes sub od.open_attributes in - Opn.mk ~loc ~attrs - ~override:od.open_override - (map_loc sub od.open_txt) + Opn.mk ~loc ~attrs ~override:od.open_override (map_loc sub od.open_txt) let structure_item sub item = let loc = sub.location sub item.str_loc in let desc = match item.str_desc with - Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) + | Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) | Tstr_value (rec_flag, list) -> - Pstr_value (rec_flag, List.map (sub.value_binding sub) list) - | Tstr_primitive vd -> - Pstr_primitive (sub.value_description sub vd) + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) + | Tstr_primitive vd -> Pstr_primitive (sub.value_description sub vd) | Tstr_type (rec_flag, list) -> - Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) - | Tstr_typext tyext -> - Pstr_typext (sub.type_extension sub tyext) - | Tstr_exception ext -> - Pstr_exception (sub.extension_constructor sub ext) - | Tstr_module mb -> - Pstr_module (sub.module_binding sub mb) + Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tstr_typext tyext -> Pstr_typext (sub.type_extension sub tyext) + | Tstr_exception ext -> Pstr_exception (sub.extension_constructor sub ext) + | Tstr_module mb -> Pstr_module (sub.module_binding sub mb) | Tstr_recmodule list -> - Pstr_recmodule (List.map (sub.module_binding sub) list) - | Tstr_modtype mtd -> - Pstr_modtype (sub.module_type_declaration sub mtd) - | Tstr_open od -> - Pstr_open (sub.open_description sub od) - | Tstr_class () -> - Pstr_class () - | Tstr_class_type () -> - Pstr_class_type () - | Tstr_include incl -> - Pstr_include (sub.include_declaration sub incl) - | Tstr_attribute x -> - Pstr_attribute x + Pstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype mtd -> Pstr_modtype (sub.module_type_declaration sub mtd) + | Tstr_open od -> Pstr_open (sub.open_description sub od) + | Tstr_class () -> Pstr_class () + | Tstr_class_type () -> Pstr_class_type () + | Tstr_include incl -> Pstr_include (sub.include_declaration sub incl) + | Tstr_attribute x -> Pstr_attribute x in Str.mk ~loc desc let value_description sub v = let loc = sub.location sub v.val_loc in let attrs = sub.attributes sub v.val_attributes in - Val.mk ~loc ~attrs - ~prim:v.val_prim - (map_loc sub v.val_name) + Val.mk ~loc ~attrs ~prim:v.val_prim (map_loc sub v.val_name) (sub.typ sub v.val_desc) let module_binding sub mb = let loc = sub.location sub mb.mb_loc in let attrs = sub.attributes sub mb.mb_attributes in - Mb.mk ~loc ~attrs - (map_loc sub mb.mb_name) - (sub.module_expr sub mb.mb_expr) + Mb.mk ~loc ~attrs (map_loc sub mb.mb_name) (sub.module_expr sub mb.mb_expr) let type_parameter sub (ct, v) = (sub.typ sub ct, v) @@ -182,27 +165,28 @@ let type_declaration sub decl = let attrs = sub.attributes sub decl.typ_attributes in Type.mk ~loc ~attrs ~params:(List.map (type_parameter sub) decl.typ_params) - ~cstrs:( - List.map - (fun (ct1, ct2, loc) -> + ~cstrs: + (List.map + (fun (ct1, ct2, loc) -> (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) - decl.typ_cstrs) + decl.typ_cstrs) ~kind:(sub.type_kind sub decl.typ_kind) ~priv:decl.typ_private ?manifest:(map_opt (sub.typ sub) decl.typ_manifest) (map_loc sub decl.typ_name) -let type_kind sub tk = match tk with +let type_kind sub tk = + match tk with | Ttype_abstract -> Ptype_abstract | Ttype_variant list -> - Ptype_variant (List.map (sub.constructor_declaration sub) list) + Ptype_variant (List.map (sub.constructor_declaration sub) list) | Ttype_record list -> - Ptype_record (List.map (sub.label_declaration sub) list) + Ptype_record (List.map (sub.label_declaration sub) list) | Ttype_open -> Ptype_open let constructor_arguments sub = function - | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) + | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) let constructor_declaration sub cd = let loc = sub.location sub cd.cd_loc in @@ -215,9 +199,7 @@ let constructor_declaration sub cd = let label_declaration sub ld = let loc = sub.location sub ld.ld_loc in let attrs = sub.attributes sub ld.ld_attributes in - Type.field ~loc ~attrs - ~mut:ld.ld_mutable - (map_loc sub ld.ld_name) + Type.field ~loc ~attrs ~mut:ld.ld_mutable (map_loc sub ld.ld_name) (sub.typ sub ld.ld_type) let type_extension sub tyext = @@ -231,72 +213,60 @@ let type_extension sub tyext = let extension_constructor sub ext = let loc = sub.location sub ext.ext_loc in let attrs = sub.attributes sub ext.ext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub ext.ext_name) + Te.constructor ~loc ~attrs (map_loc sub ext.ext_name) (match ext.ext_kind with - | Text_decl (args, ret) -> - Pext_decl (constructor_arguments sub args, - map_opt (sub.typ sub) ret) - | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) - ) + | Text_decl (args, ret) -> + Pext_decl (constructor_arguments sub args, map_opt (sub.typ sub) ret) + | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)) let pattern sub pat = let loc = sub.location sub pat.pat_loc in (* todo: fix attributes on extras *) let attrs = sub.attributes sub pat.pat_attributes in let desc = - match pat with - { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> - Ppat_unpack name - | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> - Ppat_type (map_loc sub lid) - | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> - Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, - sub.typ sub ct) - | _ -> - match pat.pat_desc with - Tpat_any -> Ppat_any - | Tpat_var (id, name) -> - begin - match (Ident.name id).[0] with - 'A'..'Z' -> - Ppat_unpack name - | _ -> - Ppat_var name - end - - (* We transform (_ as x) in x if _ and x have the same location. - The compiler transforms (x:t) into (_ as x : t). - This avoids transforming a warning 27 into a 26. - *) - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) - when pat_loc = pat.pat_loc -> - Ppat_var name - - | Tpat_alias (pat, _id, name) -> - Ppat_alias (sub.pat sub pat, name) - | Tpat_constant cst -> Ppat_constant (constant cst) - | Tpat_tuple list -> - Ppat_tuple (List.map (sub.pat sub) list) - | Tpat_construct (lid, _, args) -> - Ppat_construct (map_loc sub lid, - (match args with - [] -> None + match pat with + | {pat_extra = [(Tpat_unpack, _, _attrs)]; pat_desc = Tpat_var (_, name); _} + -> + Ppat_unpack name + | {pat_extra = [(Tpat_type (_path, lid), _, _attrs)]; _} -> + Ppat_type (map_loc sub lid) + | {pat_extra = (Tpat_constraint ct, _, _attrs) :: rem; _} -> + Ppat_constraint (sub.pat sub {pat with pat_extra = rem}, sub.typ sub ct) + | _ -> ( + match pat.pat_desc with + | Tpat_any -> Ppat_any + | Tpat_var (id, name) -> ( + match (Ident.name id).[0] with + | 'A' .. 'Z' -> Ppat_unpack name + | _ -> Ppat_var name) + (* We transform (_ as x) in x if _ and x have the same location. + The compiler transforms (x:t) into (_ as x : t). + This avoids transforming a warning 27 into a 26. + *) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) + when pat_loc = pat.pat_loc -> + Ppat_var name + | Tpat_alias (pat, _id, name) -> Ppat_alias (sub.pat sub pat, name) + | Tpat_constant cst -> Ppat_constant (constant cst) + | Tpat_tuple list -> Ppat_tuple (List.map (sub.pat sub) list) + | Tpat_construct (lid, _, args) -> + Ppat_construct + ( map_loc sub lid, + match args with + | [] -> None | [arg] -> Some (sub.pat sub arg) - | args -> - Some - (Pat.tuple ~loc - (List.map (sub.pat sub) args) - ) - )) - | Tpat_variant (label, pato, _) -> + | args -> Some (Pat.tuple ~loc (List.map (sub.pat sub) args)) ) + | Tpat_variant (label, pato, _) -> Ppat_variant (label, map_opt (sub.pat sub) pato) - | Tpat_record (list, closed) -> - Ppat_record (List.map (fun (lid, _, pat) -> - map_loc sub lid, sub.pat sub pat) list, closed) - | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) - | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) - | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) + | Tpat_record (list, closed) -> + Ppat_record + ( List.map + (fun (lid, _, pat) -> (map_loc sub lid, sub.pat sub pat)) + list, + closed ) + | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) + | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) + | Tpat_lazy p -> Ppat_lazy (sub.pat sub p)) in Pat.mk ~loc ~attrs desc @@ -305,14 +275,9 @@ let exp_extra sub (extra, loc, attrs) sexp = let attrs = sub.attributes sub attrs in let desc = match extra with - Texp_coerce ((), cty2) -> - Pexp_coerce (sexp, - (), - sub.typ sub cty2) - | Texp_constraint cty -> - Pexp_constraint (sexp, sub.typ sub cty) - | Texp_open (ovf, _path, lid, _) -> - Pexp_open (ovf, map_loc sub lid, sexp) + | Texp_coerce ((), cty2) -> Pexp_coerce (sexp, (), sub.typ sub cty2) + | Texp_constraint cty -> Pexp_constraint (sexp, sub.typ sub cty) + | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, map_loc sub lid, sexp) | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) in @@ -322,140 +287,126 @@ let cases sub l = List.map (sub.case sub) l let case sub {c_lhs; c_guard; c_rhs} = { - pc_lhs = sub.pat sub c_lhs; - pc_guard = map_opt (sub.expr sub) c_guard; - pc_rhs = sub.expr sub c_rhs; + pc_lhs = sub.pat sub c_lhs; + pc_guard = map_opt (sub.expr sub) c_guard; + pc_rhs = sub.expr sub c_rhs; } let value_binding sub vb = let loc = sub.location sub vb.vb_loc in let attrs = sub.attributes sub vb.vb_attributes in - Vb.mk ~loc ~attrs - (sub.pat sub vb.vb_pat) - (sub.expr sub vb.vb_expr) + Vb.mk ~loc ~attrs (sub.pat sub vb.vb_pat) (sub.expr sub vb.vb_expr) let expression sub exp = let loc = sub.location sub exp.exp_loc in let attrs = sub.attributes sub exp.exp_attributes in let desc = match exp.exp_desc with - Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) + | Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) | Texp_constant cst -> Pexp_constant (constant cst) | Texp_let (rec_flag, list, exp) -> - Pexp_let (rec_flag, - List.map (sub.value_binding sub) list, - sub.expr sub exp) - + Pexp_let + (rec_flag, List.map (sub.value_binding sub) list, sub.expr sub exp) (* Pexp_function can't have a label, so we split in 3 cases. *) (* One case, no guard: It's a fun. *) - | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; - _ } -> - Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) + | Texp_function + {arg_label; cases = [{c_lhs = p; c_guard = None; c_rhs = e}]; _} -> + Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) (* No label: it's a function. *) - | Texp_function { arg_label = Nolabel; cases; _; } -> - Pexp_function (sub.cases sub cases) + | Texp_function {arg_label = Nolabel; cases; _} -> + Pexp_function (sub.cases sub cases) (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) - | Texp_function { arg_label = Labelled s | Optional s as label; cases; - _ } -> - let name = fresh_name s exp.exp_env in - Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, - Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) - (sub.cases sub cases)) + | Texp_function {arg_label = (Labelled s | Optional s) as label; cases; _} + -> + let name = fresh_name s exp.exp_env in + Pexp_fun + ( label, + None, + Pat.var ~loc {loc; txt = name}, + Exp.match_ ~loc + (Exp.ident ~loc {loc; txt = Lident name}) + (sub.cases sub cases) ) | Texp_apply (exp, list) -> - Pexp_apply (sub.expr sub exp, - List.fold_right (fun (label, expo) list -> + Pexp_apply + ( sub.expr sub exp, + List.fold_right + (fun (label, expo) list -> match expo with - None -> list - | Some exp -> (label, sub.expr sub exp) :: list - ) list []) + | None -> list + | Some exp -> (label, sub.expr sub exp) :: list) + list [] ) | Texp_match (exp, cases, exn_cases, _) -> - let merged_cases = sub.cases sub cases + let merged_cases = + sub.cases sub cases @ List.map - (fun c -> - let uc = sub.case sub c in - let pat = { uc.pc_lhs - with ppat_desc = Ppat_exception uc.pc_lhs } - in - { uc with pc_lhs = pat }) - exn_cases + (fun c -> + let uc = sub.case sub c in + let pat = {uc.pc_lhs with ppat_desc = Ppat_exception uc.pc_lhs} in + {uc with pc_lhs = pat}) + exn_cases in Pexp_match (sub.expr sub exp, merged_cases) - | Texp_try (exp, cases) -> - Pexp_try (sub.expr sub exp, sub.cases sub cases) - | Texp_tuple list -> - Pexp_tuple (List.map (sub.expr sub) list) + | Texp_try (exp, cases) -> Pexp_try (sub.expr sub exp, sub.cases sub cases) + | Texp_tuple list -> Pexp_tuple (List.map (sub.expr sub) list) | Texp_construct (lid, _, args) -> - Pexp_construct (map_loc sub lid, - (match args with - [] -> None - | [ arg ] -> Some (sub.expr sub arg) - | args -> - Some - (Exp.tuple ~loc (List.map (sub.expr sub) args)) - )) + Pexp_construct + ( map_loc sub lid, + match args with + | [] -> None + | [arg] -> Some (sub.expr sub arg) + | args -> Some (Exp.tuple ~loc (List.map (sub.expr sub) args)) ) | Texp_variant (label, expo) -> - Pexp_variant (label, map_opt (sub.expr sub) expo) - | Texp_record { fields; extended_expression; _ } -> - let list = Array.fold_left (fun l -> function + Pexp_variant (label, map_opt (sub.expr sub) expo) + | Texp_record {fields; extended_expression; _} -> + let list = + Array.fold_left + (fun l -> function | _, Kept _ -> l | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) - [] fields - in - Pexp_record (list, map_opt (sub.expr sub) extended_expression) + [] fields + in + Pexp_record (list, map_opt (sub.expr sub) extended_expression) | Texp_field (exp, lid, _label) -> - Pexp_field (sub.expr sub exp, map_loc sub lid) + Pexp_field (sub.expr sub exp, map_loc sub lid) | Texp_setfield (exp1, lid, _label, exp2) -> - Pexp_setfield (sub.expr sub exp1, map_loc sub lid, - sub.expr sub exp2) - | Texp_array list -> - Pexp_array (List.map (sub.expr sub) list) + Pexp_setfield (sub.expr sub exp1, map_loc sub lid, sub.expr sub exp2) + | Texp_array list -> Pexp_array (List.map (sub.expr sub) list) | Texp_ifthenelse (exp1, exp2, expo) -> - Pexp_ifthenelse (sub.expr sub exp1, - sub.expr sub exp2, - map_opt (sub.expr sub) expo) + Pexp_ifthenelse + (sub.expr sub exp1, sub.expr sub exp2, map_opt (sub.expr sub) expo) | Texp_sequence (exp1, exp2) -> - Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) + Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) | Texp_while (exp1, exp2) -> - Pexp_while (sub.expr sub exp1, sub.expr sub exp2) + Pexp_while (sub.expr sub exp1, sub.expr sub exp2) | Texp_for (_id, name, exp1, exp2, dir, exp3) -> - Pexp_for (name, - sub.expr sub exp1, sub.expr sub exp2, - dir, sub.expr sub exp3) + Pexp_for + (name, sub.expr sub exp1, sub.expr sub exp2, dir, sub.expr sub exp3) | Texp_send (exp, meth, _) -> - Pexp_send (sub.expr sub exp, match meth with - Tmeth_name name -> mkloc name loc) - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> - assert false + Pexp_send + ( sub.expr sub exp, + match meth with + | Tmeth_name name -> mkloc name loc ) + | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ -> + assert false | Texp_letmodule (_id, name, mexpr, exp) -> - Pexp_letmodule (name, sub.module_expr sub mexpr, - sub.expr sub exp) + Pexp_letmodule (name, sub.module_expr sub mexpr, sub.expr sub exp) | Texp_letexception (ext, exp) -> - Pexp_letexception (sub.extension_constructor sub ext, - sub.expr sub exp) + Pexp_letexception (sub.extension_constructor sub ext, sub.expr sub exp) | Texp_assert exp -> Pexp_assert (sub.expr sub exp) | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) - | Texp_object () -> - assert false - | Texp_pack (mexpr) -> - Pexp_pack (sub.module_expr sub mexpr) - | Texp_unreachable -> - Pexp_unreachable + | Texp_object () -> assert false + | Texp_pack mexpr -> Pexp_pack (sub.module_expr sub mexpr) + | Texp_unreachable -> Pexp_unreachable | Texp_extension_constructor (lid, _) -> - Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, - PStr [ Str.eval ~loc - (Exp.construct ~loc (map_loc sub lid) None) - ]) + Pexp_extension + ( {txt = "ocaml.extension_constructor"; loc}, + PStr [Str.eval ~loc (Exp.construct ~loc (map_loc sub lid) None)] ) in - List.fold_right (exp_extra sub) exp.exp_extra - (Exp.mk ~loc ~attrs desc) + List.fold_right (exp_extra sub) exp.exp_extra (Exp.mk ~loc ~attrs desc) let package_type sub pack = - (map_loc sub pack.pack_txt, - List.map (fun (s, ct) -> - (s, sub.typ sub ct)) pack.pack_fields) + ( map_loc sub pack.pack_txt, + List.map (fun (s, ct) -> (s, sub.typ sub ct)) pack.pack_fields ) let module_type_declaration sub mtd = let loc = sub.location sub mtd.mtd_loc in @@ -464,52 +415,38 @@ let module_type_declaration sub mtd = ?typ:(map_opt (sub.module_type sub) mtd.mtd_type) (map_loc sub mtd.mtd_name) -let signature sub sg = - List.map (sub.signature_item sub) sg.sig_items +let signature sub sg = List.map (sub.signature_item sub) sg.sig_items let signature_item sub item = let loc = sub.location sub item.sig_loc in let desc = match item.sig_desc with - Tsig_value v -> - Psig_value (sub.value_description sub v) + | Tsig_value v -> Psig_value (sub.value_description sub v) | Tsig_type (rec_flag, list) -> - Psig_type (rec_flag, List.map (sub.type_declaration sub) list) - | Tsig_typext tyext -> - Psig_typext (sub.type_extension sub tyext) - | Tsig_exception ext -> - Psig_exception (sub.extension_constructor sub ext) - | Tsig_module md -> - Psig_module (sub.module_declaration sub md) + Psig_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tsig_typext tyext -> Psig_typext (sub.type_extension sub tyext) + | Tsig_exception ext -> Psig_exception (sub.extension_constructor sub ext) + | Tsig_module md -> Psig_module (sub.module_declaration sub md) | Tsig_recmodule list -> - Psig_recmodule (List.map (sub.module_declaration sub) list) - | Tsig_modtype mtd -> - Psig_modtype (sub.module_type_declaration sub mtd) - | Tsig_open od -> - Psig_open (sub.open_description sub od) - | Tsig_include incl -> - Psig_include (sub.include_description sub incl) - | Tsig_class () -> - Psig_class () - | Tsig_class_type () -> - Psig_class_type () - | Tsig_attribute x -> - Psig_attribute x + Psig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype mtd -> Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_open od -> Psig_open (sub.open_description sub od) + | Tsig_include incl -> Psig_include (sub.include_description sub incl) + | Tsig_class () -> Psig_class () + | Tsig_class_type () -> Psig_class_type () + | Tsig_attribute x -> Psig_attribute x in Sig.mk ~loc desc let module_declaration sub md = let loc = sub.location sub md.md_loc in let attrs = sub.attributes sub md.md_attributes in - Md.mk ~loc ~attrs - (map_loc sub md.md_name) - (sub.module_type sub md.md_type) + Md.mk ~loc ~attrs (map_loc sub md.md_name) (sub.module_type sub md.md_type) let include_infos f sub incl = let loc = sub.location sub incl.incl_loc in let attrs = sub.attributes sub incl.incl_attributes in - Incl.mk ~loc ~attrs - (f sub incl.incl_mod) + Incl.mk ~loc ~attrs (f sub incl.incl_mod) let include_declaration sub = include_infos sub.module_expr sub let include_description sub = include_infos sub.module_type sub @@ -517,142 +454,134 @@ let include_description sub = include_infos sub.module_type sub let module_type sub mty = let loc = sub.location sub mty.mty_loc in let attrs = sub.attributes sub mty.mty_attributes in - let desc = match mty.mty_desc with - Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) + let desc = + match mty.mty_desc with + | Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) | Tmty_functor (_id, name, mtype1, mtype2) -> - Pmty_functor (name, map_opt (sub.module_type sub) mtype1, - sub.module_type sub mtype2) + Pmty_functor + (name, map_opt (sub.module_type sub) mtype1, sub.module_type sub mtype2) | Tmty_with (mtype, list) -> - Pmty_with (sub.module_type sub mtype, - List.map (sub.with_constraint sub) list) - | Tmty_typeof mexpr -> - Pmty_typeof (sub.module_expr sub mexpr) + Pmty_with + (sub.module_type sub mtype, List.map (sub.with_constraint sub) list) + | Tmty_typeof mexpr -> Pmty_typeof (sub.module_expr sub mexpr) in Mty.mk ~loc ~attrs desc let with_constraint sub (_path, lid, cstr) = match cstr with | Twith_type decl -> - Pwith_type (map_loc sub lid, sub.type_declaration sub decl) + Pwith_type (map_loc sub lid, sub.type_declaration sub decl) | Twith_module (_path, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) + Pwith_module (map_loc sub lid, map_loc sub lid2) | Twith_typesubst decl -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) | Twith_modsubst (_path, lid2) -> - Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) let module_expr sub mexpr = let loc = sub.location sub mexpr.mod_loc in let attrs = sub.attributes sub mexpr.mod_attributes in match mexpr.mod_desc with - Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> - sub.module_expr sub m - | _ -> - let desc = match mexpr.mod_desc with - Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) - | Tmod_structure st -> Pmod_structure (sub.structure sub st) - | Tmod_functor (_id, name, mtype, mexpr) -> - Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype, - sub.module_expr sub mexpr) - | Tmod_apply (mexp1, mexp2, _) -> - Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - Pmod_constraint (sub.module_expr sub mexpr, - sub.module_type sub mtype) - | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> - assert false - | Tmod_unpack (exp, _pack) -> - Pmod_unpack (sub.expr sub exp) - (* TODO , sub.package_type sub pack) *) - in - Mod.mk ~loc ~attrs desc - + | Tmod_constraint (m, _, Tmodtype_implicit, _) -> sub.module_expr sub m + | _ -> + let desc = + match mexpr.mod_desc with + | Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) + | Tmod_structure st -> Pmod_structure (sub.structure sub st) + | Tmod_functor (_id, name, mtype, mexpr) -> + Pmod_functor + ( name, + Misc.may_map (sub.module_type sub) mtype, + sub.module_expr sub mexpr ) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (sub.module_expr sub mexpr, sub.module_type sub mtype) + | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> assert false + | Tmod_unpack (exp, _pack) -> Pmod_unpack (sub.expr sub exp) + (* TODO , sub.package_type sub pack) *) + in + Mod.mk ~loc ~attrs desc let core_type sub ct = let loc = sub.location sub ct.ctyp_loc in let attrs = sub.attributes sub ct.ctyp_attributes in - let desc = match ct.ctyp_desc with - Ttyp_any -> Ptyp_any + let desc = + match ct.ctyp_desc with + | Ttyp_any -> Ptyp_any | Ttyp_var s -> Ptyp_var s | Ttyp_arrow (label, ct1, ct2) -> - Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) | Ttyp_constr (_path, lid, list) -> - Ptyp_constr (map_loc sub lid, - List.map (sub.typ sub) list) + Ptyp_constr (map_loc sub lid, List.map (sub.typ sub) list) | Ttyp_object (list, o) -> - Ptyp_object - (List.map (sub.object_field sub) list, o) - | Ttyp_class () -> - Ptyp_class () - | Ttyp_alias (ct, s) -> - Ptyp_alias (sub.typ sub ct, s) + Ptyp_object (List.map (sub.object_field sub) list, o) + | Ttyp_class () -> Ptyp_class () + | Ttyp_alias (ct, s) -> Ptyp_alias (sub.typ sub ct, s) | Ttyp_variant (list, bool, labels) -> - Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) + Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) | Ttyp_poly (list, ct) -> - let list = List.map (fun v -> mkloc v loc) list in - Ptyp_poly (list, sub.typ sub ct) + let list = List.map (fun v -> mkloc v loc) list in + Ptyp_poly (list, sub.typ sub ct) | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) in Typ.mk ~loc ~attrs desc - let row_field sub rf = match rf with - Ttag (label, attrs, bool, list) -> - Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) + | Ttag (label, attrs, bool, list) -> + Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) | Tinherit ct -> Rinherit (sub.typ sub ct) let object_field sub ofield = match ofield with - OTtag (label, attrs, ct) -> - Otag (label, sub.attributes sub attrs, sub.typ sub ct) + | OTtag (label, attrs, ct) -> + Otag (label, sub.attributes sub attrs, sub.typ sub ct) | OTinherit ct -> Oinherit (sub.typ sub ct) - - let location _sub l = l let default_mapper = { - attribute = attribute ; - attributes = attributes ; - structure = structure; - structure_item = structure_item; - module_expr = module_expr; - signature = signature; - signature_item = signature_item; - module_type = module_type; - with_constraint = with_constraint; - type_declaration = type_declaration; - type_kind = type_kind; + attribute; + attributes; + structure; + structure_item; + module_expr; + signature; + signature_item; + module_type; + with_constraint; + type_declaration; + type_kind; typ = core_type; - type_extension = type_extension; - extension_constructor = extension_constructor; - value_description = value_description; + type_extension; + extension_constructor; + value_description; pat = pattern; expr = expression; - module_declaration = module_declaration; - module_type_declaration = module_type_declaration; - module_binding = module_binding; - package_type = package_type ; - open_description = open_description; - include_description = include_description; - include_declaration = include_declaration; - value_binding = value_binding; - constructor_declaration = constructor_declaration; - label_declaration = label_declaration; - cases = cases; - case = case; - location = location; - row_field = row_field ; - object_field = object_field ; + module_declaration; + module_type_declaration; + module_binding; + package_type; + open_description; + include_description; + include_declaration; + value_binding; + constructor_declaration; + label_declaration; + cases; + case; + location; + row_field; + object_field; } -let untype_structure ?(mapper=default_mapper) structure = +let untype_structure ?(mapper = default_mapper) structure = mapper.structure mapper structure -let untype_signature ?(mapper=default_mapper) signature = +let untype_signature ?(mapper = default_mapper) signature = mapper.signature mapper signature diff --git a/compiler/ml/untypeast.mli b/compiler/ml/untypeast.mli index a47df546d4..a86e69be65 100644 --- a/compiler/ml/untypeast.mli +++ b/compiler/ml/untypeast.mli @@ -22,17 +22,16 @@ type mapper = { attributes: mapper -> Typedtree.attribute list -> attribute list; case: mapper -> Typedtree.case -> case; cases: mapper -> Typedtree.case list -> case list; - constructor_declaration: mapper -> Typedtree.constructor_declaration - -> constructor_declaration; + constructor_declaration: + mapper -> Typedtree.constructor_declaration -> constructor_declaration; expr: mapper -> Typedtree.expression -> expression; - extension_constructor: mapper -> Typedtree.extension_constructor - -> extension_constructor; + extension_constructor: + mapper -> Typedtree.extension_constructor -> extension_constructor; include_declaration: mapper -> Typedtree.include_declaration -> include_declaration; include_description: mapper -> Typedtree.include_description -> include_description; - label_declaration: - mapper -> Typedtree.label_declaration -> label_declaration; + label_declaration: mapper -> Typedtree.label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> Typedtree.module_binding -> module_binding; module_declaration: @@ -57,8 +56,9 @@ type mapper = { value_binding: mapper -> Typedtree.value_binding -> value_binding; value_description: mapper -> Typedtree.value_description -> value_description; with_constraint: - mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) - -> with_constraint; + mapper -> + Path.t * Longident.t Location.loc * Typedtree.with_constraint -> + with_constraint; } val default_mapper : mapper diff --git a/compiler/ml/used_attributes.ml b/compiler/ml/used_attributes.ml index 4903002e04..0dcdf9f178 100644 --- a/compiler/ml/used_attributes.ml +++ b/compiler/ml/used_attributes.ml @@ -1,19 +1,18 @@ let used_attributes : string Asttypes.loc Hash_set_poly.t = Hash_set_poly.create 16 +(* let dump_attribute fmt = (fun ( (sloc : string Asttypes.loc)) -> + Format.fprintf fmt "@[%s@]" sloc.txt + ) -(* let dump_attribute fmt = (fun ( (sloc : string Asttypes.loc)) -> - Format.fprintf fmt "@[%s@]" sloc.txt - ) - -let dump_used_attributes fmt = - Format.fprintf fmt "Used attributes Listing Start:@."; - Hash_set_poly.iter used_attributes (fun attr -> dump_attribute fmt attr) ; - Format.fprintf fmt "Used attributes Listing End:@." *) - + let dump_used_attributes fmt = + Format.fprintf fmt "Used attributes Listing Start:@."; + Hash_set_poly.iter used_attributes (fun attr -> dump_attribute fmt attr) ; + Format.fprintf fmt "Used attributes Listing End:@." *) (* only mark non-ghost used bs attribute *) let mark_used_attribute ((x, _) : Parsetree.attribute) = if not x.loc.loc_ghost then Hash_set_poly.add used_attributes x -let is_used_attribute (sloc : string Asttypes.loc) = Hash_set_poly.mem used_attributes sloc \ No newline at end of file +let is_used_attribute (sloc : string Asttypes.loc) = + Hash_set_poly.mem used_attributes sloc diff --git a/compiler/ml/used_attributes.mli b/compiler/ml/used_attributes.mli index fe80737586..52dfa56c37 100644 --- a/compiler/ml/used_attributes.mli +++ b/compiler/ml/used_attributes.mli @@ -1,3 +1,3 @@ val mark_used_attribute : Parsetree.attribute -> unit -val is_used_attribute : string Asttypes.loc -> bool \ No newline at end of file +val is_used_attribute : string Asttypes.loc -> bool diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index b1eb0a1e5c..5aa8ce2784 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -10,18 +10,19 @@ let can_coerce_primitive (path : Path.t) = let check_paths_same p1 p2 target_path = Path.same p1 target_path && Path.same p2 target_path -let variant_has_catch_all_case (constructors : Types.constructor_declaration list) path_is_same = +let variant_has_catch_all_case + (constructors : Types.constructor_declaration list) path_is_same = let has_catch_all_string_case (c : Types.constructor_declaration) = let args = c.cd_args in match args with - | Cstr_tuple [{desc = Tconstr (p, [], _)}] -> - path_is_same p + | Cstr_tuple [{desc = Tconstr (p, [], _)}] -> path_is_same p | _ -> false in - constructors |> List.exists has_catch_all_string_case + constructors |> List.exists has_catch_all_string_case -let variant_has_relevant_primitive_catch_all (constructors : Types.constructor_declaration list) = +let variant_has_relevant_primitive_catch_all + (constructors : Types.constructor_declaration list) = variant_has_catch_all_case constructors can_coerce_primitive (* Checks if every case of the variant has the same runtime representation as the target type. *) @@ -37,8 +38,8 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) let path_same = check_paths_same p target_path in (* unboxed String(string) :> string *) path_same Predef.path_string - || (* unboxed Number(float) :> float *) - path_same Predef.path_float + (* unboxed Number(float) :> float *) + || path_same Predef.path_float || (* unboxed BigInt(bigint) :> bigint *) path_same Predef.path_bigint | Cstr_tuple [] -> ( @@ -64,9 +65,9 @@ let can_try_coerce_variant_to_primitive Some (constructors, type_attributes |> Ast_untagged_variants.has_untagged) | _ -> None -let can_try_coerce_variant_to_primitive_opt p = - match p with - | None -> None +let can_try_coerce_variant_to_primitive_opt p = + match p with + | None -> None | Some p -> can_try_coerce_variant_to_primitive p let variant_representation_matches (c1_attrs : Parsetree.attributes) @@ -152,15 +153,15 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc error = TagName {left_tag; right_tag}; })) -let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_attributes - = +let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors + ~type_attributes = let polyvariant_runtime_representations = row_fields |> List.filter_map (fun (label, (field : Types.row_field)) -> - (* Check that there's no payload in the polyvariant *) - match field with - | Rpresent None -> Some label - | _ -> None) + (* Check that there's no payload in the polyvariant *) + match field with + | Rpresent None -> Some label + | _ -> None) in if List.length polyvariant_runtime_representations <> List.length row_fields then @@ -173,39 +174,38 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_at (fun polyvariant_value -> variant_constructors |> List.exists (fun (c : Types.constructor_declaration) -> - let constructor_name = Ident.name c.cd_id in - match - Ast_untagged_variants.process_tag_type c.cd_attributes - with - | Some (String as_runtime_string) -> - (* `@as("")`, does the configured string match the polyvariant value? *) - as_runtime_string = polyvariant_value - | Some _ -> - (* Any other `@as` can't match since it's by definition not a string *) - false - | None -> - (* No `@as` means the runtime representation will be the constructor + let constructor_name = Ident.name c.cd_id in + match + Ast_untagged_variants.process_tag_type c.cd_attributes + with + | Some (String as_runtime_string) -> + (* `@as("")`, does the configured string match the polyvariant value? *) + as_runtime_string = polyvariant_value + | Some _ -> + (* Any other `@as` can't match since it's by definition not a string *) + false + | None -> ( + (* No `@as` means the runtime representation will be the constructor name as a string. - - However, there's a special case with unboxed types where there's a + + However, there's a special case with unboxed types where there's a string catch-all case. In that case, any polyvariant will match, since the catch-all case will match any string. *) - (match is_unboxed, c.cd_args with - | true, Cstr_tuple [{desc=Tconstr (p, _, _)}] -> - Path.same p Predef.path_string - | _ -> polyvariant_value = constructor_name) - )) + match (is_unboxed, c.cd_args) with + | true, Cstr_tuple [{desc = Tconstr (p, _, _)}] -> + Path.same p Predef.path_string + | _ -> polyvariant_value = constructor_name))) polyvariant_runtime_representations then Ok () else Error `Unknown -let type_is_variant (typ: (Path.t * Path.t * Types.type_declaration) option) = - match typ with - | Some (_, _, {type_kind = Type_variant _; _}) -> true +let type_is_variant (typ : (Path.t * Path.t * Types.type_declaration) option) = + match typ with + | Some (_, _, {type_kind = Type_variant _; _}) -> true | _ -> false let has_res_pat_variant_spread_attribute attrs = attrs |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> - txt = "res.patVariantSpread") + txt = "res.patVariantSpread") |> Option.is_some diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml index 2585426605..f80e4a209f 100644 --- a/compiler/ml/variant_type_spread.ml +++ b/compiler/ml/variant_type_spread.ml @@ -42,7 +42,8 @@ let map_constructors ~(sdecl : Parsetree.type_declaration) ~all_constructors env in match type_decl with - | {type_kind = Type_variant [] } -> raise (VariantTypeSpreadError (loc.loc, InvalidType)) + | {type_kind = Type_variant []} -> + raise (VariantTypeSpreadError (loc.loc, InvalidType)) | {type_kind = Type_variant cstrs; type_attributes; type_params} -> if List.length type_params > 0 then raise (VariantTypeSpreadError (loc.loc, HasTypeParams)); diff --git a/compiler/ounit_tests/.ocamlformat b/compiler/ounit_tests/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/compiler/ounit_tests/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/compiler/ounit_tests/ounit_array_tests.ml b/compiler/ounit_tests/ounit_array_tests.ml index dbf82d53d7..74274cd4f5 100644 --- a/compiler/ounit_tests/ounit_array_tests.ml +++ b/compiler/ounit_tests/ounit_array_tests.ml @@ -1,89 +1,59 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal +let ( =~ ) = OUnit.assert_equal -let printer_int_array = fun xs -> - String.concat "," - (List.map string_of_int @@ Array.to_list xs ) +let printer_int_array xs = + String.concat "," (List.map string_of_int @@ Array.to_list xs) -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [|"a"; "b";"c"|] - Ext_string.equal "--" =~ No_split - end; - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [|"a"; "b";"c";"--"|] - Ext_string.equal "--" =~ Split( [|"a";"b";"c"|], [||]) - end; - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [|"--"; "a"; "b";"c";"--"|] - Ext_string.equal "--" =~ Split ([||], [|"a";"b";"c";"--"|]) - end; - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [| "u"; "g"; "--"; "a"; "b";"c";"--"|] - Ext_string.equal "--" =~ Split ([|"u";"g"|], [|"a";"b";"c";"--"|]) - end; - __LOC__ >:: begin fun _ -> - Ext_array.reverse [|1;2|] =~ [|2;1|]; - Ext_array.reverse [||] =~ [||] - end ; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:printer_int_array in - let k x y = Ext_array.of_list_map y x in - k succ [] =~ [||]; - k succ [1] =~ [|2|]; - k succ [1;2;3] =~ [|2;3;4|]; - k succ [1;2;3;4] =~ [|2;3;4;5|]; - k succ [1;2;3;4;5] =~ [|2;3;4;5;6|]; - k succ [1;2;3;4;5;6] =~ [|2;3;4;5;6;7|]; - k succ [1;2;3;4;5;6;7] =~ [|2;3;4;5;6;7;8|]; - end; - __LOC__ >:: begin fun _ -> - Ext_array.to_list_map_acc - [|1;2;3;4;5;6|] [1;2;3] - (fun x -> if x mod 2 = 0 then Some x else None ) - =~ [2;4;6;1;2;3] - end; - __LOC__ >:: begin fun _ -> - Ext_array.to_list_map_acc - [|1;2;3;4;5;6|] [] - (fun x -> if x mod 2 = 0 then Some x else None ) - =~ [2;4;6] - end; - - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_array.for_all2_no_exn - [|1;2;3|] - [|1;2;3|] - (=) - ) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_array.for_all2_no_exn - [||] [||] (=) - ); - OUnit.assert_bool __LOC__ - (not @@ Ext_array.for_all2_no_exn - [||] [|1|] (=) - ) - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (not (Ext_array.for_all2_no_exn - [|1;2;3|] - [|1;2;33|] - (=) - )) - end - ] \ No newline at end of file +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + Ext_array.find_and_split [|"a"; "b"; "c"|] Ext_string.equal "--" + =~ No_split ); + ( __LOC__ >:: fun _ -> + Ext_array.find_and_split [|"a"; "b"; "c"; "--"|] Ext_string.equal + "--" + =~ Split ([|"a"; "b"; "c"|], [||]) ); + ( __LOC__ >:: fun _ -> + Ext_array.find_and_split + [|"--"; "a"; "b"; "c"; "--"|] + Ext_string.equal "--" + =~ Split ([||], [|"a"; "b"; "c"; "--"|]) ); + ( __LOC__ >:: fun _ -> + Ext_array.find_and_split + [|"u"; "g"; "--"; "a"; "b"; "c"; "--"|] + Ext_string.equal "--" + =~ Split ([|"u"; "g"|], [|"a"; "b"; "c"; "--"|]) ); + ( __LOC__ >:: fun _ -> + Ext_array.reverse [|1; 2|] =~ [|2; 1|]; + Ext_array.reverse [||] =~ [||] ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal ~printer:printer_int_array in + let k x y = Ext_array.of_list_map y x in + k succ [] =~ [||]; + k succ [1] =~ [|2|]; + k succ [1; 2; 3] =~ [|2; 3; 4|]; + k succ [1; 2; 3; 4] =~ [|2; 3; 4; 5|]; + k succ [1; 2; 3; 4; 5] =~ [|2; 3; 4; 5; 6|]; + k succ [1; 2; 3; 4; 5; 6] =~ [|2; 3; 4; 5; 6; 7|]; + k succ [1; 2; 3; 4; 5; 6; 7] =~ [|2; 3; 4; 5; 6; 7; 8|] ); + ( __LOC__ >:: fun _ -> + Ext_array.to_list_map_acc [|1; 2; 3; 4; 5; 6|] [1; 2; 3] (fun x -> + if x mod 2 = 0 then Some x else None) + =~ [2; 4; 6; 1; 2; 3] ); + ( __LOC__ >:: fun _ -> + Ext_array.to_list_map_acc [|1; 2; 3; 4; 5; 6|] [] (fun x -> + if x mod 2 = 0 then Some x else None) + =~ [2; 4; 6] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Ext_array.for_all2_no_exn [|1; 2; 3|] [|1; 2; 3|] ( = )) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_array.for_all2_no_exn [||] [||] ( = )); + OUnit.assert_bool __LOC__ + (not @@ Ext_array.for_all2_no_exn [||] [|1|] ( = )) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (not (Ext_array.for_all2_no_exn [|1; 2; 3|] [|1; 2; 33|] ( = ))) ); + ] diff --git a/compiler/ounit_tests/ounit_bal_tree_tests.ml b/compiler/ounit_tests/ounit_bal_tree_tests.ml index 647da535ee..8e0dd03b6c 100644 --- a/compiler/ounit_tests/ounit_bal_tree_tests.ml +++ b/compiler/ounit_tests/ounit_bal_tree_tests.ml @@ -1,155 +1,139 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal +let ( =~ ) = OUnit.assert_equal -module Set_poly = struct +module Set_poly = struct include Set_int -let of_sorted_list xs = Array.of_list xs |> of_sorted_array -let of_array l = - Ext_array.fold_left l empty add + let of_sorted_list xs = Array.of_list xs |> of_sorted_array + let of_array l = Ext_array.fold_left l empty add end -let suites = - __FILE__ >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun n -> n)))) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun n -> 1000-n)))) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun _ -> Random.int 1000)))) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_sorted_list (Array.to_list (Array.init 1000 (fun n -> n))))) - end; - __LOC__ >:: begin fun _ -> - let arr = Array.init 1000 (fun n -> n) in - let set = (Set_poly.of_sorted_array arr) in - OUnit.assert_bool __LOC__ - (Set_poly.invariant set ); - OUnit.assert_equal 1000 (Set_poly.cardinal set) - end; - __LOC__ >:: begin fun _ -> - for i = 0 to 200 do - let arr = Array.init i (fun n -> n) in - let set = (Set_poly.of_sorted_array arr) in - OUnit.assert_bool __LOC__ - (Set_poly.invariant set ); - OUnit.assert_equal i (Set_poly.cardinal set) - done - end; - __LOC__ >:: begin fun _ -> - let arr_size = 200 in - let arr_sets = Array.make 200 Set_poly.empty in - for i = 0 to arr_size - 1 do - let size = Random.int 1000 in - let arr = Array.init size (fun n -> n) in - arr_sets.(i)<- (Set_poly.of_sorted_array arr) - done; - let large = Array.fold_left Set_poly.union Set_poly.empty arr_sets in - OUnit.assert_bool __LOC__ (Set_poly.invariant large) - end; - - __LOC__ >:: begin fun _ -> - let arr_size = 1_00_000 in - let v = ref Set_int.empty in - for _ = 0 to arr_size - 1 do - let size = Random.int 0x3FFFFFFF in - v := Set_int.add !v size - done; - OUnit.assert_bool __LOC__ (Set_int.invariant !v) - end; - - ] +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Set_poly.invariant + (Set_poly.of_array (Array.init 1000 (fun n -> n)))) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Set_poly.invariant + (Set_poly.of_array (Array.init 1000 (fun n -> 1000 - n)))) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Set_poly.invariant + (Set_poly.of_array (Array.init 1000 (fun _ -> Random.int 1000)))) + ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Set_poly.invariant + (Set_poly.of_sorted_list + (Array.to_list (Array.init 1000 (fun n -> n))))) ); + ( __LOC__ >:: fun _ -> + let arr = Array.init 1000 (fun n -> n) in + let set = Set_poly.of_sorted_array arr in + OUnit.assert_bool __LOC__ (Set_poly.invariant set); + OUnit.assert_equal 1000 (Set_poly.cardinal set) ); + ( __LOC__ >:: fun _ -> + for i = 0 to 200 do + let arr = Array.init i (fun n -> n) in + let set = Set_poly.of_sorted_array arr in + OUnit.assert_bool __LOC__ (Set_poly.invariant set); + OUnit.assert_equal i (Set_poly.cardinal set) + done ); + ( __LOC__ >:: fun _ -> + let arr_size = 200 in + let arr_sets = Array.make 200 Set_poly.empty in + for i = 0 to arr_size - 1 do + let size = Random.int 1000 in + let arr = Array.init size (fun n -> n) in + arr_sets.(i) <- Set_poly.of_sorted_array arr + done; + let large = Array.fold_left Set_poly.union Set_poly.empty arr_sets in + OUnit.assert_bool __LOC__ (Set_poly.invariant large) ); + ( __LOC__ >:: fun _ -> + let arr_size = 1_00_000 in + let v = ref Set_int.empty in + for _ = 0 to arr_size - 1 do + let size = Random.int 0x3FFFFFFF in + v := Set_int.add !v size + done; + OUnit.assert_bool __LOC__ (Set_int.invariant !v) ); + ] +type ident = {stamp: int; name: string; mutable flags: int} -type ident = { stamp : int ; name : string ; mutable flags : int} +module Set_ident = Set.Make (struct + type t = ident + let compare = Stdlib.compare +end) -module Set_ident = Set.Make(struct type t = ident - let compare = Stdlib.compare end) +let compare_ident x y = + let a = compare (x.stamp : int) y.stamp in + if a <> 0 then a + else + let b = compare (x.name : string) y.name in + if b <> 0 then b else compare (x.flags : int) y.flags -let compare_ident x y = - let a = compare (x.stamp : int) y.stamp in - if a <> 0 then a - else - let b = compare (x.name : string) y.name in - if b <> 0 then b - else compare (x.flags : int) y.flags - - -let rec add (tree : _ Set_gen.t) x = match tree with +let rec add (tree : _ Set_gen.t) x = + match tree with | Empty -> Set_gen.singleton x - | Leaf v -> + | Leaf v -> let c = compare_ident x v in - if c = 0 then tree else - if c < 0 then - Set_gen.unsafe_two_elements x v - else - Set_gen.unsafe_two_elements v x + if c = 0 then tree + else if c < 0 then Set_gen.unsafe_two_elements x v + else Set_gen.unsafe_two_elements v x | Node {l; v; r} as t -> let c = compare_ident x v in - if c = 0 then t else - if c < 0 then Set_gen.bal (add l x ) v r else Set_gen.bal l v (add r x ) + if c = 0 then t + else if c < 0 then Set_gen.bal (add l x) v r + else Set_gen.bal l v (add r x) + +let rec mem (tree : _ Set_gen.t) x = + match tree with + | Empty -> false + | Leaf v -> compare_ident x v = 0 + | Node {l; v; r} -> + let c = compare_ident x v in + c = 0 || mem (if c < 0 then l else r) x -let rec mem (tree : _ Set_gen.t) x = match tree with - | Empty -> false - | Leaf v -> compare_ident x v = 0 - | Node{l; v; r} -> - let c = compare_ident x v in - c = 0 || mem (if c < 0 then l else r) x - -module Ident_set2 = Set.Make(struct type t = ident - let compare = compare_ident - end) +module Ident_set2 = Set.Make (struct + type t = ident + let compare = compare_ident +end) -let bench () = +let bench () = let times = 1_000_000 in - Ounit_tests_util.time "functor set" begin fun _ -> - let v = ref Set_ident.empty in - for i = 0 to times do - v := Set_ident.add {stamp = i ; name = "name"; flags = -1 } !v - done; - for i = 0 to times do - ignore @@ Set_ident.mem {stamp = i; name = "name" ; flags = -1} !v - done - end ; - Ounit_tests_util.time "functor set (specialized)" begin fun _ -> - let v = ref Ident_set2.empty in - for i = 0 to times do - v := Ident_set2.add {stamp = i ; name = "name"; flags = -1 } !v - done; - for i = 0 to times do - ignore @@ Ident_set2.mem {stamp = i; name = "name" ; flags = -1} !v - done - end ; - - Ounit_tests_util.time "poly set" begin fun _ -> - let module Set_poly = Set_ident in - let v = ref Set_poly.empty in - for i = 0 to times do - v := Set_poly.add {stamp = i ; name = "name"; flags = -1 } !v - done; - for i = 0 to times do - ignore @@ Set_poly.mem {stamp = i; name = "name" ; flags = -1} !v - done; - end; - Ounit_tests_util.time "poly set (specialized)" begin fun _ -> - let v = ref Set_gen.empty in - for i = 0 to times do - v := add !v {stamp = i ; name = "name"; flags = -1 } - done; - for i = 0 to times do - ignore @@ mem !v {stamp = i; name = "name" ; flags = -1} - done + Ounit_tests_util.time "functor set" (fun _ -> + let v = ref Set_ident.empty in + for i = 0 to times do + v := Set_ident.add {stamp = i; name = "name"; flags = -1} !v + done; + for i = 0 to times do + ignore @@ Set_ident.mem {stamp = i; name = "name"; flags = -1} !v + done); + Ounit_tests_util.time "functor set (specialized)" (fun _ -> + let v = ref Ident_set2.empty in + for i = 0 to times do + v := Ident_set2.add {stamp = i; name = "name"; flags = -1} !v + done; + for i = 0 to times do + ignore @@ Ident_set2.mem {stamp = i; name = "name"; flags = -1} !v + done); - end ; + Ounit_tests_util.time "poly set" (fun _ -> + let module Set_poly = Set_ident in + let v = ref Set_poly.empty in + for i = 0 to times do + v := Set_poly.add {stamp = i; name = "name"; flags = -1} !v + done; + for i = 0 to times do + ignore @@ Set_poly.mem {stamp = i; name = "name"; flags = -1} !v + done); + Ounit_tests_util.time "poly set (specialized)" (fun _ -> + let v = ref Set_gen.empty in + for i = 0 to times do + v := add !v {stamp = i; name = "name"; flags = -1} + done; + for i = 0 to times do + ignore @@ mem !v {stamp = i; name = "name"; flags = -1} + done) diff --git a/compiler/ounit_tests/ounit_bsb_pkg_tests.ml b/compiler/ounit_tests/ounit_bsb_pkg_tests.ml index eae14ca573..b2c8fc6bb7 100644 --- a/compiler/ounit_tests/ounit_bsb_pkg_tests.ml +++ b/compiler/ounit_tests/ounit_bsb_pkg_tests.ml @@ -1,115 +1,105 @@ - - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let printer_string = fun x -> x -let (=~) = OUnit.assert_equal ~printer:printer_string - - -let scope_test s (a,b,c)= - match Bsb_pkg_types.extract_pkg_name_and_file s with - | Scope(a0,b0),c0 -> - a =~ a0 ; b =~ b0 ; c =~ c0 - | Global _,_ -> OUnit.assert_failure __LOC__ - -let global_test s (a,b) = - match Bsb_pkg_types.extract_pkg_name_and_file s with - | Scope _, _ -> - OUnit.assert_failure __LOC__ - | Global a0, b0-> - a=~a0; b=~b0 - -let s_test0 s (a,b)= - match Bsb_pkg_types.string_as_package s with - | Scope(name,scope) -> - a =~ name ; b =~scope - | _ -> OUnit.assert_failure __LOC__ - -let s_test1 s a = - match Bsb_pkg_types.string_as_package s with - | Global x -> - a =~ x - | _ -> OUnit.assert_failure __LOC__ - -let group0 = Map_string.of_list [ - "Liba", - {Bsb_db.info = Impl_intf; dir= "a";case = false; - name_sans_extension = "liba"} -] -let group1 = Map_string.of_list [ - "Ciba", - {Bsb_db.info = Impl_intf; dir= "b";case = false; - name_sans_extension = "liba"} -] - -let parse_db db : Bsb_db_decode.t = - let buf = Ext_buffer.create 10_000 in +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +let printer_string x = x +let ( =~ ) = OUnit.assert_equal ~printer:printer_string + +let scope_test s (a, b, c) = + match Bsb_pkg_types.extract_pkg_name_and_file s with + | Scope (a0, b0), c0 -> + a =~ a0; + b =~ b0; + c =~ c0 + | Global _, _ -> OUnit.assert_failure __LOC__ + +let global_test s (a, b) = + match Bsb_pkg_types.extract_pkg_name_and_file s with + | Scope _, _ -> OUnit.assert_failure __LOC__ + | Global a0, b0 -> + a =~ a0; + b =~ b0 + +let s_test0 s (a, b) = + match Bsb_pkg_types.string_as_package s with + | Scope (name, scope) -> + a =~ name; + b =~ scope + | _ -> OUnit.assert_failure __LOC__ + +let s_test1 s a = + match Bsb_pkg_types.string_as_package s with + | Global x -> a =~ x + | _ -> OUnit.assert_failure __LOC__ + +let group0 = + Map_string.of_list + [ + ( "Liba", + { + Bsb_db.info = Impl_intf; + dir = "a"; + case = false; + name_sans_extension = "liba"; + } ); + ] +let group1 = + Map_string.of_list + [ + ( "Ciba", + { + Bsb_db.info = Impl_intf; + dir = "b"; + case = false; + name_sans_extension = "liba"; + } ); + ] + +let parse_db db : Bsb_db_decode.t = + let buf = Ext_buffer.create 10_000 in Bsb_db_encode.encode db buf; let s = Ext_buffer.contents buf in Bsb_db_decode.decode s -let suites = - __FILE__ >::: [ - __LOC__ >:: begin fun _ -> - scope_test "@hello/hi" - ("hi", "@hello",""); - - scope_test "@hello/hi/x" - ("hi", "@hello","x"); - - - scope_test "@hello/hi/x/y" - ("hi", "@hello","x/y"); - end ; - __LOC__ >:: begin fun _ -> - global_test "hello" - ("hello",""); - global_test "hello/x" - ("hello","x"); - global_test "hello/x/y" - ("hello","x/y") - end ; - __LOC__ >:: begin fun _ -> - s_test0 "@x/y" ("y","@x"); - s_test0 "@x/y/z" ("y/z","@x"); - s_test1 "xx" "xx"; - s_test1 "xx/yy/zz" "xx/yy/zz" - end; - - __LOC__ >:: begin fun _ -> - match parse_db {lib= group0; dev = group1}with - | {lib = Group {modules = [|"Liba"|]}; - dev = Group {modules = [|"Ciba"|]}} - -> OUnit.assert_bool __LOC__ true - | _ -> - OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match parse_db {lib = group0;dev = Map_string.empty } with - | {lib = Group {modules = [|"Liba"|]}; - dev = Dummy} - -> OUnit.assert_bool __LOC__ true - | _ -> - OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match parse_db {lib = Map_string.empty ; dev = group1} with - | {lib = Dummy; - dev = Group {modules = [|"Ciba"|]} - } - -> OUnit.assert_bool __LOC__ true - | _ -> - OUnit.assert_failure __LOC__ - end - (* __LOC__ >:: begin fun _ -> - OUnit.assert_equal parse_data_one data_one - end ; - __LOC__ >:: begin fun _ -> - - OUnit.assert_equal parse_data_two data_two - end *) - ] - - - +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + scope_test "@hello/hi" ("hi", "@hello", ""); + + scope_test "@hello/hi/x" ("hi", "@hello", "x"); + + scope_test "@hello/hi/x/y" ("hi", "@hello", "x/y") ); + ( __LOC__ >:: fun _ -> + global_test "hello" ("hello", ""); + global_test "hello/x" ("hello", "x"); + global_test "hello/x/y" ("hello", "x/y") ); + ( __LOC__ >:: fun _ -> + s_test0 "@x/y" ("y", "@x"); + s_test0 "@x/y/z" ("y/z", "@x"); + s_test1 "xx" "xx"; + s_test1 "xx/yy/zz" "xx/yy/zz" ); + ( __LOC__ >:: fun _ -> + match parse_db {lib = group0; dev = group1} with + | { + lib = Group {modules = [|"Liba"|]}; + dev = Group {modules = [|"Ciba"|]}; + } -> + OUnit.assert_bool __LOC__ true + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + match parse_db {lib = group0; dev = Map_string.empty} with + | {lib = Group {modules = [|"Liba"|]}; dev = Dummy} -> + OUnit.assert_bool __LOC__ true + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + match parse_db {lib = Map_string.empty; dev = group1} with + | {lib = Dummy; dev = Group {modules = [|"Ciba"|]}} -> + OUnit.assert_bool __LOC__ true + | _ -> OUnit.assert_failure __LOC__ ) + (* __LOC__ >:: begin fun _ -> + OUnit.assert_equal parse_data_one data_one + end ; + __LOC__ >:: begin fun _ -> + + OUnit.assert_equal parse_data_two data_two + end *); + ] diff --git a/compiler/ounit_tests/ounit_bsb_regex_tests.ml b/compiler/ounit_tests/ounit_bsb_regex_tests.ml index d5f87d0458..57eb79567a 100644 --- a/compiler/ounit_tests/ounit_bsb_regex_tests.ml +++ b/compiler/ounit_tests/ounit_bsb_regex_tests.ml @@ -1,48 +1,36 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let ( =~ ) = OUnit.assert_equal -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let test_eq x y = + Bsb_regex.global_substitute ~reg:"\\${rescript:\\([-a-zA-Z0-9]+\\)}" x + (fun _ groups -> + match groups with + | x :: _ -> x + | _ -> assert false) + =~ y -let (=~) = OUnit.assert_equal - - -let test_eq x y = - Bsb_regex.global_substitute ~reg:"\\${rescript:\\([-a-zA-Z0-9]+\\)}" x - (fun _ groups -> - match groups with - | x::_ -> x - | _ -> assert false - ) =~ y - - -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - test_eq - {| hi hi hi ${rescript:name} +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + test_eq + {| hi hi hi ${rescript:name} ${rescript:x} ${rescript:u} - |} - {| hi hi hi name + |} + {| hi hi hi name x u - |} - end; - __LOC__ >:: begin fun _ -> - test_eq "xx" "xx"; - test_eq "${rescript:x}" "x"; - test_eq "a${rescript:x}" "ax"; - - end; - - __LOC__ >:: begin fun _ -> - test_eq "${rescript:x}x" "xx" - end; - - __LOC__ >:: begin fun _ -> - test_eq {| + |} ); + ( __LOC__ >:: fun _ -> + test_eq "xx" "xx"; + test_eq "${rescript:x}" "x"; + test_eq "a${rescript:x}" "ax" ); + (__LOC__ >:: fun _ -> test_eq "${rescript:x}x" "xx"); + ( __LOC__ >:: fun _ -> + test_eq + {| { "name": "${rescript:name}", "version": "${rescript:proj-version}", @@ -53,7 +41,8 @@ let suites = "bs-dependencies" : [ ] } -|} {| +|} + {| { "name": "name", "version": "proj-version", @@ -65,11 +54,10 @@ let suites = ] } |} - end - - ; - __LOC__ >:: begin fun _ -> - test_eq {| + ); + ( __LOC__ >:: fun _ -> + test_eq + {| { "name": "${rescript:name}", "version": "${rescript:proj-version}", @@ -88,7 +76,8 @@ let suites = "bs-platform": "${rescript:bs-version}" } } -|} {| +|} + {| { "name": "name", "version": "proj-version", @@ -108,9 +97,10 @@ let suites = } } |} - end; - __LOC__ >:: begin fun _ -> - test_eq {| + ); + ( __LOC__ >:: fun _ -> + test_eq + {| { "version": "0.1.0", "command": "${rescript:bsb}", @@ -148,7 +138,8 @@ let suites = ] } } -|} {| +|} + {| { "version": "0.1.0", "command": "bsb", @@ -187,5 +178,5 @@ let suites = } } |} - end - ] + ); + ] diff --git a/compiler/ounit_tests/ounit_data_random.ml b/compiler/ounit_tests/ounit_data_random.ml index 87dbc499df..e66333d7c5 100644 --- a/compiler/ounit_tests/ounit_data_random.ml +++ b/compiler/ounit_tests/ounit_data_random.ml @@ -1,9 +1,6 @@ +let min_int x y = if x < y then x else y - -let min_int x y = - if x < y then x else y - -let random_string chars upper = - let len = Array.length chars in - let string_len = (Random.int (min_int upper len)) in - String.init string_len (fun _i -> chars.(Random.int len )) \ No newline at end of file +let random_string chars upper = + let len = Array.length chars in + let string_len = Random.int (min_int upper len) in + String.init string_len (fun _i -> chars.(Random.int len)) diff --git a/compiler/ounit_tests/ounit_hash_set_tests.ml b/compiler/ounit_tests/ounit_hash_set_tests.ml index 5d418ea248..15a133014e 100644 --- a/compiler/ounit_tests/ounit_hash_set_tests.ml +++ b/compiler/ounit_tests/ounit_hash_set_tests.ml @@ -1,121 +1,213 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal +let ( =~ ) = OUnit.assert_equal -type id = { name : string ; stamp : int } +type id = {name: string; stamp: int} -module Id_hash_set = Hash_set.Make(struct - type t = id - let equal x y = x.stamp = y.stamp && x.name = y.name - let hash x = Hashtbl.hash x.stamp - end - ) +module Id_hash_set = Hash_set.Make (struct + type t = id + let equal x y = x.stamp = y.stamp && x.name = y.name + let hash x = Hashtbl.hash x.stamp +end) -let const_tbl = [|"0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "100"; "99"; "98"; - "97"; "96"; "95"; "94"; "93"; "92"; "91"; "90"; "89"; "88"; "87"; "86"; "85"; - "84"; "83"; "82"; "81"; "80"; "79"; "78"; "77"; "76"; "75"; "74"; "73"; "72"; - "71"; "70"; "69"; "68"; "67"; "66"; "65"; "64"; "63"; "62"; "61"; "60"; "59"; - "58"; "57"; "56"; "55"; "54"; "53"; "52"; "51"; "50"; "49"; "48"; "47"; "46"; - "45"; "44"; "43"; "42"; "41"; "40"; "39"; "38"; "37"; "36"; "35"; "34"; "33"; - "32"; "31"; "30"; "29"; "28"; "27"; "26"; "25"; "24"; "23"; "22"; "21"; "20"; - "19"; "18"; "17"; "16"; "15"; "14"; "13"; "12"; "11"|] -let suites = +let const_tbl = + [| + "0"; + "1"; + "2"; + "3"; + "4"; + "5"; + "6"; + "7"; + "8"; + "9"; + "10"; + "100"; + "99"; + "98"; + "97"; + "96"; + "95"; + "94"; + "93"; + "92"; + "91"; + "90"; + "89"; + "88"; + "87"; + "86"; + "85"; + "84"; + "83"; + "82"; + "81"; + "80"; + "79"; + "78"; + "77"; + "76"; + "75"; + "74"; + "73"; + "72"; + "71"; + "70"; + "69"; + "68"; + "67"; + "66"; + "65"; + "64"; + "63"; + "62"; + "61"; + "60"; + "59"; + "58"; + "57"; + "56"; + "55"; + "54"; + "53"; + "52"; + "51"; + "50"; + "49"; + "48"; + "47"; + "46"; + "45"; + "44"; + "43"; + "42"; + "41"; + "40"; + "39"; + "38"; + "37"; + "36"; + "35"; + "34"; + "33"; + "32"; + "31"; + "30"; + "29"; + "28"; + "27"; + "26"; + "25"; + "24"; + "23"; + "22"; + "21"; + "20"; + "19"; + "18"; + "17"; + "16"; + "15"; + "14"; + "13"; + "12"; + "11"; + |] +let suites = __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - let v = Hash_set_poly.create 31 in - for i = 0 to 1000 do - Hash_set_poly.add v i - done ; - OUnit.assert_equal (Hash_set_poly.length v) 1001 - end ; - __LOC__ >:: begin fun _ -> - let v = Hash_set_poly.create 31 in - for _ = 0 to 1_0_000 do - Hash_set_poly.add v 0 - done ; - OUnit.assert_equal (Hash_set_poly.length v) 1 - end ; - __LOC__ >:: begin fun _ -> - let v = Hash_set_poly.create 30 in - for i = 0 to 2_000 do - Hash_set_poly.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - Hash_set_poly.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - assert (Hash_set_poly.mem v {name = "x"; stamp = i}) - done; - OUnit.assert_equal (Hash_set_poly.length v) 2_001; - for i = 1990 to 3_000 do - Hash_set_poly.remove v {name = "x"; stamp = i} - done ; - OUnit.assert_equal (Hash_set_poly.length v) 1990; - (* OUnit.assert_equal (Hash_set.stats v) *) - (* {Hashtbl.num_bindings = 1990; num_buckets = 1024; max_bucket_length = 7; *) - (* bucket_histogram = [|139; 303; 264; 178; 93; 32; 12; 3|]} *) - end ; - __LOC__ >:: begin fun _ -> - let v = Id_hash_set.create 30 in - for i = 0 to 2_000 do - Id_hash_set.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - Id_hash_set.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - assert (Id_hash_set.mem v {name = "x"; stamp = i}) - done; - OUnit.assert_equal (Id_hash_set.length v) 2_001; - for i = 1990 to 3_000 do - Id_hash_set.remove v {name = "x"; stamp = i} - done ; - OUnit.assert_equal (Id_hash_set.length v) 1990; - for i = 1000 to 3990 do - Id_hash_set.remove v { name = "x"; stamp = i } - done; - OUnit.assert_equal (Id_hash_set.length v) 1000; - for i = 1000 to 1100 do - Id_hash_set.add v { name = "x"; stamp = i}; - done; - OUnit.assert_equal (Id_hash_set.length v ) 1101; - for i = 0 to 1100 do - OUnit.assert_bool "exist" (Id_hash_set.mem v {name = "x"; stamp = i}) - done - (* OUnit.assert_equal (Hash_set.stats v) *) - (* {num_bindings = 1990; num_buckets = 1024; max_bucket_length = 8; *) - (* bucket_histogram = [|148; 275; 285; 182; 95; 21; 14; 2; 2|]} *) - - end - ; - __LOC__ >:: begin fun _ -> - let duplicate arr = - let len = Array.length arr in - let rec aux tbl off = - if off >= len then None - else - let curr = (Array.unsafe_get arr off) in - if Hash_set_string.check_add tbl curr then - aux tbl (off + 1) - else Some curr in - aux (Hash_set_string.create len) 0 in - let v = [| "if"; "a"; "b"; "c" |] in - OUnit.assert_equal (duplicate v) None; - OUnit.assert_equal (duplicate [|"if"; "a"; "b"; "b"; "c"|]) (Some "b") - end; - __LOC__ >:: begin fun _ -> - let of_array lst = - let len = Array.length lst in - let tbl = Hash_set_string.create len in - Ext_array.iter lst (Hash_set_string.add tbl) ; tbl in - let hash = of_array const_tbl in - let len = Hash_set_string.length hash in - Hash_set_string.remove hash "x"; - OUnit.assert_equal len (Hash_set_string.length hash); - Hash_set_string.remove hash "0"; - OUnit.assert_equal (len - 1 ) (Hash_set_string.length hash) - end - ] + >::: [ + ( __LOC__ >:: fun _ -> + let v = Hash_set_poly.create 31 in + for i = 0 to 1000 do + Hash_set_poly.add v i + done; + OUnit.assert_equal (Hash_set_poly.length v) 1001 ); + ( __LOC__ >:: fun _ -> + let v = Hash_set_poly.create 31 in + for _ = 0 to 1_0_000 do + Hash_set_poly.add v 0 + done; + OUnit.assert_equal (Hash_set_poly.length v) 1 ); + ( __LOC__ >:: fun _ -> + let v = Hash_set_poly.create 30 in + for i = 0 to 2_000 do + Hash_set_poly.add v {name = "x"; stamp = i} + done; + for i = 0 to 2_000 do + Hash_set_poly.add v {name = "x"; stamp = i} + done; + for i = 0 to 2_000 do + assert (Hash_set_poly.mem v {name = "x"; stamp = i}) + done; + OUnit.assert_equal (Hash_set_poly.length v) 2_001; + for i = 1990 to 3_000 do + Hash_set_poly.remove v {name = "x"; stamp = i} + done; + OUnit.assert_equal (Hash_set_poly.length v) 1990 + (* OUnit.assert_equal (Hash_set.stats v) *) + (* {Hashtbl.num_bindings = 1990; num_buckets = 1024; max_bucket_length = 7; *) + (* bucket_histogram = [|139; 303; 264; 178; 93; 32; 12; 3|]} *) ); + ( __LOC__ >:: fun _ -> + let v = Id_hash_set.create 30 in + for i = 0 to 2_000 do + Id_hash_set.add v {name = "x"; stamp = i} + done; + for i = 0 to 2_000 do + Id_hash_set.add v {name = "x"; stamp = i} + done; + for i = 0 to 2_000 do + assert (Id_hash_set.mem v {name = "x"; stamp = i}) + done; + OUnit.assert_equal (Id_hash_set.length v) 2_001; + for i = 1990 to 3_000 do + Id_hash_set.remove v {name = "x"; stamp = i} + done; + OUnit.assert_equal (Id_hash_set.length v) 1990; + for i = 1000 to 3990 do + Id_hash_set.remove v {name = "x"; stamp = i} + done; + OUnit.assert_equal (Id_hash_set.length v) 1000; + for i = 1000 to 1100 do + Id_hash_set.add v {name = "x"; stamp = i} + done; + OUnit.assert_equal (Id_hash_set.length v) 1101; + for i = 0 to 1100 do + OUnit.assert_bool "exist" + (Id_hash_set.mem v {name = "x"; stamp = i}) + done + (* OUnit.assert_equal (Hash_set.stats v) *) + (* {num_bindings = 1990; num_buckets = 1024; max_bucket_length = 8; *) + (* bucket_histogram = [|148; 275; 285; 182; 95; 21; 14; 2; 2|]} *) + ); + ( __LOC__ >:: fun _ -> + let duplicate arr = + let len = Array.length arr in + let rec aux tbl off = + if off >= len then None + else + let curr = Array.unsafe_get arr off in + if Hash_set_string.check_add tbl curr then aux tbl (off + 1) + else Some curr + in + aux (Hash_set_string.create len) 0 + in + let v = [|"if"; "a"; "b"; "c"|] in + OUnit.assert_equal (duplicate v) None; + OUnit.assert_equal + (duplicate [|"if"; "a"; "b"; "b"; "c"|]) + (Some "b") ); + ( __LOC__ >:: fun _ -> + let of_array lst = + let len = Array.length lst in + let tbl = Hash_set_string.create len in + Ext_array.iter lst (Hash_set_string.add tbl); + tbl + in + let hash = of_array const_tbl in + let len = Hash_set_string.length hash in + Hash_set_string.remove hash "x"; + OUnit.assert_equal len (Hash_set_string.length hash); + Hash_set_string.remove hash "0"; + OUnit.assert_equal (len - 1) (Hash_set_string.length hash) ); + ] diff --git a/compiler/ounit_tests/ounit_hash_stubs_test.ml b/compiler/ounit_tests/ounit_hash_stubs_test.ml index 859d01cda4..6f686653c3 100644 --- a/compiler/ounit_tests/ounit_hash_stubs_test.ml +++ b/compiler/ounit_tests/ounit_hash_stubs_test.ml @@ -1,74 +1,65 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal +let ( =~ ) = OUnit.assert_equal let count = 2_000_000 -let bench () = - Ounit_tests_util.time "int hash set" begin fun _ -> - let v = Hash_set_int.create 2_000_000 in - for i = 0 to count do - Hash_set_int.add v i - done ; - for _ = 0 to 3 do - for i = 0 to count do - assert (Hash_set_int.mem v i) - done - done - end; - Ounit_tests_util.time "int hash set" begin fun _ -> - let v = Hash_set_poly.create 2_000_000 in - for i = 0 to count do - Hash_set_poly.add v i - done ; - for _ = 0 to 3 do - for i = 0 to count do - assert (Hash_set_poly.mem v i) - done - done - end +let bench () = + Ounit_tests_util.time "int hash set" (fun _ -> + let v = Hash_set_int.create 2_000_000 in + for i = 0 to count do + Hash_set_int.add v i + done; + for _ = 0 to 3 do + for i = 0 to count do + assert (Hash_set_int.mem v i) + done + done); + Ounit_tests_util.time "int hash set" (fun _ -> + let v = Hash_set_poly.create 2_000_000 in + for i = 0 to count do + Hash_set_poly.add v i + done; + for _ = 0 to 3 do + for i = 0 to count do + assert (Hash_set_poly.mem v i) + done + done) - -type id (* = Ident.t *) = { stamp : int; name : string; mutable flags : int; } -let hash id = Bs_hash_stubs.hash_stamp_and_name id.stamp id.name -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_int 0 =~ Hashtbl.hash 0 - end; - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_int max_int =~ Hashtbl.hash max_int - end; - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_int max_int =~ Hashtbl.hash max_int - end; - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_string "The quick brown fox jumps over the lazy dog" =~ - Hashtbl.hash "The quick brown fox jumps over the lazy dog" - end; - __LOC__ >:: begin fun _ -> - Array.init 100 (fun i -> String.make i 'a' ) - |> Array.iter (fun x -> - Bs_hash_stubs.hash_string x =~ Hashtbl.hash x) - end; - __LOC__ >:: begin fun _ -> - (* only stamp matters here *) - hash {stamp = 1 ; name = "xx"; flags = 0} =~ Bs_hash_stubs.hash_small_int 1 ; - hash {stamp = 11 ; name = "xx"; flags = 0} =~ Bs_hash_stubs.hash_small_int 11; - end; - __LOC__ >:: begin fun _ -> - (* only string matters here *) - hash {stamp = 0 ; name = "Pervasives"; flags = 0} =~ Bs_hash_stubs.hash_string "Pervasives"; - hash {stamp = 0 ; name = "UU"; flags = 0} =~ Bs_hash_stubs.hash_string "UU"; - end; - __LOC__ >:: begin fun _ -> - let v = Array.init 20 (fun i -> i) in - let u = Array.init 30 (fun i -> (0-i) ) in - Bs_hash_stubs.int_unsafe_blit - v 0 u 10 20 ; - OUnit.assert_equal u (Array.init 30 (fun i -> if i < 10 then -i else i - 10)) - end - ] +type id = {stamp: int; name: string; mutable flags: int} (* = Ident.t *) +let hash id = Bs_hash_stubs.hash_stamp_and_name id.stamp id.name +let suites = + __FILE__ + >::: [ + (__LOC__ >:: fun _ -> Bs_hash_stubs.hash_int 0 =~ Hashtbl.hash 0); + ( __LOC__ >:: fun _ -> + Bs_hash_stubs.hash_int max_int =~ Hashtbl.hash max_int ); + ( __LOC__ >:: fun _ -> + Bs_hash_stubs.hash_int max_int =~ Hashtbl.hash max_int ); + ( __LOC__ >:: fun _ -> + Bs_hash_stubs.hash_string + "The quick brown fox jumps over the lazy dog" + =~ Hashtbl.hash "The quick brown fox jumps over the lazy dog" ); + ( __LOC__ >:: fun _ -> + Array.init 100 (fun i -> String.make i 'a') + |> Array.iter (fun x -> + Bs_hash_stubs.hash_string x =~ Hashtbl.hash x) ); + ( __LOC__ >:: fun _ -> + (* only stamp matters here *) + hash {stamp = 1; name = "xx"; flags = 0} + =~ Bs_hash_stubs.hash_small_int 1; + hash {stamp = 11; name = "xx"; flags = 0} + =~ Bs_hash_stubs.hash_small_int 11 ); + ( __LOC__ >:: fun _ -> + (* only string matters here *) + hash {stamp = 0; name = "Pervasives"; flags = 0} + =~ Bs_hash_stubs.hash_string "Pervasives"; + hash {stamp = 0; name = "UU"; flags = 0} + =~ Bs_hash_stubs.hash_string "UU" ); + ( __LOC__ >:: fun _ -> + let v = Array.init 20 (fun i -> i) in + let u = Array.init 30 (fun i -> 0 - i) in + Bs_hash_stubs.int_unsafe_blit v 0 u 10 20; + OUnit.assert_equal u + (Array.init 30 (fun i -> if i < 10 then -i else i - 10)) ); + ] diff --git a/compiler/ounit_tests/ounit_hashtbl_tests.ml b/compiler/ounit_tests/ounit_hashtbl_tests.ml index 96980b804f..fde7bb0aae 100644 --- a/compiler/ounit_tests/ounit_hashtbl_tests.ml +++ b/compiler/ounit_tests/ounit_hashtbl_tests.ml @@ -1,53 +1,46 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal ~printer:Ext_obj.dump +let ( =~ ) = OUnit.assert_equal ~printer:Ext_obj.dump - -let suites = +let suites = __FILE__ - >:::[ - (* __LOC__ >:: begin fun _ -> *) - (* let h = Hash_string.create 0 in *) - (* let accu key = *) - (* Hash_string.replace_or_init h key succ 1 in *) - (* let count = 1000 in *) - (* for i = 0 to count - 1 do *) - (* Array.iter accu [|"a";"b";"c";"d";"e";"f"|] *) - (* done; *) - (* Hash_string.length h =~ 6; *) - (* Hash_string.iter (fun _ v -> v =~ count ) h *) - (* end; *) - - "add semantics " >:: begin fun _ -> - let h = Hash_string.create 0 in - let count = 1000 in - for _ = 0 to 1 do - for i = 0 to count - 1 do - Hash_string.add h (string_of_int i) i - done - done ; - Hash_string.length h =~ 2 * count - end; - "replace semantics" >:: begin fun _ -> - let h = Hash_string.create 0 in - let count = 1000 in - for _ = 0 to 1 do - for i = 0 to count - 1 do - Hash_string.replace h (string_of_int i) i - done - done ; - Hash_string.length h =~ count - end; - - __LOC__ >:: begin fun _ -> - let h = Hash_string.create 0 in - let count = 10 in - for i = 0 to count - 1 do - Hash_string.replace h (string_of_int i) i - done; - let xs = Hash_string.to_list h (fun k _ -> k) in - let ys = List.sort compare xs in - ys =~ ["0";"1";"2";"3";"4";"5";"6";"7";"8";"9"] - end - ] + >::: [ + (* __LOC__ >:: begin fun _ -> *) + (* let h = Hash_string.create 0 in *) + (* let accu key = *) + (* Hash_string.replace_or_init h key succ 1 in *) + (* let count = 1000 in *) + (* for i = 0 to count - 1 do *) + (* Array.iter accu [|"a";"b";"c";"d";"e";"f"|] *) + (* done; *) + (* Hash_string.length h =~ 6; *) + (* Hash_string.iter (fun _ v -> v =~ count ) h *) + (* end; *) + ( "add semantics " >:: fun _ -> + let h = Hash_string.create 0 in + let count = 1000 in + for _ = 0 to 1 do + for i = 0 to count - 1 do + Hash_string.add h (string_of_int i) i + done + done; + Hash_string.length h =~ 2 * count ); + ( "replace semantics" >:: fun _ -> + let h = Hash_string.create 0 in + let count = 1000 in + for _ = 0 to 1 do + for i = 0 to count - 1 do + Hash_string.replace h (string_of_int i) i + done + done; + Hash_string.length h =~ count ); + ( __LOC__ >:: fun _ -> + let h = Hash_string.create 0 in + let count = 10 in + for i = 0 to count - 1 do + Hash_string.replace h (string_of_int i) i + done; + let xs = Hash_string.to_list h (fun k _ -> k) in + let ys = List.sort compare xs in + ys =~ ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"] ); + ] diff --git a/compiler/ounit_tests/ounit_ident_mask_tests.ml b/compiler/ounit_tests/ounit_ident_mask_tests.ml index 10a2b46256..be644e702d 100644 --- a/compiler/ounit_tests/ounit_ident_mask_tests.ml +++ b/compiler/ounit_tests/ounit_ident_mask_tests.ml @@ -1,53 +1,59 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal -let suites = +let ( =~ ) = OUnit.assert_equal +let suites = __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - let set = Hash_set_ident_mask.create 0 in - let a,b,_,_ = - Ident.create "a", - Ident.create "b", - Ident.create "c", - Ident.create "d" in - Hash_set_ident_mask.add_unmask set a ; - Hash_set_ident_mask.add_unmask set a ; - Hash_set_ident_mask.add_unmask set b ; - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set a); - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set b ); - Hash_set_ident_mask.iter_and_unmask set (fun id mask -> - if id.Ident.name = "a" then - OUnit.assert_bool __LOC__ mask - else if id.Ident.name = "b" then - OUnit.assert_bool __LOC__ mask - else () - ) ; - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set a ); - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set b ); - end; - __LOC__ >:: begin fun _ -> - let len = 1000 in - let idents = Array.init len (fun i -> Ident.create (string_of_int i)) in - let set = Hash_set_ident_mask.create 0 in - Array.iter (fun i -> Hash_set_ident_mask.add_unmask set i) idents; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)); - done ; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i) ); - done ; - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set idents.(len - 1)) ; - Hash_set_ident_mask.iter_and_unmask set(fun _ _ -> ()) ; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i) ); - done ; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)); - done ; - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set idents.(len - 1)) ; - - end - ] \ No newline at end of file + >::: [ + ( __LOC__ >:: fun _ -> + let set = Hash_set_ident_mask.create 0 in + let a, b, _, _ = + ( Ident.create "a", + Ident.create "b", + Ident.create "c", + Ident.create "d" ) + in + Hash_set_ident_mask.add_unmask set a; + Hash_set_ident_mask.add_unmask set a; + Hash_set_ident_mask.add_unmask set b; + OUnit.assert_bool __LOC__ + (not @@ Hash_set_ident_mask.mask_and_check_all_hit set a); + OUnit.assert_bool __LOC__ + (Hash_set_ident_mask.mask_and_check_all_hit set b); + Hash_set_ident_mask.iter_and_unmask set (fun id mask -> + if id.Ident.name = "a" then OUnit.assert_bool __LOC__ mask + else if id.Ident.name = "b" then OUnit.assert_bool __LOC__ mask + else ()); + OUnit.assert_bool __LOC__ + (not @@ Hash_set_ident_mask.mask_and_check_all_hit set a); + OUnit.assert_bool __LOC__ + (Hash_set_ident_mask.mask_and_check_all_hit set b) ); + ( __LOC__ >:: fun _ -> + let len = 1000 in + let idents = + Array.init len (fun i -> Ident.create (string_of_int i)) + in + let set = Hash_set_ident_mask.create 0 in + Array.iter (fun i -> Hash_set_ident_mask.add_unmask set i) idents; + for i = 0 to len - 2 do + OUnit.assert_bool __LOC__ + (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)) + done; + for i = 0 to len - 2 do + OUnit.assert_bool __LOC__ + (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)) + done; + OUnit.assert_bool __LOC__ + (Hash_set_ident_mask.mask_and_check_all_hit set idents.(len - 1)); + Hash_set_ident_mask.iter_and_unmask set (fun _ _ -> ()); + for i = 0 to len - 2 do + OUnit.assert_bool __LOC__ + (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)) + done; + for i = 0 to len - 2 do + OUnit.assert_bool __LOC__ + (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)) + done; + OUnit.assert_bool __LOC__ + (Hash_set_ident_mask.mask_and_check_all_hit set idents.(len - 1)) + ); + ] diff --git a/compiler/ounit_tests/ounit_int_vec_tests.ml b/compiler/ounit_tests/ounit_int_vec_tests.ml index dc29ba9a5b..b814518dc0 100644 --- a/compiler/ounit_tests/ounit_int_vec_tests.ml +++ b/compiler/ounit_tests/ounit_int_vec_tests.ml @@ -1,33 +1,23 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Int_vec_util.mem 3 (Vec_int.of_list [1;2;3])) - ; - OUnit.assert_bool __LOC__ - (not @@ Int_vec_util.mem 0 (Vec_int.of_list [1;2]) ); - - let v = Vec_int.make 100 in - OUnit.assert_bool __LOC__ - (not @@ Int_vec_util.mem 0 v) ; - Vec_int.push v 0; - OUnit.assert_bool __LOC__ - (Int_vec_util.mem 0 v ) - end; +let ( =~ ) = OUnit.assert_equal +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Int_vec_util.mem 3 (Vec_int.of_list [1; 2; 3])); + OUnit.assert_bool __LOC__ + (not @@ Int_vec_util.mem 0 (Vec_int.of_list [1; 2])); - __LOC__ >:: begin fun _ -> - let u = Vec_int.make 100 in - Vec_int.push u 1; - OUnit.assert_bool __LOC__ - (not @@ Int_vec_util.mem 0 u ); - Vec_int.push u 0; - OUnit.assert_bool __LOC__ - (Int_vec_util.mem 0 u) - end - ] \ No newline at end of file + let v = Vec_int.make 100 in + OUnit.assert_bool __LOC__ (not @@ Int_vec_util.mem 0 v); + Vec_int.push v 0; + OUnit.assert_bool __LOC__ (Int_vec_util.mem 0 v) ); + ( __LOC__ >:: fun _ -> + let u = Vec_int.make 100 in + Vec_int.push u 1; + OUnit.assert_bool __LOC__ (not @@ Int_vec_util.mem 0 u); + Vec_int.push u 0; + OUnit.assert_bool __LOC__ (Int_vec_util.mem 0 u) ); + ] diff --git a/compiler/ounit_tests/ounit_js_regex_checker_tests.ml b/compiler/ounit_tests/ounit_js_regex_checker_tests.ml index 0b1e1c31ec..363a131c32 100644 --- a/compiler/ounit_tests/ounit_js_regex_checker_tests.ml +++ b/compiler/ounit_tests/ounit_js_regex_checker_tests.ml @@ -1,46 +1,35 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) open Ext_js_regex let suites = - __FILE__ - >::: - [ - "test_empty_string" >:: begin fun _ -> - let b = js_regex_checker "" in - OUnit.assert_equal b false - end; - "test_normal_regex" >:: begin fun _ -> - let b = js_regex_checker "/abc/" in - OUnit.assert_equal b true - end; - "test_wrong_regex_last" >:: begin fun _ -> - let b = js_regex_checker "/abc" in - OUnit.assert_equal b false - end; - "test_regex_with_flag" >:: begin fun _ -> - let b = js_regex_checker "/ss/ig" in - OUnit.assert_equal b true - end; - "test_regex_with_invalid_flag" >:: begin fun _ -> - let b = js_regex_checker "/ss/j" in - OUnit.assert_equal b false - end; - "test_regex_invalid_regex" >:: begin fun _ -> - let b = js_regex_checker "abc/i" in - OUnit.assert_equal b false - end; - "test_regex_empty_pattern" >:: begin fun _ -> - let b = js_regex_checker "//" in - OUnit.assert_equal b true - end; - "test_regex_with_utf8" >:: begin fun _ -> - let b = js_regex_checker "/😃/" in - OUnit.assert_equal b true - end; - "test_regex_repeated_flags" >:: begin fun _ -> - let b = js_regex_checker "/abc/gg" in - OUnit.assert_equal b false - end; - ] \ No newline at end of file + __FILE__ + >::: [ + ( "test_empty_string" >:: fun _ -> + let b = js_regex_checker "" in + OUnit.assert_equal b false ); + ( "test_normal_regex" >:: fun _ -> + let b = js_regex_checker "/abc/" in + OUnit.assert_equal b true ); + ( "test_wrong_regex_last" >:: fun _ -> + let b = js_regex_checker "/abc" in + OUnit.assert_equal b false ); + ( "test_regex_with_flag" >:: fun _ -> + let b = js_regex_checker "/ss/ig" in + OUnit.assert_equal b true ); + ( "test_regex_with_invalid_flag" >:: fun _ -> + let b = js_regex_checker "/ss/j" in + OUnit.assert_equal b false ); + ( "test_regex_invalid_regex" >:: fun _ -> + let b = js_regex_checker "abc/i" in + OUnit.assert_equal b false ); + ( "test_regex_empty_pattern" >:: fun _ -> + let b = js_regex_checker "//" in + OUnit.assert_equal b true ); + ( "test_regex_with_utf8" >:: fun _ -> + let b = js_regex_checker "/😃/" in + OUnit.assert_equal b true ); + ( "test_regex_repeated_flags" >:: fun _ -> + let b = js_regex_checker "/abc/gg" in + OUnit.assert_equal b false ); + ] diff --git a/compiler/ounit_tests/ounit_json_tests.ml b/compiler/ounit_tests/ounit_json_tests.ml index 7990049071..00ceefd492 100644 --- a/compiler/ounit_tests/ounit_json_tests.ml +++ b/compiler/ounit_tests/ounit_json_tests.ml @@ -1,185 +1,153 @@ - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) -type t = Ext_json_noloc.t -let rec equal - (x : t) - (y : t) = - match x with - | Null -> (* [%p? Null _ ] *) - begin match y with - | Null -> true - | _ -> false end - | Str str -> - begin match y with - | Str str2 -> str = str2 - | _ -> false end - | Flo flo - -> - begin match y with - | Flo flo2 -> - flo = flo2 - | _ -> false - end - | True -> - begin match y with - | True -> true - | _ -> false - end - | False -> - begin match y with - | False -> true - | _ -> false - end - | Arr content - -> - begin match y with - | Arr content2 - -> - Ext_array.for_all2_no_exn content content2 equal - | _ -> false - end - - | Obj map -> - begin match y with - | Obj map2 -> - let xs = Map_string.bindings map - |> List.sort (fun (a,_) (b,_) -> compare a b) in - let ys = Map_string.bindings map2 - |> List.sort (fun (a,_) (b,_) -> compare a b) in - Ext_list.for_all2_no_exn xs ys (fun (k0,v0) (k1,v1) -> k0=k1 && equal v0 v1) - | _ -> false - end - +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +type t = Ext_json_noloc.t +let rec equal (x : t) (y : t) = + match x with + | Null -> ( + (* [%p? Null _ ] *) + match y with + | Null -> true + | _ -> false) + | Str str -> ( + match y with + | Str str2 -> str = str2 + | _ -> false) + | Flo flo -> ( + match y with + | Flo flo2 -> flo = flo2 + | _ -> false) + | True -> ( + match y with + | True -> true + | _ -> false) + | False -> ( + match y with + | False -> true + | _ -> false) + | Arr content -> ( + match y with + | Arr content2 -> Ext_array.for_all2_no_exn content content2 equal + | _ -> false) + | Obj map -> ( + match y with + | Obj map2 -> + let xs = + Map_string.bindings map |> List.sort (fun (a, _) (b, _) -> compare a b) + in + let ys = + Map_string.bindings map2 |> List.sort (fun (a, _) (b, _) -> compare a b) + in + Ext_list.for_all2_no_exn xs ys (fun (k0, v0) (k1, v1) -> + k0 = k1 && equal v0 v1) + | _ -> false) open Ext_json_parse -let (|?) m (key, cb) = - m |> Ext_json.test key cb +let ( |? ) m (key, cb) = m |> Ext_json.test key cb -let rec strip (x : Ext_json_types.t) : Ext_json_noloc.t = - let open Ext_json_noloc in - match x with +let rec strip (x : Ext_json_types.t) : Ext_json_noloc.t = + let open Ext_json_noloc in + match x with | True _ -> true_ | False _ -> false_ | Null _ -> null - | Flo {flo = s} -> flo s - | Str {str = s} -> str s - | Arr {content } -> arr (Array.map strip content) - | Obj {map} -> - obj (Map_string.map map strip) + | Flo {flo = s} -> flo s + | Str {str = s} -> str s + | Arr {content} -> arr (Array.map strip content) + | Obj {map} -> obj (Map_string.map map strip) -let id_parsing_serializing x = - let normal_s = - Ext_json_noloc.to_string - @@ strip - @@ Ext_json_parse.parse_json_from_string x - in - let normal_ss = - Ext_json_noloc.to_string - @@ strip +let id_parsing_serializing x = + let normal_s = + Ext_json_noloc.to_string @@ strip @@ Ext_json_parse.parse_json_from_string x + in + let normal_ss = + Ext_json_noloc.to_string @@ strip @@ Ext_json_parse.parse_json_from_string normal_s - in - if normal_s <> normal_ss then - begin - prerr_endline "ERROR"; - prerr_endline normal_s ; - prerr_endline normal_ss ; - end; - OUnit.assert_equal ~cmp:(fun (x:string) y -> x = y) normal_s normal_ss + in + if normal_s <> normal_ss then ( + prerr_endline "ERROR"; + prerr_endline normal_s; + prerr_endline normal_ss); + OUnit.assert_equal ~cmp:(fun (x : string) y -> x = y) normal_s normal_ss -let id_parsing_x2 x = - let stru = Ext_json_parse.parse_json_from_string x |> strip in - let normal_s = Ext_json_noloc.to_string stru in - let normal_ss = strip (Ext_json_parse.parse_json_from_string normal_s) in - if equal stru normal_ss then - true - else begin +let id_parsing_x2 x = + let stru = Ext_json_parse.parse_json_from_string x |> strip in + let normal_s = Ext_json_noloc.to_string stru in + let normal_ss = strip (Ext_json_parse.parse_json_from_string normal_s) in + if equal stru normal_ss then true + else ( prerr_endline "ERROR"; prerr_endline normal_s; - Format.fprintf Format.err_formatter - "%a@.%a@." Ext_obj.pp_any stru Ext_obj.pp_any normal_ss; - + Format.fprintf Format.err_formatter "%a@.%a@." Ext_obj.pp_any stru + Ext_obj.pp_any normal_ss; + prerr_endline (Ext_json_noloc.to_string normal_ss); - false - end + false) -let test_data = - [{| +let test_data = + [ + {| {} |}; - {| [] |}; - {| [1,2,3]|}; - {| ["x", "y", 1,2,3 ]|}; - {| { "x" : 3, "y" : "x", "z" : [1,2,3, "x"] }|}; - {| {"x " : true , "y" : false , "z\"" : 1} |} - ] -exception Parse_error -let suites = - __FILE__ - >::: - [ - - __LOC__ >:: begin fun _ -> - List.iter id_parsing_serializing test_data - end; - - __LOC__ >:: begin fun _ -> - List.iteri (fun i x -> OUnit.assert_bool (__LOC__ ^ string_of_int i ) (id_parsing_x2 x)) test_data - end; - "empty_json" >:: begin fun _ -> - let v =parse_json_from_string "{}" in - match v with - | Obj {map = v} -> OUnit.assert_equal (Map_string.is_empty v ) true - | _ -> OUnit.assert_failure "should be empty" - end - ; - "empty_arr" >:: begin fun _ -> - let v =parse_json_from_string "[]" in - match v with - | Arr {content = [||]} -> () - | _ -> OUnit.assert_failure "should be empty" - end - ; - "empty trails" >:: begin fun _ -> - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| [,]|} with _ -> raise Parse_error); - OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| {,}|} with _ -> raise Parse_error - end; - "two trails" >:: begin fun _ -> - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| [1,2,,]|} with _ -> raise Parse_error); - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| { "x": 3, ,}|} with _ -> raise Parse_error) - end; - - "two trails fail" >:: begin fun _ -> - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| { "x": 3, 2 ,}|} with _ -> raise Parse_error) - end; - - "trail comma obj" >:: begin fun _ -> - let v = parse_json_from_string {| { "x" : 3 , }|} in - let v1 = parse_json_from_string {| { "x" : 3 , }|} in - let test (v : Ext_json_types.t) = - match v with - | Obj {map = v} -> - v - |? ("x" , `Flo (fun x -> OUnit.assert_equal x "3")) - |> ignore - | _ -> OUnit.assert_failure "trail comma" in - test v ; - test v1 - end - ; - "trail comma arr" >:: begin fun _ -> - let v = parse_json_from_string {| [ 1, 3, ]|} in - let v1 = parse_json_from_string {| [ 1, 3 ]|} in - let test (v : Ext_json_types.t) = - match v with - | Arr { content = [| Flo {flo = "1"} ; Flo { flo = "3"} |] } -> () - | _ -> OUnit.assert_failure "trailing comma array" in - test v ; - test v1 - end + {| [] |}; + {| [1,2,3]|}; + {| ["x", "y", 1,2,3 ]|}; + {| { "x" : 3, "y" : "x", "z" : [1,2,3, "x"] }|}; + {| {"x " : true , "y" : false , "z\"" : 1} |}; ] +exception Parse_error +let suites = + __FILE__ + >::: [ + (__LOC__ >:: fun _ -> List.iter id_parsing_serializing test_data); + ( __LOC__ >:: fun _ -> + List.iteri + (fun i x -> + OUnit.assert_bool (__LOC__ ^ string_of_int i) (id_parsing_x2 x)) + test_data ); + ( "empty_json" >:: fun _ -> + let v = parse_json_from_string "{}" in + match v with + | Obj {map = v} -> OUnit.assert_equal (Map_string.is_empty v) true + | _ -> OUnit.assert_failure "should be empty" ); + ( "empty_arr" >:: fun _ -> + let v = parse_json_from_string "[]" in + match v with + | Arr {content = [||]} -> () + | _ -> OUnit.assert_failure "should be empty" ); + ( "empty trails" >:: fun _ -> + ( OUnit.assert_raises Parse_error @@ fun _ -> + try parse_json_from_string {| [,]|} with _ -> raise Parse_error ); + OUnit.assert_raises Parse_error @@ fun _ -> + try parse_json_from_string {| {,}|} with _ -> raise Parse_error ); + ( "two trails" >:: fun _ -> + ( OUnit.assert_raises Parse_error @@ fun _ -> + try parse_json_from_string {| [1,2,,]|} + with _ -> raise Parse_error ); + OUnit.assert_raises Parse_error @@ fun _ -> + try parse_json_from_string {| { "x": 3, ,}|} + with _ -> raise Parse_error ); + ( "two trails fail" >:: fun _ -> + OUnit.assert_raises Parse_error @@ fun _ -> + try parse_json_from_string {| { "x": 3, 2 ,}|} + with _ -> raise Parse_error ); + ( "trail comma obj" >:: fun _ -> + let v = parse_json_from_string {| { "x" : 3 , }|} in + let v1 = parse_json_from_string {| { "x" : 3 , }|} in + let test (v : Ext_json_types.t) = + match v with + | Obj {map = v} -> + v |? ("x", `Flo (fun x -> OUnit.assert_equal x "3")) |> ignore + | _ -> OUnit.assert_failure "trail comma" + in + test v; + test v1 ); + ( "trail comma arr" >:: fun _ -> + let v = parse_json_from_string {| [ 1, 3, ]|} in + let v1 = parse_json_from_string {| [ 1, 3 ]|} in + let test (v : Ext_json_types.t) = + match v with + | Arr {content = [|Flo {flo = "1"}; Flo {flo = "3"}|]} -> () + | _ -> OUnit.assert_failure "trailing comma array" + in + test v; + test v1 ); + ] diff --git a/compiler/ounit_tests/ounit_list_test.ml b/compiler/ounit_tests/ounit_list_test.ml index 2fe732e09c..c08725ddab 100644 --- a/compiler/ounit_tests/ounit_list_test.ml +++ b/compiler/ounit_tests/ounit_list_test.ml @@ -1,145 +1,102 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal -let printer_int_list = fun xs -> Format.asprintf "%a" - (Format.pp_print_list Format.pp_print_int - ~pp_sep:Format.pp_print_space - ) xs -let suites = +let ( =~ ) = OUnit.assert_equal +let printer_int_list xs = + Format.asprintf "%a" + (Format.pp_print_list Format.pp_print_int ~pp_sep:Format.pp_print_space) + xs +let suites = __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.flat_map [1;2] (fun x -> [x;x]) ) [1;1;2;2] - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.flat_map_append - [1;2] [3;4] (fun x -> [x;x]) ) [1;1;2;2;3;4] - end; - __LOC__ >:: begin fun _ -> - - let (=~) = OUnit.assert_equal ~printer:printer_int_list in - (Ext_list.flat_map [] (fun x -> [succ x ])) =~ []; - (Ext_list.flat_map [1] (fun x -> [x;succ x ]) ) =~ [1;2]; - (Ext_list.flat_map [1;2] (fun x -> [x;succ x ])) =~ [1;2;2;3]; - (Ext_list.flat_map [1;2;3] (fun x -> [x;succ x ]) ) =~ [1;2;2;3;3;4] - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.stable_group - [1;2;3;4;3] (=) - ) - ([[1];[2];[4];[3;3]]) - end - ; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:printer_int_list in - let f b _v = if b then 1 else 0 in - Ext_list.map_last [] f =~ []; - Ext_list.map_last [0] f =~ [1]; - Ext_list.map_last [0;0] f =~ [0;1]; - Ext_list.map_last [0;0;0] f =~ [0;0;1]; - Ext_list.map_last [0;0;0;0] f =~ [0;0;0;1]; - Ext_list.map_last [0;0;0;0;0] f =~ [0;0;0;0;1]; - Ext_list.map_last [0;0;0;0;0;0] f =~ [0;0;0;0;0;1]; - Ext_list.map_last [0;0;0;0;0;0;0] f =~ [0;0;0;0;0;0;1]; - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal ( - Ext_list.flat_map_append - [1;2] [false;false] - (fun x -> if x mod 2 = 0 then [true] else []) - ) [true;false;false] - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal ( - Ext_list.map_append - [0;1;2] - ["1";"2";"3"] - (fun x -> string_of_int x) - ) - ["0";"1";"2"; "1";"2";"3"] - end; + >::: [ + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (Ext_list.flat_map [1; 2] (fun x -> [x; x])) + [1; 1; 2; 2] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (Ext_list.flat_map_append [1; 2] [3; 4] (fun x -> [x; x])) + [1; 1; 2; 2; 3; 4] ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal ~printer:printer_int_list in + Ext_list.flat_map [] (fun x -> [succ x]) =~ []; + Ext_list.flat_map [1] (fun x -> [x; succ x]) =~ [1; 2]; + Ext_list.flat_map [1; 2] (fun x -> [x; succ x]) =~ [1; 2; 2; 3]; + Ext_list.flat_map [1; 2; 3] (fun x -> [x; succ x]) + =~ [1; 2; 2; 3; 3; 4] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (Ext_list.stable_group [1; 2; 3; 4; 3] ( = )) + [[1]; [2]; [4]; [3; 3]] ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal ~printer:printer_int_list in + let f b _v = if b then 1 else 0 in + Ext_list.map_last [] f =~ []; + Ext_list.map_last [0] f =~ [1]; + Ext_list.map_last [0; 0] f =~ [0; 1]; + Ext_list.map_last [0; 0; 0] f =~ [0; 0; 1]; + Ext_list.map_last [0; 0; 0; 0] f =~ [0; 0; 0; 1]; + Ext_list.map_last [0; 0; 0; 0; 0] f =~ [0; 0; 0; 0; 1]; + Ext_list.map_last [0; 0; 0; 0; 0; 0] f =~ [0; 0; 0; 0; 0; 1]; + Ext_list.map_last [0; 0; 0; 0; 0; 0; 0] f =~ [0; 0; 0; 0; 0; 0; 1] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (Ext_list.flat_map_append [1; 2] [false; false] (fun x -> + if x mod 2 = 0 then [true] else [])) + [true; false; false] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (Ext_list.map_append [0; 1; 2] ["1"; "2"; "3"] (fun x -> + string_of_int x)) + ["0"; "1"; "2"; "1"; "2"; "3"] ); + ( __LOC__ >:: fun _ -> + let a, b = Ext_list.split_at [1; 2; 3; 4; 5; 6] 3 in + OUnit.assert_equal (a, b) ([1; 2; 3], [4; 5; 6]); + OUnit.assert_equal (Ext_list.split_at [1] 1) ([1], []); + OUnit.assert_equal (Ext_list.split_at [1; 2; 3] 2) ([1; 2], [3]) ); + ( __LOC__ >:: fun _ -> + let printer (a, b) = + Format.asprintf "([%a],%d)" + (Format.pp_print_list Format.pp_print_int) + a b + in + let ( =~ ) = OUnit.assert_equal ~printer in + Ext_list.split_at_last [1; 2; 3] =~ ([1; 2], 3); + Ext_list.split_at_last [1; 2; 3; 4; 5; 6; 7; 8] + =~ ([1; 2; 3; 4; 5; 6; 7], 8); + Ext_list.split_at_last [1; 2; 3; 4; 5; 6; 7] + =~ ([1; 2; 3; 4; 5; 6], 7) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (Ext_list.assoc_by_int [(2, "x"); (3, "y"); (1, "z")] 1 None) + "z" ); + ( __LOC__ >:: fun _ -> + Ounit_tests_util.assert_raise_any (fun _ -> + Ext_list.assoc_by_int [(2, "x"); (3, "y"); (1, "z")] 11 None) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal (Ext_list.length_compare [0; 0; 0] 3) `Eq; + OUnit.assert_equal (Ext_list.length_compare [0; 0; 0] 1) `Gt; + OUnit.assert_equal (Ext_list.length_compare [0; 0; 0] 4) `Lt; + OUnit.assert_equal (Ext_list.length_compare [] (-1)) `Gt; + OUnit.assert_equal (Ext_list.length_compare [] 0) `Eq ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Ext_list.length_larger_than_n [1; 2] [1] 1); + OUnit.assert_bool __LOC__ + (Ext_list.length_larger_than_n [1; 2] [1; 2] 0); + OUnit.assert_bool __LOC__ (Ext_list.length_larger_than_n [1; 2] [] 2) + ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_list.length_ge [1; 2; 3] 3); + OUnit.assert_bool __LOC__ (Ext_list.length_ge [] 0); + OUnit.assert_bool __LOC__ (not (Ext_list.length_ge [] 1)) ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal in - __LOC__ >:: begin fun _ -> - let (a,b) = Ext_list.split_at [1;2;3;4;5;6] 3 in - OUnit.assert_equal (a,b) - ([1;2;3],[4;5;6]); - OUnit.assert_equal (Ext_list.split_at [1] 1) - ([1],[]) ; - OUnit.assert_equal (Ext_list.split_at [1;2;3] 2 ) - ([1;2],[3]) - end; - __LOC__ >:: begin fun _ -> - let printer = fun (a,b) -> - Format.asprintf "([%a],%d)" - (Format.pp_print_list Format.pp_print_int ) a - b - in - let (=~) = OUnit.assert_equal ~printer in - (Ext_list.split_at_last [1;2;3]) - =~ ([1;2],3); - (Ext_list.split_at_last [1;2;3;4;5;6;7;8]) - =~ - ([1;2;3;4;5;6;7],8); - (Ext_list.split_at_last [1;2;3;4;5;6;7;]) - =~ - ([1;2;3;4;5;6],7) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (Ext_list.assoc_by_int [2,"x"; 3,"y"; 1, "z"] 1 None) "z" - end; - __LOC__ >:: begin fun _ -> - Ounit_tests_util.assert_raise_any - (fun _ -> Ext_list.assoc_by_int [2,"x"; 3,"y"; 1, "z"] 11 None ) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.length_compare [0;0;0] 3) `Eq ; - OUnit.assert_equal - (Ext_list.length_compare [0;0;0] 1) `Gt ; - OUnit.assert_equal - (Ext_list.length_compare [0;0;0] 4) `Lt ; - OUnit.assert_equal - (Ext_list.length_compare [] (-1)) `Gt ; - OUnit.assert_equal - (Ext_list.length_compare [] (0)) `Eq ; - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [1;2] [1] 1 ); - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [1;2] [1;2] 0); - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [1;2] [] 2) - - end; - - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_list.length_ge [1;2;3] 3 ); - OUnit.assert_bool __LOC__ - (Ext_list.length_ge [] 0 ); - OUnit.assert_bool __LOC__ - (not (Ext_list.length_ge [] 1 )); - - end; - - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal in - - let f p x = Ext_list.exclude_with_val x p in - f (fun x -> x = 1) [1;2;3] =~ (Some [2;3]); - f (fun x -> x = 4) [1;2;3] =~ (None); - f (fun x -> x = 2) [1;2;3;2] =~ (Some [1;3]); - f (fun x -> x = 2) [1;2;2;3;2] =~ (Some [1;3]); - f (fun x -> x = 2) [2;2;2] =~ (Some []); - f (fun x -> x = 3) [2;2;2] =~ (None) - end ; - - ] \ No newline at end of file + let f p x = Ext_list.exclude_with_val x p in + f (fun x -> x = 1) [1; 2; 3] =~ Some [2; 3]; + f (fun x -> x = 4) [1; 2; 3] =~ None; + f (fun x -> x = 2) [1; 2; 3; 2] =~ Some [1; 3]; + f (fun x -> x = 2) [1; 2; 2; 3; 2] =~ Some [1; 3]; + f (fun x -> x = 2) [2; 2; 2] =~ Some []; + f (fun x -> x = 3) [2; 2; 2] =~ None ); + ] diff --git a/compiler/ounit_tests/ounit_map_tests.ml b/compiler/ounit_tests/ounit_map_tests.ml index d75beb052e..b488f8eb42 100644 --- a/compiler/ounit_tests/ounit_map_tests.ml +++ b/compiler/ounit_tests/ounit_map_tests.ml @@ -1,59 +1,65 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal +let ( =~ ) = OUnit.assert_equal -let test_sorted_strict arr = - let v = Map_int.of_array arr |> Map_int.to_sorted_array in - let arr_copy = Array.copy arr in - Array.sort (fun ((a:int),_) (b,_) -> compare a b ) arr_copy; - v =~ arr_copy +let test_sorted_strict arr = + let v = Map_int.of_array arr |> Map_int.to_sorted_array in + let arr_copy = Array.copy arr in + Array.sort (fun ((a : int), _) (b, _) -> compare a b) arr_copy; + v =~ arr_copy -let suites = - __MODULE__ >::: - [ - __LOC__ >:: begin fun _ -> - [1,"1"; 2,"2"; 12,"12"; 3, "3"] - |> Map_int.of_list - |> Map_int.keys - |> OUnit.assert_equal [1;2;3;12] - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (Map_int.cardinal Map_int.empty) 0 ; - OUnit.assert_equal ([1,"1"; 2,"2"; 12,"12"; 3, "3"] - |> Map_int.of_list|>Map_int.cardinal ) 4 - end; - __LOC__ >:: begin fun _ -> - let v = - [1,"1"; 2,"2"; 12,"12"; 3, "3"] - |> Map_int.of_list - |> Map_int.to_sorted_array in - Array.length v =~ 4 ; - v =~ [|1,"1"; 2,"2"; 3, "3"; 12,"12"; |] - end; - __LOC__ >:: begin fun _ -> - test_sorted_strict [||]; - test_sorted_strict [|1,""|]; - test_sorted_strict [|2,""; 1,""|]; - test_sorted_strict [|2,""; 1,""; 3, ""|]; - test_sorted_strict [|2,""; 1,""; 3, ""; 4,""|] - end; - __LOC__ >:: begin fun _ -> - Map_int.cardinal (Map_int.of_array (Array.init 1000 (fun i -> (i,i)))) - =~ 1000 - end; - __LOC__ >:: begin fun _ -> - let count = 1000 in - let a = Array.init count (fun x -> x ) in - let v = Map_int.empty in - let u = - begin - let v = Array.fold_left (fun acc key -> Map_int.adjust acc key (fun v -> match v with None -> 1 | Some v -> succ v) ) v a in - Array.fold_left (fun acc key -> Map_int.adjust acc key (fun v -> match v with None -> 1 | Some v -> succ v) ) v a - end - in - Map_int.iter u (fun _ v -> v =~ 2 ) ; - Map_int.cardinal u =~ count - end - ] +let suites = + __MODULE__ + >::: [ + ( __LOC__ >:: fun _ -> + [(1, "1"); (2, "2"); (12, "12"); (3, "3")] + |> Map_int.of_list |> Map_int.keys + |> OUnit.assert_equal [1; 2; 3; 12] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal (Map_int.cardinal Map_int.empty) 0; + OUnit.assert_equal + ([(1, "1"); (2, "2"); (12, "12"); (3, "3")] + |> Map_int.of_list |> Map_int.cardinal) + 4 ); + ( __LOC__ >:: fun _ -> + let v = + [(1, "1"); (2, "2"); (12, "12"); (3, "3")] + |> Map_int.of_list |> Map_int.to_sorted_array + in + Array.length v =~ 4; + v =~ [|(1, "1"); (2, "2"); (3, "3"); (12, "12")|] ); + ( __LOC__ >:: fun _ -> + test_sorted_strict [||]; + test_sorted_strict [|(1, "")|]; + test_sorted_strict [|(2, ""); (1, "")|]; + test_sorted_strict [|(2, ""); (1, ""); (3, "")|]; + test_sorted_strict [|(2, ""); (1, ""); (3, ""); (4, "")|] ); + ( __LOC__ >:: fun _ -> + Map_int.cardinal + (Map_int.of_array (Array.init 1000 (fun i -> (i, i)))) + =~ 1000 ); + ( __LOC__ >:: fun _ -> + let count = 1000 in + let a = Array.init count (fun x -> x) in + let v = Map_int.empty in + let u = + let v = + Array.fold_left + (fun acc key -> + Map_int.adjust acc key (fun v -> + match v with + | None -> 1 + | Some v -> succ v)) + v a + in + Array.fold_left + (fun acc key -> + Map_int.adjust acc key (fun v -> + match v with + | None -> 1 + | Some v -> succ v)) + v a + in + Map_int.iter u (fun _ v -> v =~ 2); + Map_int.cardinal u =~ count ); + ] diff --git a/compiler/ounit_tests/ounit_path_tests.ml b/compiler/ounit_tests/ounit_path_tests.ml index 6cb5ad8561..ebe55eb16c 100644 --- a/compiler/ounit_tests/ounit_path_tests.ml +++ b/compiler/ounit_tests/ounit_path_tests.ml @@ -1,145 +1,110 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let normalize = Ext_path.normalize_absolute_path -let (=~) x y = - OUnit.assert_equal - ~printer:(fun x -> x) - ~cmp:(fun x y -> Ext_string.equal x y ) x y - -let suites = - __FILE__ - >::: - [ - "linux path tests" >:: begin fun _ -> - let norm = - Array.map normalize - [| - "/gsho/./.."; - "/a/b/../c../d/e/f"; - "/a/b/../c/../d/e/f"; - "/gsho/./../.."; - "/a/b/c/d"; - "/a/b/c/d/"; - "/a/"; - "/a"; - "/a.txt/"; - "/a.txt" - |] in - OUnit.assert_equal norm - [| - "/"; - "/a/c../d/e/f"; - "/a/d/e/f"; - "/"; - "/a/b/c/d" ; - "/a/b/c/d"; - "/a"; - "/a"; - "/a.txt"; - "/a.txt" - |] - end; - __LOC__ >:: begin fun _ -> - normalize "/./a/.////////j/k//../////..///././b/./c/d/./." =~ "/a/b/c/d" - end; - __LOC__ >:: begin fun _ -> - normalize "/./a/.////////j/k//../////..///././b/./c/d/././../" =~ "/a/b/c" - end; - - __LOC__ >:: begin fun _ -> - let aux a b result = - - Ext_path.rel_normalized_absolute_path - ~from:a b =~ result ; - - Ext_path.rel_normalized_absolute_path - ~from:(String.sub a 0 (String.length a - 1)) - b =~ result ; - - Ext_path.rel_normalized_absolute_path - ~from:a - (String.sub b 0 (String.length b - 1)) =~ result - ; - - - Ext_path.rel_normalized_absolute_path - ~from:(String.sub a 0 (String.length a - 1 )) - (String.sub b 0 (String.length b - 1)) - =~ result - in - aux - "/a/b/c/" - "/a/b/c/d/" "./d"; - aux - "/a/b/c/" - "/a/b/c/d/e/f/" "./d/e/f" ; - aux - "/a/b/c/d/" - "/a/b/c/" ".." ; - aux - "/a/b/c/d/" - "/a/b/" "../.." ; - aux - "/a/b/c/d/" - "/a/" "../../.." ; - aux - "/a/b/c/d/" - "//" "../../../.." ; - +let ( =~ ) x y = + OUnit.assert_equal + ~printer:(fun x -> x) + ~cmp:(fun x y -> Ext_string.equal x y) + x y - end; - (* This is still correct just not optimal depends - on user's perspective *) - __LOC__ >:: begin fun _ -> - Ext_path.rel_normalized_absolute_path - ~from:"/a/b/c/d" - "/x/y" =~ "../../../../x/y" +let suites = + __FILE__ + >::: [ + ( "linux path tests" >:: fun _ -> + let norm = + Array.map normalize + [| + "/gsho/./.."; + "/a/b/../c../d/e/f"; + "/a/b/../c/../d/e/f"; + "/gsho/./../.."; + "/a/b/c/d"; + "/a/b/c/d/"; + "/a/"; + "/a"; + "/a.txt/"; + "/a.txt"; + |] + in + OUnit.assert_equal norm + [| + "/"; + "/a/c../d/e/f"; + "/a/d/e/f"; + "/"; + "/a/b/c/d"; + "/a/b/c/d"; + "/a"; + "/a"; + "/a.txt"; + "/a.txt"; + |] ); + ( __LOC__ >:: fun _ -> + normalize "/./a/.////////j/k//../////..///././b/./c/d/./." + =~ "/a/b/c/d" ); + ( __LOC__ >:: fun _ -> + normalize "/./a/.////////j/k//../////..///././b/./c/d/././../" + =~ "/a/b/c" ); + ( __LOC__ >:: fun _ -> + let aux a b result = + Ext_path.rel_normalized_absolute_path ~from:a b =~ result; - end; + Ext_path.rel_normalized_absolute_path + ~from:(String.sub a 0 (String.length a - 1)) + b + =~ result; - (* used in module system: [es6-global] and [amdjs-global] *) - __LOC__ >:: begin fun _ -> - Ext_path.rel_normalized_absolute_path - ~from:"/usr/local/lib/node_modules/" - "//" =~ "../../../.."; - Ext_path.rel_normalized_absolute_path - ~from:"/usr/local/lib/node_modules/" - "/" =~ "../../../.."; - Ext_path.rel_normalized_absolute_path - ~from:"./" - "./node_modules/xx/./xx.js" =~ "./node_modules/xx/xx.js"; - Ext_path.rel_normalized_absolute_path - ~from:"././" - "./node_modules/xx/./xx.js" =~ "./node_modules/xx/xx.js" - end; + Ext_path.rel_normalized_absolute_path ~from:a + (String.sub b 0 (String.length b - 1)) + =~ result; - __LOC__ >:: begin fun _ -> - Ext_path.node_rebase_file - ~to_:( "lib/js/src/a") - ~from:( "lib/js/src") "b" =~ "./a/b" ; - Ext_path.node_rebase_file - ~to_:( "lib/js/src/") - ~from:( "lib/js/src") "b" =~ "./b" ; - Ext_path.node_rebase_file - ~to_:( "lib/js/src") - ~from:("lib/js/src/a") "b" =~ "../b"; - Ext_path.node_rebase_file - ~to_:( "lib/js/src/a") - ~from:("lib/js/") "b" =~ "./src/a/b" ; - Ext_path.node_rebase_file - ~to_:("lib/js/./src/a") - ~from:("lib/js/src/a/") "b" - =~ "./b"; + Ext_path.rel_normalized_absolute_path + ~from:(String.sub a 0 (String.length a - 1)) + (String.sub b 0 (String.length b - 1)) + =~ result + in + aux "/a/b/c/" "/a/b/c/d/" "./d"; + aux "/a/b/c/" "/a/b/c/d/e/f/" "./d/e/f"; + aux "/a/b/c/d/" "/a/b/c/" ".."; + aux "/a/b/c/d/" "/a/b/" "../.."; + aux "/a/b/c/d/" "/a/" "../../.."; + aux "/a/b/c/d/" "//" "../../../.." ); + (* This is still correct just not optimal depends + on user's perspective *) + ( __LOC__ >:: fun _ -> + Ext_path.rel_normalized_absolute_path ~from:"/a/b/c/d" "/x/y" + =~ "../../../../x/y" ); + (* used in module system: [es6-global] and [amdjs-global] *) + ( __LOC__ >:: fun _ -> + Ext_path.rel_normalized_absolute_path + ~from:"/usr/local/lib/node_modules/" "//" + =~ "../../../.."; + Ext_path.rel_normalized_absolute_path + ~from:"/usr/local/lib/node_modules/" "/" + =~ "../../../.."; + Ext_path.rel_normalized_absolute_path ~from:"./" + "./node_modules/xx/./xx.js" + =~ "./node_modules/xx/xx.js"; + Ext_path.rel_normalized_absolute_path ~from:"././" + "./node_modules/xx/./xx.js" + =~ "./node_modules/xx/xx.js" ); + ( __LOC__ >:: fun _ -> + Ext_path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/src" "b" + =~ "./a/b"; + Ext_path.node_rebase_file ~to_:"lib/js/src/" ~from:"lib/js/src" "b" + =~ "./b"; + Ext_path.node_rebase_file ~to_:"lib/js/src" ~from:"lib/js/src/a" "b" + =~ "../b"; + Ext_path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/" "b" + =~ "./src/a/b"; + Ext_path.node_rebase_file ~to_:"lib/js/./src/a" ~from:"lib/js/src/a/" + "b" + =~ "./b"; - Ext_path.node_rebase_file - ~to_:"lib/js/src/a" - ~from: "lib/js/src/a/" "b" - =~ "./b"; - Ext_path.node_rebase_file - ~to_:"lib/js/src/a/" - ~from:"lib/js/src/a/" "b" - =~ "./b" - end - ] + Ext_path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/src/a/" + "b" + =~ "./b"; + Ext_path.node_rebase_file ~to_:"lib/js/src/a/" ~from:"lib/js/src/a/" + "b" + =~ "./b" ); + ] diff --git a/compiler/ounit_tests/ounit_scc_tests.ml b/compiler/ounit_tests/ounit_scc_tests.ml index f20c087025..041925adaa 100644 --- a/compiler/ounit_tests/ounit_scc_tests.ml +++ b/compiler/ounit_tests/ounit_scc_tests.ml @@ -1,9 +1,9 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal +let ( =~ ) = OUnit.assert_equal -let tiny_test_cases = {| +let tiny_test_cases = + {| 13 22 4 2 @@ -28,9 +28,10 @@ let tiny_test_cases = {| 6 4 6 9 7 6 -|} +|} -let medium_test_cases = {| +let medium_test_cases = + {| 50 147 0 7 @@ -181,212 +182,201 @@ let medium_test_cases = {| 49 22 49 49 |} -(* -reference output: -http://algs4.cs.princeton.edu/42digraph/KosarajuSharirSCC.java.html +(* + reference output: + http://algs4.cs.princeton.edu/42digraph/KosarajuSharirSCC.java.html *) -let handle_lines tiny_test_cases = - match Ext_string.split tiny_test_cases '\n' with - | nodes :: _edges :: rest -> - let nodes_num = int_of_string nodes in - let node_array = - Array.init nodes_num - (fun _ -> Vec_int.empty () ) - in - begin +let handle_lines tiny_test_cases = + match Ext_string.split tiny_test_cases '\n' with + | nodes :: _edges :: rest -> + let nodes_num = int_of_string nodes in + let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in Ext_list.iter rest (fun x -> - match Ext_string.split x ' ' with - | [ a ; b] -> - let a , b = int_of_string a , int_of_string b in - Vec_int.push node_array.(a) b - | _ -> assert false - ); - node_array - end + match Ext_string.split x ' ' with + | [a; b] -> + let a, b = (int_of_string a, int_of_string b) in + Vec_int.push node_array.(a) b + | _ -> assert false); + node_array | _ -> assert false -let read_file file = - let in_chan = open_in_bin file in - let nodes_sum = int_of_string (input_line in_chan) in - let node_array = Array.init nodes_sum (fun _ -> Vec_int.empty () ) in - let rec aux () = - match input_line in_chan with +let read_file file = + let in_chan = open_in_bin file in + let nodes_sum = int_of_string (input_line in_chan) in + let node_array = Array.init nodes_sum (fun _ -> Vec_int.empty ()) in + let rec aux () = + match input_line in_chan with | exception End_of_file -> () - | x -> - begin match Ext_string.split x ' ' with - | [ a ; b] -> - let a , b = int_of_string a , int_of_string b in - Vec_int.push node_array.(a) b - | _ -> (* assert false *) () - end; - aux () in + | x -> + (match Ext_string.split x ' ' with + | [a; b] -> + let a, b = (int_of_string a, int_of_string b) in + Vec_int.push node_array.(a) b + | _ -> (* assert false *) ()); + aux () + in print_endline "read data into memory"; aux (); - (fst (Ext_scc.graph_check node_array)) (* 25 *) - + fst (Ext_scc.graph_check node_array) +(* 25 *) -let test (input : (string * string list) list) = +let test (input : (string * string list) list) = (* string -> int mapping *) let tbl = Hash_string.create 32 in - let idx = ref 0 in + let idx = ref 0 in let add x = - if not (Hash_string.mem tbl x ) then - begin - Hash_string.add tbl x !idx ; - incr idx - end in - input |> List.iter - (fun (x,others) -> List.iter add (x::others)); + if not (Hash_string.mem tbl x) then ( + Hash_string.add tbl x !idx; + incr idx) + in + input |> List.iter (fun (x, others) -> List.iter add (x :: others)); let nodes_num = Hash_string.length tbl in - let node_array = - Array.init nodes_num - (fun _ -> Vec_int.empty () ) in - input |> - List.iter (fun (x,others) -> - let idx = Hash_string.find_exn tbl x in - others |> - List.iter (fun y -> Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y ) ) - ) ; - Ext_scc.graph_check node_array + let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in + input + |> List.iter (fun (x, others) -> + let idx = Hash_string.find_exn tbl x in + others + |> List.iter (fun y -> + Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y))); + Ext_scc.graph_check node_array -let test2 (input : (string * string list) list) = +let test2 (input : (string * string list) list) = (* string -> int mapping *) let tbl = Hash_string.create 32 in - let idx = ref 0 in + let idx = ref 0 in let add x = - if not (Hash_string.mem tbl x ) then - begin - Hash_string.add tbl x !idx ; - incr idx - end in - input |> List.iter - (fun (x,others) -> List.iter add (x::others)); + if not (Hash_string.mem tbl x) then ( + Hash_string.add tbl x !idx; + incr idx) + in + input |> List.iter (fun (x, others) -> List.iter add (x :: others)); let nodes_num = Hash_string.length tbl in - let other_mapping = Array.make nodes_num "" in - Hash_string.iter tbl (fun k v -> other_mapping.(v) <- k ) ; - - let node_array = - Array.init nodes_num - (fun _ -> Vec_int.empty () ) in - input |> - List.iter (fun (x,others) -> - let idx = Hash_string.find_exn tbl x in - others |> - List.iter (fun y -> Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y ) ) - ) ; - let output = Ext_scc.graph node_array in - output |> Int_vec_vec.map_into_array (fun int_vec -> Vec_int.map_into_array (fun i -> other_mapping.(i)) int_vec ) + let other_mapping = Array.make nodes_num "" in + Hash_string.iter tbl (fun k v -> other_mapping.(v) <- k); + let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in + input + |> List.iter (fun (x, others) -> + let idx = Hash_string.find_exn tbl x in + others + |> List.iter (fun y -> + Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y))); + let output = Ext_scc.graph node_array in + output + |> Int_vec_vec.map_into_array (fun int_vec -> + Vec_int.map_into_array (fun i -> other_mapping.(i)) int_vec) -let suites = - __FILE__ - >::: [ - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (fst @@ Ext_scc.graph_check (handle_lines tiny_test_cases)) 5 - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (fst @@ Ext_scc.graph_check (handle_lines medium_test_cases)) 10 - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", []; - ]) (3 , [1;2;1]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", []; - "e", [] - ]) (4, [1;1;2;1]) - (* {[ +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (fst @@ Ext_scc.graph_check (handle_lines tiny_test_cases)) + 5 ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (fst @@ Ext_scc.graph_check (handle_lines medium_test_cases)) + 10 ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [("a", ["b"; "c"]); ("b", ["c"; "d"]); ("c", ["b"]); ("d", [])]) + (3, [1; 2; 1]) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [ + ("a", ["b"; "c"]); + ("b", ["c"; "d"]); + ("c", ["b"]); + ("d", []); + ("e", []); + ]) + (4, [1; 1; 2; 1]) + (* {[ a -> b - a -> c - b -> c - b -> d - c -> b - d + a -> c + b -> c + b -> d + c -> b + d e ]} {[ [d ; e ; [b;c] [a] ] - ]} - *) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", ["e"]; - "e", [] - ]) (4 , [1;2;1;1]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", ["e"]; - "e", ["c"] - ]) (2, [1;4]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", ["e"]; - "e", ["a"] - ]) (1, [5]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b"]; - "b" , ["c" ]; - "c", [ ]; - "d", []; - "e", [] - ]) (5, [1;1;1;1;1]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "1", ["0"]; - "0" , ["2" ]; - "2", ["1" ]; - "0", ["3"]; - "3", [ "4"] - ]) (3, [3;1;1]) - end ; - (* http://algs4.cs.princeton.edu/42digraph/largeDG.txt *) - (* __LOC__ >:: begin fun _ -> *) - (* OUnit.assert_equal (read_file "largeDG.txt") 25 *) - (* end *) - (* ; *) - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test2 [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", []; - ]) [|[|"d"|]; [|"b"; "c"|]; [|"a"|]|] - end ; - - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test2 [ - "a", ["b"]; - "b" , ["c" ]; - "c", ["d" ]; - "d", ["e"]; - "e", [] - ]) [|[|"e"|]; [|"d"|]; [|"c"|]; [|"b"|]; [|"a"|]|] - end ; - - ] + ]} + *) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [ + ("a", ["b"; "c"]); + ("b", ["c"; "d"]); + ("c", ["b"]); + ("d", ["e"]); + ("e", []); + ]) + (4, [1; 2; 1; 1]) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [ + ("a", ["b"; "c"]); + ("b", ["c"; "d"]); + ("c", ["b"]); + ("d", ["e"]); + ("e", ["c"]); + ]) + (2, [1; 4]) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [ + ("a", ["b"; "c"]); + ("b", ["c"; "d"]); + ("c", ["b"]); + ("d", ["e"]); + ("e", ["a"]); + ]) + (1, [5]) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [("a", ["b"]); ("b", ["c"]); ("c", []); ("d", []); ("e", [])]) + (5, [1; 1; 1; 1; 1]) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test + [ + ("1", ["0"]); + ("0", ["2"]); + ("2", ["1"]); + ("0", ["3"]); + ("3", ["4"]); + ]) + (3, [3; 1; 1]) ); + (* http://algs4.cs.princeton.edu/42digraph/largeDG.txt *) + (* __LOC__ >:: begin fun _ -> *) + (* OUnit.assert_equal (read_file "largeDG.txt") 25 *) + (* end *) + (* ; *) + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test2 + [("a", ["b"; "c"]); ("b", ["c"; "d"]); ("c", ["b"]); ("d", [])]) + [|[|"d"|]; [|"b"; "c"|]; [|"a"|]|] ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (test2 + [ + ("a", ["b"]); + ("b", ["c"]); + ("c", ["d"]); + ("d", ["e"]); + ("e", []); + ]) + [|[|"e"|]; [|"d"|]; [|"c"|]; [|"b"|]; [|"a"|]|] ); + ] diff --git a/compiler/ounit_tests/ounit_string_tests.ml b/compiler/ounit_tests/ounit_string_tests.ml index 4b7a64fece..ee0fe72565 100644 --- a/compiler/ounit_tests/ounit_string_tests.ml +++ b/compiler/ounit_tests/ounit_string_tests.ml @@ -1,534 +1,433 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal ~printer:Ext_obj.dump +let ( =~ ) = OUnit.assert_equal ~printer:Ext_obj.dump -let printer_string = fun x -> x +let printer_string x = x let string_eq = OUnit.assert_equal ~printer:(fun id -> id) -let suites = - __FILE__ >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_bool "not found " (Ext_string.rindex_neg "hello" 'x' < 0 ) - end; - - __LOC__ >:: begin fun _ -> - Ext_string.rindex_neg "hello" 'h' =~ 0 ; - Ext_string.rindex_neg "hello" 'e' =~ 1 ; - Ext_string.rindex_neg "hello" 'l' =~ 3 ; - Ext_string.rindex_neg "hello" 'l' =~ 3 ; - Ext_string.rindex_neg "hello" 'o' =~ 4 ; - end; - (* __LOC__ >:: begin - fun _ -> - let nl cur s = Ext_string.extract_until s cur '\n' in - nl (ref 0) "hello\n" =~ "hello"; - nl (ref 0) "\nhell" =~ ""; - nl (ref 0) "hello" =~ "hello"; - let cur = ref 0 in - let b = "a\nb\nc\nd" in - nl cur b =~ "a"; - nl cur b =~ "b"; - nl cur b =~ "c"; - nl cur b =~ "d"; - nl cur b =~ "" ; - nl cur b =~ "" ; - cur := 0 ; - let b = "a\nb\nc\nd\n" in - nl cur b =~ "a"; - nl cur b =~ "b"; - nl cur b =~ "c"; - nl cur b =~ "d"; - nl cur b =~ "" ; - nl cur b =~ "" ; - end ; *) - __LOC__ >:: begin fun _ -> - let b = "a\nb\nc\nd\n" in - let a = Ext_string.index_count in - a b 0 '\n' 1 =~ 1 ; - a b 0 '\n' 2 =~ 3; - a b 0 '\n' 3 =~ 5; - a b 0 '\n' 4 =~ 7; - a b 0 '\n' 5 =~ -1; - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool "empty string" (Ext_string.rindex_neg "" 'x' < 0 ) - end; - - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (not (Ext_string.for_all_from "xABc"1 - (function 'A' .. 'Z' -> true | _ -> false))); - OUnit.assert_bool __LOC__ - ( (Ext_string.for_all_from "xABC" 1 - (function 'A' .. 'Z' -> true | _ -> false))); - OUnit.assert_bool __LOC__ - ( (Ext_string.for_all_from "xABC" 1_000 - (function 'A' .. 'Z' -> true | _ -> false))); - end; - - (* __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ @@ - List.for_all (fun x -> Ext_string.is_valid_source_name x = Good) - ["x.ml"; "x.mli"; "x.res"; "x.resi"; - "A_x.ml"; "ab.ml"; "a_.ml"; "a__.ml"; - "ax.ml"]; - OUnit.assert_bool __LOC__ @@ not @@ - List.exists (fun x -> Ext_string.is_valid_source_name x = Good) - [".res"; ".resi";"..res"; "..resi"; "..ml"; ".mll~"; - "...ml"; "_.mli"; "_x.ml"; "__.ml"; "__.rei"; - ".#hello.ml"; ".#hello.rei"; "a-.ml"; "a-b.ml"; "-a-.ml" - ; "-.ml" - ] - end; *) - __LOC__ >:: begin fun _ -> - Ext_filename.module_name "a/hello.ml" =~ "Hello"; - Ext_filename.as_module ~basename:"a.ml" =~ Some {module_name = "A"; case = false}; - Ext_filename.as_module ~basename:"Aa.ml" =~ Some {module_name = "Aa"; case = true}; - (* Ext_filename.as_module ~basename:"_Aa.ml" =~ None; *) - Ext_filename.as_module ~basename:"A_a" =~ Some {module_name = "A_a"; case = true}; - Ext_filename.as_module ~basename:"" =~ None; - Ext_filename.as_module ~basename:"a/hello.ml" =~ - None - - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ @@ - List.for_all Ext_namespace.is_valid_npm_package_name - ["x"; "@angualr"; "test"; "hi-x"; "hi-"] - ; - OUnit.assert_bool __LOC__ @@ - List.for_all - (fun x -> not (Ext_namespace.is_valid_npm_package_name x)) - ["x "; "x'"; "Test"; "hI"] - ; - end; - __LOC__ >:: begin fun _ -> - Ext_string.find ~sub:"hello" "xx hello xx" =~ 3 ; - Ext_string.rfind ~sub:"hello" "xx hello xx" =~ 3 ; - Ext_string.find ~sub:"hello" "xx hello hello xx" =~ 3 ; - Ext_string.rfind ~sub:"hello" "xx hello hello xx" =~ 9 ; - end; - __LOC__ >:: begin fun _ -> - Ext_string.non_overlap_count ~sub:"0" "1000,000" =~ 6; - Ext_string.non_overlap_count ~sub:"0" "000000" =~ 6; - Ext_string.non_overlap_count ~sub:"00" "000000" =~ 3; - Ext_string.non_overlap_count ~sub:"00" "00000" =~ 2 - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "abc"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "a"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "b"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "c"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" ""); - OUnit.assert_bool __LOC__ (not @@ Ext_string.contain_substring "abc" "abcc"); - end; - __LOC__ >:: begin fun _ -> - Ext_string.trim " \t\n" =~ ""; - Ext_string.trim " \t\nb" =~ "b"; - Ext_string.trim "b \t\n" =~ "b"; - Ext_string.trim "\t\n b \t\n" =~ "b"; - end; - __LOC__ >:: begin fun _ -> - Ext_string.starts_with "ab" "a" =~ true; - Ext_string.starts_with "ab" "" =~ true; - Ext_string.starts_with "abb" "abb" =~ true; - Ext_string.starts_with "abb" "abbc" =~ false; - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> string_of_bool x ) in - let k = Ext_string.ends_with in - k "xx.ml" ".ml" =~ true; - k "xx.bs.js" ".js" =~ true ; - k "xx" ".x" =~false; - k "xx" "" =~true - end; - __LOC__ >:: begin fun _ -> - Ext_string.ends_with_then_chop "xx.ml" ".ml" =~ Some "xx"; - Ext_string.ends_with_then_chop "xx.ml" ".mll" =~ None - end; - (* __LOC__ >:: begin fun _ -> - Ext_string.starts_with_and_number "js_fn_mk_01" ~offset:0 "js_fn_mk_" =~ 1 ; - Ext_string.starts_with_and_number "js_fn_run_02" ~offset:0 "js_fn_mk_" =~ -1 ; - Ext_string.starts_with_and_number "js_fn_mk_03" ~offset:6 "mk_" =~ 3 ; - Ext_string.starts_with_and_number "js_fn_mk_04" ~offset:6 "run_" =~ -1; - Ext_string.starts_with_and_number "js_fn_run_04" ~offset:6 "run_" =~ 4; - Ext_string.(starts_with_and_number "js_fn_run_04" ~offset:6 "run_" = 3) =~ false - end; *) - __LOC__ >:: begin fun _ -> - Ext_string.for_all "____" (function '_' -> true | _ -> false) - =~ true; - Ext_string.for_all "___-" (function '_' -> true | _ -> false) - =~ false; - Ext_string.for_all "" (function '_' -> true | _ -> false) - =~ true - end; - __LOC__ >:: begin fun _ -> - Ext_string.tail_from "ghsogh" 1 =~ "hsogh"; - Ext_string.tail_from "ghsogh" 0 =~ "ghsogh" - end; - (* __LOC__ >:: begin fun _ -> - Ext_string.digits_of_str "11_js" ~offset:0 2 =~ 11 - end; *) - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.replace_backward_slash "a:\\b\\d" = - "a:/b/d" - ) ; - OUnit.assert_bool __LOC__ - (Ext_string.replace_backward_slash "a:\\b\\d\\" = - "a:/b/d/" - ) ; - OUnit.assert_bool __LOC__ - (Ext_string.replace_slash_backward "a:/b/d/"= - "a:\\b\\d\\" - ) ; - OUnit.assert_bool __LOC__ - (let old = "a:bd" in - Ext_string.replace_backward_slash old == - old - ) ; - OUnit.assert_bool __LOC__ - (let old = "a:bd" in - Ext_string.replace_backward_slash old == - old - ) ; - - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.no_slash "ahgoh" ); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash "" ); - OUnit.assert_bool __LOC__ - (not (Ext_string.no_slash "ahgoh/" )); - OUnit.assert_bool __LOC__ - (not (Ext_string.no_slash "/ahgoh" )); - OUnit.assert_bool __LOC__ - (not (Ext_string.no_slash "/ahgoh/" )); - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ (Ext_string.compare "" "" = 0); - OUnit.assert_bool __LOC__ (Ext_string.compare "0" "0" = 0); - OUnit.assert_bool __LOC__ (Ext_string.compare "" "acd" < 0); - OUnit.assert_bool __LOC__ (Ext_string.compare "acd" "" > 0); - for i = 0 to 256 do - let a = String.init i (fun _ -> '0') in - let b = String.init i (fun _ -> '0') in - OUnit.assert_bool __LOC__ (Ext_string.compare b a = 0); - OUnit.assert_bool __LOC__ (Ext_string.compare a b = 0) - done ; - for i = 0 to 256 do - let a = String.init i (fun _ -> '0') in - let b = String.init i (fun _ -> '0') ^ "\000"in - OUnit.assert_bool __LOC__ (Ext_string.compare a b < 0); - OUnit.assert_bool __LOC__ (Ext_string.compare b a > 0) - done ; - - end; - __LOC__ >:: begin fun _ -> - let slow_compare x y = - let x_len = String.length x in - let y_len = String.length y in - if x_len = y_len then - String.compare x y - else - Stdlib.compare x_len y_len in - let same_sign x y = - if x = 0 then y = 0 - else if x < 0 then y < 0 - else y > 0 in - for _ = 0 to 3000 do - let chars = [|'a';'b';'c';'d'|] in - let x = Ounit_data_random.random_string chars 129 in - let y = Ounit_data_random.random_string chars 129 in - let a = Ext_string.compare x y in - let b = slow_compare x y in - if same_sign a b then OUnit.assert_bool __LOC__ true - else failwith ("incosistent " ^ x ^ " " ^ y ^ " " ^ string_of_int a ^ " " ^ string_of_int b) - done - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat3 "a0" "a1" "a2") "a0a1a2" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat3 "a0" "a11" "") "a0a11" - ); - - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat4 "a0" "a1" "a2" "a3") "a0a1a2a3" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat4 "a0" "a11" "" "a33") "a0a11a33" - ); - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.inter2 "a0" "a1") "a0 a1" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.inter3 "a0" "a1" "a2") "a0 a1 a2" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.inter4 "a0" "a1" "a2" "a3") "a0 a1 a2 a3" - ); - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "" < 0); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "xxx" < 0); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "xxx/" = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "xxx/g/" = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "/xxx/g/" = 0) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx" 0 < 0); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx/" 1 = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx/g/" 4 = 5); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx/g/" 3 = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "/xxx/g/" 0 = 0) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [||]) - Ext_string.empty - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0"|]) - "a0" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"|]) - "a0 a1" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"; "a2"|]) - "a0 a1 a2" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"; "a2";"a3"|]) - "a0 a1 a2 a3" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"; "a2";"a3";""; "a4"|]) - "a0 a1 a2 a3 a4" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"0";"a1"; "2";"a3";""; "a4"|]) - "0 a1 2 a3 a4" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"0";"a1"; "2";"3";"d"; ""; "e"|]) - "0 a1 2 3 d e" - ); - - end; - - __LOC__ >:: begin fun _ -> - Ext_namespace.namespace_of_package_name "bs-json" - =~ "BsJson" - end; - __LOC__ >:: begin fun _ -> - Ext_namespace.namespace_of_package_name "xx" - =~ "Xx" - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in - Ext_namespace.namespace_of_package_name - "reason-react" - =~ "ReasonReact"; - Ext_namespace.namespace_of_package_name - "Foo_bar" - =~ "Foo_bar"; - Ext_namespace.namespace_of_package_name - "reason" - =~ "Reason"; - Ext_namespace.namespace_of_package_name - "@aa/bb" - =~"AaBb"; - Ext_namespace.namespace_of_package_name - "@A/bb" - =~"ABb" - end; - __LOC__ >:: begin fun _ -> - Ext_namespace.change_ext_ns_suffix "a-b" Literals.suffix_js - =~ "a.js"; - Ext_namespace.change_ext_ns_suffix "a-" Literals.suffix_js - =~ "a.js"; - Ext_namespace.change_ext_ns_suffix "a--" Literals.suffix_js - =~ "a-.js"; - Ext_namespace.change_ext_ns_suffix "AA-b" Literals.suffix_js - =~ "AA.js"; - Ext_namespace.js_name_of_modulename "AA-b" Little Literals.suffix_js - =~ "aA.js"; - Ext_namespace.js_name_of_modulename "AA-b" Upper Literals.suffix_js - =~ "AA.js"; - Ext_namespace.js_name_of_modulename "AA-b" Upper ".bs.js" - =~ "AA.bs.js"; - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> - match x with - | None -> "" - | Some (a,b) -> a ^","^ b - ) in - Ext_namespace.try_split_module_name "Js-X" =~ Some ("X","Js"); - Ext_namespace.try_split_module_name "Js_X" =~ None - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in - let f = Ext_string.capitalize_ascii in - f "x" =~ "X"; - f "X" =~ "X"; - f "" =~ ""; - f "abc" =~ "Abc"; - f "_bc" =~ "_bc"; - let v = "bc" in - f v =~ "Bc"; - v =~ "bc" - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:printer_string in - Ext_filename.chop_all_extensions_maybe "a.bs.js" =~ "a" ; - Ext_filename.chop_all_extensions_maybe "a.js" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a.x.bs.js" =~ "a" - end; - (* let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in *) - __LOC__ >:: begin fun _ -> - let k = Ext_modulename.js_id_name_of_hint_name in - k "xx" =~ "Xx"; - k "react-dom" =~ "ReactDom"; - k "a/b/react-dom" =~ "ReactDom"; - k "a/b" =~ "B"; - k "a/" =~ "A/" ; (*TODO: warning?*) - k "#moduleid" =~ "Moduleid"; - k "@bundle" =~ "Bundle"; - k "xx#bc" =~ "Xxbc"; - k "hi@myproj" =~ "Himyproj"; - k "ab/c/xx.b.js" =~ "XxBJs"; (* improve it in the future*) - k "c/d/a--b"=~ "AB"; - k "c/d/ac--" =~ "Ac" - end ; - __LOC__ >:: begin fun _ -> - Ext_string.capitalize_sub "ab-Ns.cmi" 2 =~ "Ab"; - Ext_string.capitalize_sub "Ab-Ns.cmi" 2 =~ "Ab"; - Ext_string.capitalize_sub "Ab-Ns.cmi" 3 =~ "Ab-" - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (String.length (Digest.string "")) - Ext_digest.length - end; - - __LOC__ >:: begin fun _ -> - let bench = String.concat - ";" (Ext_list.init 11 (fun i -> string_of_int i)) in - let buf = Ext_buffer.create 10 in - OUnit.assert_bool - __LOC__ (Ext_buffer.not_equal buf bench); - for i = 0 to 9 do - Ext_buffer.add_string buf (string_of_int i); - Ext_buffer.add_string buf ";" - done ; - OUnit.assert_bool - __LOC__ (Ext_buffer.not_equal buf bench); - Ext_buffer.add_string buf "10" ; - (* print_endline (Ext_buffer.contents buf); - print_endline bench; *) - OUnit.assert_bool - __LOC__ (not (Ext_buffer.not_equal buf bench)) - end ; - - __LOC__ >:: begin fun _ -> - string_eq (Ext_filename.new_extension "a.c" ".xx") "a.xx"; - string_eq (Ext_filename.new_extension "abb.c" ".xx") "abb.xx"; - string_eq (Ext_filename.new_extension ".c" ".xx") ".xx"; - string_eq (Ext_filename.new_extension "a/b" ".xx") "a/b.xx"; - string_eq (Ext_filename.new_extension "a/b." ".xx") "a/b.xx"; - string_eq (Ext_filename.chop_all_extensions_maybe "a.b.x") "a"; - string_eq (Ext_filename.chop_all_extensions_maybe "a.b") "a"; - string_eq (Ext_filename.chop_all_extensions_maybe ".a.b.x") ""; - string_eq (Ext_filename.chop_all_extensions_maybe "abx") "abx"; - end; - __LOC__ >:: begin fun _ -> - string_eq - (Ext_filename.module_name "a/b/c.d") - "C"; - string_eq - (Ext_filename.module_name "a/b/xc.res") - "Xc"; - string_eq - (Ext_filename.module_name "a/b/xc.resi") - "Xc"; - string_eq - (Ext_filename.module_name "a/b/xc.ml") - "Xc" ; - string_eq - (Ext_filename.module_name "a/b/xc.mli") - "Xc" ; - string_eq - (Ext_filename.module_name "a/b/xc.cppo.mli") - "Xc.cppo"; - string_eq - (Ext_filename.module_name "a/b/xc.cppo.") - "Xc.cppo" ; - string_eq - (Ext_filename.module_name "a/b/xc..") - "Xc." ; - string_eq - (Ext_filename.module_name "a/b/Xc..") - "Xc." ; - string_eq - (Ext_filename.module_name "a/b/.") - "" ; - end; - __LOC__ >:: begin fun _ -> - Ext_string.split "" ':' =~ []; - Ext_string.split "a:b:" ':' =~ ["a";"b"]; - Ext_string.split "a:b:" ':' ~keep_empty:true =~ ["a";"b";""] - end; - __LOC__ >:: begin fun _ -> - let cmp0 = Ext_string.compare in - let cmp1 = Map_string.compare_key in - let f a b = - cmp0 a b =~ cmp1 a b ; - cmp0 b a =~ cmp1 b a - in - (* This is needed since deserialization/serialization - needs to be synced up for .bsbuild decoding - *) - f "a" "A"; - f "bcdef" "abcdef"; - f "" "A"; - f "Abcdef" "abcdef"; - end - ] +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + OUnit.assert_bool "not found " (Ext_string.rindex_neg "hello" 'x' < 0) + ); + ( __LOC__ >:: fun _ -> + Ext_string.rindex_neg "hello" 'h' =~ 0; + Ext_string.rindex_neg "hello" 'e' =~ 1; + Ext_string.rindex_neg "hello" 'l' =~ 3; + Ext_string.rindex_neg "hello" 'l' =~ 3; + Ext_string.rindex_neg "hello" 'o' =~ 4 ); + (* __LOC__ >:: begin + fun _ -> + let nl cur s = Ext_string.extract_until s cur '\n' in + nl (ref 0) "hello\n" =~ "hello"; + nl (ref 0) "\nhell" =~ ""; + nl (ref 0) "hello" =~ "hello"; + let cur = ref 0 in + let b = "a\nb\nc\nd" in + nl cur b =~ "a"; + nl cur b =~ "b"; + nl cur b =~ "c"; + nl cur b =~ "d"; + nl cur b =~ "" ; + nl cur b =~ "" ; + cur := 0 ; + let b = "a\nb\nc\nd\n" in + nl cur b =~ "a"; + nl cur b =~ "b"; + nl cur b =~ "c"; + nl cur b =~ "d"; + nl cur b =~ "" ; + nl cur b =~ "" ; + end ; *) + ( __LOC__ >:: fun _ -> + let b = "a\nb\nc\nd\n" in + let a = Ext_string.index_count in + a b 0 '\n' 1 =~ 1; + a b 0 '\n' 2 =~ 3; + a b 0 '\n' 3 =~ 5; + a b 0 '\n' 4 =~ 7; + a b 0 '\n' 5 =~ -1 ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool "empty string" (Ext_string.rindex_neg "" 'x' < 0) + ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (not + (Ext_string.for_all_from "xABc" 1 (function + | 'A' .. 'Z' -> true + | _ -> false))); + OUnit.assert_bool __LOC__ + (Ext_string.for_all_from "xABC" 1 (function + | 'A' .. 'Z' -> true + | _ -> false)); + OUnit.assert_bool __LOC__ + (Ext_string.for_all_from "xABC" 1_000 (function + | 'A' .. 'Z' -> true + | _ -> false)) ); + (* __LOC__ >:: begin fun _ -> + OUnit.assert_bool __LOC__ @@ + List.for_all (fun x -> Ext_string.is_valid_source_name x = Good) + ["x.ml"; "x.mli"; "x.res"; "x.resi"; + "A_x.ml"; "ab.ml"; "a_.ml"; "a__.ml"; + "ax.ml"]; + OUnit.assert_bool __LOC__ @@ not @@ + List.exists (fun x -> Ext_string.is_valid_source_name x = Good) + [".res"; ".resi";"..res"; "..resi"; "..ml"; ".mll~"; + "...ml"; "_.mli"; "_x.ml"; "__.ml"; "__.rei"; + ".#hello.ml"; ".#hello.rei"; "a-.ml"; "a-b.ml"; "-a-.ml" + ; "-.ml" + ] + end; *) + ( __LOC__ >:: fun _ -> + Ext_filename.module_name "a/hello.ml" =~ "Hello"; + Ext_filename.as_module ~basename:"a.ml" + =~ Some {module_name = "A"; case = false}; + Ext_filename.as_module ~basename:"Aa.ml" + =~ Some {module_name = "Aa"; case = true}; + (* Ext_filename.as_module ~basename:"_Aa.ml" =~ None; *) + Ext_filename.as_module ~basename:"A_a" + =~ Some {module_name = "A_a"; case = true}; + Ext_filename.as_module ~basename:"" =~ None; + Ext_filename.as_module ~basename:"a/hello.ml" =~ None ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + @@ List.for_all Ext_namespace.is_valid_npm_package_name + ["x"; "@angualr"; "test"; "hi-x"; "hi-"]; + OUnit.assert_bool __LOC__ + @@ List.for_all + (fun x -> not (Ext_namespace.is_valid_npm_package_name x)) + ["x "; "x'"; "Test"; "hI"] ); + ( __LOC__ >:: fun _ -> + Ext_string.find ~sub:"hello" "xx hello xx" =~ 3; + Ext_string.rfind ~sub:"hello" "xx hello xx" =~ 3; + Ext_string.find ~sub:"hello" "xx hello hello xx" =~ 3; + Ext_string.rfind ~sub:"hello" "xx hello hello xx" =~ 9 ); + ( __LOC__ >:: fun _ -> + Ext_string.non_overlap_count ~sub:"0" "1000,000" =~ 6; + Ext_string.non_overlap_count ~sub:"0" "000000" =~ 6; + Ext_string.non_overlap_count ~sub:"00" "000000" =~ 3; + Ext_string.non_overlap_count ~sub:"00" "00000" =~ 2 ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "abc"); + OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "a"); + OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "b"); + OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "c"); + OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" ""); + OUnit.assert_bool __LOC__ + (not @@ Ext_string.contain_substring "abc" "abcc") ); + ( __LOC__ >:: fun _ -> + Ext_string.trim " \t\n" =~ ""; + Ext_string.trim " \t\nb" =~ "b"; + Ext_string.trim "b \t\n" =~ "b"; + Ext_string.trim "\t\n b \t\n" =~ "b" ); + ( __LOC__ >:: fun _ -> + Ext_string.starts_with "ab" "a" =~ true; + Ext_string.starts_with "ab" "" =~ true; + Ext_string.starts_with "abb" "abb" =~ true; + Ext_string.starts_with "abb" "abbc" =~ false ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = + OUnit.assert_equal ~printer:(fun x -> string_of_bool x) + in + let k = Ext_string.ends_with in + k "xx.ml" ".ml" =~ true; + k "xx.bs.js" ".js" =~ true; + k "xx" ".x" =~ false; + k "xx" "" =~ true ); + ( __LOC__ >:: fun _ -> + Ext_string.ends_with_then_chop "xx.ml" ".ml" =~ Some "xx"; + Ext_string.ends_with_then_chop "xx.ml" ".mll" =~ None ); + (* __LOC__ >:: begin fun _ -> + Ext_string.starts_with_and_number "js_fn_mk_01" ~offset:0 "js_fn_mk_" =~ 1 ; + Ext_string.starts_with_and_number "js_fn_run_02" ~offset:0 "js_fn_mk_" =~ -1 ; + Ext_string.starts_with_and_number "js_fn_mk_03" ~offset:6 "mk_" =~ 3 ; + Ext_string.starts_with_and_number "js_fn_mk_04" ~offset:6 "run_" =~ -1; + Ext_string.starts_with_and_number "js_fn_run_04" ~offset:6 "run_" =~ 4; + Ext_string.(starts_with_and_number "js_fn_run_04" ~offset:6 "run_" = 3) =~ false + end; *) + ( __LOC__ >:: fun _ -> + Ext_string.for_all "____" (function + | '_' -> true + | _ -> false) + =~ true; + Ext_string.for_all "___-" (function + | '_' -> true + | _ -> false) + =~ false; + Ext_string.for_all "" (function + | '_' -> true + | _ -> false) + =~ true ); + ( __LOC__ >:: fun _ -> + Ext_string.tail_from "ghsogh" 1 =~ "hsogh"; + Ext_string.tail_from "ghsogh" 0 =~ "ghsogh" ); + (* __LOC__ >:: begin fun _ -> + Ext_string.digits_of_str "11_js" ~offset:0 2 =~ 11 + end; *) + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Ext_string.replace_backward_slash "a:\\b\\d" = "a:/b/d"); + OUnit.assert_bool __LOC__ + (Ext_string.replace_backward_slash "a:\\b\\d\\" = "a:/b/d/"); + OUnit.assert_bool __LOC__ + (Ext_string.replace_slash_backward "a:/b/d/" = "a:\\b\\d\\"); + OUnit.assert_bool __LOC__ + (let old = "a:bd" in + Ext_string.replace_backward_slash old == old); + OUnit.assert_bool __LOC__ + (let old = "a:bd" in + Ext_string.replace_backward_slash old == old) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_string.no_slash "ahgoh"); + OUnit.assert_bool __LOC__ (Ext_string.no_slash ""); + OUnit.assert_bool __LOC__ (not (Ext_string.no_slash "ahgoh/")); + OUnit.assert_bool __LOC__ (not (Ext_string.no_slash "/ahgoh")); + OUnit.assert_bool __LOC__ (not (Ext_string.no_slash "/ahgoh/")) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_string.compare "" "" = 0); + OUnit.assert_bool __LOC__ (Ext_string.compare "0" "0" = 0); + OUnit.assert_bool __LOC__ (Ext_string.compare "" "acd" < 0); + OUnit.assert_bool __LOC__ (Ext_string.compare "acd" "" > 0); + for i = 0 to 256 do + let a = String.init i (fun _ -> '0') in + let b = String.init i (fun _ -> '0') in + OUnit.assert_bool __LOC__ (Ext_string.compare b a = 0); + OUnit.assert_bool __LOC__ (Ext_string.compare a b = 0) + done; + for i = 0 to 256 do + let a = String.init i (fun _ -> '0') in + let b = String.init i (fun _ -> '0') ^ "\000" in + OUnit.assert_bool __LOC__ (Ext_string.compare a b < 0); + OUnit.assert_bool __LOC__ (Ext_string.compare b a > 0) + done ); + ( __LOC__ >:: fun _ -> + let slow_compare x y = + let x_len = String.length x in + let y_len = String.length y in + if x_len = y_len then String.compare x y + else Stdlib.compare x_len y_len + in + let same_sign x y = + if x = 0 then y = 0 else if x < 0 then y < 0 else y > 0 + in + for _ = 0 to 3000 do + let chars = [|'a'; 'b'; 'c'; 'd'|] in + let x = Ounit_data_random.random_string chars 129 in + let y = Ounit_data_random.random_string chars 129 in + let a = Ext_string.compare x y in + let b = slow_compare x y in + if same_sign a b then OUnit.assert_bool __LOC__ true + else + failwith + ("incosistent " ^ x ^ " " ^ y ^ " " ^ string_of_int a ^ " " + ^ string_of_int b) + done ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Ext_string.equal (Ext_string.concat3 "a0" "a1" "a2") "a0a1a2"); + OUnit.assert_bool __LOC__ + (Ext_string.equal (Ext_string.concat3 "a0" "a11" "") "a0a11"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat4 "a0" "a1" "a2" "a3") + "a0a1a2a3"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat4 "a0" "a11" "" "a33") + "a0a11a33") ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Ext_string.equal (Ext_string.inter2 "a0" "a1") "a0 a1"); + OUnit.assert_bool __LOC__ + (Ext_string.equal (Ext_string.inter3 "a0" "a1" "a2") "a0 a1 a2"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.inter4 "a0" "a1" "a2" "a3") + "a0 a1 a2 a3") ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx "" < 0); + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx "xxx" < 0); + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx "xxx/" = 3); + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx "xxx/g/" = 3); + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx "/xxx/g/" = 0) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx_from "xxx" 0 < 0); + OUnit.assert_bool __LOC__ (Ext_string.no_slash_idx_from "xxx/" 1 = 3); + OUnit.assert_bool __LOC__ + (Ext_string.no_slash_idx_from "xxx/g/" 4 = 5); + OUnit.assert_bool __LOC__ + (Ext_string.no_slash_idx_from "xxx/g/" 3 = 3); + OUnit.assert_bool __LOC__ + (Ext_string.no_slash_idx_from "/xxx/g/" 0 = 0) ); + ( __LOC__ >:: fun _ -> + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space [||]) + Ext_string.empty); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space [|"a0"|]) + "a0"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space [|"a0"; "a1"|]) + "a0 a1"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space + [|"a0"; "a1"; "a2"|]) + "a0 a1 a2"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space + [|"a0"; "a1"; "a2"; "a3"|]) + "a0 a1 a2 a3"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space + [|"a0"; "a1"; "a2"; "a3"; ""; "a4"|]) + "a0 a1 a2 a3 a4"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space + [|"0"; "a1"; "2"; "a3"; ""; "a4"|]) + "0 a1 2 a3 a4"); + OUnit.assert_bool __LOC__ + (Ext_string.equal + (Ext_string.concat_array Ext_string.single_space + [|"0"; "a1"; "2"; "3"; "d"; ""; "e"|]) + "0 a1 2 3 d e") ); + ( __LOC__ >:: fun _ -> + Ext_namespace.namespace_of_package_name "bs-json" =~ "BsJson" ); + ( __LOC__ >:: fun _ -> + Ext_namespace.namespace_of_package_name "xx" =~ "Xx" ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal ~printer:(fun x -> x) in + Ext_namespace.namespace_of_package_name "reason-react" + =~ "ReasonReact"; + Ext_namespace.namespace_of_package_name "Foo_bar" =~ "Foo_bar"; + Ext_namespace.namespace_of_package_name "reason" =~ "Reason"; + Ext_namespace.namespace_of_package_name "@aa/bb" =~ "AaBb"; + Ext_namespace.namespace_of_package_name "@A/bb" =~ "ABb" ); + ( __LOC__ >:: fun _ -> + Ext_namespace.change_ext_ns_suffix "a-b" Literals.suffix_js =~ "a.js"; + Ext_namespace.change_ext_ns_suffix "a-" Literals.suffix_js =~ "a.js"; + Ext_namespace.change_ext_ns_suffix "a--" Literals.suffix_js + =~ "a-.js"; + Ext_namespace.change_ext_ns_suffix "AA-b" Literals.suffix_js + =~ "AA.js"; + Ext_namespace.js_name_of_modulename "AA-b" Little Literals.suffix_js + =~ "aA.js"; + Ext_namespace.js_name_of_modulename "AA-b" Upper Literals.suffix_js + =~ "AA.js"; + Ext_namespace.js_name_of_modulename "AA-b" Upper ".bs.js" + =~ "AA.bs.js" ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = + OUnit.assert_equal ~printer:(fun x -> + match x with + | None -> "" + | Some (a, b) -> a ^ "," ^ b) + in + Ext_namespace.try_split_module_name "Js-X" =~ Some ("X", "Js"); + Ext_namespace.try_split_module_name "Js_X" =~ None ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal ~printer:(fun x -> x) in + let f = Ext_string.capitalize_ascii in + f "x" =~ "X"; + f "X" =~ "X"; + f "" =~ ""; + f "abc" =~ "Abc"; + f "_bc" =~ "_bc"; + let v = "bc" in + f v =~ "Bc"; + v =~ "bc" ); + ( __LOC__ >:: fun _ -> + let ( =~ ) = OUnit.assert_equal ~printer:printer_string in + Ext_filename.chop_all_extensions_maybe "a.bs.js" =~ "a"; + Ext_filename.chop_all_extensions_maybe "a.js" =~ "a"; + Ext_filename.chop_all_extensions_maybe "a" =~ "a"; + Ext_filename.chop_all_extensions_maybe "a.x.bs.js" =~ "a" ); + (* let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in *) + ( __LOC__ >:: fun _ -> + let k = Ext_modulename.js_id_name_of_hint_name in + k "xx" =~ "Xx"; + k "react-dom" =~ "ReactDom"; + k "a/b/react-dom" =~ "ReactDom"; + k "a/b" =~ "B"; + k "a/" =~ "A/"; + (*TODO: warning?*) + k "#moduleid" =~ "Moduleid"; + k "@bundle" =~ "Bundle"; + k "xx#bc" =~ "Xxbc"; + k "hi@myproj" =~ "Himyproj"; + k "ab/c/xx.b.js" =~ "XxBJs"; + (* improve it in the future*) + k "c/d/a--b" =~ "AB"; + k "c/d/ac--" =~ "Ac" ); + ( __LOC__ >:: fun _ -> + Ext_string.capitalize_sub "ab-Ns.cmi" 2 =~ "Ab"; + Ext_string.capitalize_sub "Ab-Ns.cmi" 2 =~ "Ab"; + Ext_string.capitalize_sub "Ab-Ns.cmi" 3 =~ "Ab-" ); + ( __LOC__ >:: fun _ -> + OUnit.assert_equal + (String.length (Digest.string "")) + Ext_digest.length ); + ( __LOC__ >:: fun _ -> + let bench = + String.concat ";" (Ext_list.init 11 (fun i -> string_of_int i)) + in + let buf = Ext_buffer.create 10 in + OUnit.assert_bool __LOC__ (Ext_buffer.not_equal buf bench); + for i = 0 to 9 do + Ext_buffer.add_string buf (string_of_int i); + Ext_buffer.add_string buf ";" + done; + OUnit.assert_bool __LOC__ (Ext_buffer.not_equal buf bench); + Ext_buffer.add_string buf "10"; + (* print_endline (Ext_buffer.contents buf); + print_endline bench; *) + OUnit.assert_bool __LOC__ (not (Ext_buffer.not_equal buf bench)) ); + ( __LOC__ >:: fun _ -> + string_eq (Ext_filename.new_extension "a.c" ".xx") "a.xx"; + string_eq (Ext_filename.new_extension "abb.c" ".xx") "abb.xx"; + string_eq (Ext_filename.new_extension ".c" ".xx") ".xx"; + string_eq (Ext_filename.new_extension "a/b" ".xx") "a/b.xx"; + string_eq (Ext_filename.new_extension "a/b." ".xx") "a/b.xx"; + string_eq (Ext_filename.chop_all_extensions_maybe "a.b.x") "a"; + string_eq (Ext_filename.chop_all_extensions_maybe "a.b") "a"; + string_eq (Ext_filename.chop_all_extensions_maybe ".a.b.x") ""; + string_eq (Ext_filename.chop_all_extensions_maybe "abx") "abx" ); + ( __LOC__ >:: fun _ -> + string_eq (Ext_filename.module_name "a/b/c.d") "C"; + string_eq (Ext_filename.module_name "a/b/xc.res") "Xc"; + string_eq (Ext_filename.module_name "a/b/xc.resi") "Xc"; + string_eq (Ext_filename.module_name "a/b/xc.ml") "Xc"; + string_eq (Ext_filename.module_name "a/b/xc.mli") "Xc"; + string_eq (Ext_filename.module_name "a/b/xc.cppo.mli") "Xc.cppo"; + string_eq (Ext_filename.module_name "a/b/xc.cppo.") "Xc.cppo"; + string_eq (Ext_filename.module_name "a/b/xc..") "Xc."; + string_eq (Ext_filename.module_name "a/b/Xc..") "Xc."; + string_eq (Ext_filename.module_name "a/b/.") "" ); + ( __LOC__ >:: fun _ -> + Ext_string.split "" ':' =~ []; + Ext_string.split "a:b:" ':' =~ ["a"; "b"]; + Ext_string.split "a:b:" ':' ~keep_empty:true =~ ["a"; "b"; ""] ); + ( __LOC__ >:: fun _ -> + let cmp0 = Ext_string.compare in + let cmp1 = Map_string.compare_key in + let f a b = + cmp0 a b =~ cmp1 a b; + cmp0 b a =~ cmp1 b a + in + (* This is needed since deserialization/serialization + needs to be synced up for .bsbuild decoding + *) + f "a" "A"; + f "bcdef" "abcdef"; + f "" "A"; + f "Abcdef" "abcdef" ); + ] diff --git a/compiler/ounit_tests/ounit_tests_main.ml b/compiler/ounit_tests/ounit_tests_main.ml index 5d4dc9fae8..249ecd5533 100644 --- a/compiler/ounit_tests/ounit_tests_main.ml +++ b/compiler/ounit_tests/ounit_tests_main.ml @@ -1,27 +1,28 @@ let suites = - OUnit.(>:::) __FILE__ [ - Ounit_vec_test.suites; - Ounit_json_tests.suites; - Ounit_path_tests.suites; - Ounit_array_tests.suites; - Ounit_scc_tests.suites; - Ounit_list_test.suites; - Ounit_hash_set_tests.suites; - Ounit_union_find_tests.suites; - Ounit_bal_tree_tests.suites; - Ounit_hash_stubs_test.suites; - Ounit_map_tests.suites; - Ounit_hashtbl_tests.suites; - Ounit_string_tests.suites; - Ounit_topsort_tests.suites; - Ounit_int_vec_tests.suites; - Ounit_ident_mask_tests.suites; - Ounit_js_regex_checker_tests.suites; - Ounit_utf8_test.suites; - Ounit_unicode_tests.suites; - Ounit_bsb_regex_tests.suites; - Ounit_bsb_pkg_tests.suites; - Ounit_util_tests.suites; - ] + OUnit.( >::: ) __FILE__ + [ + Ounit_vec_test.suites; + Ounit_json_tests.suites; + Ounit_path_tests.suites; + Ounit_array_tests.suites; + Ounit_scc_tests.suites; + Ounit_list_test.suites; + Ounit_hash_set_tests.suites; + Ounit_union_find_tests.suites; + Ounit_bal_tree_tests.suites; + Ounit_hash_stubs_test.suites; + Ounit_map_tests.suites; + Ounit_hashtbl_tests.suites; + Ounit_string_tests.suites; + Ounit_topsort_tests.suites; + Ounit_int_vec_tests.suites; + Ounit_ident_mask_tests.suites; + Ounit_js_regex_checker_tests.suites; + Ounit_utf8_test.suites; + Ounit_unicode_tests.suites; + Ounit_bsb_regex_tests.suites; + Ounit_bsb_pkg_tests.suites; + Ounit_util_tests.suites; + ] let _ = OUnit.run_test_tt_main suites diff --git a/compiler/ounit_tests/ounit_tests_util.ml b/compiler/ounit_tests/ounit_tests_util.ml index d1836345c5..5115c34646 100644 --- a/compiler/ounit_tests/ounit_tests_util.ml +++ b/compiler/ounit_tests/ounit_tests_util.ml @@ -2,45 +2,34 @@ let raises f = try ignore (f ()); None - with e -> - Some e + with e -> Some e -let assert_raise_any ?msg (f: unit -> 'a) = +let assert_raise_any ?msg (f : unit -> 'a) = let get_error_string () = - let str = - Format.sprintf - "expected exception, but no exception was raised." + let str = + Format.sprintf "expected exception, but no exception was raised." in - match msg with - | None -> - OUnit.assert_failure str - | Some s -> - OUnit.assert_failure (s^"\n"^str) + match msg with + | None -> OUnit.assert_failure str + | Some s -> OUnit.assert_failure (s ^ "\n" ^ str) in match raises f with - | None -> - OUnit.assert_failure (get_error_string ()) - | Some exn -> - OUnit.assert_bool (Printexc.to_string exn) true + | None -> OUnit.assert_failure (get_error_string ()) + | Some exn -> OUnit.assert_bool (Printexc.to_string exn) true -let time ?nums description f = - match nums with - | None -> - begin - let start = Unix.gettimeofday () in - ignore @@ f (); - let finish = Unix.gettimeofday () in - Printf.printf "\n%s elapsed %f\n" description (finish -. start) ; - flush stdout; - end - - | Some nums -> - begin - let start = Unix.gettimeofday () in - for _i = 0 to nums - 1 do - ignore @@ f (); - done ; - let finish = Unix.gettimeofday () in - Printf.printf "\n%s elapsed %f\n" description (finish -. start) ; - flush stdout; - end +let time ?nums description f = + match nums with + | None -> + let start = Unix.gettimeofday () in + ignore @@ f (); + let finish = Unix.gettimeofday () in + Printf.printf "\n%s elapsed %f\n" description (finish -. start); + flush stdout + | Some nums -> + let start = Unix.gettimeofday () in + for _i = 0 to nums - 1 do + ignore @@ f () + done; + let finish = Unix.gettimeofday () in + Printf.printf "\n%s elapsed %f\n" description (finish -. start); + flush stdout diff --git a/compiler/ounit_tests/ounit_topsort_tests.ml b/compiler/ounit_tests/ounit_topsort_tests.ml index 0a94176342..bb4ca585e7 100644 --- a/compiler/ounit_tests/ounit_topsort_tests.ml +++ b/compiler/ounit_tests/ounit_topsort_tests.ml @@ -1,70 +1,48 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let handle graph = - let len = List.length graph in - let result = Ext_topsort.Edge_vec.make len in - List.iter (fun (id,deps) -> - Ext_topsort.Edge_vec.push result {id ; deps = Vec_int.of_list deps } - ) graph; - result - - -let graph1 = - [ - 0, [1;2]; - 1, [2;3]; - 2, [4]; - 3, []; - 4, [] - ], [[0]; [1]; [2] ; [3;4]] - - -let graph2 = - [ - 0, [1;2]; - 1, [2;3]; - 2, [4]; - 3, [5]; - 4, [5]; - 5, [] - ], - [[0]; [1]; [2] ; [3;4]; [5]] - -let graph3 = - [ 0,[1;2;3;4;5]; - 1, [6;7;8] ; - 2, [6;7;8]; - 3, [6;7;8]; - 4, [6;7;8]; - 5, [6;7;8]; - 6, []; - 7, [] ; - 8, [] - ], - [[0]; [1;2;3;4;5]; [6; 7; 8]] - - -let expect loc (graph1, v) = - let graph = handle graph1 in - let queue = Ext_topsort.layered_dfs graph in +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) + +let handle graph = + let len = List.length graph in + let result = Ext_topsort.Edge_vec.make len in + List.iter + (fun (id, deps) -> + Ext_topsort.Edge_vec.push result {id; deps = Vec_int.of_list deps}) + graph; + result + +let graph1 = + ( [(0, [1; 2]); (1, [2; 3]); (2, [4]); (3, []); (4, [])], + [[0]; [1]; [2]; [3; 4]] ) + +let graph2 = + ( [(0, [1; 2]); (1, [2; 3]); (2, [4]); (3, [5]); (4, [5]); (5, [])], + [[0]; [1]; [2]; [3; 4]; [5]] ) + +let graph3 = + ( [ + (0, [1; 2; 3; 4; 5]); + (1, [6; 7; 8]); + (2, [6; 7; 8]); + (3, [6; 7; 8]); + (4, [6; 7; 8]); + (5, [6; 7; 8]); + (6, []); + (7, []); + (8, []); + ], + [[0]; [1; 2; 3; 4; 5]; [6; 7; 8]] ) + +let expect loc (graph1, v) = + let graph = handle graph1 in + let queue = Ext_topsort.layered_dfs graph in OUnit.assert_bool loc - (Queue.fold (fun acc x -> Set_int.elements x::acc) [] queue = - v) - - + (Queue.fold (fun acc x -> Set_int.elements x :: acc) [] queue = v) - - -let (=~) = OUnit.assert_equal -let suites = +let ( =~ ) = OUnit.assert_equal +let suites = __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - expect __LOC__ graph1; - expect __LOC__ graph2 ; - expect __LOC__ graph3 - end - - ] \ No newline at end of file + >::: [ + ( __LOC__ >:: fun _ -> + expect __LOC__ graph1; + expect __LOC__ graph2; + expect __LOC__ graph3 ); + ] diff --git a/compiler/ounit_tests/ounit_unicode_tests.ml b/compiler/ounit_tests/ounit_unicode_tests.ml index 0c289da83e..0bd7954172 100644 --- a/compiler/ounit_tests/ounit_unicode_tests.ml +++ b/compiler/ounit_tests/ounit_unicode_tests.ml @@ -1,246 +1,172 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) a b = - OUnit.assert_equal ~cmp:Ext_string.equal a b +let ( =~ ) a b = OUnit.assert_equal ~cmp:Ext_string.equal a b (** Test for single line *) -let (==~) a b = +let ( ==~ ) a b = OUnit.assert_equal - ( - Ext_list.map (Ast_utf8_string_interp.transform_test a - |> List.filter (fun x -> not @@ Ast_utf8_string_interp.empty_segment x)) - (fun - ({start = {offset = a}; finish = {offset = b}; kind ; content } - : Ast_utf8_string_interp.segment) -> - a,b,kind,content - ) - ) - b + (Ext_list.map + (Ast_utf8_string_interp.transform_test a + |> List.filter (fun x -> not @@ Ast_utf8_string_interp.empty_segment x)) + (fun ({start = {offset = a}; finish = {offset = b}; kind; content} : + Ast_utf8_string_interp.segment) -> (a, b, kind, content))) + b -let (==*) a b = - let segments = - Ext_list.map ( - Ast_utf8_string_interp.transform_test a - |> List.filter (fun x -> not @@ Ast_utf8_string_interp.empty_segment x) - )(fun - ({start = {lnum=la; offset = a}; finish = {lnum = lb; offset = b}; kind ; content } - : Ast_utf8_string_interp.segment) -> - la,a,lb,b,kind,content - ) - in - OUnit.assert_equal segments b +let ( ==* ) a b = + let segments = + Ext_list.map + (Ast_utf8_string_interp.transform_test a + |> List.filter (fun x -> not @@ Ast_utf8_string_interp.empty_segment x)) + (fun ({ + start = {lnum = la; offset = a}; + finish = {lnum = lb; offset = b}; + kind; + content; + } : + Ast_utf8_string_interp.segment) -> (la, a, lb, b, kind, content)) + in + OUnit.assert_equal segments b -let varParen : Ast_utf8_string_interp.kind = Var (2,-1) -let var : Ast_utf8_string_interp.kind = Var (1,0) -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test {|x|} =~ {|x|} - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "a\nb" =~ {|a\nb|} - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test - "\\n" =~ "\\n" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test {|\h\e\l\lo \"world\"!|} =~ {|\h\e\l\lo \"world\"!|} - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "\\u{1d306}" =~ "\\u{1d306}" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "unicode escape: \\u{1d306}" =~ "unicode escape: \\u{1d306}" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "unicode escape: \\u{1d306} with suffix text" =~ "unicode escape: \\u{1d306} with suffix text" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test - "\\\\\\b\\t\\n\\v\\f\\r\\0\\$" =~ - "\\\\\\b\\t\\n\\v\\f\\r\\0\\$" - end; +let varParen : Ast_utf8_string_interp.kind = Var (2, -1) +let var : Ast_utf8_string_interp.kind = Var (1, 0) +let suites = + __FILE__ + >::: [ + (__LOC__ >:: fun _ -> Ast_utf8_string.transform_test {|x|} =~ {|x|}); + (__LOC__ >:: fun _ -> Ast_utf8_string.transform_test "a\nb" =~ {|a\nb|}); + (__LOC__ >:: fun _ -> Ast_utf8_string.transform_test "\\n" =~ "\\n"); + ( __LOC__ >:: fun _ -> + Ast_utf8_string.transform_test {|\h\e\l\lo \"world\"!|} + =~ {|\h\e\l\lo \"world\"!|} ); + ( __LOC__ >:: fun _ -> + Ast_utf8_string.transform_test "\\u{1d306}" =~ "\\u{1d306}" ); + ( __LOC__ >:: fun _ -> + Ast_utf8_string.transform_test "unicode escape: \\u{1d306}" + =~ "unicode escape: \\u{1d306}" ); + ( __LOC__ >:: fun _ -> + Ast_utf8_string.transform_test + "unicode escape: \\u{1d306} with suffix text" + =~ "unicode escape: \\u{1d306} with suffix text" ); + ( __LOC__ >:: fun _ -> + Ast_utf8_string.transform_test "\\\\\\b\\t\\n\\v\\f\\r\\0\\$" + =~ "\\\\\\b\\t\\n\\v\\f\\r\\0\\$" ); + ( __LOC__ >:: fun _ -> + match Ast_utf8_string.transform_test {|\|} with + | exception Ast_utf8_string.Error (offset, _) -> + OUnit.assert_equal offset 1 + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + match Ast_utf8_string.transform_test {|你\|} with + | exception Ast_utf8_string.Error (offset, _) -> + OUnit.assert_equal offset 2 + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + match Ast_utf8_string.transform_test {|你BuckleScript,好啊\uffff\|} with + | exception Ast_utf8_string.Error (offset, _) -> + OUnit.assert_equal offset 23 + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + match Ast_utf8_string.transform_test {js|\u{110000}|js} with + (* bigger than max valid unicode codepoint *) + | exception Ast_utf8_string.Error (offset, _) -> + OUnit.assert_equal offset 3 + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + match + Ast_utf8_string.transform_test + {js|\u{FFFFFFFFFFFFFFFFFFFFFFFFFFFFF}|js} + with + (* overflow *) + | exception Ast_utf8_string.Error (offset, _) -> + OUnit.assert_equal offset 3 + | _ -> OUnit.assert_failure __LOC__ ); + ( __LOC__ >:: fun _ -> + "hie $x hi 你好" + ==~ [ + (0, 4, String, "hie "); + (4, 6, var, "x"); + (6, 12, String, " hi 你好"); + ] ); + (__LOC__ >:: fun _ -> "x" ==~ [(0, 1, String, "x")]); + (__LOC__ >:: fun _ -> "" ==~ []); + (__LOC__ >:: fun _ -> "你好" ==~ [(0, 2, String, "你好")]); + ( __LOC__ >:: fun _ -> + "你好$x" ==~ [(0, 2, String, "你好"); (2, 4, var, "x")] ); + ( __LOC__ >:: fun _ -> + "你好$this" ==~ [(0, 2, String, "你好"); (2, 7, var, "this")] ); + ( __LOC__ >:: fun _ -> + "你好$(this)" ==~ [(0, 2, String, "你好"); (2, 9, varParen, "this")]; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {|\|} with - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 1 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {|你\|} with - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 2 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {|你BuckleScript,好啊\uffff\|} with - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 23 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {js|\u{110000}|js} with (* bigger than max valid unicode codepoint *) - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 3 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {js|\u{FFFFFFFFFFFFFFFFFFFFFFFFFFFFF}|js} with (* overflow *) - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 3 - | _ -> OUnit.assert_failure __LOC__ - end ; + "你好$this)" + ==~ [(0, 2, String, "你好"); (2, 7, var, "this"); (7, 8, String, ")")]; + {|\xff\xff你好 $x |} + ==~ [ + (0, 11, String, {|\xff\xff你好 |}); + (11, 13, var, "x"); + (13, 14, String, " "); + ]; + {|\xff\xff你好 $x 不吃亏了buckle $y $z = $sum|} + ==~ [ + (0, 11, String, {|\xff\xff你好 |}); + (11, 13, var, "x"); + (13, 25, String, {| 不吃亏了buckle |}); + (25, 27, var, "y"); + (27, 28, String, " "); + (28, 30, var, "z"); + (30, 33, String, " = "); + (33, 37, var, "sum"); + ] ); + ( __LOC__ >:: fun _ -> + "你好 $(this_is_a_var) x" + ==~ [ + (0, 3, String, "你好 "); + (3, 19, varParen, "this_is_a_var"); + (19, 22, String, " x"); + ] ); + ( __LOC__ >:: fun _ -> + "hi\n$x\n" + ==* [ + (0, 0, 1, 0, String, "hi\\n"); + (1, 0, 1, 2, var, "x"); + (1, 2, 2, 0, String, "\\n"); + ]; + "$x" ==* [(0, 0, 0, 2, var, "x")]; - __LOC__ >:: begin fun _ -> - "hie $x hi 你好" ==~ - [ - 0,4, String, "hie "; - 4,6, var, "x"; - 6,12,String, " hi 你好" - ] - end; - __LOC__ >:: begin fun _ -> - "x" ==~ - [0,1, String, "x"] - end; - - __LOC__ >:: begin fun _ -> - "" ==~ - [] - end; - __LOC__ >:: begin fun _ -> - "你好" ==~ - [0,2,String, "你好"] - end; - __LOC__ >:: begin fun _ -> - "你好$x" ==~ - [0,2,String, "你好"; - 2,4,var, "x"; - - ] - end - ; - __LOC__ >:: begin fun _ -> - "你好$this" ==~ - [ - 0,2,String, "你好"; - 2,7,var, "this"; - ] - end - ; - __LOC__ >:: begin fun _ -> - "你好$(this)" ==~ - [ - 0,2,String, "你好"; - 2,9,varParen, "this" - ]; - - "你好$this)" ==~ - [ - 0,2,String, "你好"; - 2,7,var, "this"; - 7,8,String,")" - ]; - {|\xff\xff你好 $x |} ==~ - [ - 0,11,String, {|\xff\xff你好 |}; - 11,13, var, "x"; - 13,14, String, " " - ]; - {|\xff\xff你好 $x 不吃亏了buckle $y $z = $sum|} - ==~ - [(0, 11, String,{|\xff\xff你好 |} ); - (11, 13, var, "x"); - (13, 25, String,{| 不吃亏了buckle |} ); - (25, 27, var, "y"); - (27, 28, String, " "); - (28, 30, var, "z"); - (30, 33, String, " = "); - (33, 37, var, "sum"); - ] - end - ; - __LOC__ >:: begin fun _ -> - "你好 $(this_is_a_var) x" ==~ - [ - 0,3,String, "你好 "; - 3,19,varParen, "this_is_a_var"; - 19,22, String, " x" - ] - end - ; - - __LOC__ >:: begin fun _ -> - "hi\n$x\n" ==* - [ - 0,0,1,0,String, "hi\\n"; - 1,0,1,2,var, "x" ; - 1,2,2,0,String,"\\n" - ]; - "$x" ==* - [0,0,0,2,var,"x"]; - - - "\n$x\n" ==* - [ - 0,0,1,0,String,"\\n"; - 1,0,1,2,var,"x"; - 1,2,2,0,String,"\\n" - ] - end; - - __LOC__ >:: begin fun _ -> - "\n$(x_this_is_cool) " ==* - [ - 0,0,1,0,String, "\\n"; - 1,0,1,17,varParen, "x_this_is_cool"; - 1,17,1,18,String, " " - ] - end; - __LOC__ >:: begin fun _ -> - " $x + $y = $sum " ==* - [ - 0,0,0,1,String , " "; - 0,1,0,3,var, "x"; - 0,3,0,6,String, " + "; - 0,6,0,8,var, "y"; - 0,8,0,11,String, " = "; - 0,11,0,15,var, "sum"; - 0,15,0,16,String, " " - ] - end; - __LOC__ >:: begin fun _ -> - "中文 | $a " ==* - [ - 0,0,0,5,String, "中文 | "; - 0,5,0,7,var, "a"; - 0,7,0,8,String, " " - ] - end - ; - __LOC__ >:: begin fun _ -> - {|Hello \\$world|} ==* - [ - 0,0,0,8,String,"Hello \\\\"; - 0,8,0,14,var, "world" - ] - end - ; - __LOC__ >:: begin fun _ -> - {|$x)|} ==* - [ - 0,0,0,2,var,"x"; - 0,2,0,3,String,")" - ] - end; - ] + "\n$x\n" + ==* [ + (0, 0, 1, 0, String, "\\n"); + (1, 0, 1, 2, var, "x"); + (1, 2, 2, 0, String, "\\n"); + ] ); + ( __LOC__ >:: fun _ -> + "\n$(x_this_is_cool) " + ==* [ + (0, 0, 1, 0, String, "\\n"); + (1, 0, 1, 17, varParen, "x_this_is_cool"); + (1, 17, 1, 18, String, " "); + ] ); + ( __LOC__ >:: fun _ -> + " $x + $y = $sum " + ==* [ + (0, 0, 0, 1, String, " "); + (0, 1, 0, 3, var, "x"); + (0, 3, 0, 6, String, " + "); + (0, 6, 0, 8, var, "y"); + (0, 8, 0, 11, String, " = "); + (0, 11, 0, 15, var, "sum"); + (0, 15, 0, 16, String, " "); + ] ); + ( __LOC__ >:: fun _ -> + "中文 | $a " + ==* [ + (0, 0, 0, 5, String, "中文 | "); + (0, 5, 0, 7, var, "a"); + (0, 7, 0, 8, String, " "); + ] ); + ( __LOC__ >:: fun _ -> + {|Hello \\$world|} + ==* [(0, 0, 0, 8, String, "Hello \\\\"); (0, 8, 0, 14, var, "world")] + ); + ( __LOC__ >:: fun _ -> + {|$x)|} ==* [(0, 0, 0, 2, var, "x"); (0, 2, 0, 3, String, ")")] ); + ] diff --git a/compiler/ounit_tests/ounit_union_find_tests.ml b/compiler/ounit_tests/ounit_union_find_tests.ml index 1c8b406afc..83ea61ee31 100644 --- a/compiler/ounit_tests/ounit_union_find_tests.ml +++ b/compiler/ounit_tests/ounit_union_find_tests.ml @@ -1,8 +1,8 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal -let tinyUF = {|10 +let ( =~ ) = OUnit.assert_equal +let tinyUF = + {|10 4 3 3 8 6 5 @@ -15,7 +15,8 @@ let tinyUF = {|10 1 0 6 7 |} -let mediumUF = {|625 +let mediumUF = + {|625 528 503 548 523 389 414 @@ -918,67 +919,58 @@ let mediumUF = {|625 403 402 |} - -let process_str tinyUF = - match Ext_string.split tinyUF '\n' with +let process_str tinyUF = + match Ext_string.split tinyUF '\n' with | number :: rest -> let n = int_of_string number in let store = Union_find.init n in - List.iter (fun x -> - match Ext_string.quick_split_by_ws x with - | [a;b] -> - let a,b = int_of_string a , int_of_string b in - Union_find.union store a b - | _ -> ()) rest; + List.iter + (fun x -> + match Ext_string.quick_split_by_ws x with + | [a; b] -> + let a, b = (int_of_string a, int_of_string b) in + Union_find.union store a b + | _ -> ()) + rest; Union_find.count store | _ -> assert false -;; -let process_file file = +let process_file file = let ichan = open_in_bin file in let n = int_of_string (input_line ichan) in let store = Union_find.init n in - let edges = Int_vec_vec.make n in - let rec aux i = - match input_line ichan with + let edges = Int_vec_vec.make n in + let rec aux i = + match input_line ichan with | exception _ -> () | v -> - begin - (* if i = 0 then - print_endline "processing 100 nodes start"; - *) - begin match Ext_string.quick_split_by_ws v with - | [a;b] -> - let a,b = int_of_string a , int_of_string b in - Int_vec_vec.push edges (Vec_int.of_array [|a;b|]); - | _ -> () - end; - aux ((i+1) mod 10000); - end - in aux 0; + (* if i = 0 then + print_endline "processing 100 nodes start"; + *) + (match Ext_string.quick_split_by_ws v with + | [a; b] -> + let a, b = (int_of_string a, int_of_string b) in + Int_vec_vec.push edges (Vec_int.of_array [|a; b|]) + | _ -> ()); + aux ((i + 1) mod 10000) + in + aux 0; (* indeed, [unsafe_internal_array] is necessary for real performnace *) let internal = Int_vec_vec.unsafe_internal_array edges in for i = 0 to Array.length internal - 1 do - let i = Vec_int.unsafe_internal_array (Array.unsafe_get internal i) in - Union_find.union store (Array.unsafe_get i 0) (Array.unsafe_get i 1) - done; - (* Union_find.union store a b *) - Union_find.count store -;; -let suites = + let i = Vec_int.unsafe_internal_array (Array.unsafe_get internal i) in + Union_find.union store (Array.unsafe_get i 0) (Array.unsafe_get i 1) + done; + (* Union_find.union store a b *) + Union_find.count store +let suites = __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (process_str tinyUF) 2 - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (process_str mediumUF) 3 - end; -(* + >::: [ + (__LOC__ >:: fun _ -> OUnit.assert_equal (process_str tinyUF) 2); + (__LOC__ >:: fun _ -> OUnit.assert_equal (process_str mediumUF) 3); + (* __LOC__ >:: begin fun _ -> OUnit.assert_equal (process_file "largeUF.txt") 6 end; - *) - - ] \ No newline at end of file + *) + ] diff --git a/compiler/ounit_tests/ounit_utf8_test.ml b/compiler/ounit_tests/ounit_utf8_test.ml index 7eb0a66355..42846b6d04 100644 --- a/compiler/ounit_tests/ounit_utf8_test.ml +++ b/compiler/ounit_tests/ounit_utf8_test.ml @@ -1,23 +1,32 @@ - - (* https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt *) -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let (=~) = OUnit.assert_equal -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Ext_utf8.decode_utf8_string - "hello 你好，中华民族 hei" =~ - [104; 101; 108; 108; 111; 32; 20320; 22909; 65292; 20013; 21326; 27665; 26063; 32; 104; 101; 105] - end ; - __LOC__ >:: begin fun _ -> - Ext_utf8.decode_utf8_string - "" =~ [] - end - ] \ No newline at end of file +let ( =~ ) = OUnit.assert_equal +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + Ext_utf8.decode_utf8_string "hello 你好，中华民族 hei" + =~ [ + 104; + 101; + 108; + 108; + 111; + 32; + 20320; + 22909; + 65292; + 20013; + 21326; + 27665; + 26063; + 32; + 104; + 101; + 105; + ] ); + (__LOC__ >:: fun _ -> Ext_utf8.decode_utf8_string "" =~ []); + ] diff --git a/compiler/ounit_tests/ounit_util_tests.ml b/compiler/ounit_tests/ounit_util_tests.ml index 0360ffcf21..3ecb59ec97 100644 --- a/compiler/ounit_tests/ounit_util_tests.ml +++ b/compiler/ounit_tests/ounit_util_tests.ml @@ -1,67 +1,58 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( =~ ) = OUnit.assert_equal ~printer:Ext_obj.dump +let suites = + __FILE__ + >::: [ + ( __LOC__ >:: fun _ -> + Ext_pervasives.nat_of_string_exn "003" =~ 3; + (try + Ext_pervasives.nat_of_string_exn "0a" |> ignore; + 2 + with _ -> -1) + =~ -1 ); + ( __LOC__ >:: fun _ -> + let cursor = ref 0 in + let v = Ext_pervasives.parse_nat_of_string "123a" cursor in + (v, !cursor) =~ (123, 3); + cursor := 0; + let v = Ext_pervasives.parse_nat_of_string "a" cursor in + (v, !cursor) =~ (0, 0) ); + (* __LOC__ >:: begin fun _ -> + for i = 0 to 0xff do + let buf = Ext_buffer.create 0 in + Ext_buffer.add_int_1 buf i; + let s = Ext_buffer.contents buf in + s =~ String.make 1 (Char.chr i); + Ext_string.get_int_1 s 0 =~ i + done + end; *) - -let (=~) = - OUnit.assert_equal - ~printer:Ext_obj.dump -let suites = - __FILE__ >::: - [ - __LOC__ >:: begin fun _ -> - Ext_pervasives.nat_of_string_exn "003" =~ 3; - (try Ext_pervasives.nat_of_string_exn "0a" |> ignore ; 2 with _ -> -1) =~ -1; - end; - __LOC__ >:: begin fun _ -> - let cursor = ref 0 in - let v = Ext_pervasives.parse_nat_of_string "123a" cursor in - (v, !cursor) =~ (123,3); - cursor := 0; - let v = Ext_pervasives.parse_nat_of_string "a" cursor in - (v,!cursor) =~ (0,0) - end; - - (* __LOC__ >:: begin fun _ -> - for i = 0 to 0xff do - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_1 buf i; - let s = Ext_buffer.contents buf in - s =~ String.make 1 (Char.chr i); - Ext_string.get_int_1 s 0 =~ i - done - end; *) - - (* __LOC__ >:: begin fun _ -> - for i = 0x100 to 0xff_ff do - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_2 buf i; - let s = Ext_buffer.contents buf in - Ext_string.get_int_2 s 0 =~ i - done ; - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_3 buf 0x1_ff_ff; - Ext_string.get_int_3 (Ext_buffer.contents buf) 0 =~ 0x1_ff_ff - ; - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_4 buf 0x1_ff_ff_ff; - Ext_string.get_int_4 (Ext_buffer.contents buf) 0 =~ 0x1_ff_ff_ff - end; *) - __LOC__ >:: begin fun _ -> - let buf = Ext_buffer.create 0 in - Ext_buffer.add_string_char buf "hello" 'v'; - Ext_buffer.contents buf =~ "hellov"; - Ext_buffer.length buf =~ 6 - end; - __LOC__ >:: begin fun _ -> - let buf = Ext_buffer.create 0 in - Ext_buffer.add_char_string buf 'h' "ellov"; - Ext_buffer.contents buf =~ "hellov"; - Ext_buffer.length buf =~ 6 - end; - __LOC__ >:: begin fun _ -> - String.length - (Digest.to_hex(Digest.string "")) =~ 32 - end - - ] \ No newline at end of file + (* __LOC__ >:: begin fun _ -> + for i = 0x100 to 0xff_ff do + let buf = Ext_buffer.create 0 in + Ext_buffer.add_int_2 buf i; + let s = Ext_buffer.contents buf in + Ext_string.get_int_2 s 0 =~ i + done ; + let buf = Ext_buffer.create 0 in + Ext_buffer.add_int_3 buf 0x1_ff_ff; + Ext_string.get_int_3 (Ext_buffer.contents buf) 0 =~ 0x1_ff_ff + ; + let buf = Ext_buffer.create 0 in + Ext_buffer.add_int_4 buf 0x1_ff_ff_ff; + Ext_string.get_int_4 (Ext_buffer.contents buf) 0 =~ 0x1_ff_ff_ff + end; *) + ( __LOC__ >:: fun _ -> + let buf = Ext_buffer.create 0 in + Ext_buffer.add_string_char buf "hello" 'v'; + Ext_buffer.contents buf =~ "hellov"; + Ext_buffer.length buf =~ 6 ); + ( __LOC__ >:: fun _ -> + let buf = Ext_buffer.create 0 in + Ext_buffer.add_char_string buf 'h' "ellov"; + Ext_buffer.contents buf =~ "hellov"; + Ext_buffer.length buf =~ 6 ); + ( __LOC__ >:: fun _ -> + String.length (Digest.to_hex (Digest.string "")) =~ 32 ); + ] diff --git a/compiler/ounit_tests/ounit_vec_test.ml b/compiler/ounit_tests/ounit_vec_test.ml index a834b83416..b38d0e0a6c 100644 --- a/compiler/ounit_tests/ounit_vec_test.ml +++ b/compiler/ounit_tests/ounit_vec_test.ml @@ -1,153 +1,151 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) (* open Ext_json *) -let v = Vec_int.init 10 (fun i -> i);; -let (=~) x y = OUnit.assert_equal ~cmp:(Vec_int.equal (fun (x: int) y -> x=y)) x y -let (=~~) x y - = - OUnit.assert_equal ~cmp:(Vec_int.equal (fun (x: int) y -> x=y)) - x (Vec_int.of_array y) +let v = Vec_int.init 10 (fun i -> i) +let ( =~ ) x y = + OUnit.assert_equal ~cmp:(Vec_int.equal (fun (x : int) y -> x = y)) x y +let ( =~~ ) x y = + OUnit.assert_equal + ~cmp:(Vec_int.equal (fun (x : int) y -> x = y)) + x (Vec_int.of_array y) -let suites = - __FILE__ - >::: - [ - (* idea - [%loc "inplace filter" ] --> __LOC__ ^ "inplace filter" - or "inplace filter" [@bs.loc] - *) - "inplace_filter " ^ __LOC__ >:: begin fun _ -> - v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]; - - ignore @@ Vec_int.push v 32; - let capacity = Vec_int.capacity v in - v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 32|]; - Vec_int.inplace_filter (fun x -> x mod 2 = 0) v ; - v =~~ [|0; 2; 4; 6; 8; 32|]; - Vec_int.inplace_filter (fun x -> x mod 3 = 0) v ; - v =~~ [|0;6|]; - Vec_int.inplace_filter (fun x -> x mod 3 <> 0) v ; - v =~~ [||]; - OUnit.assert_equal (Vec_int.capacity v ) capacity ; - Vec_int.compact v ; - OUnit.assert_equal (Vec_int.capacity v ) 0 - end - ; - "inplace_filter_from " ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array (Array.init 10 (fun i -> i)) in - v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]; - Vec_int.push v 96 ; - Vec_int.inplace_filter_from 2 (fun x -> x mod 2 = 0) v ; - v =~~ [|0; 1; 2; 4; 6; 8; 96|]; - Vec_int.inplace_filter_from 2 (fun x -> x mod 3 = 0) v ; - v =~~ [|0; 1; 6; 96|]; - Vec_int.inplace_filter (fun x -> x mod 3 <> 0) v ; - v =~~ [|1|]; - Vec_int.compact v ; - OUnit.assert_equal (Vec_int.capacity v ) 1 - end - ; - "map " ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array (Array.init 1000 (fun i -> i )) in - Vec_int.map succ v =~~ (Array.init 1000 succ) ; - OUnit.assert_bool __LOC__ (Vec_int.exists (fun x -> x >= 999) v ); - OUnit.assert_bool __LOC__ (not (Vec_int.exists (fun x -> x > 1000) v )); - OUnit.assert_equal (Vec_int.last v ) 999 - end ; - __LOC__ >:: begin fun _ -> - let count = 1000 in - let init_array = (Array.init count (fun i -> i)) in - let u = Vec_int.of_array init_array in - let v = Vec_int.inplace_filter_with (fun x -> x mod 2 = 0) ~cb_no:(fun a b -> Set_int.add b a)Set_int.empty u in - let (even,odd) = init_array |> Array.to_list |> List.partition (fun x -> x mod 2 = 0) in - OUnit.assert_equal - (Set_int.elements v) odd ; - u =~~ Array.of_list even - end ; - "filter" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array [|1;2;3;4;5;6|] in - v |> Vec_int.filter (fun x -> x mod 3 = 0) |> (fun x -> x =~~ [|3;6|]); - v =~~ [|1;2;3;4;5;6|]; - Vec_int.pop v ; - v =~~ [|1;2;3;4;5|]; - let count = ref 0 in - let len = Vec_int.length v in - while not (Vec_int.is_empty v ) do - Vec_int.pop v ; - incr count - done; - OUnit.assert_equal len !count - end - ; - __LOC__ >:: begin fun _ -> - let count = 100 in - let v = Vec_int.of_array (Array.init count (fun i -> i)) in - OUnit.assert_bool __LOC__ - (try Vec_int.delete v count; false with _ -> true ); - for i = count - 1 downto 10 do - Vec_int.delete v i ; - done ; - v =~~ [|0;1;2;3;4;5;6;7;8;9|] - end; - "sub" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.make 5 in - OUnit.assert_bool __LOC__ - (try ignore @@ Vec_int.sub v 0 2 ; false with Invalid_argument _ -> true); - Vec_int.push v 1; - OUnit.assert_bool __LOC__ - (try ignore @@ Vec_int.sub v 0 2 ; false with Invalid_argument _ -> true); - Vec_int.push v 2; - ( Vec_int.sub v 0 2 =~~ [|1;2|]) - end; - "reserve" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.empty () in - Vec_int.reserve v 1000 ; - for i = 0 to 900 do - Vec_int.push v i - done ; - OUnit.assert_equal (Vec_int.length v) 901 ; - OUnit.assert_equal (Vec_int.capacity v) 1000 - end ; - "capacity" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array [|3|] in - Vec_int.reserve v 10 ; - v =~~ [|3 |]; - Vec_int.push v 1 ; - Vec_int.push v 2 ; - Vec_int.push v 5; - v=~~ [|3;1;2;5|]; - OUnit.assert_equal (Vec_int.capacity v ) 10 ; - for i = 0 to 5 do - Vec_int.push v i - done; - v=~~ [|3;1;2;5;0;1;2;3;4;5|]; - Vec_int.push v 100; - v=~~[|3;1;2;5;0;1;2;3;4;5;100|]; - OUnit.assert_equal (Vec_int.capacity v ) 20 - end - ; - __LOC__ >:: begin fun _ -> - let empty = Vec_int.empty () in - Vec_int.push empty 3; - empty =~~ [|3|]; +let suites = + __FILE__ + >::: [ + (* idea + [%loc "inplace filter" ] --> __LOC__ ^ "inplace filter" + or "inplace filter" [@bs.loc] + *) + ( "inplace_filter " ^ __LOC__ >:: fun _ -> + v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]; - end - ; - __LOC__ >:: begin fun _ -> - let lst = [1;2;3;4] in - let v = Vec_int.of_list lst in - OUnit.assert_equal - (Vec_int.map_into_list (fun x -> x + 1) v) - (Ext_list.map lst (fun x -> x + 1) ) - end; - __LOC__ >:: begin fun _ -> - let v = Vec_int.make 4 in - Vec_int.push v 1 ; - Vec_int.push v 2; - Vec_int.reverse_in_place v; - v =~~ [|2;1|] - end - ; - ] + ignore @@ Vec_int.push v 32; + let capacity = Vec_int.capacity v in + v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 32|]; + Vec_int.inplace_filter (fun x -> x mod 2 = 0) v; + v =~~ [|0; 2; 4; 6; 8; 32|]; + Vec_int.inplace_filter (fun x -> x mod 3 = 0) v; + v =~~ [|0; 6|]; + Vec_int.inplace_filter (fun x -> x mod 3 <> 0) v; + v =~~ [||]; + OUnit.assert_equal (Vec_int.capacity v) capacity; + Vec_int.compact v; + OUnit.assert_equal (Vec_int.capacity v) 0 ); + ( "inplace_filter_from " ^ __LOC__ >:: fun _ -> + let v = Vec_int.of_array (Array.init 10 (fun i -> i)) in + v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]; + Vec_int.push v 96; + Vec_int.inplace_filter_from 2 (fun x -> x mod 2 = 0) v; + v =~~ [|0; 1; 2; 4; 6; 8; 96|]; + Vec_int.inplace_filter_from 2 (fun x -> x mod 3 = 0) v; + v =~~ [|0; 1; 6; 96|]; + Vec_int.inplace_filter (fun x -> x mod 3 <> 0) v; + v =~~ [|1|]; + Vec_int.compact v; + OUnit.assert_equal (Vec_int.capacity v) 1 ); + ( "map " ^ __LOC__ >:: fun _ -> + let v = Vec_int.of_array (Array.init 1000 (fun i -> i)) in + Vec_int.map succ v =~~ Array.init 1000 succ; + OUnit.assert_bool __LOC__ (Vec_int.exists (fun x -> x >= 999) v); + OUnit.assert_bool __LOC__ + (not (Vec_int.exists (fun x -> x > 1000) v)); + OUnit.assert_equal (Vec_int.last v) 999 ); + ( __LOC__ >:: fun _ -> + let count = 1000 in + let init_array = Array.init count (fun i -> i) in + let u = Vec_int.of_array init_array in + let v = + Vec_int.inplace_filter_with + (fun x -> x mod 2 = 0) + ~cb_no:(fun a b -> Set_int.add b a) + Set_int.empty u + in + let even, odd = + init_array |> Array.to_list + |> List.partition (fun x -> x mod 2 = 0) + in + OUnit.assert_equal (Set_int.elements v) odd; + u =~~ Array.of_list even ); + ( "filter" ^ __LOC__ >:: fun _ -> + let v = Vec_int.of_array [|1; 2; 3; 4; 5; 6|] in + ( v |> Vec_int.filter (fun x -> x mod 3 = 0) |> fun x -> + x =~~ [|3; 6|] ); + v =~~ [|1; 2; 3; 4; 5; 6|]; + Vec_int.pop v; + v =~~ [|1; 2; 3; 4; 5|]; + let count = ref 0 in + let len = Vec_int.length v in + while not (Vec_int.is_empty v) do + Vec_int.pop v; + incr count + done; + OUnit.assert_equal len !count ); + ( __LOC__ >:: fun _ -> + let count = 100 in + let v = Vec_int.of_array (Array.init count (fun i -> i)) in + OUnit.assert_bool __LOC__ + (try + Vec_int.delete v count; + false + with _ -> true); + for i = count - 1 downto 10 do + Vec_int.delete v i + done; + v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|] ); + ( "sub" ^ __LOC__ >:: fun _ -> + let v = Vec_int.make 5 in + OUnit.assert_bool __LOC__ + (try + ignore @@ Vec_int.sub v 0 2; + false + with Invalid_argument _ -> true); + Vec_int.push v 1; + OUnit.assert_bool __LOC__ + (try + ignore @@ Vec_int.sub v 0 2; + false + with Invalid_argument _ -> true); + Vec_int.push v 2; + Vec_int.sub v 0 2 =~~ [|1; 2|] ); + ( "reserve" ^ __LOC__ >:: fun _ -> + let v = Vec_int.empty () in + Vec_int.reserve v 1000; + for i = 0 to 900 do + Vec_int.push v i + done; + OUnit.assert_equal (Vec_int.length v) 901; + OUnit.assert_equal (Vec_int.capacity v) 1000 ); + ( "capacity" ^ __LOC__ >:: fun _ -> + let v = Vec_int.of_array [|3|] in + Vec_int.reserve v 10; + v =~~ [|3|]; + Vec_int.push v 1; + Vec_int.push v 2; + Vec_int.push v 5; + v =~~ [|3; 1; 2; 5|]; + OUnit.assert_equal (Vec_int.capacity v) 10; + for i = 0 to 5 do + Vec_int.push v i + done; + v =~~ [|3; 1; 2; 5; 0; 1; 2; 3; 4; 5|]; + Vec_int.push v 100; + v =~~ [|3; 1; 2; 5; 0; 1; 2; 3; 4; 5; 100|]; + OUnit.assert_equal (Vec_int.capacity v) 20 ); + ( __LOC__ >:: fun _ -> + let empty = Vec_int.empty () in + Vec_int.push empty 3; + empty =~~ [|3|] ); + ( __LOC__ >:: fun _ -> + let lst = [1; 2; 3; 4] in + let v = Vec_int.of_list lst in + OUnit.assert_equal + (Vec_int.map_into_list (fun x -> x + 1) v) + (Ext_list.map lst (fun x -> x + 1)) ); + ( __LOC__ >:: fun _ -> + let v = Vec_int.make 4 in + Vec_int.push v 1; + Vec_int.push v 2; + Vec_int.reverse_in_place v; + v =~~ [|2; 1|] ); + ] diff --git a/compiler/syntax/.ocamlformat-ignore b/compiler/syntax/.ocamlformat-ignore deleted file mode 100644 index 0c4403d0c7..0000000000 --- a/compiler/syntax/.ocamlformat-ignore +++ /dev/null @@ -1 +0,0 @@ -compiler-libs-406/* diff --git a/dune-project b/dune-project index 35aec69994..d0d3bdca87 100644 --- a/dune-project +++ b/dune-project @@ -21,7 +21,13 @@ (ocaml (>= 4.10)) (ocamlformat - (= 0.26.2)) + (and + :with-test + (= 0.26.2))) + (ocaml-lsp-server + (and + :with-dev-setup + (= 1.19.0))) (cppo (= 1.6.9)) (js_of_ocaml diff --git a/rescript.opam b/rescript.opam index a436a9f2df..ff2913835d 100644 --- a/rescript.opam +++ b/rescript.opam @@ -8,7 +8,8 @@ homepage: "https://github.com/rescript-lang/rescript-compiler" bug-reports: "https://github.com/rescript-lang/rescript-compiler/issues" depends: [ "ocaml" {>= "4.10"} - "ocamlformat" {= "0.26.2"} + "ocamlformat" {with-test & = "0.26.2"} + "ocaml-lsp-server" {with-dev-setup & = "1.19.0"} "cppo" {= "1.6.9"} "js_of_ocaml" {= "5.8.1"} "ounit2" {= "2.2.7"}