diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore index a0940f84d..1bb071a2d 100644 --- a/.ocamlformat-ignore +++ b/.ocamlformat-ignore @@ -1,2 +1,15 @@ -analysis/vendor/compiler-libs-406/* -analysis/vendor/res_outcome_printer/* +analysis/vendor/js_parser/** +analysis/vendor/ml/cmt_format.ml +analysis/vendor/ml/parser.ml +analysis/vendor/ml/pprintast.ml +analysis/vendor/ext/bs_hash_stubs.ml +analysis/vendor/ext/js_reserved_map.ml +analysis/vendor/ext/ext_string.ml +analysis/vendor/ext/ext_string.mli +analysis/vendor/ext/ext_sys.ml +analysis/vendor/ext/hash.cppo.ml +analysis/vendor/ext/hash_set.cppo.ml +analysis/vendor/ext/map.cppo.ml +analysis/vendor/ext/ordered_hash_map.cppo.ml +analysis/vendor/ext/set.cppo.ml +analysis/vendor/ext/vec.cppo.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index c983fc7bd..9f528e2f0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,10 @@ - Enable incremental typechecking and project config cache by default. https://github.com/rescript-lang/rescript-vscode/pull/1047 +#### :house: Internal + +- Auto-format vendored OCaml sources like in compiler repo. https://github.com/rescript-lang/rescript-vscode/pull/1053 + ## 1.58.0 #### :bug: Bug fix diff --git a/analysis/vendor/.ocamlformat b/analysis/vendor/.ocamlformat deleted file mode 100644 index 593b6a1ff..000000000 --- a/analysis/vendor/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/analysis/vendor/ext/.ocamlformat b/analysis/vendor/ext/.ocamlformat deleted file mode 100644 index 593b6a1ff..000000000 --- a/analysis/vendor/ext/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/analysis/vendor/ext/bsb_db.ml b/analysis/vendor/ext/bsb_db.ml index 6ce515499..b08e6943b 100644 --- a/analysis/vendor/ext/bsb_db.ml +++ b/analysis/vendor/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/analysis/vendor/ext/bsb_db.mli b/analysis/vendor/ext/bsb_db.mli index d4a8cfe43..3b54f9f1c 100644 --- a/analysis/vendor/ext/bsb_db.mli +++ b/analysis/vendor/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/analysis/vendor/ext/bsc_args.ml b/analysis/vendor/ext/bsc_args.ml index 5f1fd2e19..1f907eb26 100644 --- a/analysis/vendor/ext/bsc_args.ml +++ b/analysis/vendor/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/analysis/vendor/ext/config.mli b/analysis/vendor/ext/config.mli index d409fe0b6..7030d19ff 100644 --- a/analysis/vendor/ext/config.mli +++ b/analysis/vendor/ext/config.mli @@ -21,7 +21,7 @@ val version : string val standard_library : string (* The directory containing the standard libraries *) -val syntax_kind : [ `ml | `rescript ] ref +val syntax_kind : [`ml | `rescript] ref val bs_only : bool ref @@ -48,4 +48,4 @@ val cmt_magic_number : string val print_config : out_channel -> unit type uncurried = Legacy | Uncurried | Swap -val uncurried : uncurried ref \ No newline at end of file +val uncurried : uncurried ref diff --git a/analysis/vendor/ext/ext_array.ml b/analysis/vendor/ext/ext_array.ml index 0f3f1a75d..5e0bb32d7 100644 --- a/analysis/vendor/ext/ext_array.ml +++ b/analysis/vendor/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 @@ -101,7 +103,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) [] @@ -110,50 +114,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/analysis/vendor/ext/ext_buffer.ml b/analysis/vendor/ext/ext_buffer.ml index 1e478b354..5dbb8396d 100644 --- a/analysis/vendor/ext/ext_buffer.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_bytes.ml b/analysis/vendor/ext/ext_bytes.ml index f4148ebba..68808ab42 100644 --- a/analysis/vendor/ext/ext_bytes.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_bytes.mli b/analysis/vendor/ext/ext_bytes.mli index f4148ebba..68808ab42 100644 --- a/analysis/vendor/ext/ext_bytes.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_char.ml b/analysis/vendor/ext/ext_char.ml index 9dcb31a73..3754665a6 100644 --- a/analysis/vendor/ext/ext_char.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_color.ml b/analysis/vendor/ext/ext_color.ml index d5ed3bb16..db926ead0 100644 --- a/analysis/vendor/ext/ext_color.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_file_extensions.ml b/analysis/vendor/ext/ext_file_extensions.ml index 8cd52c569..9004b5821 100644 --- a/analysis/vendor/ext/ext_file_extensions.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_filename.ml b/analysis/vendor/ext/ext_filename.ml index a12e0ccf3..cb3302bac 100644 --- a/analysis/vendor/ext/ext_filename.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_filename.mli b/analysis/vendor/ext/ext_filename.mli index e95c3f217..e111ee200 100644 --- a/analysis/vendor/ext/ext_filename.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_ident.ml b/analysis/vendor/ext/ext_ident.ml index 4f1e6dfa7..8a7910ca3 100644 --- a/analysis/vendor/ext/ext_ident.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_ident.mli b/analysis/vendor/ext/ext_ident.mli index 27e7a0505..ff21fca3c 100644 --- a/analysis/vendor/ext/ext_ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_io.ml b/analysis/vendor/ext/ext_io.ml index ee3a96eb6..ffb84a49d 100644 --- a/analysis/vendor/ext/ext_io.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_js_file_kind.ml b/analysis/vendor/ext/ext_js_file_kind.ml index 196ba3246..2efce680a 100644 --- a/analysis/vendor/ext/ext_js_file_kind.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_js_regex.ml b/analysis/vendor/ext/ext_js_regex.ml index 83a881fcf..dcb917959 100644 --- a/analysis/vendor/ext/ext_js_regex.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_json.ml b/analysis/vendor/ext/ext_json.ml index 3dedb8d87..90915a250 100644 --- a/analysis/vendor/ext/ext_json.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_json_noloc.ml b/analysis/vendor/ext/ext_json_noloc.ml index 9ce2733c0..5f751f4fd 100644 --- a/analysis/vendor/ext/ext_json_noloc.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_json_types.ml b/analysis/vendor/ext/ext_json_types.ml index 1eb6212dd..3c3384468 100644 --- a/analysis/vendor/ext/ext_json_types.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_list.ml b/analysis/vendor/ext/ext_list.ml index be7f30b8d..7066f301b 100644 --- a/analysis/vendor/ext/ext_list.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_list.mli b/analysis/vendor/ext/ext_list.mli index 95a078bd3..61a07c7b3 100644 --- a/analysis/vendor/ext/ext_list.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_module_system.ml b/analysis/vendor/ext/ext_module_system.ml index 9b06848f3..c8a0734f5 100644 --- a/analysis/vendor/ext/ext_module_system.ml +++ b/analysis/vendor/ext/ext_module_system.ml @@ -1 +1 @@ -type t = Commonjs | Esmodule | Es6_global +type t = Commonjs | Esmodule | Es6_global diff --git a/analysis/vendor/ext/ext_modulename.ml b/analysis/vendor/ext/ext_modulename.ml index ddc0292de..d2d46930f 100644 --- a/analysis/vendor/ext/ext_modulename.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_namespace.ml b/analysis/vendor/ext/ext_namespace.ml index deccf1f96..faad6920f 100644 --- a/analysis/vendor/ext/ext_namespace.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_namespace.mli b/analysis/vendor/ext/ext_namespace.mli index f562729d7..fa6401694 100644 --- a/analysis/vendor/ext/ext_namespace.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_namespace_encode.ml b/analysis/vendor/ext/ext_namespace_encode.ml index 071a92c96..87ad276f7 100644 --- a/analysis/vendor/ext/ext_namespace_encode.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_obj.ml b/analysis/vendor/ext/ext_obj.ml index f57d9f680..01ec1d8f5 100644 --- a/analysis/vendor/ext/ext_obj.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_option.ml b/analysis/vendor/ext/ext_option.ml index 0e4f128ab..92a2439a9 100644 --- a/analysis/vendor/ext/ext_option.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_path.ml b/analysis/vendor/ext/ext_path.ml index 31bbe47a6..660d69a41 100644 --- a/analysis/vendor/ext/ext_path.ml +++ b/analysis/vendor/ext/ext_path.ml @@ -37,7 +37,10 @@ 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 '/' @@ -63,11 +66,13 @@ let split_by_sep_per_os : string -> string list = *) 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 @@ -81,7 +86,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 @@ -90,7 +95,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 (*** @@ -164,20 +169,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 @@ -211,16 +216,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 @@ -229,7 +238,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 = @@ -262,16 +273,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/analysis/vendor/ext/ext_pervasives.ml b/analysis/vendor/ext/ext_pervasives.ml index ede7f8a22..68ecc7799 100644 --- a/analysis/vendor/ext/ext_pervasives.ml +++ b/analysis/vendor/ext/ext_pervasives.ml @@ -27,11 +27,11 @@ external reraise : exn -> 'a = "%reraise" 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/analysis/vendor/ext/ext_position.ml b/analysis/vendor/ext/ext_position.ml index 96e575bc6..a15409429 100644 --- a/analysis/vendor/ext/ext_position.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_position.mli b/analysis/vendor/ext/ext_position.mli index 0d17a2cf2..7d0a0563c 100644 --- a/analysis/vendor/ext/ext_position.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_pp.ml b/analysis/vendor/ext/ext_pp.ml index 5b1e4a8b0..f9237c271 100644 --- a/analysis/vendor/ext/ext_pp.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_pp_scope.ml b/analysis/vendor/ext/ext_pp_scope.ml index 66df85da5..f074a411f 100644 --- a/analysis/vendor/ext/ext_pp_scope.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_topsort.ml b/analysis/vendor/ext/ext_topsort.ml index fc44e7176..7cdef010c 100644 --- a/analysis/vendor/ext/ext_topsort.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_topsort.mli b/analysis/vendor/ext/ext_topsort.mli index 673f8d125..11d634cb9 100644 --- a/analysis/vendor/ext/ext_topsort.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ext_utf8.ml b/analysis/vendor/ext/ext_utf8.ml index 0d02b2c57..18336b804 100644 --- a/analysis/vendor/ext/ext_utf8.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_util.ml b/analysis/vendor/ext/ext_util.ml index 1be75ff11..58b8ad2a1 100644 --- a/analysis/vendor/ext/ext_util.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ext_util.mli b/analysis/vendor/ext/ext_util.mli index d31d11a90..720e5b19b 100644 --- a/analysis/vendor/ext/ext_util.mli +++ b/analysis/vendor/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/analysis/vendor/ext/hash_gen.ml b/analysis/vendor/ext/hash_gen.ml index 01b6498fb..589639aea 100644 --- a/analysis/vendor/ext/hash_gen.ml +++ b/analysis/vendor/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/analysis/vendor/ext/hash_ident.mli b/analysis/vendor/ext/hash_ident.mli index 0a299ad28..43971863e 100644 --- a/analysis/vendor/ext/hash_ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/hash_set_gen.ml b/analysis/vendor/ext/hash_set_gen.ml index a1879036f..db892caf4 100644 --- a/analysis/vendor/ext/hash_set_gen.ml +++ b/analysis/vendor/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/analysis/vendor/ext/hash_set_ident.mli b/analysis/vendor/ext/hash_set_ident.mli index 5fed77b9b..b32ba8aec 100644 --- a/analysis/vendor/ext/hash_set_ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/hash_set_ident_mask.ml b/analysis/vendor/ext/hash_set_ident_mask.ml index 8cdc76b77..67a78d836 100644 --- a/analysis/vendor/ext/hash_set_ident_mask.ml +++ b/analysis/vendor/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/analysis/vendor/ext/hash_set_ident_mask.mli b/analysis/vendor/ext/hash_set_ident_mask.mli index 19c60a028..1c5bb8f48 100644 --- a/analysis/vendor/ext/hash_set_ident_mask.mli +++ b/analysis/vendor/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/analysis/vendor/ext/ident.ml b/analysis/vendor/ext/ident.ml index ca4697332..a5ca80e84 100644 --- a/analysis/vendor/ext/ident.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ident.mli b/analysis/vendor/ext/ident.mli index c2983edbe..d73cff6f6 100644 --- a/analysis/vendor/ext/ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/identifiable.ml b/analysis/vendor/ext/identifiable.ml index 6ee0519a9..bd6133c87 100644 --- a/analysis/vendor/ext/identifiable.ml +++ b/analysis/vendor/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/analysis/vendor/ext/identifiable.mli b/analysis/vendor/ext/identifiable.mli index 46e145451..9dd8defd9 100644 --- a/analysis/vendor/ext/identifiable.mli +++ b/analysis/vendor/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/analysis/vendor/ext/js_reserved_map.mli b/analysis/vendor/ext/js_reserved_map.mli index cf4e1cb2b..5ee19826f 100644 --- a/analysis/vendor/ext/js_reserved_map.mli +++ b/analysis/vendor/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/analysis/vendor/ext/map_gen.ml b/analysis/vendor/ext/map_gen.ml index ecd0aa315..7c8af834d 100644 --- a/analysis/vendor/ext/map_gen.ml +++ b/analysis/vendor/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/analysis/vendor/ext/map_gen.mli b/analysis/vendor/ext/map_gen.mli index a1452460a..c5038ffc4 100644 --- a/analysis/vendor/ext/map_gen.mli +++ b/analysis/vendor/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/analysis/vendor/ext/map_ident.mli b/analysis/vendor/ext/map_ident.mli index f4e717e4c..56b3678c0 100644 --- a/analysis/vendor/ext/map_ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/misc.ml b/analysis/vendor/ext/misc.ml index 33ca3eee5..776b140bd 100644 --- a/analysis/vendor/ext/misc.ml +++ b/analysis/vendor/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,78 +44,82 @@ 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) module Stdlib = struct module List = struct type 'a t = 'a list let rec compare cmp l1 l2 = - match l1, l2 with + match (l1, l2) with | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | h1 :: t1, h2 :: t2 -> let c = cmp h1 h2 in - if c <> 0 then c - else compare cmp t1 t2 + if c <> 0 then c else compare cmp t1 t2 let rec equal eq l1 l2 = - match l1, l2 with - | ([], []) -> true - | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2 - | (_, _) -> false + match (l1, l2) with + | [], [] -> true + | hd1 :: tl1, hd2 :: tl2 -> eq hd1 hd2 && equal eq tl1 tl2 + | _, _ -> false let filter_map f l = let rec aux acc l = match l with | [] -> List.rev acc - | h :: t -> + | h :: t -> ( match f h with | None -> aux acc t - | Some v -> aux (v :: acc) t + | Some v -> aux (v :: acc) t) in aux [] l let map2_prefix f l1 l2 = let rec aux acc l1 l2 = - match l1, l2 with + match (l1, l2) with | [], _ -> (List.rev acc, l2) | _ :: _, [] -> raise (Invalid_argument "map2_prefix") - | h1::t1, h2::t2 -> + | h1 :: t1, h2 :: t2 -> let h = f h1 h2 in aux (h :: acc) t1 t2 in @@ -128,12 +136,11 @@ module Stdlib = struct let split_at n l = let rec aux n acc l = - if n = 0 - then List.rev acc, l + if n = 0 then (List.rev acc, l) else match l with | [] -> raise (Invalid_argument "split_at") - | t::q -> aux (n-1) (t::acc) q + | t :: q -> aux (n - 1) (t :: acc) q in aux n [] l end @@ -142,7 +149,7 @@ module Stdlib = struct type 'a t = 'a option let equal eq o1 o2 = - match o1, o2 with + match (o1, o2) with | None, None -> true | Some e1, Some e2 -> eq e1 e2 | _, _ -> false @@ -173,7 +180,8 @@ module Stdlib = struct let rec loop i = if i = n then false else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true - else loop (succ i) in + else loop (succ i) + in loop 0 end end @@ -186,14 +194,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 = @@ -205,38 +213,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 *) @@ -252,71 +258,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 @@ -324,10 +348,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 @@ -341,80 +364,85 @@ 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 module LongString = struct type t = bytes array let create str_size = - let tbl_size = str_size / Sys.max_string_length + 1 in + let tbl_size = (str_size / Sys.max_string_length) + 1 in let tbl = Array.make tbl_size Bytes.empty in for i = 0 to tbl_size - 2 do - tbl.(i) <- Bytes.create Sys.max_string_length; + tbl.(i) <- Bytes.create Sys.max_string_length done; tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length); tbl let length tbl = let tbl_size = Array.length tbl in - Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1) + (Sys.max_string_length * (tbl_size - 1)) + Bytes.length tbl.(tbl_size - 1) let get tbl ind = Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) let set tbl ind c = - Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) - c + Bytes.set + tbl.(ind / Sys.max_string_length) + (ind mod Sys.max_string_length) + c let blit src srcoff dst dstoff len = for i = 0 to len - 1 do @@ -437,32 +465,32 @@ module LongString = struct tbl end - 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 @@ -470,35 +498,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) @@ -511,33 +538,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 *) @@ -546,7 +569,6 @@ module Color = struct | Reset | Dim - let ansi_of_color = function | Black -> "0" | Red -> "1" @@ -564,26 +586,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 @@ -591,10 +606,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] @@ -619,14 +635,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" @@ -634,14 +654,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 @@ -650,42 +669,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) @@ -698,32 +713,24 @@ 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 let raise_direct_hook_exn e = raise (HookExn e) let fold_hooks list hook_info ast = - List.fold_left (fun ast (hook_name,f) -> - try - f hook_info ast - with - | HookExn e -> raise e - | error -> raise (HookExnWrapper {error; hook_name; hook_info}) - (* when explicit reraise with backtrace will be available, - it should be used here *) - - ) ast (List.sort compare list) + List.fold_left + (fun ast (hook_name, f) -> + try f hook_info ast with + | HookExn e -> raise e + | error -> raise (HookExnWrapper {error; hook_name; hook_info}) + (* when explicit reraise with backtrace will be available, + it should be used here *)) + ast (List.sort compare list) module type HookSig = sig type t @@ -732,15 +739,12 @@ module type HookSig = sig val apply_hooks : hook_info -> t -> t end -module MakeHooks(M: sig - type t - end) : HookSig with type t = M.t -= struct - +module MakeHooks (M : sig + type t +end) : HookSig with type t = M.t = struct type t = M.t let hooks = ref [] let add_hook name f = hooks := (name, f) :: !hooks - let apply_hooks sourcefile intf = - fold_hooks !hooks sourcefile intf + let apply_hooks sourcefile intf = fold_hooks !hooks sourcefile intf end diff --git a/analysis/vendor/ext/misc.mli b/analysis/vendor/ext/misc.mli index 33878bb1d..54227b1a9 100644 --- a/analysis/vendor/ext/misc.mli +++ b/analysis/vendor/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 @@ -70,7 +75,7 @@ module Stdlib : sig is returned with the [xs] being the contents of those [Some]s, with order preserved. Otherwise return [None]. *) - val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t) + val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t * 'b t (** [let r1, r2 = map2_prefix f l1 l2] If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n, r1 is [List.map2 f l1 h1] and r2 is t2. *) @@ -100,64 +105,75 @@ module Stdlib : sig end end -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: int -> ('a * 'b) list -> ('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 : int -> ('a * 'b) list -> ('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 @@ -165,54 +181,52 @@ 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. - - 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 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 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 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 - -module LongString : - sig - type t = bytes array - val create : int -> t - val length : t -> int - val get : t -> int -> char - val set : t -> int -> char -> unit - val blit : t -> int -> t -> int -> int -> unit - val output : out_channel -> t -> int -> int -> unit - val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit - val input_bytes : in_channel -> int -> t - 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. + + 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 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 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 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 + +module LongString : sig + type t = bytes array + val create : int -> t + val length : t -> int + val get : t -> int -> char + val set : t -> int -> char -> unit + val blit : t -> int -> t -> int -> int -> unit + val output : out_channel -> t -> int -> int -> unit + val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit + val input_bytes : in_channel -> int -> t +end val edit_distance : string -> string -> int -> int option (** [edit_distance a b cutoff] computes the edit distance between @@ -256,24 +270,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 *) @@ -282,19 +286,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 @@ -317,8 +316,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: @@ -327,22 +324,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 @@ -351,4 +341,8 @@ module type HookSig = sig val apply_hooks : hook_info -> t -> t end -module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t +module MakeHooks : functor + (M : sig + type t + end) + -> HookSig with type t = M.t diff --git a/analysis/vendor/ext/ordered_hash_map_gen.ml b/analysis/vendor/ext/ordered_hash_map_gen.ml index 31ad7e6d1..b85ce6e96 100644 --- a/analysis/vendor/ext/ordered_hash_map_gen.ml +++ b/analysis/vendor/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/analysis/vendor/ext/ordered_hash_map_local_ident.mli b/analysis/vendor/ext/ordered_hash_map_local_ident.mli index c22d6784a..66af1d078 100644 --- a/analysis/vendor/ext/ordered_hash_map_local_ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/set_gen.ml b/analysis/vendor/ext/set_gen.ml index 34eb1e09b..0fd5e66f4 100644 --- a/analysis/vendor/ext/set_gen.ml +++ b/analysis/vendor/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/analysis/vendor/ext/set_gen.mli b/analysis/vendor/ext/set_gen.mli index 0dac4f595..f3f39f019 100644 --- a/analysis/vendor/ext/set_gen.mli +++ b/analysis/vendor/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/analysis/vendor/ext/set_ident.mli b/analysis/vendor/ext/set_ident.mli index 2209243e5..49638c9f4 100644 --- a/analysis/vendor/ext/set_ident.mli +++ b/analysis/vendor/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/analysis/vendor/ext/union_find.ml b/analysis/vendor/ext/union_find.ml index a06b49c31..bba784620 100644 --- a/analysis/vendor/ext/union_find.ml +++ b/analysis/vendor/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/analysis/vendor/ext/warnings.ml b/analysis/vendor/ext/warnings.ml index ed53ecd69..de488a907 100644 --- a/analysis/vendor/ext/warnings.ml +++ b/analysis/vendor/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,222 +300,232 @@ 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." + "this pattern-matching is not exhaustive.\n\ + All clauses in this pattern-matching are guarded." | Unused_var v | Unused_var_strict v -> "unused variable " ^ 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 @@ -522,25 +533,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 @@ -652,10 +663,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/analysis/vendor/ext/warnings.mli b/analysis/vendor/ext/warnings.mli index e72f4f980..4b96f0f42 100644 --- a/analysis/vendor/ext/warnings.mli +++ b/analysis/vendor/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/analysis/vendor/js_parser/.ocamlformat b/analysis/vendor/js_parser/.ocamlformat deleted file mode 100644 index 593b6a1ff..000000000 --- a/analysis/vendor/js_parser/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/analysis/vendor/ml/annot.ml b/analysis/vendor/ml/annot.ml index 3cae8f273..13a586592 100644 --- a/analysis/vendor/ml/annot.ml +++ b/analysis/vendor/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/analysis/vendor/ml/ast_async.ml b/analysis/vendor/ml/ast_async.ml index 51dff6e4d..4ed394708 100644 --- a/analysis/vendor/ml/ast_async.ml +++ b/analysis/vendor/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/analysis/vendor/ml/ast_await.ml b/analysis/vendor/ml/ast_await.ml index 1393f04de..c8f0358be 100644 --- a/analysis/vendor/ml/ast_await.ml +++ b/analysis/vendor/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 diff --git a/analysis/vendor/ml/ast_helper.ml b/analysis/vendor/ml/ast_helper.ml index 80fb40a1c..d07c1912f 100644 --- a/analysis/vendor/ml/ast_helper.ml +++ b/analysis/vendor/ml/ast_helper.ml @@ -29,15 +29,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) @@ -68,59 +73,52 @@ 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 (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) + Ptyp_class (longident, List.map loop lst) + | Ptyp_alias (core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly (string_lst, core_type) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) in {t with ptyp_desc = desc} - and loop_row_field = - function - | Rtag(label,attrs,flag,lst) -> - Rtag(label,attrs,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - and loop_object_field = - function - | Otag(label, attrs, t) -> - Otag(label, attrs, loop t) - | Oinherit t -> - Oinherit (loop t) + 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 @@ -178,7 +176,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) @@ -190,12 +188,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 @@ -213,8 +206,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) @@ -245,9 +238,7 @@ module Sig = struct let attribute ?loc a = mk ?loc (Psig_attribute a) let text txt = let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "") in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt + List.map (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) f_txt end module Str = struct @@ -269,18 +260,12 @@ module Str = struct let attribute ?loc a = mk ?loc (Pstr_attribute a) let text txt = let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "") in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt + List.map (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) f_txt end module Cl = struct let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } + {pcl_desc = d; pcl_loc = loc; pcl_attributes = attrs} let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) @@ -295,11 +280,7 @@ end module Cty = struct let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } + {pcty_desc = d; pcty_loc = loc; pcty_attributes = attrs} let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) @@ -310,13 +291,8 @@ module Cty = struct end module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) d = + {pctf_desc = d; pctf_loc = loc; pctf_attributes = add_docs_attrs docs attrs} let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) @@ -325,25 +301,16 @@ module Ctf = struct let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) let attribute ?loc a = mk ?loc (Pctf_attribute a) let text txt = - let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "")in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt + let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "") in + List.map (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) f_txt let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - end module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) d = + {pcf_desc = d; pcf_loc = loc; pcf_attributes = add_docs_attrs docs attrs} - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) @@ -351,210 +318,184 @@ module Cf = struct let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) let attribute ?loc a = mk ?loc (Pcf_attribute a) let text txt = - let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "")in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt + let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "") in + List.map (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) f_txt let virtual_ ct = Cfk_virtual ct let concrete o e = Cfk_concrete (o, e) let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - end module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(prim = []) + name typ = { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; + pval_name = name; + pval_type = typ; + pval_attributes = add_docs_attrs docs attrs; + pval_loc = loc; + pval_prim = prim; } end module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) + name typ = { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; + pmd_name = name; + pmd_type = typ; + pmd_attributes = add_text_attrs text (add_docs_attrs docs attrs); + pmd_loc = loc; } end module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) + ?typ name = { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; + pmtd_name = name; + pmtd_type = typ; + pmtd_attributes = add_text_attrs text (add_docs_attrs docs attrs); + pmtd_loc = loc; } end module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) + name expr = { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; + pmb_name = name; + pmb_expr = expr; + pmb_attributes = add_text_attrs text (add_docs_attrs docs attrs); + pmb_loc = loc; } end module Opn = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = + ?(override = Fresh) lid = { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; + popen_lid = lid; + popen_override = override; + popen_loc = loc; + popen_attributes = add_docs_attrs docs attrs; } end module Incl = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; + pincl_mod = mexpr; + pincl_loc = loc; + pincl_attributes = add_docs_attrs docs attrs; } - end module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) + pat expr = { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; + pvb_pat = pat; + pvb_expr = expr; + pvb_attributes = add_text_attrs text (add_docs_attrs docs attrs); + pvb_loc = loc; } end module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) + ?(virt = Concrete) ?(params = []) name expr = { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; + pci_virt = virt; + pci_params = params; + pci_name = name; + pci_expr = expr; + pci_attributes = add_text_attrs text (add_docs_attrs docs attrs); + pci_loc = loc; } end module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) + ?(params = []) ?(cstrs = []) ?(kind = Ptype_abstract) ?(priv = Public) + ?manifest name = { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = add_text_attrs text (add_docs_attrs docs attrs); + ptype_loc = loc; } let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = + ?(args = Pcstr_tuple []) ?res name = { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; + pcd_name = name; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = add_info_attrs info attrs; } let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = + ?(mut = Immutable) name typ = { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = add_info_attrs info attrs; } - end (** Type extensions *) module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = + let mk ?(attrs = []) ?(docs = empty_docs) ?(params = []) ?(priv = Public) path + constructors = { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_attributes = add_docs_attrs docs attrs; } - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(info = empty_info) name kind = { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = + ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + pext_name = name; + pext_kind = Pext_decl (args, res); + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = + let rebind ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(info = empty_info) name lid = { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - end module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } + let mk self fields = {pcsig_self = self; pcsig_fields = fields} end module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } + let mk self fields = {pcstr_self = self; pcstr_fields = fields} end diff --git a/analysis/vendor/ml/ast_helper.mli b/analysis/vendor/ml/ast_helper.mli index 67f62492c..b9e2bf349 100644 --- a/analysis/vendor/ml/ast_helper.mli +++ b/analysis/vendor/ml/ast_helper.mli @@ -26,11 +26,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} *) @@ -49,390 +49,551 @@ end (** {1 Core language} *) (** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which +module Typ : sig + val mk : ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type + val attr : core_type -> attribute -> core_type + + val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type + val var : ?loc:loc -> ?attrs:attrs -> string -> core_type + val arrow : + ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type + val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val object_ : + ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type + val class_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type + val variant : + ?loc:loc -> + ?attrs:attrs -> + row_field list -> + closed_flag -> + label list option -> + core_type + val poly : ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + val package : + ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type + val extension : ?loc:loc -> ?attrs:attrs -> extension -> core_type + + val force_poly : core_type -> core_type + + val varify_constructors : str list -> core_type -> core_type + (** [varify_constructors newtypes te] is type expression [te], of which any of nullary type constructor [tc] is replaced by type variable of the same name, if [tc]'s name appears in [newtypes]. Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] appears in [newtypes]. @since 4.05 *) - end +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 option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end +module Exp : sig + val mk : ?loc:loc -> ?attrs:attrs -> expression_desc -> expression + val attr : expression -> attribute -> expression + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> expression + val constant : ?loc:loc -> ?attrs:attrs -> constant -> expression + val let_ : + ?loc:loc -> + ?attrs:attrs -> + rec_flag -> + value_binding list -> + expression -> + expression + val fun_ : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + expression option -> + pattern -> + expression -> + expression + val function_ : ?loc:loc -> ?attrs:attrs -> case list -> expression + val apply : + ?loc:loc -> + ?attrs:attrs -> + expression -> + (arg_label * expression) list -> + expression + val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression + val construct : + ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression + val variant : + ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression + val record : + ?loc:loc -> + ?attrs:attrs -> + (lid * expression) list -> + expression option -> + expression + val field : ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + val setfield : + ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression -> expression + val array : ?loc:loc -> ?attrs:attrs -> expression list -> expression + val ifthenelse : + ?loc:loc -> + ?attrs:attrs -> + expression -> + expression -> + expression option -> + expression + val sequence : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + val while_ : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + val for_ : + ?loc:loc -> + ?attrs:attrs -> + pattern -> + expression -> + expression -> + direction_flag -> + expression -> + expression + val coerce : + ?loc:loc -> + ?attrs:attrs -> + expression -> + core_type option -> + core_type -> + expression + val constraint_ : + ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + val new_ : ?loc:loc -> ?attrs:attrs -> lid -> expression + val setinstvar : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val override : + ?loc:loc -> ?attrs:attrs -> (str * expression) list -> expression + val letmodule : + ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression -> expression + val letexception : + ?loc:loc -> + ?attrs:attrs -> + extension_constructor -> + expression -> + expression + val assert_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + val lazy_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + val poly : + ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> expression + val object_ : ?loc:loc -> ?attrs:attrs -> class_structure -> expression + val newtype : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val pack : ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val open_ : + ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression -> expression + val extension : ?loc:loc -> ?attrs:attrs -> extension -> expression + val unreachable : ?loc:loc -> ?attrs:attrs -> unit -> expression + + val case : pattern -> ?guard:expression -> expression -> case +end (** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end +module Val : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?prim:string list -> + str -> + core_type -> + value_description +end (** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end +module Type : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?text:text -> + ?params:(core_type * variance) list -> + ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> + ?priv:private_flag -> + ?manifest:core_type -> + str -> + type_declaration + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + ?info:info -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + constructor_declaration + val field : + ?loc:loc -> + ?attrs:attrs -> + ?info:info -> + ?mut:mutable_flag -> + str -> + core_type -> + label_declaration +end (** Type extensions *) -module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end +module Te : sig + val mk : + ?attrs:attrs -> + ?docs:docs -> + ?params:(core_type * variance) list -> + ?priv:private_flag -> + lid -> + extension_constructor list -> + type_extension + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?info:info -> + str -> + extension_constructor_kind -> + extension_constructor + + val decl : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?info:info -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + extension_constructor + val rebind : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?info:info -> + str -> + lid -> + extension_constructor +end (** {1 Module language} *) (** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end +module 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 class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end +module Sig : sig + val mk : ?loc:loc -> signature_item_desc -> signature_item + + val value : ?loc:loc -> value_description -> signature_item + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> signature_item + val type_extension : ?loc:loc -> type_extension -> signature_item + val exception_ : ?loc:loc -> extension_constructor -> signature_item + val module_ : ?loc:loc -> module_declaration -> signature_item + val rec_module : ?loc:loc -> module_declaration list -> signature_item + val modtype : ?loc:loc -> module_type_declaration -> signature_item + val open_ : ?loc:loc -> open_description -> signature_item + val include_ : ?loc:loc -> include_description -> signature_item + val class_type : ?loc:loc -> class_type_declaration list -> signature_item + val extension : ?loc:loc -> ?attrs:attrs -> extension -> signature_item + val attribute : ?loc:loc -> attribute -> signature_item + val text : text -> signature_item list +end (** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end +module Str : sig + val mk : ?loc:loc -> structure_item_desc -> structure_item + + val eval : ?loc:loc -> ?attrs:attributes -> expression -> structure_item + val value : ?loc:loc -> rec_flag -> value_binding list -> structure_item + val primitive : ?loc:loc -> value_description -> structure_item + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> structure_item + val type_extension : ?loc:loc -> type_extension -> structure_item + val exception_ : ?loc:loc -> extension_constructor -> structure_item + val module_ : ?loc:loc -> module_binding -> structure_item + val rec_module : ?loc:loc -> module_binding list -> structure_item + val modtype : ?loc:loc -> module_type_declaration -> structure_item + val open_ : ?loc:loc -> open_description -> structure_item + val class_type : ?loc:loc -> class_type_declaration list -> structure_item + val include_ : ?loc:loc -> include_declaration -> structure_item + val extension : ?loc:loc -> ?attrs:attrs -> extension -> structure_item + val attribute : ?loc:loc -> attribute -> structure_item + val text : text -> structure_item list +end (** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end +module Md : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?text:text -> + str -> + module_type -> + module_declaration +end (** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end +module Mtd : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?text:text -> + ?typ:module_type -> + str -> + module_type_declaration +end (** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end +module Mb : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?text:text -> + str -> + module_expr -> + module_binding +end (** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end +module Opn : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?override:override_flag -> + lid -> + open_description +end (** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end +module Incl : sig + val mk : ?loc:loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos +end (** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - +module Vb : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?text:text -> + pattern -> + expression -> + value_binding +end (** {1 Class language} *) (** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type - -> class_type - end +module Cty : sig + val mk : ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type + val attr : class_type -> attribute -> class_type + + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type + val signature : ?loc:loc -> ?attrs:attrs -> class_signature -> class_type + val arrow : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + core_type -> + class_type -> + class_type + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_type + val open_ : + ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type -> class_type +end (** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end +module Ctf : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + class_type_field_desc -> + class_type_field + val attr : class_type_field -> attribute -> class_type_field + + val inherit_ : ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field + val val_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + mutable_flag -> + virtual_flag -> + core_type -> + class_type_field + val method_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + private_flag -> + virtual_flag -> + core_type -> + class_type_field + val constraint_ : + ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_type_field + val attribute : ?loc:loc -> attribute -> class_type_field + val text : text -> class_type_field list +end (** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr - -> class_expr - end +module Cl : sig + val mk : ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr + val attr : class_expr -> attribute -> class_expr + + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr + val structure : ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr + val fun_ : + ?loc:loc -> + ?attrs:attrs -> + arg_label -> + expression option -> + pattern -> + class_expr -> + class_expr + val apply : + ?loc:loc -> + ?attrs:attrs -> + class_expr -> + (arg_label * expression) list -> + class_expr + val let_ : + ?loc:loc -> + ?attrs:attrs -> + rec_flag -> + value_binding list -> + class_expr -> + class_expr + val constraint_ : + ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_expr + val open_ : + ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr -> class_expr +end (** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end +module Cf : sig + val mk : + ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> class_field + val attr : class_field -> attribute -> class_field + + val val_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + mutable_flag -> + class_field_kind -> + class_field + val method_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + private_flag -> + class_field_kind -> + class_field + val constraint_ : + ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_field + val initializer_ : ?loc:loc -> ?attrs:attrs -> expression -> class_field + val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_field + val attribute : ?loc:loc -> attribute -> class_field + val text : text -> class_field list + + val virtual_ : core_type -> class_field_kind + val concrete : override_flag -> expression -> class_field_kind +end (** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end +module Ci : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?docs:docs -> + ?text:text -> + ?virt:virtual_flag -> + ?params:(core_type * variance) list -> + str -> + 'a -> + 'a class_infos +end (** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end +module Csig : sig + val mk : core_type -> class_type_field list -> class_signature +end (** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end +module Cstr : sig + val mk : pattern -> class_field list -> class_structure +end diff --git a/analysis/vendor/ml/ast_invariants.ml b/analysis/vendor/ml/ast_invariants.ml index 31ee17eb9..5de72a0d4 100644 --- a/analysis/vendor/ml/ast_invariants.ml +++ b/analysis/vendor/ml/ast_invariants.ml @@ -55,13 +55,11 @@ let iterator = | _ -> () in let pat self pat = - begin match pat.ppat_desc with + (match pat.ppat_desc with | Ppat_construct (_, Some ({ppat_desc = Ppat_tuple _} as p)) when Builtin_attributes.explicit_arity pat.ppat_attributes -> - super.pat self p (* allow unary tuple, see GPR#523. *) - | _ -> - super.pat self pat - end; + super.pat self p (* allow unary tuple, see GPR#523. *) + | _ -> super.pat self pat); let loc = pat.ppat_loc in match pat.ppat_desc with | Ppat_tuple ([] | [_]) -> invalid_tuple loc @@ -72,13 +70,11 @@ let iterator = | _ -> () in let expr self exp = - begin match exp.pexp_desc with + (match exp.pexp_desc with | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e)) when Builtin_attributes.explicit_arity exp.pexp_attributes -> - super.expr self e (* allow unary tuple, see GPR#523. *) - | _ -> - super.expr self exp - end; + super.expr self e (* allow unary tuple, see GPR#523. *) + | _ -> super.expr self exp); let loc = exp.pexp_loc in match exp.pexp_desc with | Pexp_tuple ([] | [_]) -> invalid_tuple loc @@ -90,7 +86,8 @@ let iterator = | Pexp_field (_, id) | Pexp_setfield (_, id, _) | Pexp_new id - | Pexp_open (_, id, _) -> simple_longident id + | Pexp_open (_, id, _) -> + simple_longident id | Pexp_record (fields, _) -> List.iter (fun (id, _) -> simple_longident id) fields | _ -> () @@ -122,8 +119,7 @@ let iterator = let with_constraint self wc = super.with_constraint self wc; match wc with - | Pwith_type (id, _) - | Pwith_module (id, _) -> simple_longident id + | Pwith_type (id, _) | Pwith_module (id, _) -> simple_longident id | _ -> () in let module_expr self me = @@ -147,19 +143,20 @@ let iterator = | Psig_type (_, []) -> empty_type loc | _ -> () in - { super with - type_declaration - ; typ - ; pat - ; expr - ; extension_constructor - ; class_expr - ; module_expr - ; module_type - ; open_description - ; with_constraint - ; structure_item - ; signature_item + { + super with + type_declaration; + typ; + pat; + expr; + extension_constructor; + class_expr; + module_expr; + module_type; + open_description; + with_constraint; + structure_item; + signature_item; } let structure st = iterator.structure iterator st diff --git a/analysis/vendor/ml/ast_iterator.ml b/analysis/vendor/ml/ast_iterator.ml old mode 100755 new mode 100644 index f5fa930a9..8234560ce --- a/analysis/vendor/ml/ast_iterator.ml +++ b/analysis/vendor/ml/ast_iterator.ml @@ -20,7 +20,6 @@ (* Ensure that record patterns don't miss any field. *) *) - open Parsetree open Location @@ -71,9 +70,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 @@ -82,45 +88,51 @@ 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 (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl + iter_loc sub lid; + List.iter (sub.typ sub) tl | 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 @@ -133,42 +145,39 @@ 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 CT = struct @@ -179,16 +188,19 @@ module CT = struct sub.attributes sub attrs; match desc with | Pcty_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys + iter_loc sub lid; + List.iter (sub.typ sub) tys | Pcty_signature x -> sub.class_signature sub x | Pcty_arrow (_lab, t, ct) -> - sub.typ sub t; sub.class_type sub ct + sub.typ sub t; + sub.class_type sub ct | Pcty_extension x -> sub.extension sub x | Pcty_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_type sub e + iter_loc sub lid; + sub.class_type sub e let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = + = sub.location sub loc; sub.attributes sub attrs; match desc with @@ -196,7 +208,8 @@ module CT = struct | Pctf_val (_s, _m, _v, t) -> sub.typ sub t | Pctf_method (_s, _p, _v, t) -> sub.typ sub t | Pctf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 + sub.typ sub t1; + sub.typ sub t2 | Pctf_attribute x -> sub.attribute sub x | Pctf_extension x -> sub.extension sub x @@ -216,24 +229,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; @@ -243,20 +260,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 l -> - List.iter (sub.class_type_declaration sub) l + | Psig_class_type l -> List.iter (sub.class_type_declaration sub) l | 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 *) @@ -267,13 +282,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 @@ -281,7 +298,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 @@ -292,11 +310,11 @@ module M = struct | Pstr_modtype x -> sub.module_type_declaration sub x | Pstr_open x -> sub.open_description sub x | Pstr_class () -> () - | Pstr_class_type l -> - List.iter (sub.class_type_declaration sub) l + | Pstr_class_type l -> List.iter (sub.class_type_declaration sub) l | 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 @@ -310,68 +328,85 @@ 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, t1, t2) -> - sub.expr sub e; iter_opt (sub.typ sub) t1; - sub.typ sub t2 + sub.expr sub e; + iter_opt (sub.typ sub) t1; + 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 cls -> sub.class_structure sub cls | 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 @@ -385,27 +420,33 @@ 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 module CE = struct @@ -416,24 +457,26 @@ module CE = struct sub.attributes sub attrs; match desc with | Pcl_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcl_structure s -> - sub.class_structure sub s + iter_loc sub lid; + List.iter (sub.typ sub) tys + | Pcl_structure s -> sub.class_structure sub s | Pcl_fun (_lab, e, p, ce) -> - iter_opt (sub.expr sub) e; - sub.pat sub p; - sub.class_expr sub ce + iter_opt (sub.expr sub) e; + sub.pat sub p; + sub.class_expr sub ce | Pcl_apply (ce, l) -> - sub.class_expr sub ce; - List.iter (iter_snd (sub.expr sub)) l + sub.class_expr sub ce; + List.iter (iter_snd (sub.expr sub)) l | Pcl_let (_r, vbs, ce) -> - List.iter (sub.value_binding sub) vbs; - sub.class_expr sub ce + List.iter (sub.value_binding sub) vbs; + sub.class_expr sub ce | Pcl_constraint (ce, ct) -> - sub.class_expr sub ce; sub.class_type sub ct + sub.class_expr sub ce; + sub.class_type sub ct | Pcl_extension x -> sub.extension sub x | Pcl_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_expr sub e + iter_loc sub lid; + sub.class_expr sub e let iter_kind sub = function | Cfk_concrete (_o, e) -> sub.expr sub e @@ -444,11 +487,15 @@ module CE = struct sub.attributes sub attrs; match desc with | Pcf_inherit () -> () - | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k + | Pcf_val (s, _m, k) -> + iter_loc sub s; + iter_kind sub k | Pcf_method (s, _p, k) -> - iter_loc sub s; iter_kind sub k + iter_loc sub s; + iter_kind sub k | Pcf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 + sub.typ sub t1; + sub.typ sub t2 | Pcf_initializer e -> sub.expr sub e | Pcf_attribute x -> sub.attribute sub x | Pcf_extension x -> sub.extension sub x @@ -457,8 +504,15 @@ module CE = struct sub.pat sub pcstr_self; List.iter (sub.class_field sub) pcstr_fields - let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = + let class_infos sub f + { + pci_virt = _; + pci_params = pl; + pci_name; + pci_expr; + pci_loc; + pci_attributes; + } = List.iter (iter_fst (sub.typ sub)) pl; iter_loc sub pci_name; f pci_expr; @@ -493,108 +547,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/analysis/vendor/ml/ast_iterator.mli b/analysis/vendor/ml/ast_iterator.mli old mode 100755 new mode 100644 index 4f5058f1d..9730f0650 --- a/analysis/vendor/ml/ast_iterator.mli +++ b/analysis/vendor/ml/ast_iterator.mli @@ -66,5 +66,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/analysis/vendor/ml/ast_mapper.ml b/analysis/vendor/ml/ast_mapper.ml index 5aa10df2f..48527518b 100644 --- a/analysis/vendor/ml/ast_mapper.ml +++ b/analysis/vendor/ml/ast_mapper.ml @@ -20,7 +20,6 @@ (* Ensure that record patterns don't miss any field. *) *) - open Parsetree open Ast_helper open Location @@ -35,15 +34,15 @@ type mapper = { class_signature: mapper -> class_signature -> class_signature; class_structure: mapper -> class_structure -> class_structure; class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; + class_type_declaration: + mapper -> class_type_declaration -> class_type_declaration; class_type_field: mapper -> class_type_field -> class_type_field; - 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; @@ -52,8 +51,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; @@ -74,7 +73,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} @@ -83,13 +84,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} = @@ -100,37 +101,42 @@ 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 (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | 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) @@ -139,44 +145,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 CT = struct @@ -188,33 +189,32 @@ module CT = struct let attrs = sub.attributes sub attrs in match desc with | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) + arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = + = let open Ctf in let loc = sub.location sub loc in let attrs = sub.attributes sub attrs in match desc with | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) + val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) + method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) + Csig.mk (sub.typ sub pcsig_self) (List.map (sub.class_type_field sub) pcsig_fields) end @@ -230,24 +230,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 @@ -259,19 +258,18 @@ 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 l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) + class_type ~loc (List.map (sub.class_type_declaration sub) l) | 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 *) @@ -283,14 +281,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) @@ -299,7 +296,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) @@ -309,12 +306,12 @@ 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 () -> {pstr_loc = loc; pstr_desc = Pstr_class ()} | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) + class_type ~loc (List.map (sub.class_type_declaration sub) l) | 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 @@ -329,71 +326,71 @@ 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, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) + coerce ~loc ~attrs (sub.expr sub e) + (map_opt (sub.typ sub) t1) + (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 cls -> object_ ~loc ~attrs (sub.class_structure sub cls) | 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 @@ -413,19 +410,20 @@ 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 @@ -439,25 +437,24 @@ module CE = struct let attrs = sub.attributes sub attrs in match desc with | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + | Pcl_structure s -> structure ~loc ~attrs (sub.class_structure sub s) | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) e) + (sub.pat sub p) (sub.class_expr sub ce) | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) + apply ~loc ~attrs (sub.class_expr sub ce) + (List.map (map_snd (sub.expr sub)) l) | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) + let_ ~loc ~attrs r + (List.map (sub.value_binding sub) vbs) + (sub.class_expr sub ce) | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) + constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) let map_kind sub = function | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) @@ -468,13 +465,12 @@ module CE = struct let loc = sub.location sub loc in let attrs = sub.attributes sub attrs in match desc with - | Pcf_inherit () -> - {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} + | Pcf_inherit () -> {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) + method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) @@ -485,14 +481,11 @@ module CE = struct pcstr_fields = List.map (sub.class_field sub) pcstr_fields; } - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) + let class_infos sub f + {pci_virt; pci_params = pl; pci_name; pci_expr; pci_loc; pci_attributes} = + Ci.mk ~virt:pci_virt + ~params:(List.map (map_fst (sub.typ sub)) pl) + (map_loc sub pci_name) (f pci_expr) ~loc:(sub.location sub pci_loc) ~attrs:(sub.attributes sub pci_attributes) end @@ -523,266 +516,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 @@ -792,17 +749,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 = @@ -810,8 +767,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 @@ -820,8 +781,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 = @@ -829,8 +790,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 @@ -853,7 +818,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 @@ -863,19 +828,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 = @@ -884,9 +847,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 @@ -901,11 +862,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/analysis/vendor/ml/ast_mapper.mli b/analysis/vendor/ml/ast_mapper.mli index 3a4044d4c..53bce1610 100644 --- a/analysis/vendor/ml/ast_mapper.mli +++ b/analysis/vendor/ml/ast_mapper.mli @@ -62,15 +62,15 @@ type mapper = { class_signature: mapper -> class_signature -> class_signature; class_structure: mapper -> class_structure -> class_structure; class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; + class_type_declaration: + mapper -> class_type_declaration -> class_type_declaration; class_type_field: mapper -> class_type_field -> class_type_field; - 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; @@ -79,8 +79,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; @@ -101,12 +101,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 @@ -115,14 +115,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 @@ -131,9 +130,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 @@ -150,42 +149,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} *) @@ -194,5 +192,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/analysis/vendor/ml/ast_payload.ml b/analysis/vendor/ml/ast_payload.ml index 0fe198d43..8a9d37854 100644 --- a/analysis/vendor/ml/ast_payload.ml +++ b/analysis/vendor/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/analysis/vendor/ml/ast_uncurried.ml b/analysis/vendor/ml/ast_uncurried.ml index ef7ad20c5..3d36fcc65 100644 --- a/analysis/vendor/ml/ast_uncurried.ml +++ b/analysis/vendor/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/analysis/vendor/ml/ast_uncurried_utils.ml b/analysis/vendor/ml/ast_uncurried_utils.ml index d88459390..fd0ea8983 100644 --- a/analysis/vendor/ml/ast_uncurried_utils.ml +++ b/analysis/vendor/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/analysis/vendor/ml/ast_untagged_variants.ml b/analysis/vendor/ml/ast_untagged_variants.ml index 21944c6a1..6566693af 100644 --- a/analysis/vendor/ml/ast_untagged_variants.ml +++ b/analysis/vendor/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 @@ -146,7 +146,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 @@ -160,18 +162,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 -> @@ -183,17 +184,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 @@ -202,7 +203,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 @@ -265,12 +268,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)); @@ -282,8 +288,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) -> @@ -294,28 +303,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) = @@ -473,17 +483,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/analysis/vendor/ml/asttypes.ml b/analysis/vendor/ml/asttypes.ml index 5abbdaa0a..174d3aa79 100644 --- a/analysis/vendor/ml/asttypes.ml +++ b/analysis/vendor/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/analysis/vendor/ml/bigint_utils.ml b/analysis/vendor/ml/bigint_utils.ml index e0f3fe9ac..2454e0d15 100644 --- a/analysis/vendor/ml/bigint_utils.ml +++ b/analysis/vendor/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/analysis/vendor/ml/bigint_utils.mli b/analysis/vendor/ml/bigint_utils.mli index 34f9dfb62..14b09a9ef 100644 --- a/analysis/vendor/ml/bigint_utils.mli +++ b/analysis/vendor/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/analysis/vendor/ml/btype.ml b/analysis/vendor/ml/btype.ml index de95c2dfe..2dca2b003 100644 --- a/analysis/vendor/ml/btype.ml +++ b/analysis/vendor/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,221 +87,228 @@ 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_class_declaration: type_iterators -> class_declaration -> unit; - it_class_type_declaration: type_iterators -> class_type_declaration -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_class_type: type_iterators -> class_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_class_declaration: type_iterators -> class_declaration -> unit; + it_class_type_declaration: type_iterators -> class_type_declaration -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_class_type: type_iterators -> class_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 @@ -303,36 +317,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 (_, ctd, _) -> it.it_class_type_declaration it ctd - 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; @@ -342,10 +350,8 @@ 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_class_declaration it cd = List.iter (it.it_type_expr it) cd.cty_params; it.it_class_type it cd.cty_type; @@ -356,163 +362,178 @@ let type_iterators = it.it_class_type it ctd.clty_type; it.it_path ctd.clty_path 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 + may (it.it_module_type it) mto; + it.it_module_type it mt and it_class_type it = function - Cty_constr (p, tyl, cty) -> - it.it_path p; - List.iter (it.it_type_expr it) tyl; - it.it_class_type it cty + | Cty_constr (p, tyl, cty) -> + it.it_path p; + List.iter (it.it_type_expr it) tyl; + it.it_class_type it cty | Cty_signature cs -> - it.it_type_expr it cs.csig_self; - Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; - List.iter - (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl) - cs.csig_inher - | Cty_arrow (_, ty, cty) -> - it.it_type_expr it ty; - it.it_class_type it cty - and it_type_kind it kind = - iter_type_expr_kind (it.it_type_expr it) kind + it.it_type_expr it cs.csig_self; + Vars.iter (fun _ (_, _, ty) -> it.it_type_expr it ty) cs.csig_vars; + List.iter + (fun (p, tl) -> + it.it_path p; + List.iter (it.it_type_expr it) tl) + cs.csig_inher + | Cty_arrow (_, ty, cty) -> + it.it_type_expr it ty; + it.it_class_type it cty + 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_class_type; it_module_type; - it_signature; it_class_type_declaration; it_class_declaration; - it_modtype_declaration; it_module_declaration; it_extension_constructor; - it_type_declaration; it_value_description; it_signature_item; } + and it_path _p = () in + { + it_path; + it_type_expr = it_do_type_expr; + it_do_type_expr; + it_type_kind; + it_class_type; + it_module_type; + it_signature; + it_class_type_declaration; + it_class_declaration; + 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 @@ -530,128 +551,127 @@ let unmark_class_signature sign = unmark_type sign.csig_self; Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars -let unmark_class_type cty = - unmark_iterators.it_class_type unmark_iterators cty +let unmark_class_type cty = unmark_iterators.it_class_type unmark_iterators cty - - (*******************************************) - (* 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 @@ -665,81 +685,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/analysis/vendor/ml/btype.mli b/analysis/vendor/ml/btype.mli index ca1066cc5..5044721ab 100644 --- a/analysis/vendor/ml/btype.mli +++ b/analysis/vendor/ml/btype.mli @@ -20,150 +20,169 @@ 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_class_declaration: type_iterators -> class_declaration -> unit; - it_class_type_declaration: type_iterators -> class_type_declaration -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_class_type: type_iterators -> class_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 unmark_class_type: class_type -> unit -val unmark_class_signature: class_signature -> unit - (* Remove marks from a type *) +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_class_declaration: type_iterators -> class_declaration -> unit; + it_class_type_declaration: type_iterators -> class_type_declaration -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_class_type: type_iterators -> class_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 unmark_class_type : class_type -> unit +val unmark_class_signature : class_signature -> unit +(* Remove marks from a type *) (**** 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 ****) @@ -176,49 +195,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/analysis/vendor/ml/builtin_attributes.ml b/analysis/vendor/ml/builtin_attributes.ml old mode 100755 new mode 100644 index f53edbf90..5d110eda7 --- a/analysis/vendor/ml/builtin_attributes.ml +++ b/analysis/vendor/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/analysis/vendor/ml/builtin_attributes.mli b/analysis/vendor/ml/builtin_attributes.mli old mode 100755 new mode 100644 index 7282dbbe2..fd898388c --- a/analysis/vendor/ml/builtin_attributes.mli +++ b/analysis/vendor/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/analysis/vendor/ml/ccomp.ml b/analysis/vendor/ml/ccomp.ml index ae2fb79fd..d6fb5f1e5 100644 --- a/analysis/vendor/ml/ccomp.ml +++ b/analysis/vendor/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/analysis/vendor/ml/ccomp.mli b/analysis/vendor/ml/ccomp.mli index 7ba8b4bfa..87678cc14 100644 --- a/analysis/vendor/ml/ccomp.mli +++ b/analysis/vendor/ml/ccomp.mli @@ -1,2 +1 @@ - -val command: string -> int +val command : string -> int diff --git a/analysis/vendor/ml/clflags.ml b/analysis/vendor/ml/clflags.ml index b2b2a78db..a13ecdc28 100644 --- a/analysis/vendor/ml/clflags.ml +++ b/analysis/vendor/ml/clflags.ml @@ -1,65 +1,70 @@ +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_docs = ref false (* -keep-docs *) -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_docs = ref false (* -keep-docs *) +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/analysis/vendor/ml/clflags.mli b/analysis/vendor/ml/clflags.mli index 80b170422..342f427b6 100644 --- a/analysis/vendor/ml/clflags.mli +++ b/analysis/vendor/ml/clflags.mli @@ -25,21 +25,18 @@ val dont_write_files : bool ref val keep_docs : 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/analysis/vendor/ml/cmi_format.ml b/analysis/vendor/ml/cmi_format.ml index ee95e8254..1a708b96d 100644 --- a/analysis/vendor/ml/cmi_format.ml +++ b/analysis/vendor/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/analysis/vendor/ml/cmi_format.mli b/analysis/vendor/ml/cmi_format.mli index 7aa7f8d8d..ca608d3ab 100644 --- a/analysis/vendor/ml/cmi_format.mli +++ b/analysis/vendor/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/analysis/vendor/ml/cmt_format.mli b/analysis/vendor/ml/cmt_format.mli index 6daf64339..1a84aa68d 100644 --- a/analysis/vendor/ml/cmt_format.mli +++ b/analysis/vendor/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/analysis/vendor/ml/code_frame.ml b/analysis/vendor/ml/code_frame.ml index f0fdad120..25c00d951 100644 --- a/analysis/vendor/ml/code_frame.ml +++ b/analysis/vendor/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/analysis/vendor/ml/consistbl.ml b/analysis/vendor/ml/consistbl.ml index dbba5d1f5..37047a262 100644 --- a/analysis/vendor/ml/consistbl.ml +++ b/analysis/vendor/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/analysis/vendor/ml/consistbl.mli b/analysis/vendor/ml/consistbl.mli index c532bddfe..cfee26f5d 100644 --- a/analysis/vendor/ml/consistbl.mli +++ b/analysis/vendor/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/analysis/vendor/ml/ctype.ml b/analysis/vendor/ml/ctype.ml index 9aa37f276..10f362d28 100644 --- a/analysis/vendor/ml/ctype.ml +++ b/analysis/vendor/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,104 +334,100 @@ 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 *) - (*******************************) - - -let rec signature_of_class_type = - function - Cty_constr (_, _, cty) -> signature_of_class_type cty - | Cty_signature sign -> sign - | Cty_arrow (_, _, cty) -> signature_of_class_type cty - -let self_type cty = - repr (signature_of_class_type cty).csig_self - -let rec class_type_arity = - function - Cty_constr (_, _, cty) -> class_type_arity cty - | Cty_signature _ -> 0 - | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty - - - (*******************************************) - (* Miscellaneous operations on row types *) - (*******************************************) + | Fvar r -> set_kind r Fabsent + | _ -> ())) + fl + | _ -> assert false + +(*******************************) +(* Operations on class types *) +(*******************************) + +let rec signature_of_class_type = function + | Cty_constr (_, _, cty) -> signature_of_class_type cty + | Cty_signature sign -> sign + | Cty_arrow (_, _, cty) -> signature_of_class_type cty + +let self_type cty = repr (signature_of_class_type cty).csig_self + +let rec class_type_arity = function + | Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +(*******************************************) +(* 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 @@ -441,35 +436,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 := []; @@ -487,13 +477,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 @@ -501,28 +495,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, _) -> @@ -532,10 +521,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, _) -> @@ -543,26 +531,25 @@ 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 exception CCFailure of closed_class_failure let closed_class params sign = let ty = object_fields (repr sign.csig_self) in - let (fields, rest) = flatten_fields ty in + let fields, rest = flatten_fields ty in List.iter mark_type params; mark_type rest; - List.iter - (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) - fields; + List.iter (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) fields; try mark_type_node (repr sign.csig_self); List.iter (fun (lab, kind, ty) -> if field_kind_repr kind = Fpresent then - try closed_type ty with Non_closed (ty0, real) -> - raise (CCFailure (CC_Method (ty0, real, lab, ty)))) + try closed_type ty + with Non_closed (ty0, real) -> + raise (CCFailure (CC_Method (ty0, real, lab, ty)))) fields; mark_type_params (repr sign.csig_self); List.iter unmark_type params; @@ -574,24 +561,19 @@ let closed_class params sign = unmark_class_signature sign; Some reason - - (**********************) - (* 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 *) -let duplicate_class_type ty = - Subst.class_type Subst.identity ty - +let duplicate_class_type ty = Subst.class_type Subst.identity ty - (*****************************) - (* Type level manipulation *) - (*****************************) +(*****************************) +(* Type level manipulation *) +(*****************************) (* It would be a bit more efficient to remove abbreviation expansions @@ -602,15 +584,12 @@ let duplicate_class_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; @@ -620,27 +599,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) (* @@ -658,139 +638,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 = @@ -802,50 +765,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 @@ -853,7 +811,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 @@ -863,39 +821,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 @@ -908,7 +857,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 *) @@ -916,42 +865,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. @@ -960,98 +910,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 @@ -1077,19 +1032,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 = { @@ -1107,28 +1059,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) @@ -1149,48 +1100,50 @@ 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 (); decl let instance_class params cty = - let rec copy_class_type = - function - Cty_constr (path, tyl, cty) -> - Cty_constr (path, List.map simple_copy tyl, copy_class_type cty) + let rec copy_class_type = function + | Cty_constr (path, tyl, cty) -> + Cty_constr (path, List.map simple_copy tyl, copy_class_type cty) | Cty_signature sign -> - Cty_signature - {csig_self = copy sign.csig_self; - csig_vars = - Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map (fun (p,tl) -> (p, List.map simple_copy tl)) - sign.csig_inher} - | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, copy ty, copy_class_type cty) + Cty_signature + { + csig_self = copy sign.csig_self; + csig_vars = + Vars.map + (function + | m, v, ty -> (m, v, copy ty)) + sign.csig_vars; + csig_concr = sign.csig_concr; + csig_inher = + List.map + (fun (p, tl) -> (p, List.map simple_copy tl)) + sign.csig_inher; + } + | Cty_arrow (l, ty, cty) -> Cty_arrow (l, copy ty, copy_class_type cty) in let params' = List.map simple_copy params in let cty' = copy_class_type cty in @@ -1200,45 +1153,50 @@ let instance_class params cty = (**** 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 *) @@ -1247,49 +1205,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 = @@ -1297,17 +1253,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; @@ -1324,16 +1279,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 @@ -1342,14 +1295,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. *) (* @@ -1372,48 +1324,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 = @@ -1426,7 +1376,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 @@ -1437,7 +1389,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 *) @@ -1445,20 +1397,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. *) @@ -1471,20 +1422,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 @@ -1494,27 +1445,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 @@ -1522,26 +1469,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. @@ -1550,84 +1494,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 *) @@ -1637,65 +1585,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 *) @@ -1704,59 +1647,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 = @@ -1764,64 +1711,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 ? *) @@ -1829,15 +1777,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 ****) @@ -1845,16 +1799,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 @@ -1894,54 +1850,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 = @@ -1951,31 +1910,28 @@ 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 = let open Predef in - Path.same p1 p2 || - Path.same p1 path_bytes && Path.same p2 path_string || - Path.same p1 path_string && Path.same p2 path_bytes + Path.same p1 p2 + || (Path.same p1 path_bytes && Path.same p2 path_string) + || (Path.same p1 path_string && Path.same p2 path_bytes) (* Check for datatypes carefully; see PR#6348 *) 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 @@ -1984,121 +1940,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 @@ -2106,104 +2059,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) @@ -2211,45 +2162,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) @@ -2258,10 +2219,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 @@ -2270,18 +2233,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); @@ -2289,65 +2263,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 *) @@ -2359,214 +2327,216 @@ 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 _) when !Config.uncurried = Uncurried -> - (* 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 _ + when !Config.uncurried = Uncurried -> + (* 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; @@ -2578,207 +2548,248 @@ 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 - if not !Config.bs_only && (r1 <> [] && r2 <> []) then begin - (* pairs are the intersection, r1 , r2 should be disjoint *) - let ht = Hashtbl.create (List.length r1) in - List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; - List.iter - (fun (l,_) -> - try raise (Tags(l, Hashtbl.find ht (hash_variant l))) - with Not_found -> ()) - r2 - end; - 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 + if (not !Config.bs_only) && r1 <> [] && r2 <> [] then ( + (* pairs are the intersection, r1 , r2 should be disjoint *) + let ht = Hashtbl.create (List.length r1) in + List.iter (fun (l, _) -> Hashtbl.add ht (hash_variant l) l) r1; + List.iter + (fun (l, _) -> + try raise (Tags (l, Hashtbl.find ht (hash_variant l))) + with Not_found -> ()) + r2); + 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; @@ -2786,24 +2797,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 @@ -2811,10 +2820,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 ****) @@ -2834,76 +2840,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 @@ -2912,183 +2911,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 = @@ -3117,38 +3112,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 @@ -3161,8 +3155,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' = @@ -3170,181 +3166,190 @@ 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 let eqtype rename type_pairs subst env t1 t2 = eqtype_list rename type_pairs subst env [t1] [t2] @@ -3352,18 +3357,16 @@ let eqtype rename type_pairs subst env t1 t2 = (* 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_Class_type_mismatch of Env.t * class_type * class_type @@ -3384,43 +3387,42 @@ exception Failure of class_match_failure list let rec moregen_clty trace type_pairs env cty1 cty2 = try - match cty1, cty2 with - Cty_constr (_, _, cty1), _ -> - moregen_clty true type_pairs env cty1 cty2 - | _, Cty_constr (_, _, cty2) -> - moregen_clty true type_pairs env cty1 cty2 - | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when Asttypes.same_arg_label l1 l2 -> - begin try moregen true type_pairs env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) - end; - moregen_clty false type_pairs env cty1' cty2' + match (cty1, cty2) with + | Cty_constr (_, _, cty1), _ -> moregen_clty true type_pairs env cty1 cty2 + | _, Cty_constr (_, _, cty2) -> moregen_clty true type_pairs env cty1 cty2 + | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') + when Asttypes.same_arg_label l1 l2 -> + (try moregen true type_pairs env ty1 ty2 + with Unify trace -> + raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])); + moregen_clty false type_pairs env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.csig_self) in - let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, _rest1) = flatten_fields ty1 - and (fields2, _rest2) = flatten_fields ty2 in - let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in - List.iter - (fun (lab, _k1, t1, _k2, t2) -> - begin try moregen true type_pairs env t1 t2 with Unify trace -> - raise (Failure [CM_Meth_type_mismatch - (lab, env, expand_trace env trace)]) - end) + let ty1 = object_fields (repr sign1.csig_self) in + let ty2 = object_fields (repr sign2.csig_self) in + let fields1, _rest1 = flatten_fields ty1 + and fields2, _rest2 = flatten_fields ty2 in + let pairs, _miss1, _miss2 = associate_fields fields1 fields2 in + List.iter + (fun (lab, _k1, t1, _k2, t2) -> + try moregen true type_pairs env t1 t2 + with Unify trace -> + raise + (Failure + [CM_Meth_type_mismatch (lab, env, expand_trace env trace)])) pairs; Vars.iter (fun lab (_mut, _v, ty) -> - let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in - try moregen true type_pairs env ty' ty with Unify trace -> - raise (Failure [CM_Val_type_mismatch - (lab, env, expand_trace env trace)])) + let _mut', _v', ty' = Vars.find lab sign1.csig_vars in + try moregen true type_pairs env ty' ty + with Unify trace -> + raise + (Failure [CM_Val_type_mismatch (lab, env, expand_trace env trace)])) sign2.csig_vars - | _ -> - raise (Failure []) - with - Failure error when trace || error = [] -> - raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) + | _ -> raise (Failure []) + with Failure error when trace || error = [] -> + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2) :: error)) -let match_class_types ?(trace=true) env pat_sch subj_sch = +let match_class_types ?(trace = true) env pat_sch subj_sch = let type_pairs = TypePairs.create 53 in let old_level = !current_level in current_level := generic_level - 1; @@ -3430,65 +3432,66 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = then copied with [duplicate_type]. That way, its levels won't be changed. *) - let (_, subj_inst) = instance_class [] subj_sch in + let _, subj_inst = instance_class [] subj_sch in let subj = duplicate_class_type subj_inst in current_level := generic_level; (* Duplicate generic variables *) - let (_, patt) = instance_class [] pat_sch in + let _, patt = instance_class [] pat_sch in let res = let sign1 = signature_of_class_type patt in let sign2 = signature_of_class_type subj in let t1 = repr sign1.csig_self in let t2 = repr sign2.csig_self in TypePairs.add type_pairs (t1, t2) (); - let (fields1, rest1) = flatten_fields (object_fields t1) - and (fields2, rest2) = flatten_fields (object_fields t2) in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let fields1, rest1 = flatten_fields (object_fields t1) + and fields2, rest2 = flatten_fields (object_fields t2) in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in let error = List.fold_right (fun (lab, k, _) err -> - let err = - let k = field_kind_repr k in - begin match k with - Fvar r -> set_kind r Fabsent; err - | _ -> CM_Hide_public lab::err - end - in - if Concr.mem lab sign1.csig_concr then err - else CM_Hide_virtual ("method", lab) :: err) + let err = + let k = field_kind_repr k in + match k with + | Fvar r -> + set_kind r Fabsent; + err + | _ -> CM_Hide_public lab :: err + in + if Concr.mem lab sign1.csig_concr then err + else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in let error = - (List.map (fun m -> CM_Missing_method m) missing_method) @ error + List.map (fun m -> CM_Missing_method m) missing_method @ error in (* Always succeeds *) moregen true type_pairs env rest1 rest2; let error = List.fold_right (fun (lab, k1, _t1, k2, _t2) err -> - try moregen_kind k1 k2; err with - Unify _ -> CM_Public_method lab::err) + try + moregen_kind k1 k2; + err + with Unify _ -> CM_Public_method lab :: err) pairs error in let error = Vars.fold (fun lab (mut, vr, _ty) err -> try - let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in + let mut', vr', _ty' = Vars.find lab sign1.csig_vars in if mut = Mutable && mut' <> Mutable then - CM_Non_mutable_value lab::err + CM_Non_mutable_value lab :: err else if vr = Concrete && vr' <> Concrete then - CM_Non_concrete_value lab::err - else - err - with Not_found -> - CM_Missing_value lab::err) + CM_Non_concrete_value lab :: err + else err + with Not_found -> CM_Missing_value lab :: err) sign2.csig_vars error in let error = Vars.fold - (fun lab (_,vr,_) err -> + (fun lab (_, vr, _) err -> if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then CM_Hide_virtual ("instance variable", lab) :: err else err) @@ -3497,66 +3500,64 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = let error = List.fold_right (fun e l -> - if List.mem e missing_method then l else CM_Virtual_method e::l) + if List.mem e missing_method then l else CM_Virtual_method e :: l) (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) error in match error with - [] -> - begin try - moregen_clty trace type_pairs env patt subj; - [] - with - Failure r -> r - end - | error -> - CM_Class_type_mismatch (env, patt, subj)::error + | [] -> ( + try + moregen_clty trace type_pairs env patt subj; + [] + with Failure r -> r) + | error -> CM_Class_type_mismatch (env, patt, subj) :: error in current_level := old_level; res let rec equal_clty trace type_pairs subst env cty1 cty2 = try - match cty1, cty2 with - Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> - equal_clty true type_pairs subst env cty1 cty2 + match (cty1, cty2) with + | Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> + equal_clty true type_pairs subst env cty1 cty2 | Cty_constr (_, _, cty1), _ -> - equal_clty true type_pairs subst env cty1 cty2 + equal_clty true type_pairs subst env cty1 cty2 | _, Cty_constr (_, _, cty2) -> - equal_clty true type_pairs subst env cty1 cty2 - | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when Asttypes.same_arg_label l1 l2 -> - begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) - end; - equal_clty false type_pairs subst env cty1' cty2' + equal_clty true type_pairs subst env cty1 cty2 + | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') + when Asttypes.same_arg_label l1 l2 -> + (try eqtype true type_pairs subst env ty1 ty2 + with Unify trace -> + raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)])); + equal_clty false type_pairs subst env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.csig_self) in - let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, _rest1) = flatten_fields ty1 - and (fields2, _rest2) = flatten_fields ty2 in - let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in - List.iter - (fun (lab, _k1, t1, _k2, t2) -> - begin try eqtype true type_pairs subst env t1 t2 with - Unify trace -> - raise (Failure [CM_Meth_type_mismatch - (lab, env, expand_trace env trace)]) - end) - pairs; - Vars.iter - (fun lab (_, _, ty) -> - let (_, _, ty') = Vars.find lab sign1.csig_vars in - try eqtype true type_pairs subst env ty' ty with Unify trace -> - raise (Failure [CM_Val_type_mismatch - (lab, env, expand_trace env trace)])) - sign2.csig_vars + let ty1 = object_fields (repr sign1.csig_self) in + let ty2 = object_fields (repr sign2.csig_self) in + let fields1, _rest1 = flatten_fields ty1 + and fields2, _rest2 = flatten_fields ty2 in + let pairs, _miss1, _miss2 = associate_fields fields1 fields2 in + List.iter + (fun (lab, _k1, t1, _k2, t2) -> + try eqtype true type_pairs subst env t1 t2 + with Unify trace -> + raise + (Failure + [CM_Meth_type_mismatch (lab, env, expand_trace env trace)])) + pairs; + Vars.iter + (fun lab (_, _, ty) -> + let _, _, ty' = Vars.find lab sign1.csig_vars in + try eqtype true type_pairs subst env ty' ty + with Unify trace -> + raise + (Failure [CM_Val_type_mismatch (lab, env, expand_trace env trace)])) + sign2.csig_vars | _ -> - raise - (Failure (if trace then [] - else [CM_Class_type_mismatch (env, cty1, cty2)])) - with - Failure error when trace -> - raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) + raise + (Failure + (if trace then [] else [CM_Class_type_mismatch (env, cty1, cty2)])) + with Failure error when trace -> + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2) :: error)) let match_class_declarations env patt_params patt_type subj_params subj_type = let type_pairs = TypePairs.create 53 in @@ -3566,27 +3567,24 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = let t1 = repr sign1.csig_self in let t2 = repr sign2.csig_self in TypePairs.add type_pairs (t1, t2) (); - let (fields1, rest1) = flatten_fields (object_fields t1) - and (fields2, rest2) = flatten_fields (object_fields t2) in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let fields1, rest1 = flatten_fields (object_fields t1) + and fields2, rest2 = flatten_fields (object_fields t2) in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in let error = List.fold_right (fun (lab, k, _) err -> let err = let k = field_kind_repr k in - begin match k with - Fvar _ -> err - | _ -> CM_Hide_public lab::err - end + match k with + | Fvar _ -> err + | _ -> CM_Hide_public lab :: err in if Concr.mem lab sign1.csig_concr then err else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in - let error = - (List.map (fun m -> CM_Missing_method m) missing_method) @ error - in + let error = List.map (fun m -> CM_Missing_method m) missing_method @ error in (* Always succeeds *) eqtype true type_pairs subst env rest1 rest2; let error = @@ -3594,32 +3592,29 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = (fun (lab, k1, _t1, k2, _t2) err -> let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in - match k1, k2 with - (Fvar _, Fvar _) - | (Fpresent, Fpresent) -> err - | (Fvar _, Fpresent) -> CM_Private_method lab::err - | (Fpresent, Fvar _) -> CM_Public_method lab::err - | _ -> assert false) + match (k1, k2) with + | Fvar _, Fvar _ | Fpresent, Fpresent -> err + | Fvar _, Fpresent -> CM_Private_method lab :: err + | Fpresent, Fvar _ -> CM_Public_method lab :: err + | _ -> assert false) pairs error in let error = Vars.fold (fun lab (mut, vr, _ty) err -> - try - let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in - if mut = Mutable && mut' <> Mutable then - CM_Non_mutable_value lab::err - else if vr = Concrete && vr' <> Concrete then - CM_Non_concrete_value lab::err - else - err - with Not_found -> - CM_Missing_value lab::err) + try + let mut', vr', _ty' = Vars.find lab sign1.csig_vars in + if mut = Mutable && mut' <> Mutable then + CM_Non_mutable_value lab :: err + else if vr = Concrete && vr' <> Concrete then + CM_Non_concrete_value lab :: err + else err + with Not_found -> CM_Missing_value lab :: err) sign2.csig_vars error in let error = Vars.fold - (fun lab (_,vr,_) err -> + (fun lab (_, vr, _) err -> if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then CM_Hide_virtual ("instance variable", lab) :: err else err) @@ -3628,43 +3623,41 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = let error = List.fold_right (fun e l -> - if List.mem e missing_method then l else CM_Virtual_method e::l) + if List.mem e missing_method then l else CM_Virtual_method e :: l) (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) error in match error with - [] -> - begin try - let lp = List.length patt_params in - let ls = List.length subj_params in - if lp <> ls then - raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); - List.iter2 (fun p s -> - try eqtype true type_pairs subst env p s with Unify trace -> - raise (Failure [CM_Type_parameter_mismatch - (env, expand_trace env trace)])) - patt_params subj_params; - (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) - equal_clty false type_pairs subst env - (Cty_signature sign1) (Cty_signature sign2); - (* Use moregeneral for class parameters, need to recheck everything to - keeps relationships (PR#4824) *) - let clty_params = - List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in - match_class_types ~trace:false env - (clty_params patt_params patt_type) - (clty_params subj_params subj_type) - with - Failure r -> r - end - | error -> - error - - - (***************) - (* Subtyping *) - (***************) + | [] -> ( + try + let lp = List.length patt_params in + let ls = List.length subj_params in + if lp <> ls then raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); + List.iter2 + (fun p s -> + try eqtype true type_pairs subst env p s + with Unify trace -> + raise + (Failure + [CM_Type_parameter_mismatch (env, expand_trace env trace)])) + patt_params subj_params; + (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) + equal_clty false type_pairs subst env (Cty_signature sign1) + (Cty_signature sign2); + (* Use moregeneral for class parameters, need to recheck everything to + keeps relationships (PR#4824) *) + let clty_params = + List.fold_right (fun ty cty -> Cty_arrow (Labelled "*", ty, cty)) + in + match_class_types ~trace:false env + (clty_params patt_params patt_type) + (clty_params subj_params subj_type) + with Failure r -> r) + | error -> error +(***************) +(* Subtyping *) +(***************) (**** Build a subtype of a given type. ****) @@ -3675,70 +3668,69 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = [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 @@ -3746,141 +3738,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. ****) @@ -3904,280 +3903,317 @@ 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 v, _ when - !Config.bs_only && - !variant_is_subtype env (row_repr v) t2 - -> + (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 v, _ + when !Config.bs_only && !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, [])) -> + | 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; @@ -4186,52 +4222,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. *) @@ -4239,17 +4271,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 @@ -4257,31 +4290,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 = @@ -4298,76 +4327,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 @@ -4376,73 +4413,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 @@ -4457,9 +4494,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))); @@ -4473,12 +4508,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 = @@ -4486,7 +4520,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; @@ -4507,72 +4542,72 @@ 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; - } + 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; + } with Not_found -> clear_hash (); raise Not_found - (* Preserve sharing inside class types. *) let nondep_class_signature env id sign = - { csig_self = nondep_type_rec env id sign.csig_self; + { + csig_self = nondep_type_rec env id sign.csig_self; csig_vars = - Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + Vars.map + (function + | m, v, t -> (m, v, nondep_type_rec env id t)) sign.csig_vars; csig_concr = sign.csig_concr; csig_inher = - List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl)) - sign.csig_inher } + List.map + (fun (p, tl) -> (p, List.map (nondep_type_rec env id) tl)) + sign.csig_inher; + } -let rec nondep_class_type env id = - function - Cty_constr (p, _, cty) when Path.isfree id p -> - nondep_class_type env id cty +let rec nondep_class_type env id = function + | Cty_constr (p, _, cty) when Path.isfree id p -> nondep_class_type env id cty | Cty_constr (p, tyl, cty) -> - Cty_constr (p, List.map (nondep_type_rec env id) tyl, - nondep_class_type env id cty) - | Cty_signature sign -> - Cty_signature (nondep_class_signature env id sign) + Cty_constr + (p, List.map (nondep_type_rec env id) tyl, nondep_class_type env id cty) + | Cty_signature sign -> Cty_signature (nondep_class_signature env id sign) | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, nondep_type_rec env id ty, nondep_class_type env id cty) + Cty_arrow (l, nondep_type_rec env id ty, nondep_class_type env id cty) let nondep_class_declaration env id decl = assert (not (Path.isfree id decl.cty_path)); let decl = - { cty_params = List.map (nondep_type_rec env id) decl.cty_params; + { + cty_params = List.map (nondep_type_rec env id) decl.cty_params; cty_variance = decl.cty_variance; cty_type = nondep_class_type env id decl.cty_type; cty_path = decl.cty_path; cty_new = - begin match decl.cty_new with - None -> None - | Some ty -> Some (nondep_type_rec env id ty) - end; + (match decl.cty_new with + | None -> None + | Some ty -> Some (nondep_type_rec env id ty)); cty_loc = decl.cty_loc; cty_attributes = decl.cty_attributes; } @@ -4583,7 +4618,8 @@ let nondep_class_declaration env id decl = let nondep_cltype_declaration env id decl = assert (not (Path.isfree id decl.clty_path)); let decl = - { clty_params = List.map (nondep_type_rec env id) decl.clty_params; + { + clty_params = List.map (nondep_type_rec env id) decl.clty_params; clty_variance = decl.clty_variance; clty_type = nondep_class_type env id decl.clty_type; clty_path = decl.clty_path; @@ -4597,55 +4633,52 @@ let nondep_cltype_declaration env id decl = (* 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/analysis/vendor/ml/ctype.mli b/analysis/vendor/ml/ctype.mli index 7b68649e4..4bae8afd0 100644 --- a/analysis/vendor/ml/ctype.mli +++ b/analysis/vendor/ml/ctype.mli @@ -20,180 +20,223 @@ 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_class: - type_expr list -> class_type -> type_expr list * class_type -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_class : type_expr list -> class_type -> type_expr list * class_type +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_Class_type_mismatch of Env.t * class_type * class_type @@ -209,85 +252,103 @@ type class_match_failure = | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string -val match_class_types: - ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list - (* Check if the first class type is more general than the second. *) -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 match_class_declarations: - Env.t -> type_expr list -> class_type -> type_expr list -> - class_type -> class_match_failure list - (* Check if the first class type is more general than the second. *) - -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 nondep_class_declaration: - Env.t -> Ident.t -> class_declaration -> class_declaration - (* Same for class declarations. *) -val nondep_cltype_declaration: - Env.t -> Ident.t -> class_type_declaration -> class_type_declaration - (* Same for class type declarations. *) +val match_class_types : + ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list +(* Check if the first class type is more general than the second. *) + +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 match_class_declarations : + Env.t -> + type_expr list -> + class_type -> + type_expr list -> + class_type -> + class_match_failure list +(* Check if the first class type is more general than the second. *) + +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 nondep_class_declaration : + Env.t -> Ident.t -> class_declaration -> class_declaration +(* Same for class declarations. *) + +val nondep_cltype_declaration : + Env.t -> Ident.t -> class_type_declaration -> class_type_declaration + +(* Same for class type declarations. *) (*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 closed_class: - type_expr list -> class_signature -> closed_class_failure option - (* Check whether all type variables are bound *) +val closed_class : + type_expr list -> class_signature -> closed_class_failure option +(* Check whether all type variables are bound *) -val unalias: type_expr -> type_expr -val signature_of_class_type: class_type -> class_signature -val self_type: class_type -> type_expr -val class_type_arity: class_type -> int -val arity: type_expr -> int - (* Return the arity (as for curried functions) of the given type. *) +val unalias : type_expr -> type_expr +val signature_of_class_type : class_type -> class_signature +val self_type : class_type -> type_expr +val class_type_arity : class_type -> int +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/analysis/vendor/ml/datarepr.ml b/analysis/vendor/ml/datarepr.ml index 8412621f5..9971db304 100644 --- a/analysis/vendor/ml/datarepr.ml +++ b/analysis/vendor/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_args = []); - 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_args = []); + 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/analysis/vendor/ml/datarepr.mli b/analysis/vendor/ml/datarepr.mli index f6bc50f08..47113d87e 100644 --- a/analysis/vendor/ml/datarepr.mli +++ b/analysis/vendor/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/analysis/vendor/ml/delayed_checks.ml b/analysis/vendor/ml/delayed_checks.ml index 029831a74..631425ce6 100644 --- a/analysis/vendor/ml/delayed_checks.ml +++ b/analysis/vendor/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/analysis/vendor/ml/delayed_checks.mli b/analysis/vendor/ml/delayed_checks.mli index df0a34692..ac83a671c 100644 --- a/analysis/vendor/ml/delayed_checks.mli +++ b/analysis/vendor/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/analysis/vendor/ml/depend.ml b/analysis/vendor/ml/depend.ml index 5a4a336a1..7305a3da1 100644 --- a/analysis/vendor/ml/depend.ml +++ b/analysis/vendor/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,37 @@ 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(c, tl) -> add bv c; List.iter (add_type bv) tl - | 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 (c, tl) -> + add bv c; + List.iter (add_type bv) tl + | 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 +137,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 +150,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 = @@ -162,28 +176,32 @@ let add_type_extension bv te = let rec add_class_type bv cty = match cty.pcty_desc with - Pcty_constr(l, tyl) -> - add bv l; List.iter (add_type bv) tyl - | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> - add_type bv ty; - List.iter (add_class_type_field bv) fieldl - | Pcty_arrow(_, ty1, cty2) -> - add_type bv ty1; add_class_type bv cty2 + | Pcty_constr (l, tyl) -> + add bv l; + List.iter (add_type bv) tyl + | Pcty_signature {pcsig_self = ty; pcsig_fields = fieldl} -> + add_type bv ty; + List.iter (add_class_type_field bv) fieldl + | Pcty_arrow (_, ty1, cty2) -> + add_type bv ty1; + add_class_type bv cty2 | Pcty_extension e -> handle_extension e | Pcty_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_class_type bv e + let bv = open_module bv m.txt in + add_class_type bv e and add_class_type_field bv pctf = match pctf.pctf_desc with - Pctf_inherit cty -> add_class_type bv cty - | Pctf_val(_, _, _, ty) -> add_type bv ty - | Pctf_method(_, _, _, ty) -> add_type bv ty - | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pctf_inherit cty -> add_class_type bv cty + | Pctf_val (_, _, _, ty) -> add_type bv ty + | Pctf_method (_, _, _, ty) -> add_type bv ty + | Pctf_constraint (ty1, ty2) -> + add_type bv ty1; + add_type bv ty2 | Pctf_attribute _ -> () | Pctf_extension e -> handle_extension e -let add_class_description bv infos = - add_class_type bv infos.pci_expr +let add_class_description bv infos = add_class_type bv infos.pci_expr let add_class_type_declaration = add_class_description @@ -191,23 +209,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 @@ -218,69 +247,96 @@ 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, oty2, ty3) -> - add_expr bv e1; - add_opt add_type bv oty2; - 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, oty2, ty3) -> + add_expr bv e1; + add_opt add_type bv oty2; + 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_object { pcstr_self = pat; pcstr_fields = fieldl } -> - let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl + | 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 {pcstr_self = pat; pcstr_fields = fieldl} -> + let bv = add_pattern bv pat in + List.iter (add_class_field bv) fieldl | 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 @@ -295,22 +351,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 @@ -318,108 +373,109 @@ 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) + 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 cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) + List.iter (add_class_type_declaration bv) cdtl; + (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 @@ -428,74 +484,72 @@ 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) + (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 cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) + List.iter (add_class_type_declaration bv) cdtl; + (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) and add_class_field bv pcf = match pcf.pcf_desc with - Pcf_inherit() -> () - | Pcf_val(_, _, Cfk_concrete (_, e)) - | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e - | Pcf_val(_, _, Cfk_virtual ty) - | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty - | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pcf_inherit () -> () + | Pcf_val (_, _, Cfk_concrete (_, e)) | Pcf_method (_, _, Cfk_concrete (_, e)) + -> + add_expr bv e + | Pcf_val (_, _, Cfk_virtual ty) | Pcf_method (_, _, Cfk_virtual ty) -> + add_type bv ty + | Pcf_constraint (ty1, ty2) -> + add_type bv ty1; + add_type bv ty2 | Pcf_initializer e -> add_expr bv e | Pcf_attribute _ -> () | Pcf_extension e -> handle_extension e - diff --git a/analysis/vendor/ml/depend.mli b/analysis/vendor/ml/depend.mli index 23ad60dd1..b4fb4c884 100644 --- a/analysis/vendor/ml/depend.mli +++ b/analysis/vendor/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/analysis/vendor/ml/docstrings.ml b/analysis/vendor/ml/docstrings.ml index 85c58ad8d..5efe4bd0e 100644 --- a/analysis/vendor/ml/docstrings.ml +++ b/analysis/vendor/ml/docstrings.ml @@ -20,22 +20,23 @@ open Location (* A docstring is "attached" if it has been inserted in the AST. This is used for generating unexpected docstring warnings. *) type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) + | Unattached (* Not yet attached anything.*) + | Info (* Attached to a field or constructor. *) + | Docs (* Attached to an item or as floating text. *) (* A docstring is "associated" with an item if there are no blank lines between them. This is used for generating docstring ambiguity warnings. *) type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) + | Zero (* Not associated with an item *) + | One (* Associated with one item *) + | Many (* Associated with multiple items (ambiguity) *) -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } +type docstring = { + ds_body: string; + ds_loc: Location.t; + mutable ds_attached: ds_attached; + mutable ds_associated: ds_associated; +} (* List of docstrings *) @@ -44,34 +45,32 @@ let docstrings : docstring list ref = ref [] (* Warn for unused and ambiguous docstrings *) let warn_bad_docstrings () = - if Warnings.is_active (Warnings.Bad_docstring true) then begin + if Warnings.is_active (Warnings.Bad_docstring true) then List.iter (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Warnings.Bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Warnings.Bad_docstring false)) + match ds.ds_attached with + | Info -> () + | Unattached -> prerr_warning ds.ds_loc (Warnings.Bad_docstring true) + | Docs -> ( + match ds.ds_associated with + | Zero | One -> () + | Many -> prerr_warning ds.ds_loc (Warnings.Bad_docstring false))) (List.rev !docstrings) -end (* Docstring constructors and destructors *) let docstring body loc = let ds = - { ds_body = body; + { + ds_body = body; ds_loc = loc; ds_attached = Unattached; - ds_associated = Zero; } + ds_associated = Zero; + } in ds -let register ds = - docstrings := ds :: !docstrings +let register ds = docstrings := ds :: !docstrings let docstring_body ds = ds.ds_body @@ -79,35 +78,33 @@ let docstring_loc ds = ds.ds_loc (* Docstrings attached to items *) -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } +type docs = {docs_pre: docstring option; docs_post: docstring option} -let empty_docs = { docs_pre = None; docs_post = None } +let empty_docs = {docs_pre = None; docs_post = None} let doc_loc = {txt = "ocaml.doc"; loc = Location.none} let docs_attr ds = let open Parsetree in let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); + { + pexp_desc = Pexp_constant (Pconst_string (ds.ds_body, None)); pexp_loc = ds.ds_loc; - pexp_attributes = []; } + pexp_attributes = []; + } in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) + let item = {pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc} in + (doc_loc, PStr [item]) let add_docs_attrs docs attrs = let attrs = match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs + | None | Some {ds_body = ""; _} -> attrs | Some ds -> docs_attr ds :: attrs in let attrs = match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs + | None | Some {ds_body = ""; _} -> attrs | Some ds -> attrs @ [docs_attr ds] in attrs @@ -122,7 +119,7 @@ let info_attr = docs_attr let add_info_attrs info attrs = match info with - | None | Some {ds_body=""; _} -> attrs + | None | Some {ds_body = ""; _} -> attrs | Some ds -> attrs @ [info_attr ds] (* Docstrings not attached to a specific item *) @@ -137,18 +134,22 @@ let text_loc = {txt = "ocaml.text"; loc = Location.none} let text_attr ds = let open Parsetree in let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); + { + pexp_desc = Pexp_constant (Pconst_string (ds.ds_body, None)); pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } + pexp_attributes = []; + } in - (text_loc, PStr [item]) + let item = {pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc} in + (text_loc, PStr [item]) let add_text_attrs dsl attrs = - let fdsl = Ext_list.filter dsl (function {ds_body=""} -> false| _ ->true) in - (List.map text_attr fdsl) @ attrs + let fdsl = + Ext_list.filter dsl (function + | {ds_body = ""} -> false + | _ -> true) + in + List.map text_attr fdsl @ attrs (* Find the first non-info docstring in a list, attach it and return it *) let get_docstring ~info dsl = @@ -156,8 +157,8 @@ let get_docstring ~info dsl = | [] -> None | {ds_attached = Info; _} :: rest -> loop rest | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds + ds.ds_attached <- (if info then Info else Docs); + Some ds in loop dsl @@ -167,45 +168,42 @@ let get_docstrings dsl = | [] -> List.rev acc | {ds_attached = Info; _} :: rest -> loop acc rest | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest + ds.ds_attached <- Docs; + loop (ds :: acc) rest in - loop [] dsl + loop [] dsl (* "Associate" all the docstrings in a list *) let associate_docstrings dsl = List.iter (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) + match ds.ds_associated with + | Zero -> ds.ds_associated <- One + | One | Many -> ds.ds_associated <- Many) dsl (* Map from positions to pre docstrings *) -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 +let pre_table : (Lexing.position, docstring list) Hashtbl.t = Hashtbl.create 50 -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl +let set_pre_docstrings pos dsl = if dsl <> [] then Hashtbl.add pre_table pos dsl let get_pre_docs pos = try let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl + associate_docstrings dsl; + get_docstring ~info:false dsl with Not_found -> None let mark_pre_docs pos = try let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl + associate_docstrings dsl with Not_found -> () (* Map from positions to post docstrings *) -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 +let post_table : (Lexing.position, docstring list) Hashtbl.t = Hashtbl.create 50 let set_post_docstrings pos dsl = if dsl <> [] then Hashtbl.add post_table pos dsl @@ -213,20 +211,20 @@ let set_post_docstrings pos dsl = let get_post_docs pos = try let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl + associate_docstrings dsl; + get_docstring ~info:false dsl with Not_found -> None let mark_post_docs pos = try let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl + associate_docstrings dsl with Not_found -> () let get_info pos = try let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl + get_docstring ~info:true dsl with Not_found -> None (* Map from positions to floating docstrings *) @@ -240,7 +238,7 @@ let set_floating_docstrings pos dsl = let get_text pos = try let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl + get_docstrings dsl with Not_found -> [] (* Maps from positions to extra docstrings *) @@ -254,7 +252,7 @@ let set_pre_extra_docstrings pos dsl = let get_pre_extra_text pos = try let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl + get_docstrings dsl with Not_found -> [] let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = @@ -266,30 +264,32 @@ let set_post_extra_docstrings pos dsl = let get_post_extra_text pos = try let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl + get_docstrings dsl with Not_found -> [] (* Docstrings from parser actions *) let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } + { + docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); + docs_post = get_post_docs (Parsing.symbol_end_pos ()); + } let symbol_docs_lazy () = let p1 = Parsing.symbol_start_pos () in let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } + lazy {docs_pre = get_pre_docs p1; docs_post = get_post_docs p2} let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } + { + docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); + docs_post = get_post_docs (Parsing.rhs_end_pos pos2); + } let rhs_docs_lazy pos1 pos2 = let p1 = Parsing.rhs_start_pos pos1 in let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } + lazy {docs_pre = get_pre_docs p1; docs_post = get_post_docs p2} let mark_symbol_docs () = mark_pre_docs (Parsing.symbol_start_pos ()); @@ -299,38 +299,29 @@ let mark_rhs_docs pos1 pos2 = mark_pre_docs (Parsing.rhs_start_pos pos1); mark_post_docs (Parsing.rhs_end_pos pos2) -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) +let symbol_info () = get_info (Parsing.symbol_end_pos ()) -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) +let rhs_info pos = get_info (Parsing.rhs_end_pos pos) -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) +let symbol_text () = get_text (Parsing.symbol_start_pos ()) let symbol_text_lazy () = let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) + lazy (get_text pos) -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) +let rhs_text pos = get_text (Parsing.rhs_start_pos pos) let rhs_text_lazy pos = let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) + lazy (get_text pos) -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) +let symbol_pre_extra_text () = get_pre_extra_text (Parsing.symbol_start_pos ()) -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) +let symbol_post_extra_text () = get_post_extra_text (Parsing.symbol_end_pos ()) -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) +let rhs_pre_extra_text pos = get_pre_extra_text (Parsing.rhs_start_pos pos) +let rhs_post_extra_text pos = get_post_extra_text (Parsing.rhs_end_pos pos) (* (Re)Initialise all comment state *) diff --git a/analysis/vendor/ml/docstrings.mli b/analysis/vendor/ml/docstrings.mli index 892a80e27..36fcbb282 100644 --- a/analysis/vendor/ml/docstrings.mli +++ b/analysis/vendor/ml/docstrings.mli @@ -15,83 +15,83 @@ (** Documentation comments *) -(** (Re)Initialise all docstring state *) val init : unit -> unit +(** (Re)Initialise all docstring state *) -(** Emit warnings for unattached and ambiguous docstrings *) val warn_bad_docstrings : unit -> unit +(** Emit warnings for unattached and ambiguous docstrings *) (** {2 Docstrings} *) -(** Documentation comments *) type docstring +(** Documentation comments *) -(** Create a docstring *) val docstring : string -> Location.t -> docstring +(** Create a docstring *) -(** Register a docstring *) val register : docstring -> unit +(** Register a docstring *) -(** Get the text of a docstring *) val docstring_body : docstring -> string +(** Get the text of a docstring *) -(** Get the location of a docstring *) val docstring_loc : docstring -> Location.t +(** Get the location of a docstring *) (** {2 Set functions} These functions are used by the lexer to associate docstrings to the locations of tokens. *) -(** Docstrings immediately preceding a token *) val set_pre_docstrings : Lexing.position -> docstring list -> unit +(** Docstrings immediately preceding a token *) -(** Docstrings immediately following a token *) val set_post_docstrings : Lexing.position -> docstring list -> unit +(** Docstrings immediately following a token *) -(** Docstrings not immediately adjacent to a token *) val set_floating_docstrings : Lexing.position -> docstring list -> unit +(** Docstrings not immediately adjacent to a token *) -(** Docstrings immediately following the token which precedes this one *) val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit +(** Docstrings immediately following the token which precedes this one *) -(** Docstrings immediately preceding the token which follows this one *) val set_post_extra_docstrings : Lexing.position -> docstring list -> unit +(** Docstrings immediately preceding the token which follows this one *) (** {2 Items} The {!docs} type represents documentation attached to an item. *) -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } +type docs = {docs_pre: docstring option; docs_post: docstring option} val empty_docs : docs val docs_attr : docstring -> Parsetree.attribute +val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes (** Convert item documentation to attributes and add them to an attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes +val symbol_docs : unit -> docs (** Fetch the item documentation for the current symbol. This also marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs + val symbol_docs_lazy : unit -> docs Lazy.t +val rhs_docs : int -> int -> docs (** Fetch the item documentation for the symbols between two positions. This also marks this documentation (for ambiguity warnings). *) -val rhs_docs : int -> int -> docs + val rhs_docs_lazy : int -> int -> docs Lazy.t +val mark_symbol_docs : unit -> unit (** Mark the item documentation for the current symbol (for ambiguity warnings). *) -val mark_symbol_docs : unit -> unit +val mark_rhs_docs : int -> int -> unit (** Mark as associated the item documentation for the symbols between two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit (** {2 Fields and constructors} @@ -104,15 +104,15 @@ val empty_info : info val info_attr : docstring -> Parsetree.attribute +val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes (** Convert field info to attributes and add them to an attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes -(** Fetch the field info for the current symbol. *) val symbol_info : unit -> info +(** Fetch the field info for the current symbol. *) -(** Fetch the field info following the symbol at a given position. *) val rhs_info : int -> info +(** Fetch the field info following the symbol at a given position. *) (** {2 Unattached comments} @@ -126,15 +126,17 @@ val empty_text_lazy : text Lazy.t val text_attr : docstring -> Parsetree.attribute -(** Convert text to attributes and add them to an attribute list *) val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes +(** Convert text to attributes and add them to an attribute list *) -(** Fetch the text preceding the current symbol. *) val symbol_text : unit -> text +(** Fetch the text preceding the current symbol. *) + val symbol_text_lazy : unit -> text Lazy.t -(** Fetch the text preceding the symbol at the given position. *) val rhs_text : int -> text +(** Fetch the text preceding the symbol at the given position. *) + val rhs_text_lazy : int -> text Lazy.t (** {2 Extra text} @@ -144,14 +146,14 @@ val rhs_text_lazy : int -> text Lazy.t functions, which are applied to the contents of the block rather than the delimiters. *) -(** Fetch additional text preceding the current symbol *) val symbol_pre_extra_text : unit -> text +(** Fetch additional text preceding the current symbol *) -(** Fetch additional text following the current symbol *) val symbol_post_extra_text : unit -> text +(** Fetch additional text following the current symbol *) -(** Fetch additional text preceding the symbol at the given position *) val rhs_pre_extra_text : int -> text +(** Fetch additional text preceding the symbol at the given position *) -(** Fetch additional text following the symbol at the given position *) val rhs_post_extra_text : int -> text +(** Fetch additional text following the symbol at the given position *) diff --git a/analysis/vendor/ml/env.ml b/analysis/vendor/ml/env.ml index 8a914c825..9732a5931 100644 --- a/analysis/vendor/ml/env.ml +++ b/analysis/vendor/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 empty = {current = Ident.empty; opened = None} - let add id x tbl = - {tbl with current = Ident.add id x tbl.current} + let add id x tbl = {tbl with current = Ident.add id x tbl.current} - 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 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) @ - 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 + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> ( 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 @@ -454,20 +408,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; @@ -475,7 +429,7 @@ 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; comp_classes: class_declaration comp_tbl; (* warning -69*) @@ -483,18 +437,20 @@ and structure_components = { } 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) @@ -508,10 +464,9 @@ 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" @@ -519,29 +474,41 @@ let check_shadowing env = function | `Class (Some _) -> Some "class" | `Class_type (Some _) -> Some "class type" | `Constructor _ | `Label _ - | `Value None | `Type None | `Module None | `Module_type None - | `Class None | `Class_type None | `Component None -> - None + | `Value None + | `Type None + | `Module None + | `Module_type None + | `Class None + | `Class_type None + | `Component 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; classes = IdTbl.empty; - cltypes = 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; + classes = IdTbl.empty; + cltypes = 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} @@ -552,31 +519,28 @@ 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.classes env2.classes + 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.classes env2.classes -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 @@ -584,44 +548,55 @@ 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; comp_classes = Tbl.empty; - comp_cltypes = 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; + comp_classes = Tbl.empty; + comp_cltypes = Tbl.empty; + } let get_components c = match get_components_opt c with @@ -635,47 +610,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 *) @@ -686,41 +662,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 @@ -728,75 +706,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 := ""; @@ -822,196 +790,173 @@ 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 - -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_class = - find (fun env -> env.classes) (fun sc -> sc.comp_classes) -and find_cltype = - find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) + | 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) + +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_class = find (fun env -> env.classes) (fun sc -> sc.comp_classes) + +and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) 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 + + 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_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 @@ -1021,10 +966,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 @@ -1050,10 +996,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 @@ -1062,53 +1009,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; *) @@ -1117,135 +1061,127 @@ 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 !Config.bs_only && 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 + !Config.bs_only + && (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 lookup_class = - lookup (fun env -> env.classes) (fun sc -> sc.comp_classes) -let lookup_cltype = - lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +let lookup_class = lookup (fun env -> env.classes) (fun sc -> sc.comp_classes) +let lookup_cltype = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) 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 = @@ -1273,31 +1209,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 @@ -1309,19 +1246,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 = @@ -1332,32 +1269,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_decl = try find_type ty_path env with Not_found -> assert false 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_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 @@ -1367,18 +1303,17 @@ 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 -> [] let lookup_class ?loc lid env = - let (_, desc) as r = lookup_class ?loc lid env in + let ((_, desc) as r) = lookup_class ?loc lid env in (* special support for Typeclass.unbound_class *) if Path.name desc.cty_path = "" then ignore (lookup_type ?loc lid env) else mark_type_path env desc.cty_path; r let lookup_cltype ?loc lid env = - let (_, desc) as r = lookup_cltype ?loc lid env in + let ((_, desc) as r) = lookup_cltype ?loc lid env in if Path.name desc.clty_path = "" then ignore (lookup_type ?loc lid env) else mark_type_path env desc.clty_path; mark_type_path env desc.clty_path; @@ -1392,13 +1327,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 () = @@ -1410,9 +1346,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); @@ -1420,15 +1357,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) @@ -1448,109 +1387,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 @@ -1559,242 +1497,238 @@ 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(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) + | [] -> ([], 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 (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) 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; comp_classes = Tbl.empty; - comp_cltypes = 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; + comp_classes = Tbl.empty; + comp_cltypes = 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(id, decl, _) -> - let decl' = Subst.cltype_declaration sub decl in - c.comp_cltypes <- - Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) - 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 + | Sig_class_type (id, decl, _) -> + let decl' = Subst.cltype_declaration sub decl in + c.comp_cltypes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) + 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 @@ -1802,78 +1736,81 @@ 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 is_exception = Path.same ext.ext_type_path Predef.path_exn in - 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, 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 is_exception = Path.same ext.ext_type_path Predef.path_exn in + 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, 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); + } and store_cltype id desc env = - { env with + { + env with cltypes = IdTbl.add id desc env.cltypes; - summary = Env_cltype(env.summary, id, desc) } + summary = Env_cltype (env.summary, id, desc); + } (* 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 @@ -1887,59 +1824,57 @@ 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 -and add_cltype id ty env = - store_cltype id ty env +and add_cltype id ty env = store_cltype id ty 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) *) +(* let (id, env) = enter store_module name md env in + (id, add_functor_arg ?arg id env) *) + and enter_modtype = enter store_modtype and enter_cltype = enter store_cltype @@ -1952,60 +1887,47 @@ 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_class_type(id, decl, _) -> add_cltype id decl 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 (id, decl, _) -> add_cltype id decl 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 - let classes = - add (fun x -> `Class x) comps.comp_classes env0.classes - in - let cltypes = - add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes - in + let classes = add (fun x -> `Class x) comps.comp_classes env0.classes in + let cltypes = add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes in let components = 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; @@ -2022,48 +1944,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 *) @@ -2076,62 +1993,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 -> @@ -2139,103 +2054,94 @@ 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 + and fold_classs f = find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f + and fold_cltypes f = find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) 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 @@ -2250,27 +2156,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 *) @@ -2279,47 +2180,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/analysis/vendor/ml/env.mli b/analysis/vendor/ml/env.mli index dfa1027de..6ff95b65b 100644 --- a/analysis/vendor/ml/env.mli +++ b/analysis/vendor/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,191 +36,205 @@ 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_class: Path.t -> t -> class_declaration -val find_cltype: Path.t -> t -> class_type_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_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_class : Path.t -> t -> class_declaration +val find_cltype : Path.t -> t -> class_type_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 + (* 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 lookup_class: +val lookup_class : ?loc:Location.t -> Longident.t -> t -> Path.t * class_declaration -val lookup_cltype: +val lookup_cltype : ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_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_cltype: Ident.t -> class_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 +val add_cltype : Ident.t -> class_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_cltype: string -> class_type_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 + +val enter_cltype : string -> class_type_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 @@ -242,82 +256,100 @@ 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 -val fold_classs: + Longident.t option -> + t -> + 'a -> + 'a +val fold_classs : (string -> Path.t -> class_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_cltypes: + Longident.t option -> + t -> + 'a -> + 'a +val fold_cltypes : (string -> Path.t -> class_type_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/analysis/vendor/ml/envaux.ml b/analysis/vendor/ml/envaux.ml index 5fd502046..4c294e6d7 100644 --- a/analysis/vendor/ml/envaux.ml +++ b/analysis/vendor/ml/envaux.ml @@ -16,74 +16,71 @@ open Env -type error = - Module_not_found of Path.t +type error = Module_not_found of Path.t exception Error of error -let env_cache = - (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) +let env_cache = (Hashtbl.create 59 : (Env.summary * Subst.t, Env.t) Hashtbl.t) let reset_cache () = Hashtbl.clear env_cache; - Env.reset_cache() + Env.reset_cache () let rec env_from_summary sum subst = - try - Hashtbl.find env_cache (sum, subst) + try Hashtbl.find env_cache (sum, subst) with Not_found -> let env = match sum with - Env_empty -> - Env.empty - | Env_value(s, id, desc) -> - Env.add_value id (Subst.value_description subst desc) - (env_from_summary s subst) - | Env_type(s, id, desc) -> - Env.add_type ~check:false id - (Subst.type_declaration subst desc) - (env_from_summary s subst) - | Env_extension(s, id, desc) -> - Env.add_extension ~check:false id - (Subst.extension_constructor subst desc) - (env_from_summary s subst) - | Env_module(s, id, desc) -> - Env.add_module_declaration ~check:false id - (Subst.module_declaration subst desc) - (env_from_summary s subst) - | Env_modtype(s, id, desc) -> - Env.add_modtype id (Subst.modtype_declaration subst desc) - (env_from_summary s subst) + | Env_empty -> Env.empty + | Env_value (s, id, desc) -> + Env.add_value id + (Subst.value_description subst desc) + (env_from_summary s subst) + | Env_type (s, id, desc) -> + Env.add_type ~check:false id + (Subst.type_declaration subst desc) + (env_from_summary s subst) + | Env_extension (s, id, desc) -> + Env.add_extension ~check:false id + (Subst.extension_constructor subst desc) + (env_from_summary s subst) + | Env_module (s, id, desc) -> + Env.add_module_declaration ~check:false id + (Subst.module_declaration subst desc) + (env_from_summary s subst) + | Env_modtype (s, id, desc) -> + Env.add_modtype id + (Subst.modtype_declaration subst desc) + (env_from_summary s subst) | Env_cltype (s, id, desc) -> - Env.add_cltype id (Subst.cltype_declaration subst desc) - (env_from_summary s subst) - | Env_open(s, path) -> - let env = env_from_summary s subst in - let path' = Subst.module_path subst path in - begin match Env.open_signature Asttypes.Override path' env with - | Some env -> env - | None -> assert false - end - | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' -> - Env.add_module_declaration ~check:false - id (Subst.module_declaration subst desc) - ~arg:true (env_from_summary s subst) - | Env_class _ - | Env_functor_arg _ -> assert false - | Env_constraints(s, map) -> - PathMap.fold - (fun path info -> - Env.add_local_type (Subst.type_path subst path) - (Subst.type_declaration subst info)) - map (env_from_summary s subst) - | Env_copy_types (s, sl) -> - Env.copy_types sl (env_from_summary s subst) + Env.add_cltype id + (Subst.cltype_declaration subst desc) + (env_from_summary s subst) + | Env_open (s, path) -> ( + let env = env_from_summary s subst in + let path' = Subst.module_path subst path in + match Env.open_signature Asttypes.Override path' env with + | Some env -> env + | None -> assert false) + | Env_functor_arg (Env_module (s, id, desc), id') when Ident.same id id' + -> + Env.add_module_declaration ~check:false id + (Subst.module_declaration subst desc) + ~arg:true (env_from_summary s subst) + | Env_class _ | Env_functor_arg _ -> assert false + | Env_constraints (s, map) -> + PathMap.fold + (fun path info -> + Env.add_local_type + (Subst.type_path subst path) + (Subst.type_declaration subst info)) + map (env_from_summary s subst) + | Env_copy_types (s, sl) -> Env.copy_types sl (env_from_summary s subst) in - Hashtbl.add env_cache (sum, subst) env; - env + Hashtbl.add env_cache (sum, subst) env; + env -let env_of_only_summary env = - Env.env_of_only_summary env_from_summary env +let env_of_only_summary env = Env.env_of_only_summary env_from_summary env (* Error report *) @@ -91,4 +88,4 @@ open Format let report_error ppf = function | Module_not_found p -> - fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p + fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p diff --git a/analysis/vendor/ml/envaux.mli b/analysis/vendor/ml/envaux.mli index 2869890a1..d28dbf30d 100644 --- a/analysis/vendor/ml/envaux.mli +++ b/analysis/vendor/ml/envaux.mli @@ -22,15 +22,14 @@ val env_from_summary : Env.summary -> Subst.t -> Env.t (* Empty the environment caches. To be called when load_path changes. *) -val reset_cache: unit -> unit +val reset_cache : unit -> unit val env_of_only_summary : Env.t -> Env.t (* Error report *) -type error = - Module_not_found of Path.t +type error = Module_not_found of Path.t exception Error of error -val report_error: formatter -> error -> unit +val report_error : formatter -> error -> unit diff --git a/analysis/vendor/ml/error_message_utils.ml b/analysis/vendor/ml/error_message_utils.ml index 2f5312916..0b9dfe9a0 100644 --- a/analysis/vendor/ml/error_message_utils.ml +++ b/analysis/vendor/ml/error_message_utils.ml @@ -204,7 +204,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 diff --git a/analysis/vendor/ml/includeclass.ml b/analysis/vendor/ml/includeclass.ml index 7f1b1bdd8..9791bc488 100644 --- a/analysis/vendor/ml/includeclass.ml +++ b/analysis/vendor/ml/includeclass.ml @@ -17,28 +17,21 @@ open Types -let class_types env cty1 cty2 = - Ctype.match_class_types env cty1 cty2 +let class_types env cty1 cty2 = Ctype.match_class_types env cty1 cty2 let class_type_declarations ~loc env cty1 cty2 = - Builtin_attributes.check_deprecated_inclusion - ~def:cty1.clty_loc - ~use:cty2.clty_loc - loc - cty1.clty_attributes cty2.clty_attributes + Builtin_attributes.check_deprecated_inclusion ~def:cty1.clty_loc + ~use:cty2.clty_loc loc cty1.clty_attributes cty2.clty_attributes (Path.last cty1.clty_path); - Ctype.match_class_declarations env - cty1.clty_params cty1.clty_type + Ctype.match_class_declarations env cty1.clty_params cty1.clty_type cty2.clty_params cty2.clty_type let class_declarations env cty1 cty2 = - match cty1.cty_new, cty2.cty_new with - None, Some _ -> - [Ctype.CM_Virtual_class] + match (cty1.cty_new, cty2.cty_new) with + | None, Some _ -> [Ctype.CM_Virtual_class] | _ -> - Ctype.match_class_declarations env - cty1.cty_params cty1.cty_type - cty2.cty_params cty2.cty_type + Ctype.match_class_declarations env cty1.cty_params cty1.cty_type + cty2.cty_params cty2.cty_type open Format open Ctype @@ -49,68 +42,65 @@ let rec hide_params = function | cty -> cty *) -let include_err ppf = - function +let include_err ppf = function | CM_Virtual_class -> - fprintf ppf "A class cannot be changed from virtual to concrete" + fprintf ppf "A class cannot be changed from virtual to concrete" | CM_Parameter_arity_mismatch _ -> - fprintf ppf - "The classes do not have the same number of type parameters" + fprintf ppf "The classes do not have the same number of type parameters" | CM_Type_parameter_mismatch (env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "A type parameter has type") - (function ppf -> - fprintf ppf "but is expected to have type") + Printtyp.report_unification_error ppf env ~unif:false trace + (function + | ppf -> fprintf ppf "A type parameter has type") + (function + | ppf -> fprintf ppf "but is expected to have type") | CM_Class_type_mismatch (env, cty1, cty2) -> - Printtyp.wrap_printing_env env (fun () -> - fprintf ppf - "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]" - Printtyp.class_type cty1 - "is not matched by the class type" + Printtyp.wrap_printing_env env (fun () -> + fprintf ppf "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]" + Printtyp.class_type cty1 "is not matched by the class type" Printtyp.class_type cty2) | CM_Parameter_mismatch (env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "A parameter has type") - (function ppf -> - fprintf ppf "but is expected to have type") + Printtyp.report_unification_error ppf env ~unif:false trace + (function + | ppf -> fprintf ppf "A parameter has type") + (function + | ppf -> fprintf ppf "but is expected to have type") | CM_Val_type_mismatch (lab, env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "The instance variable %s@ has type" lab) - (function ppf -> - fprintf ppf "but is expected to have type") + Printtyp.report_unification_error ppf env ~unif:false trace + (function + | ppf -> fprintf ppf "The instance variable %s@ has type" lab) + (function + | ppf -> fprintf ppf "but is expected to have type") | CM_Meth_type_mismatch (lab, env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "The method %s@ has type" lab) - (function ppf -> - fprintf ppf "but is expected to have type") + Printtyp.report_unification_error ppf env ~unif:false trace + (function + | ppf -> fprintf ppf "The method %s@ has type" lab) + (function + | ppf -> fprintf ppf "but is expected to have type") | CM_Non_mutable_value lab -> - fprintf ppf - "@[The non-mutable instance variable %s cannot become mutable@]" lab + fprintf ppf "@[The non-mutable instance variable %s cannot become mutable@]" + lab | CM_Non_concrete_value lab -> - fprintf ppf - "@[The virtual instance variable %s cannot become concrete@]" lab + fprintf ppf "@[The virtual instance variable %s cannot become concrete@]" + lab | CM_Missing_value lab -> - fprintf ppf "@[The first class type has no instance variable %s@]" lab + fprintf ppf "@[The first class type has no instance variable %s@]" lab | CM_Missing_method lab -> - fprintf ppf "@[The first class type has no field %s@]" lab + fprintf ppf "@[The first class type has no field %s@]" lab | CM_Hide_public lab -> - fprintf ppf "@[The public method %s cannot be hidden@]" lab + fprintf ppf "@[The public method %s cannot be hidden@]" lab | CM_Hide_virtual (k, lab) -> - fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab + fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab | CM_Public_method lab -> - fprintf ppf "@[The public method %s cannot become private" lab + fprintf ppf "@[The public method %s cannot become private" lab | CM_Virtual_method lab -> - fprintf ppf "@[The virtual method %s cannot become concrete" lab + fprintf ppf "@[The virtual method %s cannot become concrete" lab | CM_Private_method lab -> - fprintf ppf "The private method %s cannot become public" lab + fprintf ppf "The private method %s cannot become public" lab let report_error ppf = function - | [] -> () + | [] -> () | err :: errs -> - let print_errs ppf errs = - List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in - fprintf ppf "@[%a%a@]" include_err err print_errs errs + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs + in + fprintf ppf "@[%a%a@]" include_err err print_errs errs diff --git a/analysis/vendor/ml/includeclass.mli b/analysis/vendor/ml/includeclass.mli index ebfa97897..b43d1b03f 100644 --- a/analysis/vendor/ml/includeclass.mli +++ b/analysis/vendor/ml/includeclass.mli @@ -19,14 +19,14 @@ open Types open Ctype open Format -val class_types: - Env.t -> class_type -> class_type -> class_match_failure list -val class_type_declarations: +val class_types : Env.t -> class_type -> class_type -> class_match_failure list +val class_type_declarations : loc:Location.t -> - Env.t -> class_type_declaration -> class_type_declaration -> - class_match_failure list -val class_declarations: - Env.t -> class_declaration -> class_declaration -> + Env.t -> + class_type_declaration -> + class_type_declaration -> class_match_failure list +val class_declarations : + Env.t -> class_declaration -> class_declaration -> class_match_failure list -val report_error: formatter -> class_match_failure list -> unit +val report_error : formatter -> class_match_failure list -> unit diff --git a/analysis/vendor/ml/includecore.ml b/analysis/vendor/ml/includecore.ml index af4515be1..cfa1b9e4e 100644 --- a/analysis/vendor/ml/includecore.ml +++ b/analysis/vendor/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,173 +268,204 @@ 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 = - match (decl2.type_kind, decl1.type_unboxed.unboxed, - decl2.type_unboxed.unboxed) 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 = + match + ( decl2.type_kind, + decl1.type_unboxed.unboxed, + decl2.type_unboxed.unboxed ) + 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 - 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] + 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/analysis/vendor/ml/includecore.mli b/analysis/vendor/ml/includecore.mli index 2908a07b3..20ed15063 100644 --- a/analysis/vendor/ml/includecore.mli +++ b/analysis/vendor/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/analysis/vendor/ml/includemod.ml b/analysis/vendor/ml/includemod.ml index 1f7388091..d99f29373 100644 --- a/analysis/vendor/ml/includemod.ml +++ b/analysis/vendor/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 @@ -32,14 +35,19 @@ type symptom = | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of - Ident.t * class_type_declaration * class_type_declaration * - Ctype.class_match_failure list + Ident.t + * class_type_declaration + * class_type_declaration + * Ctype.class_match_failure list | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t | 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 @@ -54,59 +62,56 @@ 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))]) (* Inclusion between class declarations *) let class_type_declarations ~loc ~old_env env cxt subst id decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations ~loc env decl1 decl2 with - [] -> () + | [] -> () | reason -> - raise(Error[cxt, old_env, - Class_type_declarations(id, decl1, decl2, reason)]) - + raise + (Error + [(cxt, old_env, Class_type_declarations (id, decl1, decl2, reason))]) (* 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 = @@ -118,7 +123,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 @@ -134,68 +139,71 @@ let kind_of_field_desc = function | Field_classtype _ -> "class 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(id, d, _) -> (id, d.clty_loc, Field_classtype(Ident.name id)) + | Sig_class_type (id, d, _) -> + (id, d.clty_loc, Field_classtype (Ident.name id)) 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. @@ -203,140 +211,138 @@ 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_class_type(i,_,_) - | Sig_type(i,_,_) -> Ident.name i - | Sig_class () -> 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_class_type (i, _, _) + | Sig_type (i, _, _) -> + Ident.name i + | Sig_class () -> 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. @@ -344,54 +350,48 @@ 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 @@ -400,85 +400,75 @@ 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) + | [] -> [] + | (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 (id1, info1, _), Sig_class_type (_id2, info2, _), _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(id1, info1, _), - Sig_class_type(_id2, info2, _), _pos) :: rem -> - class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2; - comps_rec rem - | _ -> - assert false + class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2; + comps_rec rem + | _ -> 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) @@ -486,10 +476,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 @@ -498,11 +489,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 *) @@ -535,160 +528,157 @@ 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 - | Class_type_declarations(id, d1, d2, reason) -> - fprintf ppf - "@[Class type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]@ %a" - (Printtyp.cltype_declaration id) d1 - (Printtyp.cltype_declaration id) d2 - Includeclass.report_error reason + | 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 + | Class_type_declarations (id, d1, d2, reason) -> + fprintf ppf + "@[Class type declarations do not match:@ %a@;\ + <1 -2>does not match@ %a@]@ %a" + (Printtyp.cltype_declaration id) + d1 + (Printtyp.cltype_declaration id) + d2 Includeclass.report_error reason | 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/analysis/vendor/ml/includemod.mli b/analysis/vendor/ml/includemod.mli index 731baf780..b9a33b2fa 100644 --- a/analysis/vendor/ml/includemod.mli +++ b/analysis/vendor/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 @@ -46,17 +52,22 @@ type symptom = | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of - Ident.t * class_type_declaration * class_type_declaration * - Ctype.class_match_failure list + Ident.t + * class_type_declaration + * class_type_declaration + * Ctype.class_match_failure list | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t | 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/analysis/vendor/ml/lambda.ml b/analysis/vendor/ml/lambda.ml index 96f82c9e2..93fd33bc0 100644 --- a/analysis/vendor/ml/lambda.ml +++ b/analysis/vendor/ml/lambda.ml @@ -13,10 +13,6 @@ (* *) (**************************************************************************) - - - - type compile_time_constant = | Big_endian | Word_size @@ -27,88 +23,87 @@ type compile_time_constant = | Ostype_cygwin | Backend_type -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS - -type record_repr = - | Record_regular - | Record_optional +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 : 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 = @@ -117,31 +112,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) = @@ -153,25 +155,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 @@ -181,15 +181,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 @@ -197,16 +191,12 @@ type primitive = | Pignore | 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 @@ -215,36 +205,65 @@ type primitive = (* Exceptions *) | Praise of raise_kind (* Boolean operations *) - | Psequand | Psequor | Pnot + | Psequand + | Psequor + | Pnot (* 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 | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat | Pfloatcomp of comparison (* 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 (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + | Pstringlength + | Pstringrefu + | Pstringrefs + | Pbyteslength + | Pbytesrefu + | Pbytessetu + | Pbytesrefs + | Pbytessets (* Array operations *) - | Pmakearray of Asttypes.mutable_flag - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets + | Pmakearray of Asttypes.mutable_flag + | Parraylength + | Parrayrefu + | Parraysetu + | Parrayrefs + | Parraysets (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) @@ -256,8 +275,8 @@ type primitive = | Paddbint of boxed_integer | Psubbint of boxed_integer | Pmulbint of boxed_integer - | Pdivbint of { size : boxed_integer; is_safe : is_safe } - | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pdivbint of {size: boxed_integer; is_safe: is_safe} + | Pmodbint of {size: boxed_integer; is_safe: is_safe} | Pandbint of boxed_integer | Porbint of boxed_integer | Pxorbint of boxed_integer @@ -270,34 +289,28 @@ type primitive = | Popaque | Puncurried_apply | Pcreate_extension of string -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge - -and value_kind = - Pgenval - +and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge +and value_kind = Pgenval -and boxed_integer = Primitive.boxed_integer = - Pbigint | Pint32 | Pint64 +and boxed_integer = Primitive.boxed_integer = Pbigint | Pint32 | Pint64 - -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 @@ -309,25 +322,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 @@ -347,54 +354,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 *) (* @@ -407,146 +412,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 @@ -554,90 +554,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 @@ -647,99 +647,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 @@ -747,18 +746,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" @@ -767,30 +772,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/analysis/vendor/ml/lambda.mli b/analysis/vendor/ml/lambda.mli index 1bf6b802f..fbbd412f9 100644 --- a/analysis/vendor/ml/lambda.mli +++ b/analysis/vendor/ml/lambda.mli @@ -27,80 +27,83 @@ type compile_time_constant = | Ostype_cygwin | Backend_type -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 @@ -108,51 +111,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 @@ -164,15 +154,12 @@ type primitive = | Pignore | 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 - - | Pduprecord (* Force lazy values *) | Plazyforce @@ -181,36 +168,65 @@ type primitive = (* Exceptions *) | Praise of raise_kind (* Boolean operations *) - | Psequand | Psequor | Pnot + | Psequand + | Psequor + | Pnot (* 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 | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat | Pfloatcomp of comparison (* 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 (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + | Pstringlength + | Pstringrefu + | Pstringrefs + | Pbyteslength + | Pbytesrefu + | Pbytessetu + | Pbytesrefs + | Pbytessets (* Array operations *) - | Pmakearray of mutable_flag - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets + | Pmakearray of mutable_flag + | Parraylength + | Parrayrefu + | Parraysetu + | Parrayrefs + | Parraysets (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) @@ -223,8 +239,8 @@ type primitive = | Paddbint of boxed_integer | Psubbint of boxed_integer | Pmulbint of boxed_integer - | Pdivbint of { size : boxed_integer; is_safe : is_safe } - | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pdivbint of {size: boxed_integer; is_safe: is_safe} + | Pmodbint of {size: boxed_integer; is_safe: is_safe} | Pandbint of boxed_integer | Porbint of boxed_integer | Pxorbint of boxed_integer @@ -237,40 +253,28 @@ type primitive = | Popaque | Puncurried_apply | Pcreate_extension of string -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 boxed_integer = Primitive.boxed_integer = Pbigint | Pint32 | Pint64 -and boxed_integer = Primitive.boxed_integer = - Pbigint | Pint32 | Pint64 - - -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 @@ -281,23 +285,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 @@ -305,8 +306,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 @@ -317,31 +318,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 @@ -356,29 +356,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 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 iter : (lambda -> unit) -> lambda -> unit +module IdentSet : Set.S with type elt = Ident.t +val free_variables : lambda -> IdentSet.t -val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) +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 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 @@ -394,19 +393,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/analysis/vendor/ml/lexer.mli b/analysis/vendor/ml/lexer.mli index 2388b9b31..de589aa92 100644 --- a/analysis/vendor/ml/lexer.mli +++ b/analysis/vendor/ml/lexer.mli @@ -16,9 +16,8 @@ (* The lexical analyzer *) val init : unit -> unit -val token: Lexing.lexbuf -> Parser.token -val skip_hash_bang: Lexing.lexbuf -> unit - +val token : Lexing.lexbuf -> Parser.token +val skip_hash_bang : Lexing.lexbuf -> unit type error = | Illegal_character of char @@ -29,19 +28,14 @@ type error = | Keyword_as_label of string | Invalid_literal of string | Invalid_directive of string * string option - -;; exception Error of error * Location.t - - -val in_comment : unit -> bool;; -val in_string : unit -> bool;; - +val in_comment : unit -> bool +val in_string : unit -> bool val print_warnings : bool ref -val handle_docstrings: bool ref +val handle_docstrings : bool ref val comments : unit -> (string * Location.t) list val token_with_comments : Lexing.lexbuf -> Parser.token @@ -60,6 +54,3 @@ val set_preprocessor : (unit -> unit) -> ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) -> unit - - - diff --git a/analysis/vendor/ml/location.ml b/analysis/vendor/ml/location.ml index 4ca193cfd..bbf80e8ee 100644 --- a/analysis/vendor/ml/location.ml +++ b/analysis/vendor/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/analysis/vendor/ml/location.mli b/analysis/vendor/ml/location.mli index e0f91d4c5..db4aa270d 100644 --- a/analysis/vendor/ml/location.mli +++ b/analysis/vendor/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/analysis/vendor/ml/longident.ml b/analysis/vendor/ml/longident.ml index acae9a6d3..721a13105 100644 --- a/analysis/vendor/ml/longident.ml +++ b/analysis/vendor/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/analysis/vendor/ml/longident.mli b/analysis/vendor/ml/longident.mli index 4c65fa647..26ed938e8 100644 --- a/analysis/vendor/ml/longident.mli +++ b/analysis/vendor/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/analysis/vendor/ml/matching.ml b/analysis/vendor/ml/matching.ml index ff213fac6..174e5ab26 100644 --- a/analysis/vendor/ml/matching.ml +++ b/analysis/vendor/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,171 +1214,172 @@ 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 is_not_none_bs_primitve : Lambda.primitive = - Pccall - (Primitive.simple ~name:"#is_not_none" ~arity:1 ~alloc:false) + Pccall (Primitive.simple ~name:"#is_not_none" ~arity:1 ~alloc:false) let val_from_option_bs_primitive : Lambda.primitive = - Pccall - (Primitive.simple ~name:"#val_from_option" ~arity:1 ~alloc:true) + Pccall (Primitive.simple ~name:"#val_from_option" ~arity:1 ~alloc:true) let val_from_unnest_option_bs_primitive : Lambda.primitive = - Pccall - (Primitive.simple ~name:"#val_from_unnest_option" ~arity:1 ~alloc:true) + Pccall (Primitive.simple ~name:"#val_from_unnest_option" ~arity:1 ~alloc:true) 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 - !Config.bs_only && - Datarepr.constructor_has_optional_shape cstr + | [] -> 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 !Config.bs_only && 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 - -> val_from_unnest_option_bs_primitive - | _ -> val_from_option_bs_primitive 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 + let from_option = + match p.pat_desc with + | Tpat_construct (_, _, [{pat_type; pat_env}]) + when Typeopt.type_cannot_contain_undefined pat_type pat_env -> + val_from_unnest_option_bs_primitive + | _ -> val_from_option_bs_primitive + 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 @@ -1448,59 +1392,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 "CamlinternalLazy" "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 "CamlinternalLazy" "force" (* inline_lazy_force inlines the beginning of the code of Lazy.force. When the value argument is tagged as: @@ -1512,156 +1452,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 @@ -1680,73 +1627,66 @@ let divide_array ctx pm = let strings_test_threshold = 8 let prim_string_notequal = - Pccall(Primitive.simple - ~name:"caml_string_notequal" - ~arity:2 - ~alloc:false) + Pccall (Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false) let prim_string_compare = - Pccall(Primitive.simple - ~name:"caml_string_compare" - ~arity:2 - ~alloc:false) - -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)) + Pccall (Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false) +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)) (* 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 - (prim_string_notequal, - [arg; Lconst (Const_immstring s)], loc), - k,lam)) + ( Lprim + (prim_string_notequal, [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 - (prim_string_compare, - [arg; Lconst (Const_immstring s)], loc)) + (Lprim (prim_string_compare, [arg; Lconst (Const_immstring s)], loc)) (fun r -> tree_way_test loc r (do_make_string_test_tree loc arg lt delta d) @@ -1754,15 +1694,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 *) @@ -1773,99 +1710,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 @@ -1878,639 +1820,645 @@ 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 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) - arg const_lambda_list + make_test_sequence loc fail + (Pbintcomp (Pint32, Cneq)) + (Pbintcomp (Pint32, Clt)) + arg const_lambda_list | Const_int64 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) - arg const_lambda_list + make_test_sequence loc fail + (Pbintcomp (Pint64, Cneq)) + (Pbintcomp (Pint64, Clt)) + arg const_lambda_list | 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 split_extension_cases tag_lambda_list = let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_extension(path, true) when not !Config.bs_only -> ((path, act) :: consts, nonconsts) - | Cstr_extension(path, _) -> (consts, (path, act) :: nonconsts) - | _ -> assert false in + | [] -> ([], []) + | (cstr, act) :: rem -> ( + let consts, nonconsts = split_rec rem in + match cstr with + | Cstr_extension (path, true) when not !Config.bs_only -> + ((path, act) :: consts, nonconsts) + | Cstr_extension (path, _) -> (consts, (path, act) :: nonconsts) + | _ -> assert false) + in split_rec tag_lambda_list - -let extension_slot_eq = - Pccall (Primitive.simple ~name:"#extension_slot_eq" ~arity:2 ~alloc:false) +let extension_slot_eq = + Pccall (Primitive.simple ~name:"#extension_slot_eq" ~arity:2 ~alloc:false) 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 consts, nonconsts = split_extension_cases tag_lambda_list in let default, consts, nonconsts = match fail with - | None -> - begin match consts, nonconsts with - | _, (_, act)::rem -> act, consts, rem - | (_, act)::rem, _ -> act, rem, nonconsts - | _ -> assert false - end - | Some fail -> fail, consts, nonconsts in + | None -> ( + match (consts, nonconsts) with + | _, (_, act) :: rem -> (act, consts, rem) + | (_, act) :: rem, _ -> (act, rem, nonconsts) + | _ -> assert false) + | Some fail -> (fail, consts, nonconsts) + in let nonconst_lambda = match nonconsts with - [] -> default + | [] -> 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(extension_slot_eq , [Lvar tag; ext], loc), - act, rem)) - nonconsts - default - in - Llet(Alias, Pgenval,tag, arg, tests) + 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 (extension_slot_eq, [Lvar tag; ext], loc), act, rem)) + nonconsts default + in + Llet (Alias, Pgenval, tag, arg, tests) in - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse(Lprim(extension_slot_eq , [arg; ext], loc), - act, rem)) - consts - nonconst_lambda + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path ex_pat.pat_env path in + Lifthenelse (Lprim (extension_slot_eq, [arg; ext], loc), act, rem)) + consts nonconst_lambda 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 !Config.bs_only && Datarepr.constructor_has_optional_shape cstr then - Lprim(is_not_none_bs_primitve , [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 !Config.bs_only && Datarepr.constructor_has_optional_shape cstr + then Lprim (is_not_none_bs_primitve, [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 = - if !Config.bs_only then - Lifthenelse(Lprim (Pccall(Primitive.simple ~name:"#is_poly_var_block" ~arity:1 ~alloc:false), [arg], loc), if_block, if_int) - else - Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) 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 *) + if !Config.bs_only then + Lifthenelse + ( Lprim + ( Pccall + (Primitive.simple ~name:"#is_poly_var_block" ~arity:1 + ~alloc:false), + [arg], + loc ), + if_block, + if_int ) + else Lifthenelse (Lprim (Pisint, [arg], loc), if_int, if_block) + 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 @@ -2529,172 +2477,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) (* @@ -2708,103 +2641,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 -> - compile_no_test - divide_var ctx_rshift repr partial ctx pm - | Tpat_tuple patl -> +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_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 *) @@ -2828,45 +2762,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 @@ -2878,14 +2809,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) @@ -2893,52 +2824,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 @@ -2946,12 +2888,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 @@ -3005,12 +2946,12 @@ let rec map_return f = function | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) | Lifthenelse (lcond, lthen, lelse) -> - Lifthenelse (lcond, map_return f lthen, map_return f lelse) + Lifthenelse (lcond, map_return f lthen, map_return f lelse) | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) | Lstaticcatch (l1, b, l2) -> - Lstaticcatch (map_return f l1, b, map_return f l2) - | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l + Lstaticcatch (map_return f l1, b, map_return f l2) + | (Lstaticraise _ | Lprim (Praise _, _, _)) as l -> l | l -> f l (* The 'opt' reference indicates if the optimization is worthy. @@ -3029,20 +2970,21 @@ let rec map_return f = function *) let assign_pat opt nraise catch_ids loc pat lam = - let rec collect acc pat lam = match pat.pat_desc, lam with - | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> + let rec collect acc pat lam = + match (pat.pat_desc, lam) with + | Tpat_tuple patl, Lprim (Pmakeblock _, lams, _) -> opt := true; List.fold_left2 collect acc patl lams - | Tpat_tuple patl, Lconst(Const_block( _, scl)) -> + | Tpat_tuple patl, Lconst (Const_block (_, scl)) -> opt := true; let collect_const acc pat sc = collect acc pat (Lconst sc) in List.fold_left2 collect_const acc patl scl - | _ -> - (* pattern idents will be bound in staticcatch (let body), so we - refresh them here to guarantee binders uniqueness *) - let pat_ids = pat_bound_idents pat in - let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in - (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc + | _ -> + (* pattern idents will be bound in staticcatch (let body), so we + refresh them here to guarantee binders uniqueness *) + let pat_ids = pat_bound_idents pat in + let fresh_ids = List.map (fun id -> (id, Ident.rename id)) pat_ids in + (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc in (* sublets were accumulated by 'collect' with the leftmost tuple @@ -3057,7 +2999,7 @@ let assign_pat opt nraise catch_ids loc pat lam = let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in let tbl = List.fold_left add_ids Ident.empty rev_sublets in let fresh_var id = Lvar (Ident.find_same id tbl) in - Lstaticraise(nraise, List.map fresh_var catch_ids) + Lstaticraise (nraise, List.map fresh_var catch_ids) in let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in List.fold_left push_sublet exit rev_sublets @@ -3065,21 +3007,21 @@ let assign_pat opt nraise catch_ids loc pat lam = 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) + (* fast path, and keep track of simple bindings to unboxable numbers *) + Llet (Strict, Pgenval, id, param, body) | _ -> - (* Turn off such optimization to reduce diff in the beginning - FIXME*) - if !Config.bs_only then simple_for_let loc param pat body - else + (* Turn off such optimization to reduce diff in the beginning - FIXME*) + if !Config.bs_only then simple_for_let loc param pat body + else let opt = ref false in let nraise = next_raise_count () in let catch_ids = pat_bound_idents pat in let bind = map_return (assign_pat opt nraise catch_ids loc pat) param in - if !opt then Lstaticcatch(bind, (nraise, catch_ids), body) + if !opt then Lstaticcatch (bind, (nraise, catch_ids), body) else simple_for_let loc param pat body (* Handling of tupled functions and matchings *) @@ -3090,149 +3032,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/analysis/vendor/ml/matching.mli b/analysis/vendor/ml/matching.mli index 16fda89bf..4f86b6b04 100644 --- a/analysis/vendor/ml/matching.mli +++ b/analysis/vendor/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/analysis/vendor/ml/mtype.ml b/analysis/vendor/ml/mtype.ml index 74aaeddde..9d2399165 100644 --- a/analysis/vendor/ml/mtype.ml +++ b/analysis/vendor/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,190 +110,192 @@ 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(id, d, rs) -> - Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs) - :: rem' - + | Sig_class_type (id, d, rs) -> + Sig_class_type (id, Ctype.nondep_cltype_declaration env mid d, rs) + :: rem') 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 *) @@ -306,37 +304,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 @@ -349,60 +345,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 = @@ -410,10 +403,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/analysis/vendor/ml/mtype.mli b/analysis/vendor/ml/mtype.mli index 84e870ac6..64198df4b 100644 --- a/analysis/vendor/ml/mtype.mli +++ b/analysis/vendor/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/analysis/vendor/ml/oprint.ml b/analysis/vendor/ml/oprint.ml index a4ee54dd1..24deefb35 100644 --- a/analysis/vendor/ml/oprint.ml +++ b/analysis/vendor/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,138 @@ 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) :: 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_name, ext.oext_args, ext.oext_ret_type) :: 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)] + 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) - | 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) + | 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 +596,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,99 +610,77 @@ 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 - -and print_out_constr ppf (name, tyl,ret_type_opt) = + 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) = 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) + print_out_constr + (ext.oext_name, ext.oext_args, ext.oext_ret_type) 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 @@ -721,51 +694,48 @@ 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) :: 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_name, ext.oext_args, ext.oext_ret_type) :: 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)] + 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/analysis/vendor/ml/oprint.mli b/analysis/vendor/ml/oprint.mli index 7c53634f7..4bdd95ad7 100644 --- a/analysis/vendor/ml/oprint.mli +++ b/analysis/vendor/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/analysis/vendor/ml/outcometree.ml b/analysis/vendor/ml/outcometree.ml index 10bd6535d..46ec8643d 100644 --- a/analysis/vendor/ml/outcometree.ml +++ b/analysis/vendor/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) 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,50 +89,54 @@ 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_private: Asttypes.private_flag } -and out_type_extension = - { otyext_name: string; - otyext_params: string list; - otyext_constructors: (string * out_type list * out_type 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_private: Asttypes.private_flag; +} +and out_type_extension = { + otyext_name: string; + otyext_params: string list; + otyext_constructors: (string * out_type list * out_type 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/analysis/vendor/ml/parmatch.ml b/analysis/vendor/ml/parmatch.ml index 7c9888377..b0485d3aa 100644 --- a/analysis/vendor/ml/parmatch.ml +++ b/analysis/vendor/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,59 +2134,65 @@ 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 -> - List.iter - (fun p -> - Location.prerr_warning - p.pat_loc Warnings.Unused_pat) - ps - | 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 -> + List.iter + (fun p -> Location.prerr_warning p.pat_loc Warnings.Unused_pat) + ps + | 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 @@ -2284,38 +2205,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 *) @@ -2327,15 +2235,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 @@ -2343,10 +2248,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 *) (*************************************) @@ -2393,7 +2298,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) @@ -2401,37 +2306,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 *) @@ -2463,49 +2365,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, @@ -2516,83 +2422,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 @@ -2603,18 +2506,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/analysis/vendor/ml/parmatch.mli b/analysis/vendor/ml/parmatch.mli index e44fb78a7..1213d4783 100644 --- a/analysis/vendor/ml/parmatch.mli +++ b/analysis/vendor/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/analysis/vendor/ml/parse.ml b/analysis/vendor/ml/parse.ml index 7de593c2a..7c6b47310 100644 --- a/analysis/vendor/ml/parse.ml +++ b/analysis/vendor/ml/parse.ml @@ -15,22 +15,24 @@ (* Entry points in the parser *) - let wrap parsing_fun lexbuf = try Docstrings.init (); Lexer.init (); let ast = parsing_fun Lexer.token lexbuf in - Parsing.clear_parser(); + Parsing.clear_parser (); Docstrings.warn_bad_docstrings (); ast - with - | Parsing.Parse_error | Syntaxerr.Escape_error -> - let loc = Location.curr lexbuf in - raise(Syntaxerr.Error(Syntaxerr.Other loc)) + with Parsing.Parse_error | Syntaxerr.Escape_error -> + let loc = Location.curr lexbuf in + raise (Syntaxerr.Error (Syntaxerr.Other loc)) let implementation = wrap Parser.implementation + and interface = wrap Parser.interface + and core_type = wrap Parser.parse_core_type + and expression = wrap Parser.parse_expression + and pattern = wrap Parser.parse_pattern diff --git a/analysis/vendor/ml/parser.mli b/analysis/vendor/ml/parser.mli index fd7969f7b..c079eae2d 100644 --- a/analysis/vendor/ml/parser.mli +++ b/analysis/vendor/ml/parser.mli @@ -10,7 +10,7 @@ type token = | BARBAR | BARRBRACKET | BEGIN - | CHAR of (char) + | CHAR of char | CLASS | COLON | COLONCOLON @@ -41,16 +41,16 @@ type token = | IF | IN | INCLUDE - | INFIXOP0 of (string) - | INFIXOP1 of (string) - | INFIXOP2 of (string) - | INFIXOP3 of (string) - | INFIXOP4 of (string) - | DOTOP of (string) + | INFIXOP0 of string + | INFIXOP1 of string + | INFIXOP2 of string + | INFIXOP3 of string + | INFIXOP4 of string + | DOTOP of string | INHERIT | INITIALIZER | INT of (string * char option) - | LABEL of (string) + | LABEL of string | LAZY | LBRACE | LBRACELESS @@ -63,7 +63,7 @@ type token = | LESS | LESSMINUS | LET - | LIDENT of (string) + | LIDENT of string | LPAREN | LBRACKETAT | LBRACKETATAT @@ -80,13 +80,13 @@ type token = | OBJECT | OF | OPEN - | OPTLABEL of (string) + | OPTLABEL of string | OR | PERCENT | PLUS | PLUSDOT | PLUSEQ - | PREFIXOP of (string) + | PREFIXOP of string | PRIVATE | QUESTION | QUOTE @@ -97,7 +97,7 @@ type token = | SEMI | SEMISEMI | HASH - | HASHOP of (string) + | HASHOP of string | SIG | STAR | STRING of (string * string option) @@ -108,7 +108,7 @@ type token = | TRUE | TRY | TYPE - | UIDENT of (string) + | UIDENT of string | UNDERSCORE | VAL | VIRTUAL @@ -116,16 +116,15 @@ type token = | WHILE | WITH | COMMENT of (string * Location.t) - | DOCSTRING of (Docstrings.docstring) + | DOCSTRING of Docstrings.docstring | EOL val implementation : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.structure -val interface : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.signature + (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.structure +val interface : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.signature val parse_core_type : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.core_type + (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.core_type val parse_expression : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.expression + (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.expression val parse_pattern : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.pattern + (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.pattern diff --git a/analysis/vendor/ml/parsetree.ml b/analysis/vendor/ml/parsetree.ml index f81703e5a..c37ff8824 100644 --- a/analysis/vendor/ml/parsetree.ml +++ b/analysis/vendor/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,347 +31,310 @@ 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) - *) + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string (* T as 'a *) | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) + (* [ `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 a core_type of a Ptyp_object node. - *) + - As the pld_type field of a label_declaration. - | 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; - mutable pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } +and expression = { + pexp_desc: expression_desc; + pexp_loc: Location.t; + mutable 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 * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * label loc (* E # m *) + | Pexp_new of Longident.t loc (* new M.c *) + | Pexp_setinstvar of label loc * expression (* x <- 2 *) | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) + (* {< 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 class_structure - (* object ... end *) - | 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 class_structure (* object ... end *) + | 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 = []) @@ -379,20 +342,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) @@ -403,38 +364,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 @@ -448,108 +404,96 @@ 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 *) -(** {1 Class language} *) - (* Type expressions for the class language *) -and class_type = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } +(** {1 Class language} *) + +and class_type = { + pcty_desc: class_type_desc; + pcty_loc: Location.t; + pcty_attributes: attributes; (* ... [@id1] [@id2] *) +} and class_type_desc = | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) + (* c + ['a1, ..., 'an] c *) + | Pcty_signature of class_signature (* object ... end *) | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension (* [%id] *) | Pcty_open of override_flag * Longident.t loc * class_type - (* let open M in CT *) +(* let open M in CT *) -and class_signature = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } +and class_signature = { + pcsig_self: core_type; + pcsig_fields: class_type_field list; +} (* object('selfpat) ... end object ... end (self = Ptyp_any) - *) +*) -and class_type_field = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +and class_type_field = { + pctf_desc: class_type_field_desc; + pctf_loc: Location.t; + pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) +} and class_type_field_desc = - | Pctf_inherit of class_type - (* inherit CT *) + | Pctf_inherit of class_type (* inherit CT *) | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) + (* val x: T *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a Ptyp_poly. + *) + | Pctf_constraint of (core_type * core_type) (* constraint T1 = T2 *) + | Pctf_attribute of attribute (* [@@@id] *) | Pctf_extension of extension - (* [%%id] *) - -and 'a class_infos = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +(* [%%id] *) + +and 'a class_infos = { + pci_virt: virtual_flag; + pci_params: (core_type * variance) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) +} (* class c = ... class ['a1,...,'an] c = ... class virtual c = ... @@ -557,201 +501,162 @@ and 'a class_infos = Also used for "class type" declaration. *) - - and class_type_declaration = class_type class_infos (* Value expressions for the class language *) - -and class_expr = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } +and class_expr = { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attributes; (* ... [@id1] [@id2] *) +} and class_expr_desc = | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) + (* c + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure (* object ... end *) | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). + (* CE ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). - Invariant: n > 0 - *) + Invariant: n > 0 + *) | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type (* (CE : CT) *) | Pcl_extension of extension (* [%id] *) | Pcl_open of override_flag * Longident.t loc * class_expr - (* let open M in CE *) - +(* let open M in CE *) -and class_structure = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } +and class_structure = {pcstr_self: pattern; pcstr_fields: class_field list} (* object(selfpat) ... end object ... end (self = Ppat_any) - *) +*) -and class_field = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } +and class_field = { + pcf_desc: class_field_desc; + pcf_loc: Location.t; + pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) +} and class_field_desc = | Pcf_inherit of unit - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) + (* val x = E + val virtual x: T + *) | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a Ptyp_poly) + *) + | Pcf_constraint of (core_type * core_type) (* constraint T1 = T2 *) + | Pcf_initializer of expression (* initializer E *) + | Pcf_attribute of attribute (* [@@@id] *) | Pcf_extension of extension - (* [%%id] *) +(* [%%id] *) and class_field_kind = | Cfk_virtual of core_type | Cfk_concrete of override_flag * expression - - +(* 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 - (* class c1 : ... and ... and cn : ... *) + (* 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 (* class c1 : ... and ... and cn : ... *) | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) + (* class type ct1 = ... and ... and ctn = ... *) + | 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 *) @@ -761,100 +666,78 @@ 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 *) + (* 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 class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) + (* class type ct1 = ... and ... and ctn = ... *) + | Pstr_include of include_declaration (* include ME *) + | Pstr_attribute of attribute (* [@@@id] *) | Pstr_extension of extension * attributes - (* [%%id] *) - -and value_binding = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - -and module_binding = - { - pmb_name: string 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/analysis/vendor/ml/path.ml b/analysis/vendor/ml/path.ml index 518938651..d3c78a3b1 100644 --- a/analysis/vendor/ml/path.ml +++ b/analysis/vendor/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/analysis/vendor/ml/path.mli b/analysis/vendor/ml/path.mli index 18491462e..0c24ae12f 100644 --- a/analysis/vendor/ml/path.mli +++ b/analysis/vendor/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/analysis/vendor/ml/pprintast.mli b/analysis/vendor/ml/pprintast.mli index 7da9ee0d1..fb2666458 100644 --- a/analysis/vendor/ml/pprintast.mli +++ b/analysis/vendor/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/analysis/vendor/ml/predef.ml b/analysis/vendor/ml/predef.ml index fb45e343d..35c53951e 100644 --- a/analysis/vendor/ml/predef.ml +++ b/analysis/vendor/ml/predef.ml @@ -30,144 +30,194 @@ 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_bytes = ident_create "bytes" + 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_int64 = ident_create "int64" + 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_floatarray = ident_create "floatarray" 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 = +let type_is_builtin_path_but_option (p : Path.t) : test = match p with | Pident {stamp} -> - if - stamp >= ident_int.stamp - && stamp <= ident_floatarray.stamp - then - if (stamp = ident_option.stamp) - || (stamp = ident_unit.stamp) then - For_sure_no - else For_sure_yes - else NA + if stamp >= ident_int.stamp && stamp <= ident_floatarray.stamp then + if stamp = ident_option.stamp || stamp = ident_unit.stamp then For_sure_no + else For_sure_yes + else NA | _ -> NA let path_int = Pident ident_int + and path_char = Pident ident_char + and path_bytes = Pident ident_bytes + 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_dict = Pident ident_dict and path_int64 = Pident ident_int64 + 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_floatarray = Pident ident_floatarray 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_bytes = newgenty (Tconstr(path_bytes, [], 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_int64 = newgenty (Tconstr(path_int64, [], 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_bytes = newgenty (Tconstr (path_bytes, [], 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_int64 = newgenty (Tconstr (path_int64, [], 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)) -and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil)) + newgenty (Tconstr (path_extension_constructor, [], ref Mnil)) + +and type_floatarray = newgenty (Tconstr (path_floatarray, [], 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_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} @@ -182,163 +232,226 @@ 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 - {decl_abstr with + let tvar = newgenvar () in + { + decl_abstr with type_params = [tvar]; type_arity = 1; - type_variance = [Variance.full]} + type_variance = [Variance.full]; + } 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_extension 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_attributes = + [ + ( { + Asttypes.txt = "ocaml.warn_on_literal_pattern"; + loc = Location.none; + }, + Parsetree.PStr [] ); + ]; + } in add_extension ident_match_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_extension ident_invalid_argument [type_string] ( - add_extension ident_js_error [type_unknown] ( - add_extension ident_failure [type_string] ( - add_extension ident_not_found [] ( - add_extension ident_end_of_file [] ( - add_extension ident_division_by_zero [] ( - add_extension ident_assert_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_extension ident_undefined_recursive_module - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_type ident_int64 decl_abstr ( - 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_floatarray decl_abstr ( - add_type ident_promise decl_promise ( - empty_env)))))))))))))))))))))))))))) + [newgenty (Ttuple [type_string; type_int; type_int])] + (add_extension ident_invalid_argument [type_string] + (add_extension ident_js_error [type_unknown] + (add_extension ident_failure [type_string] + (add_extension ident_not_found [] + (add_extension ident_end_of_file [] + (add_extension ident_division_by_zero [] + (add_extension ident_assert_failure + [newgenty (Ttuple [type_string; type_int; type_int])] + (add_extension ident_undefined_recursive_module + [ + newgenty (Ttuple [type_string; type_int; type_int]); + ] + (add_type ident_int64 decl_abstr + (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_floatarray + 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 res = add_type ident_bytes decl_abstr common in - let decl_type_char = - {decl_abstr with - type_manifest = Some type_int; - type_private = Private} in - add_type ident_char decl_type_char res - - + let res = add_type ident_bytes decl_abstr common in + let decl_type_char = + {decl_abstr with type_manifest = Some type_int; type_private = Private} + in + add_type ident_char decl_type_char res + 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/analysis/vendor/ml/predef.mli b/analysis/vendor/ml/predef.mli index a8049b532..9e3da5077 100644 --- a/analysis/vendor/ml/predef.mli +++ b/analysis/vendor/ml/predef.mli @@ -17,49 +17,49 @@ open Types -val type_int: type_expr -val type_char: type_expr -val type_string: type_expr -val type_bytes: 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_bytes : 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_int64: type_expr -val type_bigint: type_expr -val type_lazy_t: type_expr -> type_expr -val type_extension_constructor:type_expr -val type_floatarray:type_expr +val type_int64 : type_expr +val type_bigint : type_expr +val type_lazy_t : type_expr -> type_expr +val type_extension_constructor : type_expr +val type_floatarray : type_expr -val path_int: Path.t -val path_char: Path.t -val path_string: Path.t -val path_bytes: 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_bytes : 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_int64: Path.t -val path_bigint: Path.t -val path_lazy_t: Path.t -val path_extension_constructor: Path.t -val path_floatarray: Path.t -val path_promise: Path.t -val path_uncurried: Path.t +val path_int64 : Path.t +val path_bigint : Path.t +val path_lazy_t : Path.t +val path_extension_constructor : Path.t +val path_floatarray : 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 @@ -67,27 +67,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/analysis/vendor/ml/primitive.ml b/analysis/vendor/ml/primitive.ml index 0fff0ccc7..e3c3697c6 100644 --- a/analysis/vendor/ml/primitive.ml +++ b/analysis/vendor/ml/primitive.ml @@ -20,46 +20,42 @@ open Parsetree type boxed_integer = Pbigint | Pint32 | Pint64 -type native_repr = - | Same_as_ocaml_repr - -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_native_repr_args: native_repr list; - prim_native_repr_res: native_repr } - -let coerce : (description -> description -> bool) ref = - ref (fun - (p1 : description) (p2 : description) -> - p1 = p2 - ) +type native_repr = Same_as_ocaml_repr +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_native_repr_args: native_repr list; + prim_native_repr_res: native_repr; +} +let coerce : (description -> description -> bool) ref = + ref (fun (p1 : description) (p2 : description) -> p1 = p2) let rec make_native_repr_args arity x = - if arity = 0 then - [] - else - x :: make_native_repr_args (arity - 1) x + if arity = 0 then [] else x :: make_native_repr_args (arity - 1) x let simple ~name ~arity ~alloc = - {prim_name = name; - prim_arity = arity; - prim_alloc = alloc; - prim_native_name = ""; - prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr; - prim_native_repr_res = Same_as_ocaml_repr} + { + prim_name = name; + prim_arity = arity; + prim_alloc = alloc; + prim_native_name = ""; + prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr; + prim_native_repr_res = Same_as_ocaml_repr; + } let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res = - {prim_name = name; - prim_arity = List.length native_repr_args; - prim_alloc = alloc; - prim_native_name = native_name; - prim_native_repr_args = native_repr_args; - prim_native_repr_res = native_repr_res} + { + prim_name = name; + prim_arity = List.length native_repr_args; + prim_alloc = alloc; + prim_native_name = native_name; + prim_native_repr_args = native_repr_args; + prim_native_repr_res = native_repr_res; + } let parse_declaration valdecl ~native_repr_args ~native_repr_res = let arity = List.length native_repr_args in @@ -67,34 +63,27 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res = 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_native_repr_args = native_repr_args; - prim_native_repr_res = native_repr_res} + { + prim_name = name; + prim_arity = arity; + prim_alloc = true; + prim_native_name = native_name; + prim_native_repr_args = native_repr_args; + prim_native_repr_res = native_repr_res; + } 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/analysis/vendor/ml/primitive.mli b/analysis/vendor/ml/primitive.mli index c364c4cc0..42fa1b410 100644 --- a/analysis/vendor/ml/primitive.mli +++ b/analysis/vendor/ml/primitive.mli @@ -19,47 +19,38 @@ type boxed_integer = Pbigint | Pint32 | Pint64 (* Representation of arguments/result for the native code version of a primitive *) -type native_repr = - | Same_as_ocaml_repr +type native_repr = Same_as_ocaml_repr -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_native_repr_args: native_repr list; - prim_native_repr_res: native_repr } +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_native_repr_args: native_repr list; + prim_native_repr_res: native_repr; +} (* 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 - -> native_repr_args: native_repr list - -> native_repr_res: native_repr - -> description +val make : + name:string -> + alloc:bool -> + native_name:string -> + native_repr_args:native_repr list -> + native_repr_res:native_repr -> + description -val parse_declaration - : Parsetree.value_description - -> native_repr_args:native_repr list - -> native_repr_res:native_repr - -> description +val parse_declaration : + Parsetree.value_description -> + native_repr_args:native_repr list -> + native_repr_res:native_repr -> + 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/analysis/vendor/ml/printast.ml b/analysis/vendor/ml/printast.ml index eee7a9051..de42a4a18 100644 --- a/analysis/vendor/ml/printast.ml +++ b/analysis/vendor/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,31 +51,27 @@ 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_virtual_flag f x = match x with - | Virtual -> fprintf f "Virtual"; - | Concrete -> fprintf f "Concrete"; -;; + | Virtual -> fprintf f "Virtual" + | Concrete -> fprintf f "Concrete" 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 @@ -92,104 +80,98 @@ 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 (li, l) -> - line i ppf "Ptyp_class %a\n" fmt_longident_loc li; - list i core_type ppf l + line i ppf "Ptyp_class %a\n" fmt_longident_loc li; + list i core_type ppf l | 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; @@ -198,220 +180,217 @@ 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, cto1, cto2) -> - line i ppf "Pexp_coerce\n"; - expression i ppf e; - option i core_type ppf cto1; - core_type i ppf cto2; + line i ppf "Pexp_coerce\n"; + expression i ppf e; + option i core_type ppf cto1; + 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 s -> - line i ppf "Pexp_object\n"; - class_structure i ppf s + line i ppf "Pexp_object\n"; + class_structure i ppf s | 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 @@ -424,30 +403,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; @@ -455,90 +431,88 @@ 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 class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.pcty_loc; attributes i ppf x.pcty_attributes; - let i = i+1 in + let i = i + 1 in match x.pcty_desc with | Pcty_constr (li, l) -> - line i ppf "Pcty_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Pcty_signature (cs) -> - line i ppf "Pcty_signature\n"; - class_signature i ppf cs; + line i ppf "Pcty_constr %a\n" fmt_longident_loc li; + list i core_type ppf l + | Pcty_signature cs -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs | Pcty_arrow (l, co, cl) -> - line i ppf "Pcty_arrow\n"; - arg_label i ppf l; - core_type i ppf co; - class_type i ppf cl; + line i ppf "Pcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl | Pcty_extension (s, arg) -> - line i ppf "Pcty_extension \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pcty_extension \"%s\"\n" s.txt; + payload i ppf arg | Pcty_open (ovf, m, e) -> - line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; - class_type i ppf e + line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_longident_loc m; + class_type i ppf e and class_signature i ppf cs = line i ppf "class_signature\n"; - core_type (i+1) ppf cs.pcsig_self; - list (i+1) class_type_field ppf cs.pcsig_fields; + core_type (i + 1) ppf cs.pcsig_self; + list (i + 1) class_type_field ppf cs.pcsig_fields and class_type_field i ppf x = line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; - let i = i+1 in + let i = i + 1 in attributes i ppf x.pctf_attributes; match x.pctf_desc with - | Pctf_inherit (ct) -> - line i ppf "Pctf_inherit\n"; - class_type i ppf ct; + | Pctf_inherit ct -> + line i ppf "Pctf_inherit\n"; + class_type i ppf ct | Pctf_val (s, mf, vf, ct) -> - line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; + line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i + 1) ppf ct | Pctf_method (s, pf, vf, ct) -> - line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; + line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i + 1) ppf ct | Pctf_constraint (ct1, ct2) -> - line i ppf "Pctf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; + line i ppf "Pctf_constraint\n"; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 | Pctf_attribute (s, arg) -> - line i ppf "Pctf_attribute \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pctf_attribute \"%s\"\n" s.txt; + payload i ppf arg | Pctf_extension (s, arg) -> - line i ppf "Pctf_extension \"%s\"\n" s.txt; - payload i ppf arg - + line i ppf "Pctf_extension \"%s\"\n" s.txt; + payload i ppf arg and class_type_declaration i ppf x = line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; attributes i ppf x.pci_attributes; - let i = i+1 in + let i = i + 1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; + list (i + 1) type_parameter ppf x.pci_params; line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.pci_expr; + class_type (i + 1) ppf x.pci_expr -and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = +and class_structure i ppf {pcstr_self = p; pcstr_fields = l} = line i ppf "class_structure\n"; - pattern (i+1) ppf p; - list (i+1) class_field ppf l; + pattern (i + 1) ppf p; + list (i + 1) class_field ppf l and class_field i ppf x = line i ppf "class_field %a\n" fmt_location x.pcf_loc; @@ -547,294 +521,289 @@ and class_field i ppf x = match x.pcf_desc with | Pcf_inherit () -> () | Pcf_val (s, mf, k) -> - line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k + line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; + line (i + 1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i + 1) ppf k | Pcf_method (s, pf, k) -> - line i ppf "Pcf_method %a\n" fmt_private_flag pf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k + line i ppf "Pcf_method %a\n" fmt_private_flag pf; + line (i + 1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i + 1) ppf k | Pcf_constraint (ct1, ct2) -> - line i ppf "Pcf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pcf_initializer (e) -> - line i ppf "Pcf_initializer\n"; - expression (i+1) ppf e; + line i ppf "Pcf_constraint\n"; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 + | Pcf_initializer e -> + line i ppf "Pcf_initializer\n"; + expression (i + 1) ppf e | Pcf_attribute (s, arg) -> - line i ppf "Pcf_attribute \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pcf_attribute \"%s\"\n" s.txt; + payload i ppf arg | Pcf_extension (s, arg) -> - line i ppf "Pcf_extension \"%s\"\n" s.txt; - payload i ppf arg + line i ppf "Pcf_extension \"%s\"\n" s.txt; + payload i ppf arg and class_field_kind i ppf = function | Cfk_concrete (o, e) -> - line i ppf "Concrete %a\n" fmt_override_flag o; - expression i ppf e + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e | Cfk_virtual t -> - line i ppf "Virtual\n"; - core_type i ppf t + line i ppf "Virtual\n"; + core_type i ppf t 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 () -> () - | Psig_class_type (l) -> - line i ppf "Psig_class_type\n"; - list i class_type_declaration ppf l; + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_class () -> () + | Psig_class_type l -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l | 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 (l) -> - line i ppf "Pstr_class_type\n"; - list i class_type_declaration ppf l; + | Pstr_class_type l -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf l | 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/analysis/vendor/ml/printast.mli b/analysis/vendor/ml/printast.mli index eb94a3bcb..87da25385 100644 --- a/analysis/vendor/ml/printast.mli +++ b/analysis/vendor/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/analysis/vendor/ml/printlambda.ml b/analysis/vendor/ml/printlambda.ml index 540ab3684..ed28b4755 100644 --- a/analysis/vendor/ml/printlambda.ml +++ b/analysis/vendor/ml/printlambda.ml @@ -18,33 +18,32 @@ 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 boxed_integer_name = function | Pbigint -> "bigint" @@ -55,10 +54,10 @@ 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 print_boxed_integer_conversion ppf bi1 bi2 = fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) @@ -69,10 +68,7 @@ let boxed_integer_mark name = function | Pint64 -> Printf.sprintf "Int64.%s" name let print_boxed_integer name ppf bi = - fprintf ppf "%s" (boxed_integer_mark name bi);; - - - + fprintf ppf "%s" (boxed_integer_mark name bi) let string_of_loc_kind = function | Loc_FILE -> "loc_FILE" @@ -82,43 +78,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 | Puncurried_apply -> fprintf ppf "@app" @@ -129,11 +130,9 @@ 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 @@ -155,14 +154,14 @@ 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 ">=" | 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 "~." @@ -171,12 +170,12 @@ let primitive ppf = function | Psubfloat -> fprintf ppf "-." | Pmulfloat -> fprintf ppf "*." | Pdivfloat -> 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 ">=." + | Pfloatcomp Ceq -> fprintf ppf "==." + | Pfloatcomp Cneq -> fprintf ppf "!=." + | Pfloatcomp Clt -> fprintf ppf "<." + | Pfloatcomp Cle -> fprintf ppf "<=." + | Pfloatcomp Cgt -> fprintf ppf ">." + | Pfloatcomp Cge -> fprintf ppf ">=." | Pnegbigint -> fprintf ppf "~" | Paddbigint -> fprintf ppf "+" | Psubbigint -> fprintf ppf "-" @@ -189,12 +188,12 @@ 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 ">=," | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" @@ -203,25 +202,26 @@ let primitive ppf = function | Pbytessetu -> fprintf ppf "bytes.unsafe_set" | Pbytesrefs -> fprintf ppf "bytes.get" | Pbytessets -> fprintf ppf "bytes.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" + | 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" | Pctconst c -> - let const_name = match c with - | Big_endian -> "big_endian" - | Word_size -> "word_size" - | Int_size -> "int_size" - | Max_wosize -> "max_wosize" - | Ostype_unix -> "ostype_unix" - | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" - | Backend_type -> "backend_type" in - fprintf ppf "sys.constant_%s" const_name + let const_name = + match c with + | Big_endian -> "big_endian" + | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" + | Ostype_unix -> "ostype_unix" + | Ostype_win32 -> "ostype_win32" + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" + in + fprintf ppf "sys.constant_%s" const_name | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" | Pbintofint bi -> print_boxed_integer "of_int" ppf bi @@ -231,28 +231,26 @@ let primitive ppf = function | Paddbint bi -> print_boxed_integer "add" ppf bi | Psubbint bi -> print_boxed_integer "sub" ppf bi | Pmulbint bi -> print_boxed_integer "mul" ppf bi - | Pdivbint { size = bi; is_safe = Safe } -> - print_boxed_integer "div" ppf bi - | Pdivbint { size = bi; is_safe = Unsafe } -> - print_boxed_integer "div_unsafe" ppf bi - | Pmodbint { size = bi; is_safe = Safe } -> - print_boxed_integer "mod" ppf bi - | Pmodbint { size = bi; is_safe = Unsafe } -> - print_boxed_integer "mod_unsafe" ppf bi + | Pdivbint {size = bi; is_safe = Safe} -> print_boxed_integer "div" ppf bi + | Pdivbint {size = bi; is_safe = Unsafe} -> + print_boxed_integer "div_unsafe" ppf bi + | Pmodbint {size = bi; is_safe = Safe} -> print_boxed_integer "mod" ppf bi + | Pmodbint {size = bi; is_safe = Unsafe} -> + print_boxed_integer "mod_unsafe" ppf bi | Pandbint bi -> print_boxed_integer "and" ppf bi | Porbint bi -> print_boxed_integer "or" ppf bi | Pxorbint bi -> print_boxed_integer "xor" ppf bi | Plslbint bi -> print_boxed_integer "lsl" ppf bi | Plsrbint bi -> print_boxed_integer "lsr" ppf bi | Pasrbint bi -> print_boxed_integer "asr" ppf bi - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi - | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi + | Pbintcomp (bi, Ceq) -> print_boxed_integer "==" ppf bi + | Pbintcomp (bi, Cneq) -> print_boxed_integer "!=" ppf bi + | Pbintcomp (bi, Clt) -> print_boxed_integer "<" ppf bi + | Pbintcomp (bi, Cgt) -> print_boxed_integer ">" ppf bi + | Pbintcomp (bi, Cle) -> print_boxed_integer "<=" ppf bi + | Pbintcomp (bi, Cge) -> print_boxed_integer ">=" ppf bi | Popaque -> fprintf ppf "opaque" - | Pcreate_extension s -> fprintf ppf "extension[%s]" s + | Pcreate_extension s -> fprintf ppf "extension[%s]" s let name_of_primitive = function | Puncurried_apply -> "Puncurried_apply" | Pidentity -> "Pidentity" @@ -265,7 +263,7 @@ let name_of_primitive = function | Pmakeblock _ -> "Pmakeblock" | Pfield _ -> "Pfield" | Psetfield _ -> "Psetfield" - | Pduprecord -> "Pduprecord" + | Pduprecord -> "Pduprecord" | Plazyforce -> "Plazyforce" | Pccall _ -> "Pccall" | Praise _ -> "Praise" @@ -318,7 +316,7 @@ let name_of_primitive = function | Pbytesrefs -> "Pbytesrefs" | Pbytessets -> "Pbytessets" | Parraylength -> "Parraylength" - | Pmakearray _-> "Pmakearray" + | Pmakearray _ -> "Pmakearray" | Parrayrefu -> "Parrayrefu" | Parraysetu -> "Parraysetu" | Parrayrefs -> "Parrayrefs" @@ -345,150 +343,135 @@ let name_of_primitive = function | Popaque -> "Popaque" | Pcreate_extension _ -> "Pcreate_extension" -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/analysis/vendor/ml/printlambda.mli b/analysis/vendor/ml/printlambda.mli index d9d242079..ce476d311 100644 --- a/analysis/vendor/ml/printlambda.mli +++ b/analysis/vendor/ml/printlambda.mli @@ -17,9 +17,9 @@ 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 -val primitive: formatter -> primitive -> unit +val primitive : formatter -> primitive -> unit val name_of_primitive : primitive -> string val value_kind : value_kind -> string diff --git a/analysis/vendor/ml/printtyp.ml b/analysis/vendor/ml/printtyp.ml index 38fe28a7e..0c8516091 100644 --- a/analysis/vendor/ml/printtyp.ml +++ b/analysis/vendor/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 *) @@ -54,40 +55,35 @@ let ident_pervasives = Ident.create_persistent "Pervasives" let ident_pervasives_u = Ident.create_persistent "PervasivesU" let printing_env = ref Env.empty let non_shadowed_pervasive = function - | Pdot(Pident id, s, _pos) as path -> - (Ident.same id ident_pervasives || Ident.same id ident_pervasives_u) && - (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 || Ident.same id ident_pervasives_u) + && + 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) @@ -101,129 +97,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 @@ -232,20 +222,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 @@ -255,62 +245,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 @@ -318,9 +302,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 (); @@ -330,69 +314,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''; *) @@ -408,12 +397,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 = @@ -423,10 +414,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 @@ -434,241 +426,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 *) @@ -677,107 +663,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 = @@ -788,28 +776,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; @@ -818,102 +806,93 @@ 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 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 -> - 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 + ( 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 - { otype_name = name; - otype_params = args; - otype_type = ty; - otype_private = priv; - otype_immediate = immediate; - otype_unboxed = decl.type_unboxed.unboxed; - 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; + 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 @@ -921,18 +900,24 @@ and tree_of_constructor cd = match cd.cd_res with | None -> (name, arg (), None) | 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) + let nm = !names in + names := []; + let ret = tree_of_typexp false res in + let args = arg () in + names := nm; + (name, args, Some ret) 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 = @@ -956,8 +941,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 @@ -969,28 +953,30 @@ 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_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) @@ -1002,10 +988,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 @@ -1020,99 +1003,90 @@ let value_description id ppf decl = (* Print a class type *) let method_type (_, kind, ty) = - match field_kind_repr kind, repr ty with - Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) - | _ , ty -> (ty, []) + match (field_kind_repr kind, repr ty) with + | Fpresent, {desc = Tpoly (ty, tyl)} -> (ty, tyl) + | _, ty -> (ty, []) let tree_of_metho sch concrete csil (lab, kind, ty) = - if lab <> dummy_method then begin + if lab <> dummy_method then ( let kind = field_kind_repr kind in let priv = kind <> Fpresent in let virt = not (Concr.mem lab concrete) in - let (ty, tyl) = method_type (lab, kind, ty) in + let ty, tyl = method_type (lab, kind, ty) in let tty = tree_of_typexp sch ty in remove_names tyl; - Ocsg_method (lab, priv, virt, tty) :: csil - end + Ocsg_method (lab, priv, virt, tty) :: csil) else csil let rec prepare_class_type params = function | Cty_constr (_p, tyl, cty) -> - let sty = Ctype.self_type cty in - if List.memq (proxy sty) !visited_objects - || not (List.for_all is_Tvar params) + let sty = Ctype.self_type cty in + if + List.memq (proxy sty) !visited_objects + || (not (List.for_all is_Tvar params)) || List.exists (deep_occur sty) tyl - then prepare_class_type params cty - else List.iter mark_loops tyl + then prepare_class_type params cty + else List.iter mark_loops tyl | Cty_signature sign -> - let sty = repr sign.csig_self in - (* Self may have a name *) - let px = proxy sty in - if List.memq px !visited_objects then add_alias sty - else visited_objects := px :: !visited_objects; - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in - List.iter (fun met -> mark_loops (fst (method_type met))) fields; - Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars + let sty = repr sign.csig_self in + (* Self may have a name *) + let px = proxy sty in + if List.memq px !visited_objects then add_alias sty + else visited_objects := px :: !visited_objects; + let fields, _ = Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in + List.iter (fun met -> mark_loops (fst (method_type met))) fields; + Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars | Cty_arrow (_, ty, cty) -> - mark_loops ty; - prepare_class_type params cty + mark_loops ty; + prepare_class_type params cty -let rec tree_of_class_type sch params = - function +let rec tree_of_class_type sch params = function | Cty_constr (p', tyl, cty) -> - let sty = Ctype.self_type cty in - if List.memq (proxy sty) !visited_objects + let sty = Ctype.self_type cty in + if + List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) - then - tree_of_class_type sch params cty - else - Octy_constr (tree_of_path p', tree_of_typlist true tyl) + then tree_of_class_type sch params cty + else Octy_constr (tree_of_path p', tree_of_typlist true tyl) | Cty_signature sign -> - let sty = repr sign.csig_self in - let self_ty = - if is_aliased sty then - Some (Otyp_var (false, name_of_type new_name (proxy sty))) - else None - in - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in - let csil = [] in - let csil = - List.fold_left - (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) - csil (tree_of_constraints params) - in - let all_vars = - Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] - in - (* Consequence of PR#3607: order of Map.fold has changed! *) - let all_vars = List.rev all_vars in - let csil = - List.fold_left - (fun csil (l, m, v, t) -> - Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) - :: csil) - csil all_vars - in - let csil = - List.fold_left (tree_of_metho sch sign.csig_concr) csil fields - in - Octy_signature (self_ty, List.rev csil) + let sty = repr sign.csig_self in + let self_ty = + if is_aliased sty then + Some (Otyp_var (false, name_of_type new_name (proxy sty))) + else None + in + let fields, _ = Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in + let csil = [] in + let csil = + List.fold_left + (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) + csil + (tree_of_constraints params) + in + let all_vars = + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] + in + (* Consequence of PR#3607: order of Map.fold has changed! *) + let all_vars = List.rev all_vars in + let csil = + List.fold_left + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) :: csil) + csil all_vars + in + let csil = List.fold_left (tree_of_metho sch sign.csig_concr) csil fields in + Octy_signature (self_ty, List.rev csil) | Cty_arrow (l, ty, cty) -> - let lab = - string_of_label l - in - let ty = - if is_optional l then - match (repr ty).desc with - | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty - | _ -> newconstr (Path.Pident(Ident.create "")) [] - else ty in - let tr = tree_of_typexp sch ty in - Octy_arrow (lab, tr, tree_of_class_type sch params cty) + let lab = string_of_label l in + let ty = + if is_optional l then + match (repr ty).desc with + | Tconstr (path, [ty], _) when Path.same path Predef.path_option -> ty + | _ -> newconstr (Path.Pident (Ident.create "")) [] + else ty + in + let tr = tree_of_typexp sch ty in + Octy_arrow (lab, tr, tree_of_class_type sch params cty) let class_type ppf cty = reset (); @@ -1120,13 +1094,12 @@ let class_type ppf cty = !Oprint.out_class_type ppf (tree_of_class_type false [] cty) let tree_of_class_param param variance = - (match tree_of_typexp true param with - Otyp_var (_, s) -> s - | _ -> "?"), - if is_Tvar (repr param) then (true, true) else variance + ( (match tree_of_typexp true param with + | Otyp_var (_, s) -> s + | _ -> "?"), + if is_Tvar (repr param) then (true, true) else variance ) -let class_variance = - List.map Variance.(fun v -> mem May_pos v, mem May_neg v) +let class_variance = List.map Variance.(fun v -> (mem May_pos v, mem May_neg v)) let tree_of_class_declaration id cl rs = let params = filter_params cl.cty_params in @@ -1142,10 +1115,11 @@ let tree_of_class_declaration id cl rs = let vir_flag = cl.cty_new = None in Osig_class - (vir_flag, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.cty_variance), - tree_of_class_type true params cl.cty_type, - tree_of_rec rs) + ( vir_flag, + Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.cty_variance), + tree_of_class_type true params cl.cty_type, + tree_of_rec rs ) let class_declaration id ppf cl = !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) @@ -1165,20 +1139,20 @@ let tree_of_cltype_declaration id cl rs = let sign = Ctype.signature_of_class_type cl.clty_type in let virt = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in + let fields, _ = Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in List.exists (fun (lab, _, _) -> - not (lab = dummy_method || Concr.mem lab sign.csig_concr)) + not (lab = dummy_method || Concr.mem lab sign.csig_concr)) fields - || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false + || Vars.fold (fun _ (_, vr, _) b -> vr = Virtual || b) sign.csig_vars false in Osig_class_type - (virt, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.clty_variance), - tree_of_class_type true params cl.clty_type, - tree_of_rec rs) + ( virt, + Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type true params cl.clty_type, + tree_of_rec rs ) let cltype_declaration id ppf cl = !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) @@ -1193,94 +1167,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(id, decl, rs) -> - [tree_of_cltype_declaration id decl rs] + | 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 (id, decl, rs) -> [tree_of_cltype_declaration id decl rs] and tree_of_modtype_declaration id decl = let mty = @@ -1301,28 +1277,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) *) @@ -1330,74 +1304,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') = @@ -1408,140 +1381,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 = @@ -1551,43 +1524,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; @@ -1598,103 +1559,84 @@ 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 unif tr txt1 ppf txt2 = begin +let super_unification_error 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\ - @]" - txt1 (super_type_expansion ~tag:"error" t1) t1' - txt2 (super_type_expansion ~tag:"info" t2) t2' - super_trace tr - (explanation unif mis); - with exn -> - raise exn -end - -let super_report_unification_error ppf env ?(unif=true) - tr txt1 txt2 = - wrap_printing_env env (fun () -> super_unification_error unif tr txt1 ppf txt2) -;; - + fprintf ppf "@[@[%t@ %a@]@,@[%t@ %a@]%a%t@]" txt1 + (super_type_expansion ~tag:"error" t1) + t1' txt2 + (super_type_expansion ~tag:"info" t2) + t2' super_trace tr (explanation unif mis) + with exn -> raise exn) + +let super_report_unification_error ppf env ?(unif = true) tr txt1 txt2 = + wrap_printing_env env (fun () -> + super_unification_error 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/analysis/vendor/ml/printtyp.mli b/analysis/vendor/ml/printtyp.mli index af92ffa01..abd43b77e 100644 --- a/analysis/vendor/ml/printtyp.mli +++ b/analysis/vendor/ml/printtyp.mli @@ -19,81 +19,100 @@ 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 class_type: formatter -> class_type -> unit -val tree_of_class_declaration: - Ident.t -> class_declaration -> rec_status -> out_sig_item -val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: - Ident.t -> class_type_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> class_type_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: - 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 class_type : formatter -> class_type -> unit +val tree_of_class_declaration : + Ident.t -> class_declaration -> rec_status -> out_sig_item +val class_declaration : Ident.t -> formatter -> class_declaration -> unit +val tree_of_cltype_declaration : + Ident.t -> class_type_declaration -> rec_status -> out_sig_item +val cltype_declaration : Ident.t -> formatter -> class_type_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 : + 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/analysis/vendor/ml/printtyped.ml b/analysis/vendor/ml/printtyped.ml index e38d17d2d..daf95ddb5 100644 --- a/analysis/vendor/ml/printtyped.ml +++ b/analysis/vendor/ml/printtyped.ml @@ -13,78 +13,69 @@ (* *) (**************************************************************************) -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_virtual_flag f x = match x with - | Virtual -> fprintf f "Virtual"; - | Concrete -> fprintf f "Concrete"; -;; + | Virtual -> fprintf f "Virtual" + | Concrete -> fprintf f "Concrete" 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 @@ -93,63 +84,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 -> @@ -163,57 +146,58 @@ 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 (li, _, l) -> - line i ppf "Ttyp_class %a\n" fmt_path li; - list i core_type ppf l; + line i ppf "Ttyp_class %a\n" fmt_path li; + list i core_type ppf l | 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; @@ -222,239 +206,234 @@ 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 (cto1, cto2) -> - line i ppf "Texp_coerce\n"; - attributes i ppf attrs; - option i core_type ppf cto1; - core_type i ppf cto2; + line i ppf "Texp_coerce\n"; + attributes i ppf attrs; + option i core_type ppf cto1; + 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; @@ -462,157 +441,153 @@ 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 class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.cltyp_loc; attributes i ppf x.cltyp_attributes; - let i = i+1 in + let i = i + 1 in match x.cltyp_desc with | Tcty_constr (li, _, l) -> - line i ppf "Tcty_constr %a\n" fmt_path li; - list i core_type ppf l; - | Tcty_signature (cs) -> - line i ppf "Tcty_signature\n"; - class_signature i ppf cs; + line i ppf "Tcty_constr %a\n" fmt_path li; + list i core_type ppf l + | Tcty_signature cs -> + line i ppf "Tcty_signature\n"; + class_signature i ppf cs | Tcty_arrow (l, co, cl) -> - line i ppf "Tcty_arrow\n"; - arg_label i ppf l; - core_type i ppf co; - class_type i ppf cl; + line i ppf "Tcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl | Tcty_open (ovf, m, _, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; - class_type i ppf e + line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + class_type i ppf e -and class_signature i ppf { csig_self = ct; csig_fields = l } = +and class_signature i ppf {csig_self = ct; csig_fields = l} = line i ppf "class_signature\n"; - core_type (i+1) ppf ct; - list (i+1) class_type_field ppf l; + core_type (i + 1) ppf ct; + list (i + 1) class_type_field ppf l and class_type_field i ppf x = line i ppf "class_type_field %a\n" fmt_location x.ctf_loc; - let i = i+1 in + let i = i + 1 in attributes i ppf x.ctf_attributes; match x.ctf_desc with - | Tctf_inherit (ct) -> - line i ppf "Tctf_inherit\n"; - class_type i ppf ct; + | Tctf_inherit ct -> + line i ppf "Tctf_inherit\n"; + class_type i ppf ct | Tctf_val (s, mf, vf, ct) -> - line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; + line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_virtual_flag + vf; + core_type (i + 1) ppf ct | Tctf_method (s, pf, vf, ct) -> - line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; + line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i + 1) ppf ct | Tctf_constraint (ct1, ct2) -> - line i ppf "Tctf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; + line i ppf "Tctf_constraint\n"; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 | Tctf_attribute (s, arg) -> - line i ppf "Tctf_attribute \"%s\"\n" s.txt; - Printast.payload i ppf arg - + line i ppf "Tctf_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg and class_type_declaration i ppf x = line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; - let i = i+1 in + let i = i + 1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.ci_params; + list (i + 1) type_parameter ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.ci_expr; - + class_type (i + 1) ppf x.ci_expr 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 (l) -> - line i ppf "Tsig_class_type\n"; - list i class_type_declaration ppf l; + line i ppf "Tsig_include\n"; + attributes i ppf incl.incl_attributes; + module_type i ppf incl.incl_mod + | Tsig_class () -> () + | Tsig_class_type l -> + line i ppf "Tsig_class_type\n"; + list i class_type_declaration ppf l | 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" @@ -620,167 +595,166 @@ 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 (l) -> - line i ppf "Tstr_class_type\n"; - list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); + | Tstr_class_type l -> + line i ppf "Tstr_class_type\n"; + list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l) | 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/analysis/vendor/ml/printtyped.mli b/analysis/vendor/ml/printtyped.mli index ded42bb32..11837f15e 100644 --- a/analysis/vendor/ml/printtyped.mli +++ b/analysis/vendor/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/analysis/vendor/ml/rec_check.ml b/analysis/vendor/ml/rec_check.ml index 161afcdd5..6942a0edb 100644 --- a/analysis/vendor/ml/rec_check.ml +++ b/analysis/vendor/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 = "%makemutable"; prim_arity = 1 }; + Types.Val_prim {Primitive.prim_name = "%makemutable"; prim_arity = 1}; } -> - true + true | _ -> false type sd = Static | Dynamic @@ -187,98 +189,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 @@ -286,16 +286,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 @@ -317,7 +317,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 @@ -345,13 +345,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) @@ -361,14 +361,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' *) @@ -384,38 +384,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 @@ -434,7 +434,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 = @@ -442,31 +442,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/analysis/vendor/ml/rec_check.mli b/analysis/vendor/ml/rec_check.mli index f37e89145..28469fa59 100644 --- a/analysis/vendor/ml/rec_check.mli +++ b/analysis/vendor/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/analysis/vendor/ml/record_coercion.ml b/analysis/vendor/ml/record_coercion.ml index 338749e52..9a0c4eb74 100644 --- a/analysis/vendor/ml/record_coercion.ml +++ b/analysis/vendor/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/analysis/vendor/ml/record_type_spread.ml b/analysis/vendor/ml/record_type_spread.ml index 76cc710f6..73c283b60 100644 --- a/analysis/vendor/ml/record_type_spread.ml +++ b/analysis/vendor/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/analysis/vendor/ml/rescript_cpp.ml b/analysis/vendor/ml/rescript_cpp.ml index 71938df29..939e64574 100644 --- a/analysis/vendor/ml/rescript_cpp.ml +++ b/analysis/vendor/ml/rescript_cpp.ml @@ -69,17 +69,17 @@ let prepare_pp_error loc = function | Unterminated_else -> Location.errorf ~loc "#else not terminated" | Unexpected_directive -> Location.errorf ~loc "Unexpected directive" | Unexpected_token_in_conditional -> - Location.errorf ~loc "Unexpected token in conditional predicate" + Location.errorf ~loc "Unexpected token in conditional predicate" | Unterminated_paren_in_conditional -> - Location.errorf ~loc "Unterminated parens in conditional predicate" + Location.errorf ~loc "Unterminated parens in conditional predicate" | Expect_hash_then_in_conditional -> - Location.errorf ~loc "Expect `then` after conditional predicate" + Location.errorf ~loc "Expect `then` after conditional predicate" | Conditional_expr_expected_type (a, b) -> - Location.errorf ~loc "Conditional expression type mismatch (%s,%s)" - (string_of_type_directive a) - (string_of_type_directive b) + Location.errorf ~loc "Conditional expression type mismatch (%s,%s)" + (string_of_type_directive a) + (string_of_type_directive b) | Illegal_semver s -> - Location.errorf ~loc "Illegal semantic version string %s" s + Location.errorf ~loc "Illegal semantic version string %s" s let () = Location.register_error_of_exn (function @@ -173,15 +173,15 @@ let semver loc lhs str = let v = String.unsafe_get str 0 in match v with | '>' -> - if last_index = 0 then raise (Pp_error (Illegal_semver str, loc)) - else if String.unsafe_get str 1 = '=' then - (`Ge, semantic_version_parse str 2 last_index) - else (`Gt, semantic_version_parse str 1 last_index) + if last_index = 0 then raise (Pp_error (Illegal_semver str, loc)) + else if String.unsafe_get str 1 = '=' then + (`Ge, semantic_version_parse str 2 last_index) + else (`Gt, semantic_version_parse str 1 last_index) | '<' -> - if last_index = 0 then raise (Pp_error (Illegal_semver str, loc)) - else if String.unsafe_get str 1 = '=' then - (`Le, semantic_version_parse str 2 last_index) - else (`Lt, semantic_version_parse str 1 last_index) + if last_index = 0 then raise (Pp_error (Illegal_semver str, loc)) + else if String.unsafe_get str 1 = '=' then + (`Le, semantic_version_parse str 2 last_index) + else (`Lt, semantic_version_parse str 1 last_index) | '^' -> (`Compatible, semantic_version_parse str 1 last_index) | '~' -> (`Approximate, semantic_version_parse str 1 last_index) | _ -> (`Exact, semantic_version_parse str 0 last_index) @@ -215,24 +215,23 @@ let defined str = | Dir_null -> false | _ -> true | exception _ -> ( - try - ignore @@ Sys.getenv str; - true - with _ -> false) + try + ignore @@ Sys.getenv str; + true + with _ -> false) let query _loc str = match find_directive_built_in_value str with | Dir_null -> Dir_bool false | v -> v | exception Not_found -> ( - match Sys.getenv str with - | v -> ( - try Dir_bool (bool_of_string v) - with _ -> ( - try Dir_int (int_of_string v) - with _ -> ( - try Dir_float (float_of_string v) with _ -> Dir_string v))) - | exception Not_found -> Dir_bool false) + match Sys.getenv str with + | v -> ( + try Dir_bool (bool_of_string v) + with _ -> ( + try Dir_int (int_of_string v) + with _ -> ( try Dir_float (float_of_string v) with _ -> Dir_string v))) + | exception Not_found -> Dir_bool false) let define_key_value key v = if String.length key > 0 && Char.uppercase_ascii key.[0] = key.[0] then ( @@ -267,16 +266,16 @@ let directive_parse (token_with_comments : Lexing.lexbuf -> Parser.token) lexbuf let v = !look_ahead in match v with | Some v -> - look_ahead := None; - v + look_ahead := None; + v | None -> - let rec skip () = - match token_with_comments lexbuf with - | COMMENT _ | DOCSTRING _ -> skip () - | EOF -> raise (Pp_error (Unterminated_if, Location.curr lexbuf)) - | t -> t - in - skip () + let rec skip () = + match token_with_comments lexbuf with + | COMMENT _ | DOCSTRING _ -> skip () + | EOF -> raise (Pp_error (Unterminated_if, Location.curr lexbuf)) + | t -> t + in + skip () in let push e = (* INVARIANT: only look at most one token *) @@ -287,39 +286,39 @@ let directive_parse (token_with_comments : Lexing.lexbuf -> Parser.token) lexbuf match token () with | (LESS | GREATER | INFIXOP0 "<=" | INFIXOP0 ">=" | EQUAL | INFIXOP0 "<>") as op -> - let f = - match op with - | LESS -> ( < ) - | GREATER -> ( > ) - | INFIXOP0 "<=" -> ( <= ) - | EQUAL -> ( = ) - | INFIXOP0 "<>" -> ( <> ) - | _ -> assert false - in + let f = + match op with + | LESS -> ( < ) + | GREATER -> ( > ) + | INFIXOP0 "<=" -> ( <= ) + | EQUAL -> ( = ) + | INFIXOP0 "<>" -> ( <> ) + | _ -> assert false + in + let curr_loc = Location.curr lexbuf in + let rhs = value_of_token curr_loc (token ()) in + (not calc) || f lhs (assert_same_type lexbuf lhs rhs) + | INFIXOP0 "=~" -> ( + (not calc) + || + match lhs with + | Dir_string s -> ( let curr_loc = Location.curr lexbuf in let rhs = value_of_token curr_loc (token ()) in - (not calc) || f lhs (assert_same_type lexbuf lhs rhs) - | INFIXOP0 "=~" -> ( - (not calc) - || - match lhs with - | Dir_string s -> ( - let curr_loc = Location.curr lexbuf in - let rhs = value_of_token curr_loc (token ()) in - match rhs with - | Dir_string rhs -> semver curr_loc s rhs - | _ -> - raise - (Pp_error - ( Conditional_expr_expected_type - (Dir_type_string, type_of_directive lhs), - Location.curr lexbuf ))) + match rhs with + | Dir_string rhs -> semver curr_loc s rhs | _ -> - raise - (Pp_error - ( Conditional_expr_expected_type - (Dir_type_string, type_of_directive lhs), - Location.curr lexbuf ))) + raise + (Pp_error + ( Conditional_expr_expected_type + (Dir_type_string, type_of_directive lhs), + Location.curr lexbuf ))) + | _ -> + raise + (Pp_error + ( Conditional_expr_expected_type + (Dir_type_string, type_of_directive lhs), + Location.curr lexbuf ))) | e -> no e and parse_or calc : bool = parse_or_aux calc (parse_and calc) and (* a || (b || (c || d))*) @@ -327,22 +326,22 @@ let directive_parse (token_with_comments : Lexing.lexbuf -> Parser.token) lexbuf (* let l = v in *) match token () with | BARBAR -> - let b = parse_or (calc && not v) in - v || b + let b = parse_or (calc && not v) in + v || b | e -> - push e; - v + push e; + v and parse_and calc = parse_and_aux calc (parse_relation calc) and parse_and_aux calc v = (* a && (b && (c && d)) *) (* let l = v in *) match token () with | AMPERAMPER -> - let b = parse_and (calc && v) in - v && b + let b = parse_and (calc && v) in + v && b | e -> - push e; - v + push e; + v and parse_relation (calc : bool) : bool = let curr_token = token () in let curr_loc = Location.curr lexbuf in @@ -350,65 +349,62 @@ let directive_parse (token_with_comments : Lexing.lexbuf -> Parser.token) lexbuf | TRUE -> true | FALSE -> false | UIDENT v -> - let value_v = query curr_loc v in - token_op calc - ~no:(fun e -> - push e; - match value_v with - | Dir_bool b -> b - | _ -> - let ty = type_of_directive value_v in - raise - (Pp_error - ( Conditional_expr_expected_type (Dir_type_bool, ty), - curr_loc ))) - value_v - | INT (v, None) -> - let num_v = cvt_int_literal v in - token_op calc - ~no:(fun e -> - push e; - num_v <> 0) - (Dir_int num_v) - | FLOAT (v, None) -> - token_op calc - ~no:(fun _e -> + let value_v = query curr_loc v in + token_op calc + ~no:(fun e -> + push e; + match value_v with + | Dir_bool b -> b + | _ -> + let ty = type_of_directive value_v in raise (Pp_error - ( Conditional_expr_expected_type (Dir_type_bool, Dir_type_float), - curr_loc ))) - (Dir_float (float_of_string v)) + (Conditional_expr_expected_type (Dir_type_bool, ty), curr_loc))) + value_v + | INT (v, None) -> + let num_v = cvt_int_literal v in + token_op calc + ~no:(fun e -> + push e; + num_v <> 0) + (Dir_int num_v) + | FLOAT (v, None) -> + token_op calc + ~no:(fun _e -> + raise + (Pp_error + ( Conditional_expr_expected_type (Dir_type_bool, Dir_type_float), + curr_loc ))) + (Dir_float (float_of_string v)) | STRING (v, _) -> - token_op calc - ~no:(fun _e -> - raise - (Pp_error - ( Conditional_expr_expected_type - (Dir_type_bool, Dir_type_string), - curr_loc ))) - (Dir_string v) + token_op calc + ~no:(fun _e -> + raise + (Pp_error + ( Conditional_expr_expected_type (Dir_type_bool, Dir_type_string), + curr_loc ))) + (Dir_string v) | LIDENT (("defined" | "undefined") as r) -> ( - let t = token () in - let loc = Location.curr lexbuf in - match t with - | UIDENT s -> - (not calc) || if r.[0] = 'u' then not @@ defined s else defined s - | _ -> raise (Pp_error (Unexpected_token_in_conditional, loc))) + let t = token () in + let loc = Location.curr lexbuf in + match t with + | UIDENT s -> + (not calc) || if r.[0] = 'u' then not @@ defined s else defined s + | _ -> raise (Pp_error (Unexpected_token_in_conditional, loc))) | LPAREN -> ( - let v = parse_or calc in - match token () with - | RPAREN -> v - | _ -> - raise - (Pp_error (Unterminated_paren_in_conditional, Location.curr lexbuf)) - ) + let v = parse_or calc in + match token () with + | RPAREN -> v + | _ -> + raise + (Pp_error (Unterminated_paren_in_conditional, Location.curr lexbuf))) | _ -> raise (Pp_error (Unexpected_token_in_conditional, curr_loc)) in let v = parse_or true in match token () with | THEN | EOL -> v | _ -> - raise (Pp_error (Expect_hash_then_in_conditional, Location.curr lexbuf)) + raise (Pp_error (Expect_hash_then_in_conditional, Location.curr lexbuf)) type dir_conditional = Dir_if_true | Dir_if_false | Dir_out @@ -444,15 +440,15 @@ let rec skip_from_if_false (token_with_comments : Lexing.lexbuf -> Parser.token) let token = token_with_comments lexbuf in match token with | END | LIDENT "endif" -> - update_if_then_else Dir_out; - cont lexbuf + update_if_then_else Dir_out; + cont lexbuf | ELSE -> - update_if_then_else Dir_if_false; - cont lexbuf + update_if_then_else Dir_if_false; + cont lexbuf | IF -> raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) | LIDENT "elif" when directive_parse token_with_comments lexbuf -> - update_if_then_else Dir_if_true; - cont lexbuf + update_if_then_else Dir_if_true; + cont lexbuf | _ -> skip_from_if_false token_with_comments cont lexbuf else skip_from_if_false token_with_comments cont lexbuf @@ -462,72 +458,70 @@ let interpret_directive_cont lexbuf ~cont let if_then_else = !if_then_else in match (token_with_comments lexbuf, if_then_else) with | IF, Dir_out -> - if directive_parse token_with_comments lexbuf then ( - update_if_then_else Dir_if_true (* Next state: ELSE *); - cont lexbuf) - else skip_from_if_false token_with_comments cont lexbuf + if directive_parse token_with_comments lexbuf then ( + update_if_then_else Dir_if_true (* Next state: ELSE *); + cont lexbuf) + else skip_from_if_false token_with_comments cont lexbuf | LIDENT (("ifndef" | "ifdef") as s), Dir_out -> - let rec token () = - match token_with_comments lexbuf with - | COMMENT _ | DOCSTRING _ -> token () - | EOF -> raise (Pp_error (Unterminated_if, Location.curr lexbuf)) - | t -> t - in - let t0 = token () in - let t = - match t0 with - | UIDENT t -> t - | _ -> - raise - (Pp_error (Unexpected_token_in_conditional, Location.curr lexbuf)) - in - let t1 = token () in - (match t1 with - | THEN | EOL -> () + let rec token () = + match token_with_comments lexbuf with + | COMMENT _ | DOCSTRING _ -> token () + | EOF -> raise (Pp_error (Unterminated_if, Location.curr lexbuf)) + | t -> t + in + let t0 = token () in + let t = + match t0 with + | UIDENT t -> t | _ -> - raise - (Pp_error (Expect_hash_then_in_conditional, Location.curr lexbuf))); - let boolean = defined t = (s = "ifdef") in - if boolean then ( - update_if_then_else Dir_if_true (* Next state: ELSE *); - cont lexbuf) - else skip_from_if_false token_with_comments cont lexbuf + raise (Pp_error (Unexpected_token_in_conditional, Location.curr lexbuf)) + in + let t1 = token () in + (match t1 with + | THEN | EOL -> () + | _ -> + raise (Pp_error (Expect_hash_then_in_conditional, Location.curr lexbuf))); + let boolean = defined t = (s = "ifdef") in + if boolean then ( + update_if_then_else Dir_if_true (* Next state: ELSE *); + cont lexbuf) + else skip_from_if_false token_with_comments cont lexbuf | (IF | LIDENT "ifndef" | LIDENT "ifdef"), (Dir_if_false | Dir_if_true) -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) | LIDENT "elif", (Dir_if_false | Dir_out) -> - (* when the predicate is false, it will continue eating `elif` *) - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + (* when the predicate is false, it will continue eating `elif` *) + raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) | ((LIDENT "elif" | ELSE) as token), Dir_if_true -> - (* looking for #end, however, it can not see #if anymore, - we need do some validation *) - let rec skip_from_if_true else_seen = + (* looking for #end, however, it can not see #if anymore, + we need do some validation *) + let rec skip_from_if_true else_seen = + let token = token_with_comments lexbuf in + if token = EOF then + raise (Pp_error (Unterminated_else, Location.curr lexbuf)) + else if token = HASH && at_bol lexbuf then let token = token_with_comments lexbuf in - if token = EOF then - raise (Pp_error (Unterminated_else, Location.curr lexbuf)) - else if token = HASH && at_bol lexbuf then - let token = token_with_comments lexbuf in - match token with - | END | LIDENT "endif" -> - update_if_then_else Dir_out; - cont lexbuf - | IF -> raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | ELSE -> - if else_seen then - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - else skip_from_if_true true - | LIDENT "elif" when else_seen -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | _ -> skip_from_if_true else_seen - else skip_from_if_true else_seen - in - skip_from_if_true (token = ELSE) + match token with + | END | LIDENT "endif" -> + update_if_then_else Dir_out; + cont lexbuf + | IF -> raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + | ELSE -> + if else_seen then + raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + else skip_from_if_true true + | LIDENT "elif" when else_seen -> + raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + | _ -> skip_from_if_true else_seen + else skip_from_if_true else_seen + in + skip_from_if_true (token = ELSE) | ELSE, Dir_if_false | ELSE, Dir_out -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) | (END | LIDENT "endif"), (Dir_if_false | Dir_if_true) -> - update_if_then_else Dir_out; - cont lexbuf + update_if_then_else Dir_out; + cont lexbuf | (END | LIDENT "endif"), Dir_out -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) + raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) | token, (Dir_if_true | Dir_if_false | Dir_out) -> look_ahead token let interpret_directive lexbuf ~cont ~token_with_comments : Parser.token = @@ -550,21 +544,21 @@ let check_sharp_look_ahead action : Parser.token = match !sharp_look_ahead with | None -> action () | Some token -> - sharp_look_ahead := None; - token + sharp_look_ahead := None; + token let rec filter_directive ~(token_with_comments : Lexing.lexbuf -> Parser.token) pos acc lexbuf : (int * int) list = match token_with_comments lexbuf with | HASH when at_bol lexbuf -> - (* ^[start_pos]#if ... #then^[end_pos] *) - let start_pos = Lexing.lexeme_start lexbuf in - interpret_directive_cont lexbuf - ~cont:(fun lexbuf -> - filter_directive (Lexing.lexeme_end lexbuf) ~token_with_comments - ((pos, start_pos) :: acc) lexbuf) - ~token_with_comments - (fun _token -> filter_directive pos acc lexbuf ~token_with_comments) + (* ^[start_pos]#if ... #then^[end_pos] *) + let start_pos = Lexing.lexeme_start lexbuf in + interpret_directive_cont lexbuf + ~cont:(fun lexbuf -> + filter_directive (Lexing.lexeme_end lexbuf) ~token_with_comments + ((pos, start_pos) :: acc) lexbuf) + ~token_with_comments + (fun _token -> filter_directive pos acc lexbuf ~token_with_comments) | EOF -> (pos, Lexing.lexeme_end lexbuf) :: acc | _ -> filter_directive ~token_with_comments pos acc lexbuf diff --git a/analysis/vendor/ml/stypes.ml b/analysis/vendor/ml/stypes.ml index 879aef7f4..0584b1693 100644 --- a/analysis/vendor/ml/stypes.ml +++ b/analysis/vendor/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/analysis/vendor/ml/stypes.mli b/analysis/vendor/ml/stypes.mli index 770956c86..3182f7eb9 100644 --- a/analysis/vendor/ml/stypes.mli +++ b/analysis/vendor/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/analysis/vendor/ml/subst.ml b/analysis/vendor/ml/subst.ml index f30b7a1f2..8666afbfd 100644 --- a/analysis/vendor/ml/subst.ml +++ b/analysis/vendor/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,62 +62,55 @@ let remove_loc = {default_mapper with location = (fun _this _loc -> Location.none)} let is_not_doc = function - | ({Location.txt = "ocaml.doc"}, _) -> false - | ({Location.txt = "ocaml.text"}, _) -> false - | ({Location.txt = "doc"}, _) -> false - | ({Location.txt = "text"}, _) -> false + | {Location.txt = "ocaml.doc"}, _ -> false + | {Location.txt = "ocaml.text"}, _ -> false + | {Location.txt = "doc"}, _ -> false + | {Location.txt = "text"}, _ -> false | _ -> true let attrs s x = let x = - if s.for_saving && not !Clflags.keep_docs then - Ext_list.filter x is_not_doc + if s.for_saving && not !Clflags.keep_docs then Ext_list.filter x is_not_doc else x in - if s.for_saving && not !Clflags.keep_locs - then remove_loc.Ast_mapper.attributes remove_loc x - else 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 @@ -131,7 +125,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 @@ -147,102 +141,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' (* @@ -264,10 +268,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 = { @@ -280,23 +282,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; @@ -310,29 +310,30 @@ let type_declaration s decl = decl let class_signature s sign = - { csig_self = typexp s sign.csig_self; + { + csig_self = typexp s sign.csig_self; csig_vars = - Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.csig_vars; + Vars.map + (function + | m, v, t -> (m, v, typexp s t)) + sign.csig_vars; csig_concr = sign.csig_concr; csig_inher = - List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) + List.map + (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) sign.csig_inher; } -let rec class_type s = - function - Cty_constr (p, tyl, cty) -> - Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) - | Cty_signature sign -> - Cty_signature (class_signature s sign) - | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, typexp s ty, class_type s cty) - - +let rec class_type s = function + | Cty_constr (p, tyl, cty) -> + Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) + | Cty_signature sign -> Cty_signature (class_signature s sign) + | Cty_arrow (l, ty, cty) -> Cty_arrow (l, typexp s ty, class_type s cty) let cltype_declaration s decl = let decl = - { clty_params = List.map (typexp s) decl.clty_params; + { + clty_params = List.map (typexp s) decl.clty_params; clty_variance = decl.clty_variance; clty_type = class_type s decl.clty_type; clty_path = type_path s decl.clty_path; @@ -350,88 +351,81 @@ let class_type s cty = cty 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_loc = (if s.for_saving then Location.none else ext.ext_loc); + } 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(id, _, _) :: sg -> - (* cheat and pretend they are types cf. PR#6650 *) - let id' = Ident.rename id in - rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | (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 (id, _, _) :: sg -> + (* cheat and pretend they are types cf. PR#6650 *) + let id' = Ident.rename id in + rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg + | (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(_id, d, rs) -> - Sig_class_type(newid, cltype_declaration s d, rs) + | 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 (_id, d, rs) -> + Sig_class_type (newid, cltype_declaration s d, rs) and module_declaration s decl = { @@ -440,7 +434,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; @@ -450,24 +444,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/analysis/vendor/ml/subst.mli b/analysis/vendor/ml/subst.mli index 3f975b48d..dd5a7644c 100644 --- a/analysis/vendor/ml/subst.mli +++ b/analysis/vendor/ml/subst.mli @@ -31,40 +31,39 @@ 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 class_type: t -> class_type -> class_type -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 class_type : t -> class_type -> class_type +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 cltype_declaration: t -> class_type_declaration -> class_type_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 cltype_declaration : t -> class_type_declaration -> class_type_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 -val class_signature: t -> class_signature -> class_signature +val class_signature : t -> class_signature -> class_signature (* 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/analysis/vendor/ml/switch.ml b/analysis/vendor/ml/switch.ml index a4bab631e..cec708ca3 100644 --- a/analysis/vendor/ml/switch.ml +++ b/analysis/vendor/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,499 +342,419 @@ 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 - - and make_if_ne arg i ifso ifnot = - make_if_test Arg.neint arg i ifso ifnot + if (*true || *) !Config.bs_only then + do_make_if_out (Arg.make_const d) + (Arg.make_offset ctx.arg (-l)) + (mk_ifso ctx) (mk_ifno ctx) + else + Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> + let ctx = {off = -l + ctx.off; arg} in + do_make_if_out (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno + let do_make_if_in h arg ifso ifno = + Arg.make_if (Arg.make_isin 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) + 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) | _ -> - if (*true || *)!Config.bs_only then - do_make_if_out - (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else - Arg.bind + if (*true || *) !Config.bs_only then + do_make_if_in (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_out - (Arg.make_const d) arg (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) - | _ -> - if (*true || *) !Config.bs_only then - do_make_if_in - (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_in - (Arg.make_const d) arg (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 -(* + (mk_ifso ctx) (mk_ifno ctx) + else + Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> + let ctx = {off = -l + ctx.off; arg} in + do_make_if_in (Arg.make_const d) arg (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 + 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_eq - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=inside}) - (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_ne - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=outside}) - (c_test ctx {s with cases=inside}) - end else begin - 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}) - 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 -> - if !Config.bs_only then - Arg.make_switch ~offset:(ll+ctx.off) loc ctx.arg tbl acts sw_names - else - match -ll-ctx.off with - | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names ~offset:0 - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-ll-ctx.off)) - (fun arg -> Arg.make_switch loc arg tbl acts sw_names ~offset:0)) - - -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 -> + if !Config.bs_only then + Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts sw_names + else + match -ll - ctx.off with + | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names ~offset:0 + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-ll - ctx.off)) + (fun arg -> Arg.make_switch loc arg tbl acts sw_names ~offset:0) + + 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/analysis/vendor/ml/switch.mli b/analysis/vendor/ml/switch.mli index a12a1be0b..8edf18a96 100644 --- a/analysis/vendor/ml/switch.mli +++ b/analysis/vendor/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/analysis/vendor/ml/syntaxerr.ml b/analysis/vendor/ml/syntaxerr.ml index 0bb55ab67..6bc31b6ea 100644 --- a/analysis/vendor/ml/syntaxerr.ml +++ b/analysis/vendor/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/analysis/vendor/ml/syntaxerr.mli b/analysis/vendor/ml/syntaxerr.mli index 319eb5794..b737acaaf 100644 --- a/analysis/vendor/ml/syntaxerr.mli +++ b/analysis/vendor/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/analysis/vendor/ml/tast_iterator.ml b/analysis/vendor/ml/tast_iterator.ml index 3fdba16cd..b058778d3 100644 --- a/analysis/vendor/ml/tast_iterator.ml +++ b/analysis/vendor/ml/tast_iterator.ml @@ -17,39 +17,39 @@ open Asttypes open Typedtree type iterator = { - case : iterator -> case -> unit; - cases : iterator -> case list -> unit; - class_description : iterator -> class_description -> unit; - class_signature : iterator -> class_signature -> unit; - class_type : iterator -> class_type -> unit; - class_type_declaration : iterator -> class_type_declaration -> unit; - class_type_field : iterator -> class_type_field -> unit; - env : iterator -> Env.t -> unit; - expr : iterator -> expression -> unit; - extension_constructor : iterator -> extension_constructor -> unit; - module_binding : iterator -> module_binding -> unit; - module_coercion : iterator -> module_coercion -> unit; - module_declaration : iterator -> module_declaration -> unit; - module_expr : iterator -> module_expr -> unit; - module_type : iterator -> module_type -> unit; - module_type_declaration : iterator -> module_type_declaration -> unit; - package_type : iterator -> package_type -> unit; - pat : iterator -> pattern -> unit; - row_field : iterator -> row_field -> unit; - object_field : iterator -> object_field -> unit; - signature : iterator -> signature -> unit; - signature_item : iterator -> signature_item -> unit; - structure : iterator -> structure -> unit; - structure_item : iterator -> structure_item -> unit; - typ : iterator -> core_type -> unit; - type_declaration : iterator -> type_declaration -> unit; - type_declarations : iterator -> rec_flag * type_declaration list -> unit; - type_extension : iterator -> type_extension -> unit; - type_kind : iterator -> type_kind -> unit; - value_binding : iterator -> value_binding -> unit; - value_bindings : iterator -> rec_flag * value_binding list -> unit; - value_description : iterator -> value_description -> unit; - with_constraint : iterator -> with_constraint -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_description: iterator -> class_description -> unit; + class_signature: iterator -> class_signature -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: iterator -> pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> rec_flag * type_declaration list -> unit; + type_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> rec_flag * value_binding list -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; } let structure sub {str_items; str_final_env; _} = @@ -184,7 +184,9 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo | Texp_record {fields; extended_expression; _} -> Array.iter - (function _, Kept _ -> () | _, Overridden (_, exp) -> sub.expr sub exp) + (function + | _, Kept _ -> () + | _, Overridden (_, exp) -> sub.expr sub exp) fields; Option.iter (sub.expr sub) extended_expression | Texp_field (exp, _, _) -> sub.expr sub exp @@ -402,4 +404,4 @@ let default_iterator = value_bindings; value_description; with_constraint; - } \ No newline at end of file + } diff --git a/analysis/vendor/ml/tast_iterator.mli b/analysis/vendor/ml/tast_iterator.mli index 50996527d..474260920 100644 --- a/analysis/vendor/ml/tast_iterator.mli +++ b/analysis/vendor/ml/tast_iterator.mli @@ -20,41 +20,40 @@ Allows the implementation of typed tree inspection using open recursion open Asttypes open Typedtree -type iterator = - { - case: iterator -> case -> unit; - cases: iterator -> case list -> unit; - class_description: iterator -> class_description -> unit; - class_signature: iterator -> class_signature -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; - env: iterator -> Env.t -> unit; - expr: iterator -> expression -> unit; - extension_constructor: iterator -> extension_constructor -> unit; - module_binding: iterator -> module_binding -> unit; - module_coercion: iterator -> module_coercion -> unit; - module_declaration: iterator -> module_declaration -> unit; - module_expr: iterator -> module_expr -> unit; - module_type: iterator -> module_type -> unit; - module_type_declaration: iterator -> module_type_declaration -> unit; - package_type: iterator -> package_type -> unit; - pat: iterator -> pattern -> unit; - row_field: iterator -> row_field -> unit; - object_field: iterator -> object_field -> unit; - signature: iterator -> signature -> unit; - signature_item: iterator -> signature_item -> unit; - structure: iterator -> structure -> unit; - structure_item: iterator -> structure_item -> unit; - typ: iterator -> core_type -> unit; - type_declaration: iterator -> type_declaration -> unit; - type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; - type_extension: iterator -> type_extension -> unit; - type_kind: iterator -> type_kind -> unit; - value_binding: iterator -> value_binding -> unit; - value_bindings: iterator -> (rec_flag * value_binding list) -> unit; - value_description: iterator -> value_description -> unit; - with_constraint: iterator -> with_constraint -> unit; - } +type iterator = { + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_description: iterator -> class_description -> unit; + class_signature: iterator -> class_signature -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: iterator -> pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> rec_flag * type_declaration list -> unit; + type_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> rec_flag * value_binding list -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} -val default_iterator: iterator \ No newline at end of file +val default_iterator : iterator diff --git a/analysis/vendor/ml/tast_mapper.ml b/analysis/vendor/ml/tast_mapper.ml index eaf6aa49e..6381a451f 100644 --- a/analysis/vendor/ml/tast_mapper.ml +++ b/analysis/vendor/ml/tast_mapper.ml @@ -19,53 +19,55 @@ 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; - class_description: mapper -> class_description -> class_description; - - class_signature: mapper -> class_signature -> class_signature; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> - class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - 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; + class_description: mapper -> class_description -> class_description; + class_signature: mapper -> class_signature -> class_signature; + class_type: mapper -> class_type -> class_type; + class_type_declaration: + mapper -> class_type_declaration -> class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + 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} = { @@ -75,9 +77,10 @@ let structure sub {str_items; str_type; str_final_env} = } let class_infos sub f x = - {x with - ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; - ci_expr = f x.ci_expr; + { + x with + ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; + ci_expr = f x.ci_expr; } let module_type_declaration sub x = @@ -90,9 +93,7 @@ let module_declaration sub x = let include_infos f x = {x with incl_mod = f x.incl_mod} -let class_type_declaration sub x = - class_infos sub (sub.class_type sub) x - +let class_type_declaration sub x = class_infos sub (sub.class_type sub) x let structure_item sub {str_desc; str_loc; str_env} = let str_env = sub.env sub str_env in @@ -100,26 +101,25 @@ let structure_item sub {str_desc; str_loc; str_env} = 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 list -> - Tstr_class_type - (List.map (tuple3 id id (sub.class_type_declaration sub)) list) + Tstr_class_type + (List.map (tuple3 id id (sub.class_type_declaration sub)) list) | 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} @@ -148,9 +148,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 @@ -170,35 +168,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 @@ -206,12 +200,11 @@ let pat sub x = let expr sub x = let extra = function - | Texp_constraint cty -> - Texp_constraint (sub.typ sub cty) + | Texp_constraint cty -> Texp_constraint (sub.typ sub cty) | Texp_coerce (cty1, cty2) -> - Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) + Texp_coerce (opt (sub.typ sub) cty1, 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 @@ -219,124 +212,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} @@ -350,79 +288,61 @@ 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_include (include_infos (sub.module_type sub) incl) | Tsig_class_type list -> - Tsig_class_type - (List.map (sub.class_type_declaration sub) list) - | Tsig_class _ - | Tsig_open _ - | Tsig_attribute _ as d -> d + Tsig_class_type (List.map (sub.class_type_declaration sub) list) + | (Tsig_class _ | Tsig_open _ | Tsig_attribute _) as d -> d in {x with sig_desc; sig_env} -let class_description sub x = - class_infos sub (sub.class_type sub) x +let class_description sub x = class_infos sub (sub.class_type sub) x 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 @@ -431,34 +351,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} @@ -466,26 +378,17 @@ let module_binding sub x = let mb_expr = sub.module_expr sub x.mb_expr in {x with mb_expr} - let class_type sub x = let cltyp_env = sub.env sub x.cltyp_env in let cltyp_desc = match x.cltyp_desc with | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg) | Tcty_constr (path, lid, list) -> - Tcty_constr ( - path, - lid, - List.map (sub.typ sub) list - ) + Tcty_constr (path, lid, List.map (sub.typ sub) list) | Tcty_arrow (label, ct, cl) -> - Tcty_arrow - (label, - sub.typ sub ct, - sub.class_type sub cl - ) + Tcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e) + Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e) in {x with cltyp_desc; cltyp_env} @@ -497,14 +400,12 @@ let class_signature sub x = let class_type_field sub x = let ctf_desc = match x.ctf_desc with - | Tctf_inherit ct -> - Tctf_inherit (sub.class_type sub ct) - | Tctf_val (s, mut, virt, ct) -> - Tctf_val (s, mut, virt, sub.typ sub ct) + | Tctf_inherit ct -> Tctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> Tctf_val (s, mut, virt, sub.typ sub ct) | Tctf_method (s, priv, virt, ct) -> - Tctf_method (s, priv, virt, sub.typ sub ct) - | Tctf_constraint (ct1, ct2) -> - Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + Tctf_method (s, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2) | Tctf_attribute _ as d -> d in {x with ctf_desc} @@ -513,50 +414,37 @@ 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 (path, lid, list) -> - Ttyp_class - (path, - lid, - List.map (sub.typ sub) list - ) - | Ttyp_alias (ct, s) -> - Ttyp_alias (sub.typ sub ct, s) + Ttyp_class (path, lid, List.map (sub.typ sub) list) + | 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/analysis/vendor/ml/tast_mapper.mli b/analysis/vendor/ml/tast_mapper.mli index 4fd87b693..3c50e4d2f 100644 --- a/analysis/vendor/ml/tast_mapper.mli +++ b/analysis/vendor/ml/tast_mapper.mli @@ -18,47 +18,47 @@ open Typedtree (** {1 A generic Typedtree mapper} *) -type mapper = - { - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_description: mapper -> class_description -> class_description; - class_signature: mapper -> class_signature -> class_signature; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> - class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - 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; + class_description: mapper -> class_description -> class_description; + class_signature: mapper -> class_signature -> class_signature; + class_type: mapper -> class_type -> class_type; + class_type_declaration: + mapper -> class_type_declaration -> class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + 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/analysis/vendor/ml/tbl.ml b/analysis/vendor/ml/tbl.ml index fa278b43b..d37ba50e7 100644 --- a/analysis/vendor/ml/tbl.ml +++ b/analysis/vendor/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/analysis/vendor/ml/tbl.mli b/analysis/vendor/ml/tbl.mli index d23b959c7..7d9296eb2 100644 --- a/analysis/vendor/ml/tbl.mli +++ b/analysis/vendor/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/analysis/vendor/ml/terminfo.ml b/analysis/vendor/ml/terminfo.ml index 5ed4bb5bc..ea66822de 100644 --- a/analysis/vendor/ml/terminfo.ml +++ b/analysis/vendor/ml/terminfo.ml @@ -15,12 +15,8 @@ (* Basic interface to the terminfo database *) -type status = - | Uninitialised - | Bad_term - | Good_term of int -;; -external setup : out_channel -> status = "caml_terminfo_setup";; -external backup : int -> unit = "caml_terminfo_backup";; -external standout : bool -> unit = "caml_terminfo_standout";; -external resume : int -> unit = "caml_terminfo_resume";; +type status = Uninitialised | Bad_term | Good_term of int +external setup : out_channel -> status = "caml_terminfo_setup" +external backup : int -> unit = "caml_terminfo_backup" +external standout : bool -> unit = "caml_terminfo_standout" +external resume : int -> unit = "caml_terminfo_resume" diff --git a/analysis/vendor/ml/terminfo.mli b/analysis/vendor/ml/terminfo.mli index 92af80f9b..bc3a793d5 100644 --- a/analysis/vendor/ml/terminfo.mli +++ b/analysis/vendor/ml/terminfo.mli @@ -18,9 +18,8 @@ type status = | Uninitialised | Bad_term - | Good_term of int (* number of lines of the terminal *) -;; -external setup : out_channel -> status = "caml_terminfo_setup";; -external backup : int -> unit = "caml_terminfo_backup";; -external standout : bool -> unit = "caml_terminfo_standout";; -external resume : int -> unit = "caml_terminfo_resume";; + | Good_term of int (* number of lines of the terminal *) +external setup : out_channel -> status = "caml_terminfo_setup" +external backup : int -> unit = "caml_terminfo_backup" +external standout : bool -> unit = "caml_terminfo_standout" +external resume : int -> unit = "caml_terminfo_resume" diff --git a/analysis/vendor/ml/transl_recmodule.ml b/analysis/vendor/ml/transl_recmodule.ml index cfef64ec7..102eca421 100644 --- a/analysis/vendor/ml/transl_recmodule.ml +++ b/analysis/vendor/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 @@ -160,18 +159,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, - bs_init_mod [ loc; shape ] Location.none, - bind_inits rem acc ) + Lambda.Llet + ( Strict, + Pgenval, + id, + bs_init_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 = @@ -179,9 +178,8 @@ 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 - ( bs_update_mod [ shape; Lvar id; rhs ] Location.none, - patch_forwards rem ) + Lsequence + (bs_update_mod [shape; Lvar id; rhs] Location.none, patch_forwards rem) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) @@ -192,27 +190,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) = @@ -224,14 +222,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 ]} @@ -262,17 +260,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/analysis/vendor/ml/transl_recmodule.mli b/analysis/vendor/ml/transl_recmodule.mli index a94a41846..826110844 100644 --- a/analysis/vendor/ml/transl_recmodule.mli +++ b/analysis/vendor/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/analysis/vendor/ml/translattribute.ml b/analysis/vendor/ml/translattribute.ml index 5b2f896d8..65916fccc 100644 --- a/analysis/vendor/ml/translattribute.ml +++ b/analysis/vendor/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 (Pccall {prim_name = "#fn_mk" | "#fn_mk_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 ((Pccall {prim_name = "#fn_mk" | "#fn_mk_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/analysis/vendor/ml/translcore.ml b/analysis/vendor/ml/translcore.ml index 0812b1554..352a23c1c 100644 --- a/analysis/vendor/ml/translcore.ml +++ b/analysis/vendor/ml/translcore.ml @@ -50,15 +50,15 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) type specialized = { - gencomp : Lambda.primitive; - intcomp : Lambda.primitive; - boolcomp : Lambda.primitive; - floatcomp : Lambda.primitive; - stringcomp : Lambda.primitive; - bytescomp : Lambda.primitive; - int64comp : Lambda.primitive; - bigintcomp : Lambda.primitive; - simplify_constant_constructor : bool; + gencomp: Lambda.primitive; + intcomp: Lambda.primitive; + boolcomp: Lambda.primitive; + floatcomp: Lambda.primitive; + stringcomp: Lambda.primitive; + bytescomp: Lambda.primitive; + int64comp: Lambda.primitive; + bigintcomp: Lambda.primitive; + simplify_constant_constructor: bool; } let arity2 name : Lambda.primitive = @@ -223,7 +223,8 @@ let comparisons_table = (Primitive.simple ~name:"caml_int64_compare" ~arity:2 ~alloc:false); bigintcomp = Pccall - (Primitive.simple ~name:"caml_bigint_compare" ~arity:2 ~alloc:false); + (Primitive.simple ~name:"caml_bigint_compare" ~arity:2 + ~alloc:false); simplify_constant_constructor = false; } ); ( "%bs_max", @@ -408,8 +409,8 @@ let primitives_table = ("%int64_add", Paddbint Pint64); ("%int64_sub", Psubbint Pint64); ("%int64_mul", Pmulbint Pint64); - ("%int64_div", Pdivbint { size = Pint64; is_safe = Safe }); - ("%int64_mod", Pmodbint { size = Pint64; is_safe = Safe }); + ("%int64_div", Pdivbint {size = Pint64; is_safe = Safe}); + ("%int64_mod", Pmodbint {size = Pint64; is_safe = Safe}); ("%int64_and", Pandbint Pint64); ("%int64_or", Porbint Pint64); ("%int64_xor", Pxorbint Pint64); @@ -429,14 +430,23 @@ let primitives_table = let find_primitive prim_name = Hashtbl.find primitives_table prim_name let specialize_comparison - ({ gencomp; intcomp; floatcomp; stringcomp; bytescomp; int64comp; bigintcomp; boolcomp } : + ({ + gencomp; + intcomp; + floatcomp; + stringcomp; + bytescomp; + int64comp; + 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_bytes -> bytescomp @@ -446,7 +456,7 @@ let specialize_comparison | () -> gencomp (* 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 @@ -465,85 +475,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 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 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)); @@ -571,110 +571,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 = @@ -708,19 +702,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; @@ -728,282 +724,290 @@ 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 arity_s = arity |> string_of_int in - let name = match (Ctype.expand_head expr.exp_env expr.exp_type).desc with + 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 arity_s = arity |> string_of_int in + let name = + 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"}, [], _) -> "#fn_mk_unit" - | _ -> "#fn_mk" - ) - | _ -> "#fn_mk" in - let prim = - Primitive.make ~name ~alloc:true ~native_name:arity_s - ~native_repr_args:[ Same_as_ocaml_repr ] - ~native_repr_res:Same_as_ocaml_repr - in - Lprim - ( Pccall prim - (* could be replaced with Opaque in the future except arity 0*), - [ lambda ], - loc ) + | Tconstr (Pident {name = "unit"}, [], _) -> "#fn_mk_unit" + | _ -> "#fn_mk") + | _ -> "#fn_mk" + in + let prim = + Primitive.make ~name ~alloc:true ~native_name:arity_s + ~native_repr_args:[Same_as_ocaml_repr] + ~native_repr_res:Same_as_ocaml_repr + in + Lprim + ( Pccall 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)) @@ -1015,7 +1019,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 = @@ -1023,13 +1027,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 = @@ -1038,53 +1042,51 @@ 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 funct args = match funct with (* Attention: This may not be what we need to change the application arity*) - | Lapply ap -> Lapply { ap with ap_args = ap.ap_args @ args; ap_loc = loc } + | Lapply ap -> Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} | lexp -> - Lapply - { ap_loc = loc; ap_func = lexp; ap_args = args; ap_inlined = inlined } + Lapply + {ap_loc = loc; ap_func = lexp; ap_args = 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 @@ -1092,29 +1094,34 @@ 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 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 = ref [] in extra_ids := Ident.create "extra" :: !extra_ids; - let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list 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) @@ -1129,207 +1136,209 @@ 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 prim = - Primitive.make ~name:"#fn_mk" ~alloc:true ~native_name:arity_s - ~native_repr_args:[ Same_as_ocaml_repr ] - ~native_repr_res:Same_as_ocaml_repr - in - Lprim - ( Pccall prim - (* 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 prim = + Primitive.make ~name:"#fn_mk" ~alloc:true ~native_name:arity_s + ~native_repr_args:[Same_as_ocaml_repr] + ~native_repr_res:Same_as_ocaml_repr + in + Lprim + ( Pccall prim + (* 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 @@ -1346,25 +1355,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/analysis/vendor/ml/translcore.mli b/analysis/vendor/ml/translcore.mli index eaf38f2f1..1847a4883 100644 --- a/analysis/vendor/ml/translcore.mli +++ b/analysis/vendor/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/analysis/vendor/ml/translmod.ml b/analysis/vendor/ml/translmod.ml index 7fea4909a..60f02bcfc 100644 --- a/analysis/vendor/ml/translmod.ml +++ b/analysis/vendor/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/analysis/vendor/ml/translmod.mli b/analysis/vendor/ml/translmod.mli index af45c84a4..74ef747e1 100644 --- a/analysis/vendor/ml/translmod.mli +++ b/analysis/vendor/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/analysis/vendor/ml/typeclass.ml b/analysis/vendor/ml/typeclass.ml index 00ea7dfcc..52b79eaef 100644 --- a/analysis/vendor/ml/typeclass.ml +++ b/analysis/vendor/ml/typeclass.ml @@ -20,33 +20,33 @@ open Typetexp open Format type 'a class_info = { - cls_id : Ident.t; - cls_id_loc : string loc; - cls_decl : class_declaration; - cls_ty_id : Ident.t; - cls_ty_decl : class_type_declaration; - cls_obj_id : Ident.t; - cls_obj_abbr : type_declaration; - cls_typesharp_id : Ident.t; - cls_abbr : type_declaration; - cls_arity : int; - cls_pub_methods : string list; - cls_info : 'a; + cls_id: Ident.t; + cls_id_loc: string loc; + cls_decl: class_declaration; + cls_ty_id: Ident.t; + cls_ty_decl: class_type_declaration; + cls_obj_id: Ident.t; + cls_obj_abbr: type_declaration; + cls_typesharp_id: Ident.t; + cls_abbr: type_declaration; + cls_arity: int; + cls_pub_methods: string list; + cls_info: 'a; } type class_type_info = { - clsty_ty_id : Ident.t; - clsty_id_loc : string loc; - clsty_ty_decl : class_type_declaration; - clsty_obj_id : Ident.t; - clsty_obj_abbr : type_declaration; - clsty_typesharp_id : Ident.t; - clsty_abbr : type_declaration; - clsty_info : Typedtree.class_type_declaration; + clsty_ty_id: Ident.t; + clsty_id_loc: string loc; + clsty_ty_decl: class_type_declaration; + clsty_obj_id: Ident.t; + clsty_obj_abbr: type_declaration; + clsty_typesharp_id: Ident.t; + clsty_abbr: type_declaration; + clsty_info: Typedtree.class_type_declaration; } type error = - Unconsistent_constraint of (type_expr * type_expr) list + | Unconsistent_constraint of (type_expr * type_expr) list | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Pattern_type_clash of type_expr @@ -58,14 +58,12 @@ type error = | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr - | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure | Non_generalizable_class of Ident.t * Types.class_declaration | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | No_overriding of string * string - exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -73,13 +71,17 @@ exception Error_forward of Location.error open Typedtree let ctyp desc typ env loc = - { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; - ctyp_attributes = [] } - - (**********************) - (* Useful constants *) - (**********************) + { + ctyp_desc = desc; + ctyp_type = typ; + ctyp_loc = loc; + ctyp_env = env; + ctyp_attributes = []; + } +(**********************) +(* Useful constants *) +(**********************) (* Self type have a dummy private method, thus preventing it to become @@ -93,31 +95,27 @@ let dummy_method = Btype.dummy_method *) let unbound_class = Path.Pident (Ident.create "*undef*") - - (************************************) - (* Some operations on class types *) - (************************************) - +(************************************) +(* Some operations on class types *) +(************************************) (* Fully expand the head of a class type *) -let rec scrape_class_type = - function - Cty_constr (_, _, cty) -> scrape_class_type cty - | cty -> cty +let rec scrape_class_type = function + | Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty (* Generalize a class type *) -let rec generalize_class_type gen = - function - Cty_constr (_, params, cty) -> - List.iter gen params; - generalize_class_type gen cty +let rec generalize_class_type gen = function + | Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type gen cty | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} -> - gen sty; - Vars.iter (fun _ (_, _, ty) -> gen ty) vars; - List.iter (fun (_,tl) -> List.iter gen tl) inher + gen sty; + Vars.iter (fun _ (_, _, ty) -> gen ty) vars; + List.iter (fun (_, tl) -> List.iter gen tl) inher | Cty_arrow (_, ty, cty) -> - gen ty; - generalize_class_type gen cty + gen ty; + generalize_class_type gen cty let generalize_class_type vars = let gen = if vars then Ctype.generalize else Ctype.generalize_structure in @@ -125,81 +123,67 @@ let generalize_class_type vars = (* Return the virtual methods of a class type *) let virtual_methods sign = - let (fields, _) = + let fields, _ = Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self) in List.fold_left (fun virt (lab, _, _) -> - if lab = dummy_method then virt else - if Concr.mem lab sign.csig_concr then virt else - lab::virt) + if lab = dummy_method then virt + else if Concr.mem lab sign.csig_concr then virt + else lab :: virt) [] fields (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = match cty with - Cty_constr (_, _, cty) -> - constructor_type constr cty - | Cty_signature _ -> - constr + | Cty_constr (_, _, cty) -> constructor_type constr cty + | Cty_signature _ -> constr | Cty_arrow (l, ty, cty) -> - Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) + Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) let rec class_body cty = match cty with - Cty_constr _ -> - cty (* Only class bodies can be abbreviated *) - | Cty_signature _ -> - cty - | Cty_arrow (_, _, cty) -> - class_body cty - + | Cty_constr _ -> cty (* Only class bodies can be abbreviated *) + | Cty_signature _ -> cty + | Cty_arrow (_, _, cty) -> class_body cty (* Check that all type variables are generalizable *) (* Use Env.empty to prevent expansion of recursively defined object types; cf. typing-poly/poly.ml *) -let rec closed_class_type = - function - Cty_constr (_, params, _) -> - List.for_all (Ctype.closed_schema Env.empty) params +let rec closed_class_type = function + | Cty_constr (_, params, _) -> + List.for_all (Ctype.closed_schema Env.empty) params | Cty_signature sign -> - Ctype.closed_schema Env.empty sign.csig_self - && - Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc) - sign.csig_vars - true + Ctype.closed_schema Env.empty sign.csig_self + && Vars.fold + (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc) + sign.csig_vars true | Cty_arrow (_, ty, cty) -> - Ctype.closed_schema Env.empty ty - && - closed_class_type cty + Ctype.closed_schema Env.empty ty && closed_class_type cty let closed_class cty = List.for_all (Ctype.closed_schema Env.empty) cty.cty_params - && - closed_class_type cty.cty_type - -let rec limited_generalize rv = - function - Cty_constr (_path, params, cty) -> - List.iter (Ctype.limited_generalize rv) params; - limited_generalize rv cty + && closed_class_type cty.cty_type + +let rec limited_generalize rv = function + | Cty_constr (_path, params, cty) -> + List.iter (Ctype.limited_generalize rv) params; + limited_generalize rv cty | Cty_signature sign -> - Ctype.limited_generalize rv sign.csig_self; - Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) - sign.csig_vars; - List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) - sign.csig_inher + Ctype.limited_generalize rv sign.csig_self; + Vars.iter + (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) + sign.csig_vars; + List.iter + (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) + sign.csig_inher | Cty_arrow (_, ty, cty) -> - Ctype.limited_generalize rv ty; - limited_generalize rv cty - - - - (***********************************) - (* Primitives for typing classes *) - (***********************************) - + Ctype.limited_generalize rv ty; + limited_generalize rv cty +(***********************************) +(* Primitives for typing classes *) +(***********************************) (* Enter an instance variable in the environment *) let concr_vals vars = @@ -209,265 +193,243 @@ let concr_vals vars = let inheritance self_type env ovf concr_meths warn_vals loc parent = match scrape_class_type parent with - Cty_signature cl_sig -> - - (* Methods *) - begin try - Ctype.unify env self_type cl_sig.csig_self - with Ctype.Unify trace -> - match trace with - _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> - raise(Error(loc, env, Field_type_mismatch ("method", n, rem))) - | _ -> - assert false - end; - - (* Overriding *) - let over_meths = Concr.inter cl_sig.csig_concr concr_meths in - let concr_vals = concr_vals cl_sig.csig_vars in - let over_vals = Concr.inter concr_vals warn_vals in - begin match ovf with - Some Fresh -> - let cname = - match parent with - Cty_constr (p, _, _) -> Path.name p - | _ -> "inherited" - in - if not (Concr.is_empty over_meths) then - Location.prerr_warning loc - (Warnings.Method_override (cname :: Concr.elements over_meths)); - if not (Concr.is_empty over_vals) then - Location.prerr_warning loc - (Warnings.Instance_variable_override - (cname :: Concr.elements over_vals)); - | Some Override - when Concr.is_empty over_meths && Concr.is_empty over_vals -> - raise (Error(loc, env, No_overriding ("",""))) - | _ -> () - end; - - let concr_meths = Concr.union cl_sig.csig_concr concr_meths - and warn_vals = Concr.union concr_vals warn_vals in - - (cl_sig, concr_meths, warn_vals) - - | _ -> - raise(Error(loc, env, Structure_expected parent)) - + | Cty_signature cl_sig -> + (* Methods *) + (try Ctype.unify env self_type cl_sig.csig_self + with Ctype.Unify trace -> ( + match trace with + | _ :: _ :: _ :: ({desc = Tfield (n, _, _, _)}, _) :: rem -> + raise (Error (loc, env, Field_type_mismatch ("method", n, rem))) + | _ -> assert false)); + + (* Overriding *) + let over_meths = Concr.inter cl_sig.csig_concr concr_meths in + let concr_vals = concr_vals cl_sig.csig_vars in + let over_vals = Concr.inter concr_vals warn_vals in + (match ovf with + | Some Fresh -> + let cname = + match parent with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (Concr.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override (cname :: Concr.elements over_meths)); + if not (Concr.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: Concr.elements over_vals)) + | Some Override when Concr.is_empty over_meths && Concr.is_empty over_vals + -> + raise (Error (loc, env, No_overriding ("", ""))) + | _ -> ()); + + let concr_meths = Concr.union cl_sig.csig_concr concr_meths + and warn_vals = Concr.union concr_vals warn_vals in + + (cl_sig, concr_meths, warn_vals) + | _ -> raise (Error (loc, env, Structure_expected parent)) let delayed_meth_specs = ref [] let declare_method val_env meths self_type lab priv sty loc = - let (_, ty') = - Ctype.filter_self_method val_env lab priv meths self_type - in + let _, ty' = Ctype.filter_self_method val_env lab priv meths self_type in let unif ty = - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))) + try Ctype.unify val_env ty ty' + with Ctype.Unify trace -> + raise (Error (loc, val_env, Field_type_mismatch ("method", lab, trace))) in let sty = Ast_helper.Typ.force_poly sty in - match sty.ptyp_desc, priv with - Ptyp_poly ([],sty'), Public -> -(* TODO: we moved the [transl_simple_type_univars] outside of the lazy, -so that we can get an immediate value. Is that correct ? Ask Jacques. *) - let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in - delayed_meth_specs := + match (sty.ptyp_desc, priv) with + | Ptyp_poly ([], sty'), Public -> + (* TODO: we moved the [transl_simple_type_univars] outside of the lazy, + so that we can get an immediate value. Is that correct ? Ask Jacques. *) + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in + delayed_meth_specs := Warnings.mk_lazy (fun () -> - let cty = transl_simple_type_univars val_env sty' in - let ty = cty.ctyp_type in - unif ty; - returned_cty.ctyp_desc <- Ttyp_poly ([], cty); - returned_cty.ctyp_type <- ty; - ) :: - !delayed_meth_specs; - returned_cty + let cty = transl_simple_type_univars val_env sty' in + let ty = cty.ctyp_type in + unif ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty) + :: !delayed_meth_specs; + returned_cty | _ -> - let cty = transl_simple_type val_env false sty in - let ty = cty.ctyp_type in - unif ty; - cty + let cty = transl_simple_type val_env false sty in + let ty = cty.ctyp_type in + unif ty; + cty let type_constraint val_env sty sty' loc = - let cty = transl_simple_type val_env false sty in + let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in let cty' = transl_simple_type val_env false sty' in let ty' = cty'.ctyp_type in - begin - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Unconsistent_constraint trace)); - end; + (try Ctype.unify val_env ty ty' + with Ctype.Unify trace -> + raise (Error (loc, val_env, Unconsistent_constraint trace))); (cty, cty') - (*******************************) let add_val lab (mut, virt, ty) val_sig = let virt = try - let (_mut', virt', _ty') = Vars.find lab val_sig in + let _mut', virt', _ty' = Vars.find lab val_sig in if virt' = Concrete then virt' else virt with Not_found -> virt in Vars.add lab (mut, virt, ty) val_sig let rec class_type_field env self_type meths arg ctf = - Builtin_attributes.warning_scope ctf.pctf_attributes - (fun () -> class_type_field_aux env self_type meths arg ctf) + Builtin_attributes.warning_scope ctf.pctf_attributes (fun () -> + class_type_field_aux env self_type meths arg ctf) and class_type_field_aux env self_type meths (fields, val_sig, concr_meths, inher) ctf = - let loc = ctf.pctf_loc in let mkctf desc = - { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } + {ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes} in match ctf.pctf_desc with - Pctf_inherit sparent -> - let parent = class_type env sparent in - let inher = - match parent.cltyp_type with - Cty_constr (p, tl, _) -> (p, tl) :: inher - | _ -> inher - in - let (cl_sig, concr_meths, _) = - inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc - parent.cltyp_type - in - let val_sig = - Vars.fold add_val cl_sig.csig_vars val_sig in - (mkctf (Tctf_inherit parent) :: fields, - val_sig, concr_meths, inher) - - | Pctf_val ({txt=lab}, mut, virt, sty) -> - let cty = transl_simple_type env false sty in - let ty = cty.ctyp_type in - (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields, - add_val lab (mut, virt, ty) val_sig, concr_meths, inher) - - | Pctf_method ({txt=lab}, priv, virt, sty) -> - let cty = - declare_method env meths self_type lab priv sty ctf.pctf_loc in - let concr_meths = - match virt with - | Concrete -> Concr.add lab concr_meths - | Virtual -> concr_meths - in - (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields, - val_sig, concr_meths, inher) - + | Pctf_inherit sparent -> + let parent = class_type env sparent in + let inher = + match parent.cltyp_type with + | Cty_constr (p, tl, _) -> (p, tl) :: inher + | _ -> inher + in + let cl_sig, concr_meths, _ = + inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc + parent.cltyp_type + in + let val_sig = Vars.fold add_val cl_sig.csig_vars val_sig in + (mkctf (Tctf_inherit parent) :: fields, val_sig, concr_meths, inher) + | Pctf_val ({txt = lab}, mut, virt, sty) -> + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + ( mkctf (Tctf_val (lab, mut, virt, cty)) :: fields, + add_val lab (mut, virt, ty) val_sig, + concr_meths, + inher ) + | Pctf_method ({txt = lab}, priv, virt, sty) -> + let cty = declare_method env meths self_type lab priv sty ctf.pctf_loc in + let concr_meths = + match virt with + | Concrete -> Concr.add lab concr_meths + | Virtual -> concr_meths + in + ( mkctf (Tctf_method (lab, priv, virt, cty)) :: fields, + val_sig, + concr_meths, + inher ) | Pctf_constraint (sty, sty') -> - let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in - (mkctf (Tctf_constraint (cty, cty')) :: fields, - val_sig, concr_meths, inher) - + let cty, cty' = type_constraint env sty sty' ctf.pctf_loc in + (mkctf (Tctf_constraint (cty, cty')) :: fields, val_sig, concr_meths, inher) | Pctf_attribute x -> - Builtin_attributes.warning_attribute x; - (mkctf (Tctf_attribute x) :: fields, - val_sig, concr_meths, inher) - + Builtin_attributes.warning_attribute x; + (mkctf (Tctf_attribute x) :: fields, val_sig, concr_meths, inher) | Pctf_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) -and class_signature env {pcsig_self=sty; pcsig_fields=sign} = +and class_signature env {pcsig_self = sty; pcsig_fields = sign} = let meths = ref Meths.empty in let self_cty = transl_simple_type env false sty in - let self_cty = { self_cty with - ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in - let self_type = self_cty.ctyp_type in + let self_cty = + {self_cty with ctyp_type = Ctype.expand_head env self_cty.ctyp_type} + in + let self_type = self_cty.ctyp_type in (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) let dummy_obj = Ctype.newvar () in - Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj) + Ctype.unify env + (Ctype.filter_method env dummy_method Private dummy_obj) (Ctype.newty (Ttuple [])); - begin try - Ctype.unify env self_type dummy_obj - with Ctype.Unify _ -> - raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) - end; + (try Ctype.unify env self_type dummy_obj + with Ctype.Unify _ -> + raise (Error (sty.ptyp_loc, env, Pattern_type_clash self_type))); (* Class type fields *) - let (rev_fields, val_sig, concr_meths, inher) = - Builtin_attributes.warning_scope [] - (fun () -> - List.fold_left (class_type_field env self_type meths) - ([], Vars.empty, Concr.empty, []) - sign - ) + let rev_fields, val_sig, concr_meths, inher = + Builtin_attributes.warning_scope [] (fun () -> + List.fold_left + (class_type_field env self_type meths) + ([], Vars.empty, Concr.empty, []) + sign) in - let cty = {csig_self = self_type; - csig_vars = val_sig; - csig_concr = concr_meths; - csig_inher = inher} + let cty = + { + csig_self = self_type; + csig_vars = val_sig; + csig_concr = concr_meths; + csig_inher = inher; + } in - { csig_self = self_cty; - csig_fields = List.rev rev_fields; - csig_type = cty; - } + {csig_self = self_cty; csig_fields = List.rev rev_fields; csig_type = cty} and class_type env scty = - Builtin_attributes.warning_scope scty.pcty_attributes - (fun () -> class_type_aux env scty) + Builtin_attributes.warning_scope scty.pcty_attributes (fun () -> + class_type_aux env scty) and class_type_aux env scty = let cltyp desc typ = { - cltyp_desc = desc; - cltyp_type = typ; - cltyp_loc = scty.pcty_loc; - cltyp_env = env; - cltyp_attributes = scty.pcty_attributes; + cltyp_desc = desc; + cltyp_type = typ; + cltyp_loc = scty.pcty_loc; + cltyp_env = env; + cltyp_attributes = scty.pcty_attributes; } in match scty.pcty_desc with - Pcty_constr (lid, styl) -> - let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in - if Path.same decl.clty_path unbound_class then - raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); - let (params, clty) = - Ctype.instance_class decl.clty_params decl.clty_type - in - if List.length params <> List.length styl then - raise(Error(scty.pcty_loc, env, - Parameter_arity_mismatch (lid.txt, List.length params, - List.length styl))); - let ctys = List.map2 + | Pcty_constr (lid, styl) -> + let path, decl = Typetexp.find_class_type env scty.pcty_loc lid.txt in + if Path.same decl.clty_path unbound_class then + raise (Error (scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); + let params, clty = Ctype.instance_class decl.clty_params decl.clty_type in + if List.length params <> List.length styl then + raise + (Error + ( scty.pcty_loc, + env, + Parameter_arity_mismatch + (lid.txt, List.length params, List.length styl) )); + let ctys = + List.map2 (fun sty ty -> let cty' = transl_simple_type env false sty in let ty' = cty'.ctyp_type in - begin - try Ctype.unify env ty' ty with Ctype.Unify trace -> - raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace)) - end; - cty' - ) styl params - in - let typ = Cty_constr (path, params, clty) in - cltyp (Tcty_constr ( path, lid , ctys)) typ - + (try Ctype.unify env ty' ty + with Ctype.Unify trace -> + raise (Error (sty.ptyp_loc, env, Parameter_mismatch trace))); + cty') + styl params + in + let typ = Cty_constr (path, params, clty) in + cltyp (Tcty_constr (path, lid, ctys)) typ | Pcty_signature pcsig -> - let clsig = class_signature env pcsig in - let typ = Cty_signature clsig.csig_type in - cltyp (Tcty_signature clsig) typ - + let clsig = class_signature env pcsig in + let typ = Cty_signature clsig.csig_type in + cltyp (Tcty_signature clsig) typ | Pcty_arrow (l, sty, scty) -> - let cty = transl_simple_type env false sty in - let ty = cty.ctyp_type in - let ty = - if Btype.is_optional l - then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil)) - else ty in - let clty = class_type env scty in - let typ = Cty_arrow (l, ty, clty.cltyp_type) in - cltyp (Tcty_arrow (l, cty, clty)) typ - + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + let ty = + if Btype.is_optional l then + Ctype.newty (Tconstr (Predef.path_option, [ty], ref Mnil)) + else ty + in + let clty = class_type env scty in + let typ = Cty_arrow (l, ty, clty.cltyp_type) in + cltyp (Tcty_arrow (l, cty, clty)) typ | Pcty_open (ovf, lid, e) -> - let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in - let clty = class_type newenv e in - cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type - + let path, newenv = !Typecore.type_open ovf env scty.pcty_loc lid in + let clty = class_type newenv e in + cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type | Pcty_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + raise (Error_forward (Builtin_attributes.error_of_extension ext)) let class_type env scty = delayed_meth_specs := []; @@ -478,7 +440,6 @@ let class_type env scty = (*******************************) - (*******************************) (* Approximate the type of the constructor to allow recursive use *) @@ -486,14 +447,14 @@ let class_type env scty = let var_option = Predef.type_option (Btype.newgenvar ()) - let rec approx_description ct = match ct.pcty_desc with - Pcty_arrow (l, _, ct) -> - let arg = - if Btype.is_optional l then Ctype.instance_def var_option - else Ctype.newvar () in - Ctype.newty (Tarrow (l, arg, approx_description ct, Cok)) + | Pcty_arrow (l, _, ct) -> + let arg = + if Btype.is_optional l then Ctype.instance_def var_option + else Ctype.newvar () + in + Ctype.newty (Tarrow (l, arg, approx_description ct, Cok)) | _ -> Ctype.newvar () (*******************************) @@ -506,87 +467,108 @@ let temp_abbrev loc env id arity = let ty = Ctype.newobj (Ctype.newvar ()) in let env = Env.add_type ~check:true id - {type_params = !params; - type_arity = arity; - type_kind = Type_abstract; - type_private = Public; - type_manifest = Some ty; - type_variance = Misc.replicate_list Variance.full arity; - type_newtype_level = None; - type_loc = loc; - type_attributes = []; (* or keep attrs from the class decl? *) - type_immediate = false; - type_unboxed = unboxed_false_default_false; + { + type_params = !params; + type_arity = arity; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some ty; + type_variance = Misc.replicate_list Variance.full arity; + type_newtype_level = None; + type_loc = loc; + type_attributes = []; + (* or keep attrs from the class decl? *) + type_immediate = false; + type_unboxed = unboxed_false_default_false; } env in (!params, ty, env) -let initial_env approx - (res, env) (cl, id, ty_id, obj_id, cl_id) = +let initial_env approx (res, env) (cl, id, ty_id, obj_id, cl_id) = (* Temporary abbreviations *) let arity = List.length cl.pci_params in - let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in - let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in + let obj_params, obj_ty, env = temp_abbrev cl.pci_loc env obj_id arity in + let cl_params, cl_ty, env = temp_abbrev cl.pci_loc env cl_id arity in (* Temporary type for the class constructor *) let constr_type = approx cl.pci_expr in let dummy_cty = Cty_signature - { csig_self = Ctype.newvar (); + { + csig_self = Ctype.newvar (); csig_vars = Vars.empty; csig_concr = Concr.empty; - csig_inher = [] } + csig_inher = []; + } in let dummy_class = - {Types.cty_params = []; (* Dummy value *) - cty_variance = []; - cty_type = dummy_cty; (* Dummy value *) - cty_path = unbound_class; - cty_new = - begin match cl.pci_virt with - | Virtual -> None - | Concrete -> Some constr_type - end; - cty_loc = Location.none; - cty_attributes = []; + { + Types.cty_params = []; + (* Dummy value *) + cty_variance = []; + cty_type = dummy_cty; + (* Dummy value *) + cty_path = unbound_class; + cty_new = + (match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type); + cty_loc = Location.none; + cty_attributes = []; } in let env = Env.add_cltype ty_id - {clty_params = []; (* Dummy value *) - clty_variance = []; - clty_type = dummy_cty; (* Dummy value *) - clty_path = unbound_class; - clty_loc = Location.none; - clty_attributes = []; - } env + { + clty_params = []; + (* Dummy value *) + clty_variance = []; + clty_type = dummy_cty; + (* Dummy value *) + clty_path = unbound_class; + clty_loc = Location.none; + clty_attributes = []; + } + env in - ((cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class)::res, - env) - -let class_infos kind - (cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class) - (res, env) = - + ( ( cl, + id, + ty_id, + obj_id, + obj_params, + obj_ty, + cl_id, + cl_params, + cl_ty, + constr_type, + dummy_class ) + :: res, + env ) + +let class_infos kind + ( cl, + id, + ty_id, + obj_id, + obj_params, + obj_ty, + cl_id, + cl_params, + cl_ty, + constr_type, + dummy_class ) (res, env) = reset_type_variables (); Ctype.begin_class_def (); (* Introduce class parameters *) let ci_params = let make_param (sty, v) = - try - (transl_type_param env sty, v) + try (transl_type_param env sty, v) with Already_bound -> - raise(Error(sty.ptyp_loc, env, Repeated_parameter)) + raise (Error (sty.ptyp_loc, env, Repeated_parameter)) in - List.map make_param cl.pci_params + List.map make_param cl.pci_params in let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in @@ -594,7 +576,7 @@ let class_infos kind let coercion_locs = ref [] in (* Type the class expression *) - let (expr, typ) = + let expr, typ = try Typecore.self_coercion := (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; @@ -602,7 +584,8 @@ let class_infos kind Typecore.self_coercion := List.tl !Typecore.self_coercion; res with exn -> - Typecore.self_coercion := []; raise exn + Typecore.self_coercion := []; + raise exn in Ctype.end_def (); @@ -610,8 +593,9 @@ let class_infos kind let sty = Ctype.self_type typ in (* First generalize the type of the dummy method (cf PR#6123) *) - let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in - List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty) + let fields, _ = Ctype.flatten_fields (Ctype.object_fields sty) in + List.iter + (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty) fields; (* Generalize the row variable *) let rv = Ctype.row_variable sty in @@ -619,305 +603,416 @@ let class_infos kind limited_generalize rv typ; (* Check the abbreviation for the object type *) - let (obj_params', obj_type) = Ctype.instance_class params typ in + let obj_params', obj_type = Ctype.instance_class params typ in let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in - begin - let ty = Ctype.self_type obj_type in - Ctype.hide_private_methods ty; - Ctype.close_object ty; - begin try - List.iter2 (Ctype.unify env) obj_params obj_params' + (let ty = Ctype.self_type obj_type in + Ctype.hide_private_methods ty; + Ctype.close_object ty; + (try List.iter2 (Ctype.unify env) obj_params obj_params' with Ctype.Unify _ -> - raise(Error(cl.pci_loc, env, - Bad_parameters (obj_id, constr, - Ctype.newconstr (Path.Pident obj_id) - obj_params'))) - end; - begin try - Ctype.unify env ty constr - with Ctype.Unify _ -> - raise(Error(cl.pci_loc, env, - Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) - end - end; + raise + (Error + ( cl.pci_loc, + env, + Bad_parameters + (obj_id, constr, Ctype.newconstr (Path.Pident obj_id) obj_params') + ))); + try Ctype.unify env ty constr + with Ctype.Unify _ -> + raise + (Error + ( cl.pci_loc, + env, + Abbrev_type_clash (constr, ty, Ctype.expand_head env constr) ))); (* Check the other temporary abbreviation (#-type) *) - begin - let (cl_params', cl_type) = Ctype.instance_class params typ in - let ty = Ctype.self_type cl_type in - Ctype.hide_private_methods ty; - Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; - begin try - List.iter2 (Ctype.unify env) cl_params cl_params' - with Ctype.Unify _ -> - raise(Error(cl.pci_loc, env, - Bad_parameters (cl_id, - Ctype.newconstr (Path.Pident cl_id) - cl_params, - Ctype.newconstr (Path.Pident cl_id) - cl_params'))) - end; - begin try - Ctype.unify env ty cl_ty + (let cl_params', cl_type = Ctype.instance_class params typ in + let ty = Ctype.self_type cl_type in + Ctype.hide_private_methods ty; + Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; + (try List.iter2 (Ctype.unify env) cl_params cl_params' with Ctype.Unify _ -> - let constr = Ctype.newconstr (Path.Pident cl_id) params in - raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty))) - end - end; + raise + (Error + ( cl.pci_loc, + env, + Bad_parameters + ( cl_id, + Ctype.newconstr (Path.Pident cl_id) cl_params, + Ctype.newconstr (Path.Pident cl_id) cl_params' ) ))); + try Ctype.unify env ty cl_ty + with Ctype.Unify _ -> + let constr = Ctype.newconstr (Path.Pident cl_id) params in + raise (Error (cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty)))); (* Type of the class constructor *) - begin try - Ctype.unify env - (constructor_type constr obj_type) - (Ctype.instance env constr_type) - with Ctype.Unify trace -> - raise(Error(cl.pci_loc, env, - Constructor_type_mismatch (cl.pci_name.txt, trace))) - end; + (try + Ctype.unify env + (constructor_type constr obj_type) + (Ctype.instance env constr_type) + with Ctype.Unify trace -> + raise + (Error + (cl.pci_loc, env, Constructor_type_mismatch (cl.pci_name.txt, trace)))); (* Class and class type temporary definitions *) let cty_variance = List.map (fun _ -> Variance.full) params in let cltydef = - {clty_params = params; clty_type = class_body typ; - clty_variance = cty_variance; - clty_path = Path.Pident obj_id; - clty_loc = cl.pci_loc; - clty_attributes = cl.pci_attributes; + { + clty_params = params; + clty_type = class_body typ; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; } in dummy_class.cty_type <- typ; - let env = - Env.add_cltype ty_id cltydef ( - env) - in - - if cl.pci_virt = Concrete then begin - let sign = Ctype.signature_of_class_type typ in - let mets = virtual_methods sign in - let vals = - Vars.fold - (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) - sign.csig_vars [] in - if mets <> [] || vals <> [] then - raise(Error(cl.pci_loc, env, Virtual_class(false, false, mets, - vals))); - end; + let env = Env.add_cltype ty_id cltydef env in + + (if cl.pci_virt = Concrete then + let sign = Ctype.signature_of_class_type typ in + let mets = virtual_methods sign in + let vals = + Vars.fold + (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) + sign.csig_vars [] + in + if mets <> [] || vals <> [] then + raise (Error (cl.pci_loc, env, Virtual_class (false, false, mets, vals)))); (* Misc. *) let arity = Ctype.class_type_arity typ in let pub_meths = - let (fields, _) = + let fields, _ = Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty)) in - List.map (function (lab, _, _) -> lab) fields + List.map + (function + | lab, _, _ -> lab) + fields in (* Final definitions *) - let (params', typ') = Ctype.instance_class params typ in + let params', typ' = Ctype.instance_class params typ in let cltydef = - {clty_params = params'; clty_type = class_body typ'; - clty_variance = cty_variance; - clty_path = Path.Pident obj_id; - clty_loc = cl.pci_loc; - clty_attributes = cl.pci_attributes; + { + clty_params = params'; + clty_type = class_body typ'; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; } and clty = - {cty_params = params'; cty_type = typ'; - cty_variance = cty_variance; - cty_path = Path.Pident obj_id; - cty_new = - begin match cl.pci_virt with - | Virtual -> None - | Concrete -> Some (Ctype.instance env constr_type) - end; - cty_loc = cl.pci_loc; - cty_attributes = cl.pci_attributes; + { + cty_params = params'; + cty_type = typ'; + cty_variance; + cty_path = Path.Pident obj_id; + cty_new = + (match cl.pci_virt with + | Virtual -> None + | Concrete -> Some (Ctype.instance env constr_type)); + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; } in let obj_abbr = - {type_params = obj_params; - type_arity = List.length obj_params; - type_kind = Type_abstract; - type_private = Public; - type_manifest = Some obj_ty; - type_variance = List.map (fun _ -> Variance.full) obj_params; - type_newtype_level = None; - type_loc = cl.pci_loc; - type_attributes = []; (* or keep attrs from cl? *) - type_immediate = false; - type_unboxed = unboxed_false_default_false; + { + type_params = obj_params; + type_arity = List.length obj_params; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some obj_ty; + type_variance = List.map (fun _ -> Variance.full) obj_params; + type_newtype_level = None; + type_loc = cl.pci_loc; + type_attributes = []; + (* or keep attrs from cl? *) + type_immediate = false; + type_unboxed = unboxed_false_default_false; } in - let (cl_params, cl_ty) = + let cl_params, cl_ty = Ctype.instance_parameterized_type params (Ctype.self_type typ) in Ctype.hide_private_methods cl_ty; Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; let cl_abbr = - {type_params = cl_params; - type_arity = List.length cl_params; - type_kind = Type_abstract; - type_private = Public; - type_manifest = Some cl_ty; - type_variance = List.map (fun _ -> Variance.full) cl_params; - type_newtype_level = None; - type_loc = cl.pci_loc; - type_attributes = []; (* or keep attrs from cl? *) - type_immediate = false; - type_unboxed = unboxed_false_default_false; + { + type_params = cl_params; + type_arity = List.length cl_params; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some cl_ty; + type_variance = List.map (fun _ -> Variance.full) cl_params; + type_newtype_level = None; + type_loc = cl.pci_loc; + type_attributes = []; + (* or keep attrs from cl? *) + type_immediate = false; + type_unboxed = unboxed_false_default_false; } in - ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, - arity, pub_meths, List.rev !coercion_locs, expr) :: res, - env) - -let final_decl env - (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, - arity, pub_meths, coe, expr) = - - begin try Ctype.collapse_conj_params env clty.cty_params - with Ctype.Unify trace -> - raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace))) - end; + ( ( cl, + id, + clty, + ty_id, + cltydef, + obj_id, + obj_abbr, + cl_id, + cl_abbr, + ci_params, + arity, + pub_meths, + List.rev !coercion_locs, + expr ) + :: res, + env ) + +let final_decl env + ( cl, + id, + clty, + ty_id, + cltydef, + obj_id, + obj_abbr, + cl_id, + cl_abbr, + ci_params, + arity, + pub_meths, + coe, + expr ) = + (try Ctype.collapse_conj_params env clty.cty_params + with Ctype.Unify trace -> + raise + (Error (cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))); List.iter Ctype.generalize clty.cty_params; generalize_class_type true clty.cty_type; - Misc.may Ctype.generalize clty.cty_new; + Misc.may Ctype.generalize clty.cty_new; List.iter Ctype.generalize obj_abbr.type_params; - Misc.may Ctype.generalize obj_abbr.type_manifest; + Misc.may Ctype.generalize obj_abbr.type_manifest; List.iter Ctype.generalize cl_abbr.type_params; - Misc.may Ctype.generalize cl_abbr.type_manifest; + Misc.may Ctype.generalize cl_abbr.type_manifest; if not (closed_class clty) then - raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); + raise (Error (cl.pci_loc, env, Non_generalizable_class (id, clty))); - begin match - Ctype.closed_class clty.cty_params - (Ctype.signature_of_class_type clty.cty_type) - with - None -> () + (match + Ctype.closed_class clty.cty_params + (Ctype.signature_of_class_type clty.cty_type) + with + | None -> () | Some reason -> - let printer = - function ppf -> Printtyp.cltype_declaration id ppf cltydef - in - raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) - end; - - (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, - { ci_loc = cl.pci_loc; - ci_virt = cl.pci_virt; - ci_params = ci_params; -(* TODO : check that we have the correct use of identifiers *) - ci_id_name = cl.pci_name; - ci_id_class = id; - ci_id_class_type = ty_id; - ci_id_object = obj_id; - ci_id_typehash = cl_id; - ci_expr = expr; - ci_decl = clty; - ci_type_decl = cltydef; - ci_attributes = cl.pci_attributes; - }) + let printer = function + | ppf -> Printtyp.cltype_declaration id ppf cltydef + in + raise (Error (cl.pci_loc, env, Unbound_type_var (printer, reason)))); + + ( id, + cl.pci_name, + clty, + ty_id, + cltydef, + obj_id, + obj_abbr, + cl_id, + cl_abbr, + arity, + pub_meths, + coe, + expr, + { + ci_loc = cl.pci_loc; + ci_virt = cl.pci_virt; + ci_params; + (* TODO : check that we have the correct use of identifiers *) + ci_id_name = cl.pci_name; + ci_id_class = id; + ci_id_class_type = ty_id; + ci_id_object = obj_id; + ci_id_typehash = cl_id; + ci_expr = expr; + ci_decl = clty; + ci_type_decl = cltydef; + ci_attributes = cl.pci_attributes; + } ) (* (cl.pci_variance, cl.pci_loc)) *) -let class_infos kind - (cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class) - (res, env) = - Builtin_attributes.warning_scope cl.pci_attributes - (fun () -> - class_infos kind - (cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class) - (res, env) - ) +let class_infos kind + ( cl, + id, + ty_id, + obj_id, + obj_params, + obj_ty, + cl_id, + cl_params, + cl_ty, + constr_type, + dummy_class ) (res, env) = + Builtin_attributes.warning_scope cl.pci_attributes (fun () -> + class_infos kind + ( cl, + id, + ty_id, + obj_id, + obj_params, + obj_ty, + cl_id, + cl_params, + cl_ty, + constr_type, + dummy_class ) + (res, env)) let extract_type_decls - (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr, - _arity, _pub_meths, _coe, _expr, required) decls = + ( _id, + _id_loc, + clty, + _ty_id, + cltydef, + obj_id, + obj_abbr, + _cl_id, + cl_abbr, + _arity, + _pub_meths, + _coe, + _expr, + required ) decls = (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls let merge_type_decls - (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, - arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) = - (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, req) + ( id, + id_loc, + _clty, + ty_id, + _cltydef, + obj_id, + _obj_abbr, + cl_id, + _cl_abbr, + arity, + pub_meths, + coe, + expr, + req ) (obj_abbr, cl_abbr, clty, cltydef) = + ( id, + id_loc, + clty, + ty_id, + cltydef, + obj_id, + obj_abbr, + cl_id, + cl_abbr, + arity, + pub_meths, + coe, + expr, + req ) let final_env env - (_id, _id_loc, _clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - _arity, _pub_meths, _coe, _expr, _req) = + ( _id, + _id_loc, + _clty, + ty_id, + cltydef, + obj_id, + obj_abbr, + cl_id, + cl_abbr, + _arity, + _pub_meths, + _coe, + _expr, + _req ) = (* Add definitions after cleaning them *) Env.add_type ~check:true obj_id - (Subst.type_declaration Subst.identity obj_abbr) ( - Env.add_type ~check:true cl_id - (Subst.type_declaration Subst.identity cl_abbr) ( - Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) - env)) + (Subst.type_declaration Subst.identity obj_abbr) + (Env.add_type ~check:true cl_id + (Subst.type_declaration Subst.identity cl_abbr) + (Env.add_cltype ty_id + (Subst.cltype_declaration Subst.identity cltydef) + env)) (* Check that #c is coercible to c if there is a self-coercion *) let check_coercions env - (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coercion_locs, _expr, req) = - begin match coercion_locs with [] -> () + ( id, + id_loc, + clty, + ty_id, + cltydef, + obj_id, + obj_abbr, + cl_id, + cl_abbr, + arity, + pub_meths, + coercion_locs, + _expr, + req ) = + (match coercion_locs with + | [] -> () | loc :: _ -> - let cl_ty, obj_ty = - match cl_abbr.type_manifest, obj_abbr.type_manifest with - Some cl_ab, Some obj_ab -> - let cl_params, cl_ty = - Ctype.instance_parameterized_type cl_abbr.type_params cl_ab - and obj_params, obj_ty = - Ctype.instance_parameterized_type obj_abbr.type_params obj_ab - in - List.iter2 (Ctype.unify env) cl_params obj_params; - cl_ty, obj_ty - | _ -> assert false - in - begin try Ctype.subtype env cl_ty obj_ty () - with Ctype.Subtype (tr1, tr2) -> - raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2))) - end; - if not (Ctype.opened_object cl_ty) then - raise(Error(loc, env, Cannot_coerce_self obj_ty)) - end; - {cls_id = id; - cls_id_loc = id_loc; - cls_decl = clty; - cls_ty_id = ty_id; - cls_ty_decl = cltydef; - cls_obj_id = obj_id; - cls_obj_abbr = obj_abbr; - cls_typesharp_id = cl_id; - cls_abbr = cl_abbr; - cls_arity = arity; - cls_pub_methods = pub_meths; - cls_info=req} + let cl_ty, obj_ty = + match (cl_abbr.type_manifest, obj_abbr.type_manifest) with + | Some cl_ab, Some obj_ab -> + let cl_params, cl_ty = + Ctype.instance_parameterized_type cl_abbr.type_params cl_ab + and obj_params, obj_ty = + Ctype.instance_parameterized_type obj_abbr.type_params obj_ab + in + List.iter2 (Ctype.unify env) cl_params obj_params; + (cl_ty, obj_ty) + | _ -> assert false + in + (try Ctype.subtype env cl_ty obj_ty () + with Ctype.Subtype (tr1, tr2) -> + raise (Typecore.Error (loc, env, Typecore.Not_subtype (tr1, tr2)))); + if not (Ctype.opened_object cl_ty) then + raise (Error (loc, env, Cannot_coerce_self obj_ty))); + { + cls_id = id; + cls_id_loc = id_loc; + cls_decl = clty; + cls_ty_id = ty_id; + cls_ty_decl = cltydef; + cls_obj_id = obj_id; + cls_obj_abbr = obj_abbr; + cls_typesharp_id = cl_id; + cls_abbr = cl_abbr; + cls_arity = arity; + cls_pub_methods = pub_meths; + cls_info = req; + } (*******************************) (* FIXME: [define_class] is always [false] here *) -let type_classes approx kind env cls = +let type_classes approx kind env cls = let cls = List.map - (function cl -> - (cl, - Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, - Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt))) + (function + | cl -> + ( cl, + Ident.create cl.pci_name.txt, + Ident.create cl.pci_name.txt, + Ident.create cl.pci_name.txt, + Ident.create ("#" ^ cl.pci_name.txt) )) cls in Ctype.init_def (Ident.current_time ()); Ctype.begin_class_def (); - let (res, env) = - List.fold_left (initial_env approx) ([], env) cls - in - let (res, env) = - List.fold_right (class_infos kind) res ([], env) - in + let res, env = List.fold_left (initial_env approx) ([], env) cls in + let res, env = List.fold_right (class_infos kind) res ([], env) in Ctype.end_def (); - let res = List.rev_map (final_decl env ) res in + let res = List.rev_map (final_decl env) res in let decls = List.fold_right extract_type_decls res [] in let decls = Typedecl.compute_variance_decls env decls in let res = List.map2 merge_type_decls res decls in @@ -925,31 +1020,26 @@ let type_classes approx kind env cls = let res = List.map (check_coercions env) res in (res, env) - let class_description env sexpr = let expr = class_type env sexpr in (expr, expr.cltyp_type) - - let class_type_declarations env cls = - let (decls, env) = - type_classes approx_description class_description env cls - in - (List.map - (fun decl -> - {clsty_ty_id = decl.cls_ty_id; - clsty_id_loc = decl.cls_id_loc; - clsty_ty_decl = decl.cls_ty_decl; - clsty_obj_id = decl.cls_obj_id; - clsty_obj_abbr = decl.cls_obj_abbr; - clsty_typesharp_id = decl.cls_typesharp_id; - clsty_abbr = decl.cls_abbr; - clsty_info = decl.cls_info}) - decls, - env) - - + let decls, env = type_classes approx_description class_description env cls in + ( List.map + (fun decl -> + { + clsty_ty_id = decl.cls_ty_id; + clsty_id_loc = decl.cls_id_loc; + clsty_ty_decl = decl.cls_ty_decl; + clsty_obj_id = decl.cls_obj_id; + clsty_obj_abbr = decl.cls_obj_abbr; + clsty_typesharp_id = decl.cls_typesharp_id; + clsty_abbr = decl.cls_abbr; + clsty_info = decl.cls_info; + }) + decls, + env ) (*******************************) @@ -958,7 +1048,7 @@ let approx_class sdecl = let open Ast_helper in let self' = Typ.any () in let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in - { sdecl with pci_expr = clty' } + {sdecl with pci_expr = clty'} let approx_class_declarations env sdecls = fst (class_type_declarations env (List.map approx_class sdecls)) @@ -970,136 +1060,133 @@ let approx_class_declarations env sdecls = open Format let report_error env ppf = function - | Repeated_parameter -> - fprintf ppf "A type parameter occurs several times" + | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Unconsistent_constraint trace -> - fprintf ppf "The class 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 class 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") | Field_type_mismatch (k, m, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The %s %s@ has type" k m) - (function ppf -> - fprintf ppf "but is expected to have type") + Printtyp.report_unification_error ppf env trace + (function + | ppf -> fprintf ppf "The %s %s@ has type" k m) + (function + | ppf -> fprintf ppf "but is expected to have type") | Structure_expected clty -> - fprintf ppf - "@[This class expression is not a class structure; it has type@ %a@]" - Printtyp.class_type clty + fprintf ppf + "@[This class expression is not a class structure; it has type@ %a@]" + Printtyp.class_type clty | Pattern_type_clash ty -> - (* XXX Trace *) - (* XXX Revoir message d'erreur | Improve error message *) - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[%s@ %a@]" - "This pattern cannot match self: it only matches values of type" - Printtyp.type_expr ty + (* XXX Trace *) + (* XXX Revoir message d'erreur | Improve error message *) + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[%s@ %a@]" + "This pattern cannot match self: it only matches values of type" + Printtyp.type_expr ty | Unbound_class_type_2 cl -> - fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" + fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" Printtyp.longident cl | Abbrev_type_clash (abbrev, actual, expected) -> - (* XXX Afficher une trace ? | Print a trace? *) - Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; - fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ - but is used with type@ %a@]" - Printtyp.type_expr abbrev - Printtyp.type_expr actual - Printtyp.type_expr expected + (* XXX Afficher une trace ? | Print a trace? *) + Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; + fprintf ppf + "@[The abbreviation@ %a@ expands to type@ %a@ but is used with type@ %a@]" + Printtyp.type_expr abbrev Printtyp.type_expr actual Printtyp.type_expr + expected | Constructor_type_mismatch (c, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The expression \"new %s\" has type" c) - (function ppf -> - fprintf ppf "but is used with type") + Printtyp.report_unification_error ppf env trace + (function + | ppf -> fprintf ppf "The expression \"new %s\" has type" c) + (function + | ppf -> fprintf ppf "but is used with type") | Virtual_class (cl, imm, mets, vals) -> - let print_mets ppf mets = - List.iter (function met -> fprintf ppf "@ %s" met) mets in - let missings = - match mets, vals with - [], _ -> "variables" - | _, [] -> "methods" - | _ -> "methods and variables" - in - let print_msg ppf = - if imm then fprintf ppf "This object has virtual %s" missings - else if cl then fprintf ppf "This class should be virtual" - else fprintf ppf "This class type should be virtual" - in - fprintf ppf - "@[%t.@ @[<2>The following %s are undefined :%a@]@]" - print_msg missings print_mets (mets @ vals) - | Parameter_arity_mismatch(lid, expected, provided) -> - fprintf ppf - "@[The class constructor %a@ expects %i type argument(s),@ \ - but is here applied to %i type argument(s)@]" - Printtyp.longident lid expected provided + let print_mets ppf mets = + List.iter + (function + | met -> fprintf ppf "@ %s" met) + mets + in + let missings = + match (mets, vals) with + | [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in + let print_msg ppf = + if imm then fprintf ppf "This object has virtual %s" missings + else if cl then fprintf ppf "This class should be virtual" + else fprintf ppf "This class type should be virtual" + in + fprintf ppf "@[%t.@ @[<2>The following %s are undefined :%a@]@]" print_msg + missings print_mets (mets @ vals) + | Parameter_arity_mismatch (lid, expected, provided) -> + fprintf ppf + "@[The class constructor %a@ expects %i type argument(s),@ but is here \ + applied to %i type argument(s)@]" + Printtyp.longident lid expected provided | Parameter_mismatch trace -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The type parameter") - (function ppf -> - fprintf ppf "does not meet its constraint: it should be") + Printtyp.report_unification_error ppf env trace + (function + | ppf -> fprintf ppf "The type parameter") + (function + | ppf -> fprintf ppf "does not meet its constraint: it should be") | Bad_parameters (id, params, cstrs) -> - Printtyp.reset_and_mark_loops_list [params; cstrs]; - fprintf ppf - "@[The abbreviation %a@ is used with parameters@ %a@ \ - which are incompatible with constraints@ %a@]" - Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs + Printtyp.reset_and_mark_loops_list [params; cstrs]; + fprintf ppf + "@[The abbreviation %a@ is used with parameters@ %a@ which are \ + incompatible with constraints@ %a@]" + Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs | Unbound_type_var (printer, reason) -> - let print_common ppf kind ty0 real lab ty = - let ty1 = - if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - List.iter Printtyp.mark_loops [ty; ty1]; - fprintf ppf - "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" - kind lab Printtyp.type_expr ty Printtyp.type_expr ty0 + let print_common ppf kind ty0 real lab ty = + let ty1 = + if real then ty0 else Btype.newgenty (Tobject (ty0, ref None)) in - let print_reason ppf = function + List.iter Printtyp.mark_loops [ty; ty1]; + fprintf ppf "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" kind lab + Printtyp.type_expr ty Printtyp.type_expr ty0 + in + let print_reason ppf = function | Ctype.CC_Method (ty0, real, lab, ty) -> - print_common ppf "method" ty0 real lab ty + print_common ppf "method" ty0 real lab ty | Ctype.CC_Value (ty0, real, lab, ty) -> - print_common ppf "instance variable" ty0 real lab ty - in - Printtyp.reset (); - fprintf ppf - "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ - @[%a@]@]" - printer print_reason reason + print_common ppf "instance variable" ty0 real lab ty + in + Printtyp.reset (); + fprintf ppf + "@[@[Some type variables are unbound in this type:@;\ + <1 2>%t@]@ @[%a@]@]" printer print_reason reason | Non_generalizable_class (id, clty) -> - fprintf ppf - "@[The type of this class,@ %a,@ \ - contains type variables that cannot be generalized@]" - (Printtyp.class_declaration id) clty + fprintf ppf + "@[The type of this class,@ %a,@ contains type variables that cannot be \ + generalized@]" + (Printtyp.class_declaration id) + clty | Cannot_coerce_self ty -> - fprintf ppf - "@[The type of self cannot be coerced to@ \ - the type of the current class:@ %a.@.\ - Some occurrences are contravariant@]" - Printtyp.type_scheme ty + fprintf ppf + "@[The type of self cannot be coerced to@ the type of the current \ + class:@ %a.@.Some occurrences are contravariant@]" + Printtyp.type_scheme ty | Non_collapsable_conjunction (id, clty, trace) -> - fprintf ppf - "@[The type of this class,@ %a,@ \ - contains non-collapsible conjunctive types in constraints@]" - (Printtyp.class_declaration id) clty; - 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 of this class,@ %a,@ contains non-collapsible conjunctive \ + types in constraints@]" + (Printtyp.class_declaration id) + clty; + Printtyp.report_unification_error ppf env trace + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") | No_overriding (_, "") -> - fprintf ppf "@[This inheritance does not override any method@ %s@]" - "instance variable" + fprintf ppf "@[This inheritance does not override any method@ %s@]" + "instance variable" | No_overriding (kind, name) -> - fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name + fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name 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) diff --git a/analysis/vendor/ml/typeclass.mli b/analysis/vendor/ml/typeclass.mli index b31bff919..770c79b93 100644 --- a/analysis/vendor/ml/typeclass.mli +++ b/analysis/vendor/ml/typeclass.mli @@ -18,46 +18,40 @@ open Types open Format type 'a class_info = { - cls_id : Ident.t; - cls_id_loc : string loc; - cls_decl : class_declaration; - cls_ty_id : Ident.t; - cls_ty_decl : class_type_declaration; - cls_obj_id : Ident.t; - cls_obj_abbr : type_declaration; - cls_typesharp_id : Ident.t; - cls_abbr : type_declaration; - cls_arity : int; - cls_pub_methods : string list; - cls_info : 'a; + cls_id: Ident.t; + cls_id_loc: string loc; + cls_decl: class_declaration; + cls_ty_id: Ident.t; + cls_ty_decl: class_type_declaration; + cls_obj_id: Ident.t; + cls_obj_abbr: type_declaration; + cls_typesharp_id: Ident.t; + cls_abbr: type_declaration; + cls_arity: int; + cls_pub_methods: string list; + cls_info: 'a; } type class_type_info = { - clsty_ty_id : Ident.t; - clsty_id_loc : string loc; - clsty_ty_decl : class_type_declaration; - clsty_obj_id : Ident.t; - clsty_obj_abbr : type_declaration; - clsty_typesharp_id : Ident.t; - clsty_abbr : type_declaration; - clsty_info : Typedtree.class_type_declaration; + clsty_ty_id: Ident.t; + clsty_id_loc: string loc; + clsty_ty_decl: class_type_declaration; + clsty_obj_id: Ident.t; + clsty_obj_abbr: type_declaration; + clsty_typesharp_id: Ident.t; + clsty_abbr: type_declaration; + clsty_info: Typedtree.class_type_declaration; } - - - - -val class_type_declarations: +val class_type_declarations : Env.t -> Parsetree.class_type_declaration list -> class_type_info list * Env.t - -val approx_class_declarations: +val approx_class_declarations : Env.t -> Parsetree.class_type_declaration list -> class_type_info list -val virtual_methods: Types.class_signature -> label list - +val virtual_methods : Types.class_signature -> label list -type error +type error exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/analysis/vendor/ml/typecore.ml b/analysis/vendor/ml/typecore.ml index 0e8f61f98..909d73bab 100644 --- a/analysis/vendor/ml/typecore.ml +++ b/analysis/vendor/ml/typecore.ml @@ -25,14 +25,14 @@ 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 string @@ -44,7 +44,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 | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list * bool @@ -82,21 +81,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 Typeclass.class_structure *) @@ -110,46 +113,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,113 +159,100 @@ 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_class_type _ - | Pstr_attribute _ - | Pstr_extension _ -> () - | Pstr_include {pincl_mod = me} - | Pstr_module {pmb_expr = me} -> module_expr me + | 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_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 _ -> instance_def Predef.type_int64 | 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 'l') -> - begin - try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) - with Failure _ -> Error (Literal_overflow "int32") - end - | Pconst_integer (i,Some 'L') -> - begin - try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) - with Failure _ -> Error (Literal_overflow "int64") - 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 'l') -> ( + try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) + with Failure _ -> Error (Literal_overflow "int32")) + | Pconst_integer (i, Some 'L') -> ( + try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) + with Failure _ -> Error (Literal_overflow "int64")) + | 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 @@ -275,83 +261,81 @@ 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 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' = @@ -360,16 +344,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 *) @@ -379,29 +359,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 = @@ -410,18 +391,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 = @@ -429,184 +414,216 @@ 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) (* 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) @@ -614,64 +631,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 @@ -679,13 +708,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] -> @@ -697,84 +725,88 @@ 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 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 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 = let descrs = get_descrs (Env.find_type_descrs tpath env) in Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); match lid.txt with - Longident.Lident s -> begin - 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 + | 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) ))) | _ -> 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 = @@ -784,51 +816,60 @@ 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 @@ -845,12 +886,13 @@ let disambiguate_label_by_ids keep closed ids labels = Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; List.for_all (Hashtbl.mem lbls) ids and check_closed (lbl, _) = - (not closed || List.length ids = Array.length lbl.lbl_all) + (not closed) || List.length ids = Array.length lbl.lbl_all in let labels' = Ext_list.filter labels check_ids in - if keep && labels' = [] then (false, labels) else - let labels'' = Ext_list.filter labels' check_closed in - if keep && labels'' = [] then (false, labels') else (true, labels'') + if keep && labels' = [] then (false, labels) + else + let labels'' = Ext_list.filter labels' check_closed in + if keep && 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 = @@ -859,8 +901,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 = @@ -873,106 +914,112 @@ 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 (opath=None) closed ids scope + | Some (_, _) -> (true, scope) (* disambiguate only checks scope *) + | _ -> disambiguate_label_by_ids (opath = None) 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 loc lbl_pat_list closed = match lbl_pat_list with - | [] -> () (* should not happen *) + | [] -> () (* should not happen *) | (_, 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(loc, Env.empty, Label_multiply_defined label.lbl_name)) - else defined.(label.lbl_pos) <- true in - List.iter check_defined lbl_pat_list; - if closed = Closed + 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 (loc, Env.empty, Label_multiply_defined label.lbl_name)) + 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 *) @@ -988,12 +1035,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 *) @@ -1001,14 +1048,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; @@ -1017,9 +1059,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 @@ -1028,439 +1070,505 @@ 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 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) -> - 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) -> + assert (constrs = None); + type_pat sq expected_ty (fun q -> begin_def (); let ty_var = 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 opath, record_ty = - try - let (p0, p, _, _) = extract_concrete_record !env expected_ty in - Some (p0, p), expected_ty - with Not_found -> None, newvar () + 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 opath, record_ty = + try + let p0, p, _, _ = extract_concrete_record !env expected_ty in + (Some (p0, p), expected_ty) + with Not_found -> (None, newvar ()) + in + let process_optional_label (ld, pat) = + let exp_optional_attr = + check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc 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 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 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 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 @@ -1468,7 +1576,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 = @@ -1478,8 +1585,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; @@ -1489,35 +1596,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; @@ -1526,94 +1641,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 = @@ -1623,104 +1734,100 @@ 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 _ -> false (* could be more precise *) - | 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 _ -> false (* could be more precise *) + | 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, sty1, 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 sty1 - 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 sty1 + 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 @@ -1733,43 +1840,52 @@ 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 (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) @@ -1777,25 +1893,29 @@ let self_coercion = ref ([] : (Path.t * Location.t list ref) list) (* 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 *) @@ -1803,99 +1923,131 @@ 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 loc env = function | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> - raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name)) - | _ :: rem -> - check_duplicates loc env rem - | [] -> () + raise (Error (loc, env, Label_multiply_defined lbl1.lbl_name)) + | _ :: rem -> check_duplicates loc env rem + | [] -> () + (* Getting proper location of already typed expressions. Used to avoid confusing locations on type error messages in presence of @@ -1917,22 +2069,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 *) @@ -1940,28 +2093,30 @@ 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 = @@ -1969,15 +2124,14 @@ let not_function env ty = ls = [] && not tvar let check_might_be_component env ty_record = - match (expand_head env ty_record).desc with - | Tconstr (path, _, _) when path |> Path.last = "props" -> true + match (expand_head env ty_record).desc with + | Tconstr (path, _, _) when path |> Path.last = "props" -> true | _ -> false - -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 ()) @@ -1986,21 +2140,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 = @@ -2008,549 +2162,670 @@ 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 = - Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.uapp") - && 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_exp ?(loc=Location.none) exp_desc exp_type = - { exp_desc; - exp_loc = loc; exp_extra = []; - exp_type; - exp_attributes = []; - exp_env = env } in - let apply_internal name e = - let lid:Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in - let (path, desc) = Env.lookup_value lid env in - let id = mk_exp (Texp_ident(path, {txt=lid; loc=Location.none}, desc)) desc.val_type in - mk_exp ~loc:e.exp_loc (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in - - let mk_apply funct args = - rue { - exp_desc = Texp_apply(funct, args); - exp_loc = loc; exp_extra = []; + 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 = + Ext_list.exists sexp.pexp_attributes (fun ({txt}, _) -> txt = "res.uapp") + && 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_exp ?(loc = Location.none) exp_desc exp_type = + { + exp_desc; + exp_loc = loc; + exp_extra = []; + exp_type; + exp_attributes = []; + exp_env = env; + } + in + let apply_internal name e = + let lid : Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in + let path, desc = Env.lookup_value lid env in + let id = + mk_exp + (Texp_ident (path, {txt = lid; loc = Location.none}, desc)) + desc.val_type + in + mk_exp ~loc:e.exp_loc (Texp_apply (id, [(Nolabel, Some e)])) e.exp_type + in + + 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 (apply_internal "opaqueFullApply" (mk_apply (apply_internal "opaque" 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 + (apply_internal "opaqueFullApply" + (mk_apply (apply_internal "opaque" 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}); + 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 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 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 ( - let might_be_component = check_might_be_component env ty_record in - raise(Error(loc, env, Labels_missing (labels_missing, might_be_component)))); - [||], 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 ( - let might_be_component = check_might_be_component env ty_record in - raise(Error(loc, env, Labels_missing ((List.rev !labels_missing), might_be_component)))); - let fields = - Array.map2 (fun descr def -> descr, def) - label_descriptions label_definitions + 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 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 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 - 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 + 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 - 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 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 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 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 + let might_be_component = check_might_be_component env ty_record in + raise + (Error + (loc, env, Labels_missing (labels_missing, might_be_component)))); + ([||], 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 + let might_be_component = check_might_be_component env ty_record in + raise + (Error + ( loc, + env, + Labels_missing (List.rev !labels_missing, might_be_component) ))); + 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 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 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'; @@ -2559,251 +2834,272 @@ 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, 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,cty') = - match sty with - | None -> - 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 - begin match arg.exp_desc, !self_coercion, (repr ty').desc with - | _ when free_variables ~env arg.exp_type = [] - && free_variables ~env ty' = [] -> - 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; - | _ -> - let ty, b = enlarge_type env ty' in - force (); - begin try Ctype.unify env arg.exp_type ty with Unify trace -> - raise(Error(sarg.pexp_loc, env, - Coercion_failure(ty', full_expand env ty', trace, b))) - end - end; - (arg, ty', None, cty') - | Some sty -> - if separate then begin_def (); - let (cty, force) = - Typetexp.transl_simple_type_delayed env sty - and (cty', force') = - Typetexp.transl_simple_type_delayed env sty' - in - let ty = cty.ctyp_type in - let ty' = cty'.ctyp_type in - begin try - let force'' = subtype env ty ty' in - force (); force' (); force'' () + | Pexp_coerce (sarg, sty, 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, cty' = + match sty with + | None -> + 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 + (match (arg.exp_desc, !self_coercion, (repr ty').desc) with + | _ + when free_variables ~env arg.exp_type = [] + && free_variables ~env ty' = [] -> ( + 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) -> - raise(Error(loc, env, Not_subtype(tr1, tr2))) - end; - if separate then begin - end_def (); - generalize_structure ty; - generalize_structure ty'; - (type_argument env sarg ty (instance env ty), - instance env ty', Some cty, cty') - end else - (type_argument env sarg ty ty, ty', Some cty, cty') - in - rue { + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype (tr1, tr2)))) + | _ -> ( + let ty, b = enlarge_type env ty' in + force (); + try Ctype.unify env arg.exp_type ty + with Unify trace -> + raise + (Error + ( sarg.pexp_loc, + env, + Coercion_failure (ty', full_expand env ty', trace, b) )))); + (arg, ty', None, cty') + | Some sty -> + if separate then begin_def (); + let cty, force = Typetexp.transl_simple_type_delayed env sty + and cty', force' = Typetexp.transl_simple_type_delayed env sty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + (try + let force'' = subtype env ty ty' in + force (); + force' (); + force'' () + with Subtype (tr1, tr2) -> + raise (Error (loc, env, Not_subtype (tr1, tr2)))); + if separate then ( + end_def (); + generalize_structure ty; + generalize_structure ty'; + ( type_argument env sarg ty (instance env ty), + instance env ty', + Some cty, + cty' )) + else (type_argument env sarg ty ty, ty', Some cty, 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, cty'), loc, sexp.pexp_attributes) :: - arg.exp_extra; + exp_extra = + (Texp_coerce (cty, 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; @@ -2816,304 +3112,355 @@ 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 let ty_exp = record.exp_type in let opath = try - let (p0, p, _, _) = extract_concrete_record env ty_exp in - Some(p0, p) + let p0, p, _, _ = extract_concrete_record env ty_exp in + Some (p0, p) 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 *) - !Config.uncurried = Uncurried && + !Config.uncurried = Uncurried + && 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 = @@ -3123,260 +3470,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; @@ -3384,29 +3792,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 @@ -3415,24 +3823,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} -> @@ -3440,41 +3853,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 = @@ -3482,34 +3893,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 *) @@ -3517,55 +3934,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 @@ -3573,32 +3993,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 = @@ -3617,94 +4039,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) @@ -3713,25 +4125,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) @@ -3740,47 +4156,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) @@ -3790,312 +4205,331 @@ open Printtyp 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 - (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 *) reset_and_mark_loops typ; - 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 - reset_and_mark_loops ty; - fprintf ppf - "@[@[<2>The function applied to this argument has type@ %a@]@.\ - This argument cannot be applied %a@]" - type_expr ty print_label l + 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 + reset_and_mark_loops ty; + 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 s -> - fprintf ppf "The record field label %s is defined several times" s + fprintf ppf "The record field label %s is defined several times" s | Labels_missing (labels, might_be_component) -> - let print_labels ppf = - List.iter (fun lbl -> fprintf ppf "@ %s" ( lbl)) in - let component_text = if might_be_component then " If this is a component, add the missing props." else "" in - fprintf ppf "@[Some required record fields are missing:%a.%s@]" - print_labels labels component_text + let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in + let component_text = + if might_be_component then + " If this is a component, add the missing props." + else "" + in + fprintf ppf "@[Some required record fields are missing:%a.%s@]" + print_labels labels component_text | Label_not_mutable lid -> - fprintf ppf "The record field %a is not mutable" longident lid + fprintf ppf "The record field %a is not mutable" longident lid | Wrong_name (eorp, ty, kind, p, name, valid_names) -> (* modified *) reset_and_mark_loops ty; - 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 + 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>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 "@[<2>%s type@ @{%a@}@]" eorp type_expr ty; - fprintf ppf "@]"; - end; - spellcheck ppf name valid_names; + 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) -> - reset_and_mark_loops ty; - 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 + 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) -> ( + reset_and_mark_loops ty; + 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 | Coercion_failure (ty, ty', trace, b) -> (* modified *) super_report_unification_error ppf env trace - (function ppf -> - let ty, ty' = Printtyp.prepare_expansion (ty, ty') in - fprintf ppf - "This expression cannot be coerced to type@;<1 2>%a;@ it has type" - (Printtyp.type_expansion ty) ty') - (function ppf -> - fprintf ppf "but is here used with type"); + (function + | ppf -> + let ty, ty' = Printtyp.prepare_expansion (ty, ty') in + fprintf ppf + "This expression cannot be coerced to type@;<1 2>%a;@ it has type" + (Printtyp.type_expansion ty) + ty') + (function + | ppf -> fprintf ppf "but is here used with type"); if b then fprintf ppf ".@.@[%s@ %s@]" "This simple coercion was not fully general." "Consider using a double coercion." - | Too_many_arguments (in_function, ty) -> + | Too_many_arguments (in_function, ty) -> ( (* modified *) reset_and_mark_loops ty; - if in_function then begin + if 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 - reset_and_mark_loops ty; - fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" - type_expr ty (label_mark l) - | Scoping_let_module(id, ty) -> - reset_and_mark_loops 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 + reset_and_mark_loops ty; + fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" type_expr + ty (label_mark l) + | Scoping_let_module (id, ty) -> + reset_and_mark_loops 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 path tpath - "must be qualified in this pattern" + fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]" name 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 uncurried 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 uncurried 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 let super_report_error_no_wrap_printing_env = report_error - let report_error env ppf err = 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/analysis/vendor/ml/typecore.mli b/analysis/vendor/ml/typecore.mli index 23cbeedb2..af467a424 100644 --- a/analysis/vendor/ml/typecore.mli +++ b/analysis/vendor/ml/typecore.mli @@ -19,41 +19,48 @@ 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 @@ -61,14 +68,16 @@ val name_pattern : string -> Typedtree.case list -> Ident.t val self_coercion : (Path.t * Location.t list ref) list ref 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 string @@ -114,29 +123,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 Typeclass.class_structure *) -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 Typeclass.class_structure *) +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/analysis/vendor/ml/typedecl.ml b/analysis/vendor/ml/typedecl.ml index f6fb1627b..d1e63ffcf 100644 --- a/analysis/vendor/ml/typedecl.ml +++ b/analysis/vendor/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,98 +193,106 @@ 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 = - if !Config.bs_only then - match !Builtin_attributes.check_duplicated_labels lbls with - | None -> () - | Some {loc;txt=name} -> raise (Error(loc,Duplicate_label (name, record_name))) - else ( - let all_labels = ref StringSet.empty in - List.iter - (fun {pld_name = {txt=name; loc}} -> - if StringSet.mem name !all_labels then - raise(Error(loc, Duplicate_label (name, record_name))); - all_labels := StringSet.add name !all_labels) - lbls); - 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} - ) + (if !Config.bs_only then + match !Builtin_attributes.check_duplicated_labels lbls with + | None -> () + | Some {loc; txt = name} -> + raise (Error (loc, Duplicate_label (name, record_name))) + else + let all_labels = ref StringSet.empty in + List.iter + (fun {pld_name = {txt = name; loc}} -> + if StringSet.mem name !all_labels then + raise (Error (loc, Duplicate_label (name, record_name))); + all_labels := StringSet.add name !all_labels) + lbls); + 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 @@ -291,356 +300,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 *) @@ -649,96 +751,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, @@ -747,32 +840,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) = @@ -784,53 +874,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 @@ -839,15 +929,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 *) @@ -855,58 +949,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 @@ -923,25 +1021,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 @@ -949,55 +1047,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 - 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 + (cvari Inv && cv Inj) || ((cvari Pos || cvari Neg) && cv Inv) 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 @@ -1012,7 +1107,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 *) @@ -1021,81 +1117,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 *) @@ -1107,104 +1211,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 *) @@ -1213,8 +1318,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 @@ -1227,44 +1333,42 @@ 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)) (* for typeclass.ml *) let compute_variance_decls env cldecls = @@ -1272,21 +1376,22 @@ let compute_variance_decls env cldecls = List.fold_right (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) -> let variance = List.map snd ci.ci_params in - (obj_id, obj_abbr) :: decls, - (add_injectivity variance, ci.ci_loc) :: req) - cldecls ([],[]) + ( (obj_id, obj_abbr) :: decls, + (add_injectivity variance, ci.ci_loc) :: req )) + cldecls ([], []) in - let (decls, _) = + let decls, _ = compute_properties_fixpoint env decls required (List.map init_variance decls) (List.map (fun _ -> false) decls) in List.map2 - (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) -> + (fun (_, decl) (_, _, cl_abbr, clty, cltydef, _) -> let variance = decl.type_variance in - (decl, {cl_abbr with type_variance = variance}, - {clty with cty_variance = variance}, - {cltydef with clty_variance = variance})) + ( decl, + {cl_abbr with type_variance = variance}, + {clty with cty_variance = variance}, + {cltydef with clty_variance = variance} )) decls cldecls (* Check multiple declarations of labels/constructors *) @@ -1294,46 +1399,46 @@ let compute_variance_decls env cldecls = 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 @@ -1345,16 +1450,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. *) @@ -1367,48 +1478,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; @@ -1419,54 +1527,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 = @@ -1479,275 +1590,259 @@ 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 ext = - { ext_type_path = type_path; + { + ext_type_path = type_path; ext_type_params = typext_params; ext_args = args; ext_ret_type = ret_type; ext_private = priv; Types.ext_loc = sext.pext_loc; - Types.ext_attributes = sext.pext_attributes; } + Types.ext_attributes = sext.pext_attributes; + } in - { ext_id = id; - ext_name = sext.pext_name; - ext_type = ext; - ext_kind = kind; - Typedtree.ext_loc = sext.pext_loc; - Typedtree.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) + { + ext_id = id; + ext_name = sext.pext_name; + ext_type = ext; + ext_kind = kind; + Typedtree.ext_loc = sext.pext_loc; + Typedtree.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_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 parse_native_repr_attributes 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, _) -> - let repr_arg = Same_as_ocaml_repr in - let repr_args, repr_res = - parse_native_repr_attributes env ct2 t2 - in + let repr_arg = Same_as_ocaml_repr in + let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in (repr_arg :: repr_args, repr_res) | Ptyp_arrow _, _ | _, Tarrow _ -> assert false | _ -> ([], Same_as_ocaml_repr) - let parse_native_repr_attributes env core_type ty = - match core_type.ptyp_desc, (Ctype.repr ty).desc - with - | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}; _]), - Tconstr (Pident {name = "function$"},[{desc = Tarrow (_, _, t2, _)}; _],_) -> + match (core_type.ptyp_desc, (Ctype.repr ty).desc) with + | ( Ptyp_constr + ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}; _]), + Tconstr + (Pident {name = "function$"}, [{desc = Tarrow (_, _, t2, _)}; _], _) ) + -> let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in let native_repr_args = Same_as_ocaml_repr :: repr_args in (native_repr_args, repr_res) @@ -1758,116 +1853,134 @@ 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)) - | _ -> + 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 native_repr_args, native_repr_res = - let rec scann (attrs : Parsetree.attributes) = - match attrs with - | ({txt = "internal.arity";_}, - PStr [ {pstr_desc = Pstr_eval - ( - ({pexp_desc = Pexp_constant (Pconst_integer (i,_))} : - Parsetree.expression) ,_)}]) :: _ -> - Some (int_of_string i) - | _ :: rest -> scann rest - | [] -> None - and make n = - if n = 0 then [] - else Primitive.Same_as_ocaml_repr :: make (n - 1) - in - match scann valdecl.pval_attributes with - | None -> parse_native_repr_attributes env valdecl.pval_type ty - | Some x -> make x , Primitive.Same_as_ocaml_repr + let rec scann (attrs : Parsetree.attributes) = + match attrs with + | ( {txt = "internal.arity"; _}, + PStr + [ + { + pstr_desc = + Pstr_eval + ( ({pexp_desc = Pexp_constant (Pconst_integer (i, _))} : + Parsetree.expression), + _ ); + }; + ] ) + :: _ -> + Some (int_of_string i) + | _ :: rest -> scann rest + | [] -> None + and make n = + if n = 0 then [] else Primitive.Same_as_ocaml_repr :: make (n - 1) + in + match scann valdecl.pval_attributes with + | None -> parse_native_repr_attributes env valdecl.pval_type ty + | Some x -> (make x, Primitive.Same_as_ocaml_repr) in let prim = - Primitive.parse_declaration valdecl - ~native_repr_args - ~native_repr_res + Primitive.parse_declaration valdecl ~native_repr_args ~native_repr_res 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; @@ -1880,12 +1993,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 @@ -1893,7 +2006,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; @@ -1912,10 +2025,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; @@ -1926,16 +2041,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 @@ -1944,12 +2060,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 @@ -1957,208 +2071,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}}) @@ -2181,24 +2289,27 @@ 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.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/analysis/vendor/ml/typedecl.mli b/analysis/vendor/ml/typedecl.mli index 03f1b8bab..8f8e527ac 100644 --- a/analysis/vendor/ml/typedecl.mli +++ b/analysis/vendor/ml/typedecl.mli @@ -18,55 +18,71 @@ 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 typeclass.ml *) -val compute_variance_decls: - Env.t -> - (Ident.t * Types.type_declaration * Types.type_declaration * - Types.class_declaration * Types.class_type_declaration * - 'a Typedtree.class_infos) list -> - (Types.type_declaration * Types.type_declaration * - Types.class_declaration * Types.class_type_declaration) list +val compute_variance_decls : + Env.t -> + (Ident.t + * Types.type_declaration + * Types.type_declaration + * Types.class_declaration + * Types.class_type_declaration + * 'a Typedtree.class_infos) + list -> + (Types.type_declaration + * Types.type_declaration + * Types.class_declaration + * Types.class_type_declaration) + list (* 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/analysis/vendor/ml/typedtree.ml b/analysis/vendor/ml/typedtree.ml index 5744f0dc6..a975ca334 100644 --- a/analysis/vendor/ml/typedtree.ml +++ b/analysis/vendor/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 class_type_declaration list | 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,123 +321,118 @@ 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 -and class_type = - { - cltyp_desc: class_type_desc; - cltyp_type: Types.class_type; - cltyp_env: Env.t; - cltyp_loc: Location.t; - cltyp_attributes: attribute list; - } +and class_type = { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attribute list; +} and class_type_desc = - Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type and class_signature = { - csig_self: core_type; - csig_fields: class_type_field list; - csig_type: Types.class_signature; - } + csig_self: core_type; + csig_fields: class_type_field list; + csig_type: Types.class_signature; +} and class_type_field = { - ctf_desc: class_type_field_desc; - ctf_loc: Location.t; - ctf_attributes: attribute list; - } + ctf_desc: class_type_field_desc; + ctf_loc: Location.t; + ctf_attributes: attribute list; +} and class_type_field_desc = | Tctf_inherit of class_type @@ -456,78 +441,67 @@ and class_type_field_desc = | Tctf_constraint of (core_type * core_type) | Tctf_attribute of attribute - -and class_description = - class_type class_infos - -and class_type_declaration = - class_type class_infos - -and 'a class_infos = - { ci_virt: virtual_flag; - ci_params: (core_type * variance) list; - ci_id_name: string loc; - ci_id_class: Ident.t; - ci_id_class_type: Ident.t; - ci_id_object: Ident.t; - ci_id_typehash: Ident.t; - ci_expr: 'a; - ci_decl: Types.class_declaration; - ci_type_decl: Types.class_type_declaration; - ci_loc: Location.t; - ci_attributes: attribute list; - } +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +and 'a class_infos = { + ci_virt: virtual_flag; + ci_params: (core_type * variance) list; + ci_id_name: string loc; + ci_id_class: Ident.t; + ci_id_class_type: Ident.t; + ci_id_object: Ident.t; + ci_id_typehash: Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl: Types.class_type_declaration; + ci_loc: Location.t; + ci_attributes: attribute list; +} (* 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 = @@ -540,30 +514,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/analysis/vendor/ml/typedtree.mli b/analysis/vendor/ml/typedtree.mli index a4559f361..d51696122 100644 --- a/analysis/vendor/ml/typedtree.mli +++ b/analysis/vendor/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,94 +57,86 @@ 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 core_type option * core_type - (** E :> T [Texp_coerce (None, T)] + (** E :> T [Texp_coerce (None, T)] E : T0 :> T [Texp_coerce (Some T0, 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 @@ -156,7 +147,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. @@ -172,7 +163,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 @@ -180,22 +171,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 @@ -214,8 +204,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 @@ -230,65 +224,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 @@ -303,70 +288,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 @@ -379,63 +363,59 @@ and signature_item_desc = | Tsig_class_type of class_type_declaration list | 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 @@ -448,124 +428,118 @@ 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 -and class_type = - { - cltyp_desc: class_type_desc; - cltyp_type: Types.class_type; - cltyp_env: Env.t; - cltyp_loc: Location.t; - cltyp_attributes: attributes; - } +and class_type = { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attributes; +} and class_type_desc = - Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type and class_signature = { - csig_self : core_type; - csig_fields : class_type_field list; - csig_type : Types.class_signature; - } + csig_self: core_type; + csig_fields: class_type_field list; + csig_type: Types.class_signature; +} and class_type_field = { - ctf_desc: class_type_field_desc; - ctf_loc: Location.t; - ctf_attributes: attributes; - } + ctf_desc: class_type_field_desc; + ctf_loc: Location.t; + ctf_attributes: attributes; +} and class_type_field_desc = | Tctf_inherit of class_type @@ -574,41 +548,37 @@ and class_type_field_desc = | Tctf_constraint of (core_type * core_type) | Tctf_attribute of attribute - -and class_description = - class_type class_infos - -and class_type_declaration = - class_type class_infos - -and 'a class_infos = - { ci_virt: virtual_flag; - ci_params: (core_type * variance) list; - ci_id_name : string loc; - ci_id_class: Ident.t; - ci_id_class_type : Ident.t; - ci_id_object : Ident.t; - ci_id_typehash : Ident.t; - ci_expr: 'a; - ci_decl: Types.class_declaration; - ci_type_decl : Types.class_type_declaration; - ci_loc: Location.t; - ci_attributes: attributes; - } +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +and 'a class_infos = { + ci_virt: virtual_flag; + ci_params: (core_type * variance) list; + ci_id_name: string loc; + ci_id_class: Ident.t; + ci_id_class_type: Ident.t; + ci_id_object: Ident.t; + ci_id_typehash: Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl: Types.class_type_declaration; + ci_loc: Location.t; + ci_attributes: attributes; +} (* 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/analysis/vendor/ml/typedtreeIter.ml b/analysis/vendor/ml/typedtreeIter.ml index 779a7c927..c151d6024 100644 --- a/analysis/vendor/ml/typedtreeIter.ml +++ b/analysis/vendor/ml/typedtreeIter.ml @@ -23,572 +23,493 @@ 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_class_signature : class_signature -> unit + + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> 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_class_signature : class_signature -> unit + + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> 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_class_signature : class_signature -> unit - - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> 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_class_signature : class_signature -> unit - - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> 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 list -> - List.iter - (fun (_, _, ct) -> iter_class_type_declaration ct) - list - | 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 (cty1, cty2) -> - option iter_core_type cty1; 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 list -> - List.iter iter_class_type_declaration list - | 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_class_type_declaration cd = - Iter.enter_class_type_declaration cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_type cd.ci_expr; - Iter.leave_class_type_declaration cd; - - 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 list -> + List.iter (fun (_, _, ct) -> iter_class_type_declaration ct) list + | 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_class_type ct = - Iter.enter_class_type ct; - begin - match ct.cltyp_desc with - Tcty_signature csg -> iter_class_signature csg - | Tcty_constr (_path, _, list) -> - List.iter iter_core_type list - | Tcty_arrow (_label, ct, cl) -> - iter_core_type ct; - iter_class_type cl - | Tcty_open (_, _, _, _, e) -> - iter_class_type e - end; - Iter.leave_class_type ct; - - and iter_class_signature cs = - Iter.enter_class_signature cs; - iter_core_type cs.csig_self; - List.iter iter_class_type_field cs.csig_fields; - Iter.leave_class_signature cs - - - and iter_class_type_field ctf = - Iter.enter_class_type_field ctf; - begin - match ctf.ctf_desc with - Tctf_inherit ct -> iter_class_type ct - | Tctf_val (_s, _mut, _virt, ct) -> - iter_core_type ct - | Tctf_method (_s, _priv, _virt, ct) -> - iter_core_type ct - | Tctf_constraint (ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Tctf_attribute _ -> () - end; - Iter.leave_class_type_field ctf - - 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 (_path, _, list) -> - List.iter iter_core_type list - | 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 (cty1, cty2) -> + option iter_core_type cty1; + 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 list -> List.iter iter_class_type_declaration list + | 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_class_type_declaration cd = + Iter.enter_class_type_declaration cd; + List.iter iter_type_parameter cd.ci_params; + iter_class_type cd.ci_expr; + Iter.leave_class_type_declaration cd + + 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_class_type ct = + Iter.enter_class_type ct; + (match ct.cltyp_desc with + | Tcty_signature csg -> iter_class_signature csg + | Tcty_constr (_path, _, list) -> List.iter iter_core_type list + | Tcty_arrow (_label, ct, cl) -> + iter_core_type ct; + iter_class_type cl + | Tcty_open (_, _, _, _, e) -> iter_class_type e); + Iter.leave_class_type ct + + and iter_class_signature cs = + Iter.enter_class_signature cs; + iter_core_type cs.csig_self; + List.iter iter_class_type_field cs.csig_fields; + Iter.leave_class_signature cs + + and iter_class_type_field ctf = + Iter.enter_class_type_field ctf; + (match ctf.ctf_desc with + | Tctf_inherit ct -> iter_class_type ct + | Tctf_val (_s, _mut, _virt, ct) -> iter_core_type ct + | Tctf_method (_s, _priv, _virt, ct) -> iter_core_type ct + | Tctf_constraint (ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Tctf_attribute _ -> ()); + Iter.leave_class_type_field ctf + + 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 (_path, _, list) -> List.iter iter_core_type list + | 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_class_signature _ = () - - let enter_class_description _ = () - let enter_class_type_declaration _ = () - let enter_class_type _ = () - let enter_class_type_field _ = () - 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_class_signature _ = () - - let leave_class_description _ = () - let leave_class_type_declaration _ = () - let leave_class_type _ = () - let leave_class_type_field _ = () - 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_class_signature _ = () + + let enter_class_description _ = () + let enter_class_type_declaration _ = () + let enter_class_type _ = () + let enter_class_type_field _ = () + 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_class_signature _ = () + + let leave_class_description _ = () + let leave_class_type_declaration _ = () + let leave_class_type _ = () + let leave_class_type_field _ = () + 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/analysis/vendor/ml/typedtreeIter.mli b/analysis/vendor/ml/typedtreeIter.mli index b215c20d0..6d80727f5 100644 --- a/analysis/vendor/ml/typedtreeIter.mli +++ b/analysis/vendor/ml/typedtreeIter.mli @@ -16,73 +16,69 @@ 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_class_signature : class_signature -> unit - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> 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_class_signature : class_signature -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> 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_class_signature : class_signature -> unit - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> 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_class_signature : class_signature -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> 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/analysis/vendor/ml/typedtreeMap.ml b/analysis/vendor/ml/typedtreeMap.ml index 7d4119b33..e38199df1 100644 --- a/analysis/vendor/ml/typedtreeMap.ml +++ b/analysis/vendor/ml/typedtreeMap.ml @@ -28,7 +28,7 @@ module type MapArgument = sig val enter_signature : signature -> signature val enter_signature_item : signature_item -> signature_item val enter_module_type_declaration : - module_type_declaration -> module_type_declaration + module_type_declaration -> module_type_declaration val enter_module_type : module_type -> module_type val enter_module_expr : module_expr -> module_expr val enter_with_constraint : with_constraint -> with_constraint @@ -54,7 +54,7 @@ module type MapArgument = sig val leave_signature : signature -> signature val leave_signature_item : signature_item -> signature_item val leave_module_type_declaration : - module_type_declaration -> module_type_declaration + module_type_declaration -> module_type_declaration val leave_module_type : module_type -> module_type val leave_module_expr : module_expr -> module_expr val leave_with_constraint : with_constraint -> with_constraint @@ -67,18 +67,15 @@ module type MapArgument = sig val leave_class_type_field : class_type_field -> class_type_field val leave_core_type : core_type -> core_type val leave_structure_item : structure_item -> structure_item - end - -module MakeMap(Map : MapArgument) = struct - +module MakeMap (Map : MapArgument) = struct open Misc let rec map_structure str = let str = Map.enter_structure str in let str_items = List.map map_structure_item str.str_items in - Map.leave_structure { str with str_items = str_items } + Map.leave_structure {str with str_items} and map_binding vb = { @@ -88,396 +85,330 @@ module MakeMap(Map : MapArgument) = struct vb_loc = vb.vb_loc; } - and map_bindings list = - List.map map_binding list + and map_bindings list = List.map map_binding list and map_case {c_lhs; c_guard; c_rhs} = { - c_lhs = map_pattern c_lhs; - c_guard = may_map map_expression c_guard; - c_rhs = map_expression c_rhs; + c_lhs = map_pattern c_lhs; + c_guard = may_map map_expression c_guard; + c_rhs = map_expression c_rhs; } - and map_cases list = - List.map map_case list + and map_cases list = List.map map_case list and map_structure_item item = let item = Map.enter_structure_item item in let str_desc = match item.str_desc with - Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs) - | Tstr_value (rec_flag, list) -> - Tstr_value (rec_flag, map_bindings list) - | Tstr_primitive vd -> - Tstr_primitive (map_value_description vd) - | Tstr_type (rf, list) -> - Tstr_type (rf, List.map map_type_declaration list) - | Tstr_typext tyext -> - Tstr_typext (map_type_extension tyext) - | Tstr_exception ext -> - Tstr_exception (map_extension_constructor ext) - | Tstr_module x -> - Tstr_module (map_module_binding x) - | Tstr_recmodule list -> - let list = List.map map_module_binding list in - Tstr_recmodule list - | Tstr_modtype mtd -> - Tstr_modtype (map_module_type_declaration mtd) - | Tstr_open od -> Tstr_open od - | Tstr_class () -> assert false - | Tstr_class_type list -> - let list = - List.map - (fun (id, name, ct) -> - id, name, map_class_type_declaration ct) - list - in - Tstr_class_type list - | Tstr_include incl -> - Tstr_include {incl with incl_mod = map_module_expr incl.incl_mod} - | Tstr_attribute x -> Tstr_attribute x + | Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs) + | Tstr_value (rec_flag, list) -> Tstr_value (rec_flag, map_bindings list) + | Tstr_primitive vd -> Tstr_primitive (map_value_description vd) + | Tstr_type (rf, list) -> + Tstr_type (rf, List.map map_type_declaration list) + | Tstr_typext tyext -> Tstr_typext (map_type_extension tyext) + | Tstr_exception ext -> Tstr_exception (map_extension_constructor ext) + | Tstr_module x -> Tstr_module (map_module_binding x) + | Tstr_recmodule list -> + let list = List.map map_module_binding list in + Tstr_recmodule list + | Tstr_modtype mtd -> Tstr_modtype (map_module_type_declaration mtd) + | Tstr_open od -> Tstr_open od + | Tstr_class () -> assert false + | Tstr_class_type list -> + let list = + List.map + (fun (id, name, ct) -> (id, name, map_class_type_declaration ct)) + list + in + Tstr_class_type list + | Tstr_include incl -> + Tstr_include {incl with incl_mod = map_module_expr incl.incl_mod} + | Tstr_attribute x -> Tstr_attribute x in - Map.leave_structure_item { item with str_desc = str_desc} + Map.leave_structure_item {item with str_desc} - and map_module_binding x = - {x with mb_expr = map_module_expr x.mb_expr} + and map_module_binding x = {x with mb_expr = map_module_expr x.mb_expr} and map_value_description v = let v = Map.enter_value_description v in let val_desc = map_core_type v.val_desc in - Map.leave_value_description { v with val_desc = val_desc } + Map.leave_value_description {v with val_desc} and map_type_declaration decl = let decl = Map.enter_type_declaration decl in let typ_params = List.map map_type_parameter decl.typ_params in - let typ_cstrs = List.map (fun (ct1, ct2, loc) -> - (map_core_type ct1, - map_core_type ct2, - loc) - ) decl.typ_cstrs in - let typ_kind = match decl.typ_kind with - Ttype_abstract -> Ttype_abstract + let typ_cstrs = + List.map + (fun (ct1, ct2, loc) -> (map_core_type ct1, map_core_type ct2, loc)) + decl.typ_cstrs + in + let typ_kind = + match decl.typ_kind with + | Ttype_abstract -> Ttype_abstract | Ttype_variant list -> - let list = List.map map_constructor_declaration list in - Ttype_variant list + let list = List.map map_constructor_declaration list in + Ttype_variant list | Ttype_record list -> let list = - List.map - (fun ld -> - {ld with ld_type = map_core_type ld.ld_type} - ) list + List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) list in Ttype_record list | Ttype_open -> Ttype_open in let typ_manifest = may_map map_core_type decl.typ_manifest in - Map.leave_type_declaration { decl with typ_params = typ_params; - typ_cstrs = typ_cstrs; typ_kind = typ_kind; typ_manifest = typ_manifest } + Map.leave_type_declaration + {decl with typ_params; typ_cstrs; typ_kind; typ_manifest} and map_type_parameter (ct, v) = (map_core_type ct, v) and map_constructor_arguments = function - | Cstr_tuple l -> - Cstr_tuple (List.map map_core_type l) + | Cstr_tuple l -> Cstr_tuple (List.map map_core_type l) | Cstr_record l -> - Cstr_record - (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) - l) + Cstr_record + (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) l) and map_constructor_declaration cd = let cd_args = map_constructor_arguments cd.cd_args in - {cd with cd_args; - cd_res = may_map map_core_type cd.cd_res - } + {cd with cd_args; cd_res = may_map map_core_type cd.cd_res} and map_type_extension tyext = let tyext = Map.enter_type_extension tyext in let tyext_params = List.map map_type_parameter tyext.tyext_params in - let tyext_constructors = + let tyext_constructors = List.map map_extension_constructor tyext.tyext_constructors in - Map.leave_type_extension { tyext with tyext_params = tyext_params; - tyext_constructors = tyext_constructors } + Map.leave_type_extension {tyext with tyext_params; tyext_constructors} and map_extension_constructor ext = let ext = Map.enter_extension_constructor ext in - let ext_kind = match ext.ext_kind with - Text_decl(args, ret) -> - let args = map_constructor_arguments args in - let ret = may_map map_core_type ret in - Text_decl(args, ret) - | Text_rebind(p, lid) -> Text_rebind(p, lid) + let ext_kind = + match ext.ext_kind with + | Text_decl (args, ret) -> + let args = map_constructor_arguments args in + let ret = may_map map_core_type ret in + Text_decl (args, ret) + | Text_rebind (p, lid) -> Text_rebind (p, lid) in - Map.leave_extension_constructor {ext with ext_kind = ext_kind} + Map.leave_extension_constructor {ext with ext_kind} and map_pattern pat = let pat = Map.enter_pattern pat in let pat_desc = match pat.pat_desc with - | Tpat_alias (pat1, p, text) -> - let pat1 = map_pattern pat1 in - Tpat_alias (pat1, p, text) - | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) - | Tpat_construct (lid, cstr_decl, args) -> - Tpat_construct (lid, cstr_decl, - List.map map_pattern args) - | Tpat_variant (label, pato, rowo) -> - let pato = match pato with - None -> pato - | Some pat -> Some (map_pattern pat) - in - Tpat_variant (label, pato, rowo) - | Tpat_record (list, closed) -> - Tpat_record (List.map (fun (lid, lab_desc, pat) -> - (lid, lab_desc, map_pattern pat) ) list, closed) - | Tpat_array list -> Tpat_array (List.map map_pattern list) - | Tpat_or (p1, p2, rowo) -> - Tpat_or (map_pattern p1, map_pattern p2, rowo) - | Tpat_lazy p -> Tpat_lazy (map_pattern p) - | Tpat_constant _ - | Tpat_any - | Tpat_var _ -> pat.pat_desc - + | Tpat_alias (pat1, p, text) -> + let pat1 = map_pattern pat1 in + Tpat_alias (pat1, p, text) + | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) + | Tpat_construct (lid, cstr_decl, args) -> + Tpat_construct (lid, cstr_decl, List.map map_pattern args) + | Tpat_variant (label, pato, rowo) -> + let pato = + match pato with + | None -> pato + | Some pat -> Some (map_pattern pat) + in + Tpat_variant (label, pato, rowo) + | Tpat_record (list, closed) -> + Tpat_record + ( List.map + (fun (lid, lab_desc, pat) -> (lid, lab_desc, map_pattern pat)) + list, + closed ) + | Tpat_array list -> Tpat_array (List.map map_pattern list) + | Tpat_or (p1, p2, rowo) -> Tpat_or (map_pattern p1, map_pattern p2, rowo) + | Tpat_lazy p -> Tpat_lazy (map_pattern p) + | Tpat_constant _ | Tpat_any | Tpat_var _ -> pat.pat_desc in + let pat_extra = List.map map_pat_extra pat.pat_extra in - Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } + Map.leave_pattern {pat with pat_desc; pat_extra} and map_pat_extra pat_extra = match pat_extra with - | Tpat_constraint ct, loc, attrs -> - (Tpat_constraint (map_core_type ct), loc, attrs) - | (Tpat_type _ | Tpat_unpack | Tpat_open _ ), _, _ -> pat_extra + | Tpat_constraint ct, loc, attrs -> + (Tpat_constraint (map_core_type ct), loc, attrs) + | (Tpat_type _ | Tpat_unpack | Tpat_open _), _, _ -> pat_extra and map_expression exp = let exp = Map.enter_expression exp in let exp_desc = match exp.exp_desc with - Texp_ident (_, _, _) - | Texp_constant _ -> exp.exp_desc - | Texp_let (rec_flag, list, exp) -> - Texp_let (rec_flag, - map_bindings list, - map_expression exp) - | Texp_function { arg_label; param; cases; partial; } -> - Texp_function { arg_label; param; cases = map_cases cases; partial; } - | Texp_apply (exp, list) -> - Texp_apply (map_expression exp, - List.map (fun (label, expo) -> - let expo = - match expo with - None -> expo - | Some exp -> Some (map_expression exp) - in - (label, expo) - ) list ) - | Texp_match (exp, list1, list2, partial) -> - Texp_match ( - map_expression exp, - map_cases list1, - map_cases list2, - partial - ) - | Texp_try (exp, list) -> - Texp_try ( - map_expression exp, - map_cases list - ) - | Texp_tuple list -> - Texp_tuple (List.map map_expression list) - | Texp_construct (lid, cstr_desc, args) -> - Texp_construct (lid, cstr_desc, - List.map map_expression args ) - | Texp_variant (label, expo) -> - let expo =match expo with - None -> expo - | Some exp -> Some (map_expression exp) - in - Texp_variant (label, 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, map_expression exp)) - fields - in - let extended_expression = match extended_expression with - None -> extended_expression - | Some exp -> Some (map_expression exp) - in - Texp_record { fields; representation; extended_expression } - | Texp_field (exp, lid, label) -> - Texp_field (map_expression exp, lid, label) - | Texp_setfield (exp1, lid, label, exp2) -> - Texp_setfield ( - map_expression exp1, - lid, - label, - map_expression exp2) - | Texp_array list -> - Texp_array (List.map map_expression list) - | Texp_ifthenelse (exp1, exp2, expo) -> - Texp_ifthenelse ( - map_expression exp1, + | Texp_ident (_, _, _) | Texp_constant _ -> exp.exp_desc + | Texp_let (rec_flag, list, exp) -> + Texp_let (rec_flag, map_bindings list, map_expression exp) + | Texp_function {arg_label; param; cases; partial} -> + Texp_function {arg_label; param; cases = map_cases cases; partial} + | Texp_apply (exp, list) -> + Texp_apply + ( map_expression exp, + List.map + (fun (label, expo) -> + let expo = + match expo with + | None -> expo + | Some exp -> Some (map_expression exp) + in + (label, expo)) + list ) + | Texp_match (exp, list1, list2, partial) -> + Texp_match + (map_expression exp, map_cases list1, map_cases list2, partial) + | Texp_try (exp, list) -> Texp_try (map_expression exp, map_cases list) + | Texp_tuple list -> Texp_tuple (List.map map_expression list) + | Texp_construct (lid, cstr_desc, args) -> + Texp_construct (lid, cstr_desc, List.map map_expression args) + | Texp_variant (label, expo) -> + let expo = + match expo with + | None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_variant (label, 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, map_expression exp))) + fields + in + let extended_expression = + match extended_expression with + | None -> extended_expression + | Some exp -> Some (map_expression exp) + in + Texp_record {fields; representation; extended_expression} + | Texp_field (exp, lid, label) -> + Texp_field (map_expression exp, lid, label) + | Texp_setfield (exp1, lid, label, exp2) -> + Texp_setfield (map_expression exp1, lid, label, map_expression exp2) + | Texp_array list -> Texp_array (List.map map_expression list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse + ( map_expression exp1, map_expression exp2, match expo with - None -> expo - | Some exp -> Some (map_expression exp) - ) - | Texp_sequence (exp1, exp2) -> - Texp_sequence ( - map_expression exp1, - map_expression exp2 - ) - | Texp_while (exp1, exp2) -> - Texp_while ( - map_expression exp1, - map_expression exp2 - ) - | Texp_for (id, name, exp1, exp2, dir, exp3) -> - Texp_for ( - id, name, + | None -> expo + | Some exp -> Some (map_expression exp) ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence (map_expression exp1, map_expression exp2) + | Texp_while (exp1, exp2) -> + Texp_while (map_expression exp1, map_expression exp2) + | Texp_for (id, name, exp1, exp2, dir, exp3) -> + Texp_for + ( id, + name, map_expression exp1, map_expression exp2, dir, - map_expression exp3 - ) - | Texp_send (exp, meth, expo) -> - Texp_send (map_expression exp, meth, may_map map_expression expo) - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> - assert false - | Texp_letmodule (id, name, mexpr, exp) -> - Texp_letmodule ( - id, name, - map_module_expr mexpr, - map_expression exp - ) - | Texp_letexception (cd, exp) -> - Texp_letexception ( - map_extension_constructor cd, - map_expression exp - ) - | Texp_assert exp -> Texp_assert (map_expression exp) - | Texp_lazy exp -> Texp_lazy (map_expression exp) - | Texp_object () -> - Texp_object () - | Texp_pack (mexpr) -> - Texp_pack (map_module_expr mexpr) - | Texp_unreachable -> - Texp_unreachable - | Texp_extension_constructor _ as e -> - e + map_expression exp3 ) + | Texp_send (exp, meth, expo) -> + Texp_send (map_expression exp, meth, may_map map_expression expo) + | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ -> + assert false + | Texp_letmodule (id, name, mexpr, exp) -> + Texp_letmodule (id, name, map_module_expr mexpr, map_expression exp) + | Texp_letexception (cd, exp) -> + Texp_letexception (map_extension_constructor cd, map_expression exp) + | Texp_assert exp -> Texp_assert (map_expression exp) + | Texp_lazy exp -> Texp_lazy (map_expression exp) + | Texp_object () -> Texp_object () + | Texp_pack mexpr -> Texp_pack (map_module_expr mexpr) + | Texp_unreachable -> Texp_unreachable + | Texp_extension_constructor _ as e -> e in let exp_extra = List.map map_exp_extra exp.exp_extra in - Map.leave_expression { - exp with - exp_desc = exp_desc; - exp_extra = exp_extra; } + Map.leave_expression {exp with exp_desc; exp_extra} and map_exp_extra ((desc, loc, attrs) as exp_extra) = match desc with - | Texp_constraint ct -> - Texp_constraint (map_core_type ct), loc, attrs - | Texp_coerce (None, ct) -> - Texp_coerce (None, map_core_type ct), loc, attrs - | Texp_coerce (Some ct1, ct2) -> - Texp_coerce (Some (map_core_type ct1), - map_core_type ct2), loc, attrs - | Texp_poly (Some ct) -> - Texp_poly (Some ( map_core_type ct )), loc, attrs - | Texp_newtype _ - | Texp_open _ - | Texp_poly None -> exp_extra - + | Texp_constraint ct -> (Texp_constraint (map_core_type ct), loc, attrs) + | Texp_coerce (None, ct) -> + (Texp_coerce (None, map_core_type ct), loc, attrs) + | Texp_coerce (Some ct1, ct2) -> + (Texp_coerce (Some (map_core_type ct1), map_core_type ct2), loc, attrs) + | Texp_poly (Some ct) -> (Texp_poly (Some (map_core_type ct)), loc, attrs) + | Texp_newtype _ | Texp_open _ | Texp_poly None -> exp_extra and map_package_type pack = let pack = Map.enter_package_type pack in - let pack_fields = List.map ( - fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in - Map.leave_package_type { pack with pack_fields = pack_fields } + let pack_fields = + List.map (fun (s, ct) -> (s, map_core_type ct)) pack.pack_fields + in + Map.leave_package_type {pack with pack_fields} and map_signature sg = let sg = Map.enter_signature sg in let sig_items = List.map map_signature_item sg.sig_items in - Map.leave_signature { sg with sig_items = sig_items } + Map.leave_signature {sg with sig_items} and map_signature_item item = let item = Map.enter_signature_item item in let sig_desc = match item.sig_desc with - Tsig_value vd -> - Tsig_value (map_value_description vd) - | Tsig_type (rf, list) -> - Tsig_type (rf, List.map map_type_declaration list) - | Tsig_typext tyext -> - Tsig_typext (map_type_extension tyext) - | Tsig_exception ext -> - Tsig_exception (map_extension_constructor ext) - | Tsig_module md -> - Tsig_module {md with md_type = map_module_type md.md_type} - | Tsig_recmodule list -> - Tsig_recmodule - (List.map - (fun md -> {md with md_type = map_module_type md.md_type}) - list - ) - | Tsig_modtype mtd -> - Tsig_modtype (map_module_type_declaration mtd) - | Tsig_open _ -> item.sig_desc - | Tsig_include incl -> - Tsig_include {incl with incl_mod = map_module_type incl.incl_mod} - | Tsig_class () -> Tsig_class () - | Tsig_class_type list -> - Tsig_class_type (List.map map_class_type_declaration list) - | Tsig_attribute _ as x -> x + | Tsig_value vd -> Tsig_value (map_value_description vd) + | Tsig_type (rf, list) -> + Tsig_type (rf, List.map map_type_declaration list) + | Tsig_typext tyext -> Tsig_typext (map_type_extension tyext) + | Tsig_exception ext -> Tsig_exception (map_extension_constructor ext) + | Tsig_module md -> + Tsig_module {md with md_type = map_module_type md.md_type} + | Tsig_recmodule list -> + Tsig_recmodule + (List.map + (fun md -> {md with md_type = map_module_type md.md_type}) + list) + | Tsig_modtype mtd -> Tsig_modtype (map_module_type_declaration mtd) + | Tsig_open _ -> item.sig_desc + | Tsig_include incl -> + Tsig_include {incl with incl_mod = map_module_type incl.incl_mod} + | Tsig_class () -> Tsig_class () + | Tsig_class_type list -> + Tsig_class_type (List.map map_class_type_declaration list) + | Tsig_attribute _ as x -> x in - Map.leave_signature_item { item with sig_desc = sig_desc } + Map.leave_signature_item {item with sig_desc} and map_module_type_declaration mtd = let mtd = Map.enter_module_type_declaration mtd in let mtd = {mtd with mtd_type = may_map map_module_type mtd.mtd_type} in Map.leave_module_type_declaration mtd - - and map_class_type_declaration cd = let cd = Map.enter_class_type_declaration cd in let ci_params = List.map map_type_parameter cd.ci_params in let ci_expr = map_class_type cd.ci_expr in - Map.leave_class_type_declaration - { cd with ci_params = ci_params; ci_expr = ci_expr } + Map.leave_class_type_declaration {cd with ci_params; ci_expr} and map_module_type mty = let mty = Map.enter_module_type mty in let mty_desc = match mty.mty_desc with - Tmty_ident _ -> mty.mty_desc - | Tmty_alias _ -> mty.mty_desc - | Tmty_signature sg -> Tmty_signature (map_signature sg) - | Tmty_functor (id, name, mtype1, mtype2) -> - Tmty_functor (id, name, Misc.may_map map_module_type mtype1, - map_module_type mtype2) - | Tmty_with (mtype, list) -> - Tmty_with (map_module_type mtype, - List.map (fun (path, lid, withc) -> - (path, lid, map_with_constraint withc) - ) list) - | Tmty_typeof mexpr -> - Tmty_typeof (map_module_expr mexpr) + | Tmty_ident _ -> mty.mty_desc + | Tmty_alias _ -> mty.mty_desc + | Tmty_signature sg -> Tmty_signature (map_signature sg) + | Tmty_functor (id, name, mtype1, mtype2) -> + Tmty_functor + (id, name, Misc.may_map map_module_type mtype1, map_module_type mtype2) + | Tmty_with (mtype, list) -> + Tmty_with + ( map_module_type mtype, + List.map + (fun (path, lid, withc) -> (path, lid, map_with_constraint withc)) + list ) + | Tmty_typeof mexpr -> Tmty_typeof (map_module_expr mexpr) in - Map.leave_module_type { mty with mty_desc = mty_desc} + Map.leave_module_type {mty with mty_desc} and map_with_constraint cstr = let cstr = Map.enter_with_constraint cstr in let cstr = match cstr with - Twith_type decl -> Twith_type (map_type_declaration decl) - | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) - | Twith_module _ -> cstr - | Twith_modsubst _ -> cstr + | Twith_type decl -> Twith_type (map_type_declaration decl) + | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) + | Twith_module _ -> cstr + | Twith_modsubst _ -> cstr in Map.leave_with_constraint cstr @@ -485,104 +416,94 @@ module MakeMap(Map : MapArgument) = struct let mexpr = Map.enter_module_expr mexpr in let mod_desc = match mexpr.mod_desc with - Tmod_ident _ -> mexpr.mod_desc - | Tmod_structure st -> Tmod_structure (map_structure st) - | Tmod_functor (id, name, mtype, mexpr) -> - Tmod_functor (id, name, Misc.may_map map_module_type mtype, - map_module_expr mexpr) - | Tmod_apply (mexp1, mexp2, coercion) -> - Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) - | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> - Tmod_constraint (map_module_expr mexpr, mod_type, - Tmodtype_implicit, coercion) - | Tmod_constraint (mexpr, mod_type, - Tmodtype_explicit mtype, coercion) -> - Tmod_constraint (map_module_expr mexpr, mod_type, - Tmodtype_explicit (map_module_type mtype), - coercion) - | Tmod_unpack (exp, mod_type) -> - Tmod_unpack (map_expression exp, mod_type) + | Tmod_ident _ -> mexpr.mod_desc + | Tmod_structure st -> Tmod_structure (map_structure st) + | Tmod_functor (id, name, mtype, mexpr) -> + Tmod_functor + (id, name, Misc.may_map map_module_type mtype, map_module_expr mexpr) + | Tmod_apply (mexp1, mexp2, coercion) -> + Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) + | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion) -> + Tmod_constraint + (map_module_expr mexpr, mod_type, Tmodtype_implicit, coercion) + | Tmod_constraint (mexpr, mod_type, Tmodtype_explicit mtype, coercion) -> + Tmod_constraint + ( map_module_expr mexpr, + mod_type, + Tmodtype_explicit (map_module_type mtype), + coercion ) + | Tmod_unpack (exp, mod_type) -> Tmod_unpack (map_expression exp, mod_type) in - Map.leave_module_expr { mexpr with mod_desc = mod_desc } + Map.leave_module_expr {mexpr with mod_desc} and map_class_type ct = let ct = Map.enter_class_type ct in let cltyp_desc = match ct.cltyp_desc with - Tcty_signature csg -> Tcty_signature (map_class_signature csg) - | Tcty_constr (path, lid, list) -> - Tcty_constr (path, lid, List.map map_core_type list) - | Tcty_arrow (label, ct, cl) -> - Tcty_arrow (label, map_core_type ct, map_class_type cl) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, env, map_class_type e) + | Tcty_signature csg -> Tcty_signature (map_class_signature csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr (path, lid, List.map map_core_type list) + | Tcty_arrow (label, ct, cl) -> + Tcty_arrow (label, map_core_type ct, map_class_type cl) + | Tcty_open (ovf, p, lid, env, e) -> + Tcty_open (ovf, p, lid, env, map_class_type e) in - Map.leave_class_type { ct with cltyp_desc = cltyp_desc } + Map.leave_class_type {ct with cltyp_desc} and map_class_signature cs = let cs = Map.enter_class_signature cs in let csig_self = map_core_type cs.csig_self in let csig_fields = List.map map_class_type_field cs.csig_fields in - Map.leave_class_signature { cs with - csig_self = csig_self; csig_fields = csig_fields } - + Map.leave_class_signature {cs with csig_self; csig_fields} and map_class_type_field ctf = let ctf = Map.enter_class_type_field ctf in let ctf_desc = match ctf.ctf_desc with - Tctf_inherit ct -> Tctf_inherit (map_class_type ct) - | Tctf_val (s, mut, virt, ct) -> - Tctf_val (s, mut, virt, map_core_type ct) - | Tctf_method (s, priv, virt, ct) -> - Tctf_method (s, priv, virt, map_core_type ct) - | Tctf_constraint (ct1, ct2) -> - Tctf_constraint (map_core_type ct1, map_core_type ct2) - | Tctf_attribute _ as x -> x + | Tctf_inherit ct -> Tctf_inherit (map_class_type ct) + | Tctf_val (s, mut, virt, ct) -> Tctf_val (s, mut, virt, map_core_type ct) + | Tctf_method (s, priv, virt, ct) -> + Tctf_method (s, priv, virt, map_core_type ct) + | Tctf_constraint (ct1, ct2) -> + Tctf_constraint (map_core_type ct1, map_core_type ct2) + | Tctf_attribute _ as x -> x in - Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } + Map.leave_class_type_field {ctf with ctf_desc} and map_core_type ct = let ct = Map.enter_core_type ct in let ctyp_desc = match ct.ctyp_desc with - Ttyp_any - | Ttyp_var _ -> ct.ctyp_desc - | Ttyp_arrow (label, ct1, ct2) -> - Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) - | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) - | Ttyp_constr (path, lid, list) -> - Ttyp_constr (path, lid, List.map map_core_type list) - | Ttyp_object (list, o) -> - Ttyp_object - (List.map map_object_field list, o) - | Ttyp_class (path, lid, list) -> - Ttyp_class (path, lid, List.map map_core_type list) - | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) - | Ttyp_variant (list, bool, labels) -> - Ttyp_variant (List.map map_row_field list, bool, labels) - | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) - | Ttyp_package pack -> Ttyp_package (map_package_type pack) + | Ttyp_any | Ttyp_var _ -> ct.ctyp_desc + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map map_core_type list) + | Ttyp_object (list, o) -> Ttyp_object (List.map map_object_field list, o) + | Ttyp_class (path, lid, list) -> + Ttyp_class (path, lid, List.map map_core_type list) + | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) + | Ttyp_variant (list, bool, labels) -> + Ttyp_variant (List.map map_row_field list, bool, labels) + | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) + | Ttyp_package pack -> Ttyp_package (map_package_type pack) in - Map.leave_core_type { ct with ctyp_desc = ctyp_desc } + Map.leave_core_type {ct with ctyp_desc} and map_row_field rf = match rf with - Ttag (label, attrs, bool, list) -> - Ttag (label, attrs, bool, List.map map_core_type list) - | Tinherit ct -> Tinherit (map_core_type ct) + | Ttag (label, attrs, bool, list) -> + Ttag (label, attrs, bool, List.map map_core_type list) + | Tinherit ct -> Tinherit (map_core_type ct) and map_object_field ofield = match ofield with - OTtag (label, attrs, ct) -> - OTtag (label, attrs, map_core_type ct) - | OTinherit ct -> OTinherit (map_core_type ct) - + | OTtag (label, attrs, ct) -> OTtag (label, attrs, map_core_type ct) + | OTinherit ct -> OTinherit (map_core_type ct) end - module DefaultMapArgument = struct - let enter_structure t = t let enter_value_description t = t let enter_type_declaration t = t @@ -606,7 +527,6 @@ module DefaultMapArgument = struct let enter_core_type t = t let enter_structure_item t = t - let leave_structure t = t let leave_value_description t = t let leave_type_declaration t = t @@ -629,5 +549,4 @@ module DefaultMapArgument = struct let leave_class_type_field t = t let leave_core_type t = t let leave_structure_item t = t - end diff --git a/analysis/vendor/ml/typedtreeMap.mli b/analysis/vendor/ml/typedtreeMap.mli index ca23e6210..fe57c1e92 100644 --- a/analysis/vendor/ml/typedtreeMap.mli +++ b/analysis/vendor/ml/typedtreeMap.mli @@ -28,7 +28,7 @@ module type MapArgument = sig val enter_signature : signature -> signature val enter_signature_item : signature_item -> signature_item val enter_module_type_declaration : - module_type_declaration -> module_type_declaration + module_type_declaration -> module_type_declaration val enter_module_type : module_type -> module_type val enter_module_expr : module_expr -> module_expr val enter_with_constraint : with_constraint -> with_constraint @@ -53,7 +53,7 @@ module type MapArgument = sig val leave_signature : signature -> signature val leave_signature_item : signature_item -> signature_item val leave_module_type_declaration : - module_type_declaration -> module_type_declaration + module_type_declaration -> module_type_declaration val leave_module_type : module_type -> module_type val leave_module_expr : module_expr -> module_expr val leave_with_constraint : with_constraint -> with_constraint @@ -65,13 +65,9 @@ module type MapArgument = sig val leave_class_type_field : class_type_field -> class_type_field val leave_core_type : core_type -> core_type val leave_structure_item : structure_item -> structure_item - end -module MakeMap : - functor - (Iter : MapArgument) -> -sig +module MakeMap : functor (Iter : MapArgument) -> sig val map_structure : structure -> structure val map_pattern : pattern -> pattern val map_structure_item : structure_item -> structure_item diff --git a/analysis/vendor/ml/typemod.ml b/analysis/vendor/ml/typemod.ml index 76b9cf1e5..591562818 100644 --- a/analysis/vendor/ml/typemod.ml +++ b/analysis/vendor/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,74 +528,76 @@ 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 sdecls -> - let decls = Typeclass.approx_class_declarations env sdecls in - let rem = approx_sig env srem in - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - decls [rem]) - | 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 sdecls -> + let decls = Typeclass.approx_class_declarations env sdecls in + let rem = approx_sig env srem in + List.flatten + (map_rec + (fun rs decl -> + let open Typeclass in + [ + Sig_class_type (decl.clsty_ty_id, decl.clsty_ty_decl, rs); + Sig_type (decl.clsty_obj_id, decl.clsty_obj_abbr, rs); + Sig_type (decl.clsty_typesharp_id, decl.clsty_abbr, rs); + ]) + decls [rem]) + | 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 *) @@ -610,54 +606,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. @@ -667,257 +662,266 @@ 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 cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, newenv) = Typeclass.class_type_declarations env cl in - let (trem,rem, final_env) = transl_sig newenv srem in - mksig (Tsig_class_type - (List.map (fun decl -> decl.Typeclass.clsty_info) classes)) - env loc :: trem, - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - classes [rem]), - final_env - | 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 cl -> + List.iter (fun {pci_name} -> check_name check_type names pci_name) cl; + let classes, newenv = Typeclass.class_type_declarations env cl in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig + (Tsig_class_type + (List.map (fun decl -> decl.Typeclass.clsty_info) classes)) + env loc + :: trem, + List.flatten + (map_rec + (fun rs decl -> + let open Typeclass in + [ + Sig_class_type (decl.clsty_ty_id, decl.clsty_ty_decl, rs); + Sig_type (decl.clsty_obj_id, decl.clsty_obj_abbr, rs); + Sig_type (decl.clsty_typesharp_id, decl.clsty_abbr, rs); + ]) + classes [rem]), + final_env ) + | 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} = @@ -925,41 +929,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 = (* @@ -970,27 +977,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) @@ -1001,9 +1004,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) @@ -1014,71 +1021,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 @@ -1100,280 +1107,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 + 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 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 = + 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 @@ -1381,257 +1423,269 @@ 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 + let _path, newenv, od = type_open ~toplevel env sod in + (Tstr_open od, [], newenv) + | Pstr_class () -> assert false | Pstr_class_type cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, new_env) = Typeclass.class_type_declarations env cl in - Tstr_class_type - (List.map (fun cl -> - (cl.Typeclass.clsty_ty_id, - cl.Typeclass.clsty_id_loc, - cl.Typeclass.clsty_info)) classes), -(* TODO: check with Jacques why this is here - Tstr_type - (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) + List.iter (fun {pci_name} -> check_name check_type names pci_name) cl; + let classes, new_env = Typeclass.class_type_declarations env cl in + ( Tstr_class_type + (List.map + (fun cl -> + ( cl.Typeclass.clsty_ty_id, + cl.Typeclass.clsty_id_loc, + cl.Typeclass.clsty_info )) + classes), + (* TODO: check with Jacques why this is here + Tstr_type + (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: + Tstr_type + (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) List.flatten (map_rec (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) + let open Typeclass in + [ + Sig_class_type (decl.clsty_ty_id, decl.clsty_ty_decl, rs); + Sig_type (decl.clsty_obj_id, decl.clsty_obj_abbr, rs); + Sig_type (decl.clsty_typesharp_id, decl.clsty_abbr, rs); + ]) classes []), - new_env + new_env ) | 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 @@ -1639,16 +1693,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 *) @@ -1656,21 +1709,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 *) @@ -1682,40 +1740,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 () = @@ -1726,30 +1786,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 + 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 sourceintf = - Filename.remove_extension sourcefile ^ !Config.interface_suffix in - let mli_status = !Clflags.assume_no_mli in - if mli_status = Clflags.Mli_exists then begin + Filename.remove_extension sourcefile ^ !Config.interface_suffix + 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 -> - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf)) 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 @@ -1757,11 +1822,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 (); @@ -1769,40 +1835,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 *) @@ -1810,126 +1871,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/analysis/vendor/ml/typemod.mli b/analysis/vendor/ml/typemod.mli index e7bcecec5..8bef382fb 100644 --- a/analysis/vendor/ml/typemod.mli +++ b/analysis/vendor/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/analysis/vendor/ml/typeopt.ml b/analysis/vendor/ml/typeopt.ml index 565cc3b79..a18e77be7 100644 --- a/analysis/vendor/ml/typeopt.ml +++ b/analysis/vendor/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,74 +114,63 @@ 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_bytes - || Path.same p Predef.path_array - || Path.same p Predef.path_int64 then Addr - else begin + else if + Path.same p Predef.path_string + || Path.same p Predef.path_bytes + || Path.same p Predef.path_array + || Path.same p Predef.path_int64 + 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/analysis/vendor/ml/typeopt.mli b/analysis/vendor/ml/typeopt.mli index d0d5dffcc..eb4a795a6 100644 --- a/analysis/vendor/ml/typeopt.mli +++ b/analysis/vendor/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/analysis/vendor/ml/types.ml b/analysis/vendor/ml/types.ml index 0c94b4bc6..4deb41350 100644 --- a/analysis/vendor/ml/types.ml +++ b/analysis/vendor/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,133 +123,136 @@ 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; } +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; +} 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 class_type = - Cty_constr of Path.t * type_expr list * class_type + | Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature | Cty_arrow of arg_label * type_expr * class_type -and class_signature = - { csig_self: type_expr; - csig_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - csig_concr: Concr.t; - csig_inher: (Path.t * type_expr list) list } - -type class_declaration = - { cty_params: type_expr list; - mutable cty_type: class_type; - cty_path: Path.t; - cty_new: type_expr option; - cty_variance: Variance.t list; - cty_loc: Location.t; - cty_attributes: Parsetree.attributes; - } - -type class_type_declaration = - { clty_params: type_expr list; - clty_type: class_type; - clty_path: Path.t; - clty_variance: Variance.t list; - clty_loc: Location.t; - clty_attributes: Parsetree.attributes; - } +and class_signature = { + csig_self: type_expr; + csig_vars: (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; + csig_concr: Concr.t; + csig_inher: (Path.t * type_expr list) list; +} + +type class_declaration = { + cty_params: type_expr list; + mutable cty_type: class_type; + cty_path: Path.t; + cty_new: type_expr option; + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; +} + +type class_type_declaration = { + clty_params: type_expr list; + clty_type: class_type; + clty_path: Path.t; + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; +} (* 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 @@ -263,95 +260,100 @@ and signature_item = | Sig_class of unit | Sig_class_type of Ident.t * class_type_declaration * rec_status -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 * bool (* Extension constructor - true if a constant false if a block*) - -let equal_tag t1 t2 = + | 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 * bool +(* Extension constructor + true if a constant false if a block*) + +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, b1), Cstr_extension (path2, b2) -> - Path.same path1 path2 && b1 = b2 - | (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 *) - lbl_all: label_description array; (* All the labels in this type *) - 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, b1), Cstr_extension (path2, b2) -> + Path.same path1 path2 && b1 = b2 + | (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 *) + lbl_all: label_description array; (* All the labels in this type *) + 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/analysis/vendor/ml/types.mli b/analysis/vendor/ml/types.mli index eacf0b7d2..e279cf6ec 100644 --- a/analysis/vendor/ml/types.mli +++ b/analysis/vendor/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,176 +213,178 @@ 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; - } +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; +} 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.S with type elt = string type class_type = - Cty_constr of Path.t * type_expr list * class_type + | Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature | Cty_arrow of arg_label * type_expr * class_type -and class_signature = - { csig_self: type_expr; - csig_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - csig_concr: Concr.t; - csig_inher: (Path.t * type_expr list) list } - -type class_declaration = - { cty_params: type_expr list; - mutable cty_type: class_type; - cty_path: Path.t; - cty_new: type_expr option; - cty_variance: Variance.t list; - cty_loc: Location.t; - cty_attributes: Parsetree.attributes; - } - -type class_type_declaration = - { clty_params: type_expr list; - clty_type: class_type; - clty_path: Path.t; - clty_variance: Variance.t list; - clty_loc: Location.t; - clty_attributes: Parsetree.attributes; - } +and class_signature = { + csig_self: type_expr; + csig_vars: (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; + csig_concr: Concr.t; + csig_inher: (Path.t * type_expr list) list; +} + +type class_declaration = { + cty_params: type_expr list; + mutable cty_type: class_type; + cty_path: Path.t; + cty_new: type_expr option; + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; +} + +type class_type_declaration = { + clty_params: type_expr list; + clty_type: class_type; + clty_path: Path.t; + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; +} (* 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 @@ -415,76 +392,75 @@ and signature_item = | Sig_class of unit | Sig_class_type of Ident.t * class_type_declaration * rec_status -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 * bool (* Extension constructor - true if a constant false if a block*) + | 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 * bool +(* Extension constructor + true if a constant false if a block*) (* 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 *) - lbl_all: label_description array; (* All the labels in this type *) - 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 *) + lbl_all: label_description array; (* All the labels in this type *) + 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/analysis/vendor/ml/typetexp.ml b/analysis/vendor/ml/typetexp.ml index 5e632574e..e8eefc280 100644 --- a/analysis/vendor/ml/typetexp.ml +++ b/analysis/vendor/ml/typetexp.ml @@ -27,7 +27,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 @@ -63,7 +63,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 *) @@ -73,62 +72,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 @@ -138,15 +132,14 @@ 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_class env loc lid = - let (path, decl) as r = + let ((path, decl) as r) = find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid in Builtin_attributes.check_deprecated loc decl.cty_attributes (Path.name path); @@ -154,15 +147,17 @@ let find_class env loc 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 @@ -171,28 +166,27 @@ 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 find_class_type env loc lid = - let (path, decl) as r = - find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) - env loc lid + let ((path, decl) as r) = + find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) env loc lid in Builtin_attributes.check_deprecated loc decl.clty_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. *) @@ -203,33 +197,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 () = @@ -237,427 +234,464 @@ 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(lid, stl) -> - let (path, decl, _is_variant) = + let ty, fields = transl_fields env policy o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_class (lid, stl) -> + let path, decl, _is_variant = + try + let path = Env.lookup_type lid.txt env in + let decl = Env.find_type path env in + let rec check decl = + match decl.type_manifest with + | None -> raise Not_found + | Some ty -> ( + match (repr ty).desc with + | Tvariant row when Btype.static_row row -> () + | Tconstr (path, _, _) -> check (Env.find_type path env) + | _ -> raise Not_found) + in + check decl; + Location.deprecated styp.ptyp_loc + "old syntax for polymorphic variant type"; + (path, decl, true) + with Not_found -> ( try - let path = Env.lookup_type lid.txt env in - let decl = Env.find_type path env in - let rec check decl = - match decl.type_manifest with - None -> raise Not_found - | Some ty -> - match (repr ty).desc with - Tvariant row when Btype.static_row row -> () - | Tconstr (path, _, _) -> - check (Env.find_type path env) - | _ -> raise Not_found - in check decl; - Location.deprecated styp.ptyp_loc - "old syntax for polymorphic variant type"; - (path, decl,true) - with Not_found -> try let lid2 = match lid.txt with - Longident.Lident s -> Longident.Lident ("#" ^ s) - | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) - | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" + | Longident.Lident s -> Longident.Lident ("#" ^ s) + | Longident.Ldot (r, s) -> Longident.Ldot (r, "#" ^ s) + | Longident.Lapply (_, _) -> fatal_error "Typetexp.transl_type" in let path = Env.lookup_type lid2 env in let decl = Env.find_type path env in (path, decl, false) with Not_found -> - ignore (find_class env lid.loc lid.txt); assert false - 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 - List.iter2 - (fun (sty, cty) ty' -> - try unify_var 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 ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in - let ty = - try Ctype.expand_head env (newconstr path ty_args) + ignore (find_class env lid.loc lid.txt); + assert false) + 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 + List.iter2 + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify trace -> - raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) - in - let ty = match ty.desc with - Tvariant row -> - let row = Btype.row_repr row in - let fields = - List.map - (fun (l,f) -> l, + raise (Error (sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) + (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = + try Ctype.expand_head env (newconstr path ty_args) + with Unify trace -> + raise (Error (styp.ptyp_loc, env, Type_mismatch trace)) + in + let ty = + match ty.desc with + | Tvariant row -> + let row = Btype.row_repr row in + let fields = + List.map + (fun (l, f) -> + ( l, match Btype.row_field_repr f with - | Rpresent (Some ty) -> - Reither(false, [ty], false, ref None) - | Rpresent None -> - Reither (true, [], false, ref None) - | _ -> f) - row.row_fields - in - let row = { row_closed = true; row_fields = fields; - row_bound = (); row_name = Some (path, ty_args); - row_fixed = false; row_more = newvar () } 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 - newty (Tvariant row) + | Rpresent (Some ty) -> Reither (false, [ty], false, ref None) + | Rpresent None -> Reither (true, [], false, ref None) + | _ -> f )) + row.row_fields + in + let row = + { + row_closed = true; + row_fields = fields; + row_bound = (); + row_name = Some (path, ty_args); + row_fixed = false; + row_more = newvar (); + } + 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 + newty (Tvariant row) | Tobject (fi, _) -> - let _, tv = flatten_fields fi in - if policy = Univars then pre_univars := tv :: !pre_univars; - ty - | _ -> - assert false - in - ctyp (Ttyp_class (path, lid, args)) ty - | 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 collection_detect = Hashtbl.create 17 in - let add_typed_field loc l f = - if not !Config.bs_only then begin - let h = Btype.hash_variant l in - if Hashtbl.mem collection_detect h then - let l' = Hashtbl.find collection_detect h in - (* Check for tag conflicts *) - if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); - else Hashtbl.add collection_detect h l - end ; - 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 _, tv = flatten_fields fi in + if policy = Univars then pre_univars := tv :: !pre_univars; + ty + | _ -> assert false + in + ctyp (Ttyp_class (path, lid, args)) ty + | 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 collection_detect = Hashtbl.create 17 in + let add_typed_field loc l f = + (if not !Config.bs_only then + let h = Btype.hash_variant l in + if Hashtbl.mem collection_detect h then ( + let l' = Hashtbl.find collection_detect h in + (* Check for tag conflicts *) + if l <> l' then + raise (Error (styp.ptyp_loc, env, Variant_tags (l, l')))) + else Hashtbl.add collection_detect h l); + 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) @@ -667,79 +701,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; @@ -753,33 +794,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 *) @@ -798,42 +849,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?@}@]" @@ -843,26 +897,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) @@ -875,196 +928,183 @@ let fold_cltypes = fold_simple Env.fold_cltypes 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 !Config.syntax_kind = `rescript && not has_candidate then - Format.fprintf ppf "If you wanted to write a recursive type, don't forget the `rec` in `type rec`@]" + if !Config.syntax_kind = `rescript && 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 "@[\ - @{The record field %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: VALUE}@}@]\ - @]" - Printtyp.longident lid - Printtyp.longident lid - Printtyp.longident lid; - spellcheck ppf fold_labels env lid; + Format.fprintf ppf + "@[@{The record field %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: VALUE}@}@]@]" + Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid; + spellcheck ppf fold_labels env lid | Unbound_class lid -> - fprintf ppf "Unbound class %a" longident lid; - spellcheck ppf fold_classs env lid; + fprintf ppf "Unbound class %a" longident lid; + spellcheck ppf fold_classs 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 | Unbound_cltype lid -> - fprintf ppf "Unbound class type %a" longident lid; - spellcheck ppf fold_cltypes env lid; + fprintf ppf "Unbound class type %a" longident lid; + spellcheck ppf fold_cltypes 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/analysis/vendor/ml/typetexp.mli b/analysis/vendor/ml/typetexp.mli index 165c17d45..1eee2f2d3 100644 --- a/analysis/vendor/ml/typetexp.mli +++ b/analysis/vendor/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 @@ -74,49 +73,57 @@ 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_class: - Env.t -> Location.t -> Longident.t -> Path.t * class_declaration -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 find_class_type: - Env.t -> Location.t -> Longident.t -> Path.t * class_type_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_class : + Env.t -> Location.t -> Longident.t -> Path.t * class_declaration +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 find_class_type : + Env.t -> Location.t -> Longident.t -> Path.t * class_type_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/analysis/vendor/ml/untypeast.ml b/analysis/vendor/ml/untypeast.ml index 17203b03d..666b38ccd 100644 --- a/analysis/vendor/ml/untypeast.ml +++ b/analysis/vendor/ml/untypeast.ml @@ -27,14 +27,14 @@ type mapper = { cases: mapper -> T.case list -> case list; class_signature: mapper -> T.class_signature -> class_signature; class_type: mapper -> T.class_type -> class_type; - class_type_declaration: mapper -> T.class_type_declaration - -> class_type_declaration; + class_type_declaration: + mapper -> T.class_type_declaration -> class_type_declaration; class_type_field: mapper -> T.class_type_field -> class_type_field; - 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; @@ -61,8 +61,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 @@ -80,17 +81,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} @@ -101,8 +102,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 @@ -110,78 +110,62 @@ 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 _list -> - Pstr_class () + 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 _list -> Pstr_class () | Tstr_class_type list -> - Pstr_class_type - (List.map - (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) - list) - | Tstr_include incl -> - Pstr_include (sub.include_declaration sub incl) - | Tstr_attribute x -> - Pstr_attribute x + Pstr_class_type + (List.map + (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) + list) + | 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) @@ -190,27 +174,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 @@ -223,9 +208,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 = @@ -239,72 +222,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 @@ -313,14 +284,10 @@ let exp_extra sub (extra, loc, attrs) sexp = let attrs = sub.attributes sub attrs in let desc = match extra with - Texp_coerce (cty1, cty2) -> - Pexp_coerce (sexp, - map_opt (sub.typ sub) cty1, - 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 (cty1, cty2) -> + Pexp_coerce (sexp, map_opt (sub.typ sub) cty1, 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 @@ -330,140 +297,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 @@ -472,52 +425,39 @@ 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 () + 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 list -> - Psig_class_type (List.map (sub.class_type_declaration sub) list) - | Tsig_attribute x -> - Psig_attribute x + Psig_class_type (List.map (sub.class_type_declaration sub) list) + | 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 @@ -525,8 +465,7 @@ let include_description sub = include_infos sub.module_type sub let class_infos f sub ci = let loc = sub.location sub ci.ci_loc in let attrs = sub.attributes sub ci.ci_attributes in - Ci.mk ~loc ~attrs - ~virt:ci.ci_virt + Ci.mk ~loc ~attrs ~virt:ci.ci_virt ~params:(List.map (type_parameter sub) ci.ci_params) (map_loc sub ci.ci_id_name) (f sub ci.ci_expr) @@ -536,71 +475,69 @@ let class_type_declaration sub = class_infos sub.class_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 class_type sub ct = let loc = sub.location sub ct.cltyp_loc in let attrs = sub.attributes sub ct.cltyp_attributes in - let desc = match ct.cltyp_desc with - Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) + let desc = + match ct.cltyp_desc with + | Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) | Tcty_constr (_path, lid, list) -> - Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) + Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) | Tcty_arrow (label, ct, cl) -> - Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) + Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) | Tcty_open (ovf, _p, lid, _env, e) -> - Pcty_open (ovf, lid, sub.class_type sub e) + Pcty_open (ovf, lid, sub.class_type sub e) in Cty.mk ~loc ~attrs desc @@ -613,14 +550,15 @@ let class_signature sub cs = let class_type_field sub ctf = let loc = sub.location sub ctf.ctf_loc in let attrs = sub.attributes sub ctf.ctf_attributes in - let desc = match ctf.ctf_desc with - Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) + let desc = + match ctf.ctf_desc with + | Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) | Tctf_val (s, mut, virt, ct) -> - Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) - | Tctf_method (s, priv, virt, ct) -> - Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) - | Tctf_constraint (ct1, ct2) -> - Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) | Tctf_attribute x -> Pctf_attribute x in Ctf.mk ~loc ~attrs desc @@ -628,90 +566,85 @@ let class_type_field sub ctf = 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) + Ptyp_object (List.map (sub.object_field sub) list, o) | Ttyp_class (_path, lid, list) -> - Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) - | Ttyp_alias (ct, s) -> - Ptyp_alias (sub.typ sub ct, s) + Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) + | 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; - class_type = class_type; - class_type_field = class_type_field; - class_signature = class_signature; - class_type_declaration = class_type_declaration; - type_declaration = type_declaration; - type_kind = type_kind; + attribute; + attributes; + structure; + structure_item; + module_expr; + signature; + signature_item; + module_type; + with_constraint; + class_type; + class_type_field; + class_signature; + class_type_declaration; + 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/analysis/vendor/ml/untypeast.mli b/analysis/vendor/ml/untypeast.mli index d6bfdd05c..a6de807b6 100644 --- a/analysis/vendor/ml/untypeast.mli +++ b/analysis/vendor/ml/untypeast.mli @@ -24,20 +24,19 @@ type mapper = { cases: mapper -> Typedtree.case list -> case list; class_signature: mapper -> Typedtree.class_signature -> class_signature; class_type: mapper -> Typedtree.class_type -> class_type; - class_type_declaration: mapper -> Typedtree.class_type_declaration - -> class_type_declaration; + class_type_declaration: + mapper -> Typedtree.class_type_declaration -> class_type_declaration; class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; - 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: @@ -62,8 +61,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/analysis/vendor/ml/variant_coercion.ml b/analysis/vendor/ml/variant_coercion.ml index 86f525ad2..136125f57 100644 --- a/analysis/vendor/ml/variant_coercion.ml +++ b/analysis/vendor/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) diff --git a/analysis/vendor/res_syntax/res_cli.ml b/analysis/vendor/res_syntax/res_cli.ml index d4436e911..fe35a63f7 100644 --- a/analysis/vendor/res_syntax/res_cli.ml +++ b/analysis/vendor/res_syntax/res_cli.ml @@ -309,12 +309,12 @@ module CliArgProcessor = struct end (*let () = - if not !Sys.interactive then ( - ResClflags.parse (); - CliArgProcessor.process_file ~is_interface:!ResClflags.interface - ~width:!ResClflags.width ~recover:!ResClflags.recover - ~target:!ResClflags.print ~origin:!ResClflags.origin - ~jsx_version:!ResClflags.jsx_version ~jsx_module:!ResClflags.jsx_module - ~jsx_mode:!ResClflags.jsx_mode ~typechecker:!ResClflags.typechecker - !ResClflags.file) -[@@raises exit]*) + if not !Sys.interactive then ( + ResClflags.parse (); + CliArgProcessor.process_file ~is_interface:!ResClflags.interface + ~width:!ResClflags.width ~recover:!ResClflags.recover + ~target:!ResClflags.print ~origin:!ResClflags.origin + ~jsx_version:!ResClflags.jsx_version ~jsx_module:!ResClflags.jsx_module + ~jsx_mode:!ResClflags.jsx_mode ~typechecker:!ResClflags.typechecker + !ResClflags.file) + [@@raises exit]*) diff --git a/tools/bin/version.ml b/tools/bin/version.ml index 21aa556ca..c496daf5a 100644 --- a/tools/bin/version.ml +++ b/tools/bin/version.ml @@ -1 +1 @@ -let version = "0.6.6" \ No newline at end of file +let version = "0.6.6"