diff options
36 files changed, 668 insertions, 290 deletions
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 6649aa3d5..0181ca12b 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -222,18 +222,19 @@ let package_object_files files targetfile targetname coercion = (* The entry point *) let package_files files targetfile = - let files = + let files = List.map - (fun f -> + (fun f -> try find_in_path !Config.load_path f with Not_found -> raise(Error(File_not_found f))) - files in - let prefix = chop_extensions targetfile in - let targetcmi = prefix ^ ".cmi" in - let targetname = String.capitalize(Filename.basename prefix) in - try - let coercion = Typemod.package_units files targetcmi targetname in - package_object_files files targetfile targetname coercion + files in + let prefix = chop_extensions targetfile in + let targetcmi = prefix ^ ".cmi" in + let targetname = String.capitalize(Filename.basename prefix) in + try + let coercion = Typemod.package_units files targetcmi targetname in + let ret = package_object_files files targetfile targetname coercion in + ret with x -> remove_file targetfile; raise x diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index f8e43f0df..56c3a0075 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -37,9 +37,12 @@ let maybe_pointer exp = not (Path.same p Predef.path_char) && begin try match Env.find_type p exp.exp_env with - {type_kind = Type_variant []} -> true (* type exn *) + | {type_kind = Type_variant []} -> true (* type exn *) + | {type_kind = Type_generalized_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun (name, args) -> args <> []) cstrs + List.exists (fun (name, args) -> args <> []) cstrs (* GAH: dunno what's going on *) + | {type_kind = Type_generalized_variant cstrs} -> + List.exists (fun (name, args,_) -> args <> []) cstrs (* GAH: dunno what's going on *) | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -69,7 +72,10 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args) -> args = []) cstrs -> + when List.for_all (fun (name, args) -> args = []) cstrs -> (* GAH: guess? *) + Pintarray + | {type_kind = Type_generalized_variant cstrs} + when List.for_all (fun (name, args,_) -> args = []) cstrs -> (* GAH: guess? *) Pintarray | {type_kind = _} -> Paddrarray diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 020a7e0c2..abb34cd53 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -319,9 +319,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False (*FIXME*) ]; value mkvariant = fun - [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc) + [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc) (* GAH : pretty sure this is wrong *) | <:ctyp@loc< $uid:s$ of $t$ >> -> - (conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc) + (conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc) (* GAH: dunno what I'm doing *) | _ -> assert False (*FIXME*) ]; value rec type_decl tl cl loc m pflag = fun diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 92daa282d..d7b882828 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -14520,9 +14520,9 @@ module Struct = let mkvariant = function | Ast.TyId (loc, (Ast.IdUid (_, s))) -> - ((conv_con s), [], (mkloc loc)) + ((conv_con s), [], None,(mkloc loc)) (* GAH: probably wrong *) | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) -> - ((conv_con s), (List.map ctyp (list_of_ctyp t [])), + ((conv_con s), (List.map ctyp (list_of_ctyp t [])),None, (* GAH: probably wrong *) (mkloc loc)) | _ -> assert false diff --git a/driver/main.ml b/driver/main.ml index 09aa89655..832c26655 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -165,16 +165,18 @@ let main () = fatal "Option -i is incompatible with -pack, -a, -output-obj" else fatal "Please specify at most one of -pack, -a, -c, -output-obj"; - if !make_archive then begin Compile.init_path(); + Bytelibrarian.create_archive (List.rev !objfiles) (extract_output !output_name) end else if !make_package then begin Compile.init_path(); - Bytepackager.package_files (List.rev !objfiles) - (extract_output !output_name) + let exctracted_output = extract_output !output_name in + let revd = List.rev !objfiles in + Bytepackager.package_files (revd) + (exctracted_output) end else if not !compile_only && !objfiles <> [] then begin let target = diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index f8308d6c6..e55c80901 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -179,21 +179,21 @@ module Analyser = match cons_core_type_list_list with [] -> (0, acc) - | (name, core_type_list, loc) :: [] -> + | (name, (_ : Parsetree.core_type list),(_:Parsetree.core_type option), loc) :: [] -> let s = get_string_of_file loc.Location.loc_end.Lexing.pos_cnum pos_limit in let (len, comment_opt) = My_ir.just_after_special !file_name s in (len, acc @ [ (name, comment_opt) ]) - | (name, core_type_list, loc) :: (name2, core_type_list2, loc2) + | (name, core_type_list, _, loc) :: (name2, core_type_list2, (ret_type2:Parsetree.core_type option), loc2) :: q -> let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos_end_first pos_start_second in let (_,comment_opt) = My_ir.just_after_special !file_name s in f (acc @ [name, comment_opt]) - ((name2, core_type_list2, loc2) :: q) + ((name2, core_type_list2, ret_type2, loc2) :: q) in f [] cons_core_type_list_list @@ -236,6 +236,22 @@ module Analyser = } in Odoc_type.Type_variant (List.map f l) + | Types.Type_generalized_variant l -> + let f (constructor_name, type_expr_list,(_:Parsetree.core_type option)) = + let comment_opt = + try + match List.assoc constructor_name name_comment_list with + None -> None + | Some d -> d.Odoc_types.i_desc + with Not_found -> None + in + { + vc_name = constructor_name ; + vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; + vc_text = comment_opt + } + in + Odoc_type.Type_variant (List.map f l) | Types.Type_record (l, _) -> let f (field_name, mutable_flag, type_expr) = diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index 284814390..3c09b90b6 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -230,6 +230,8 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = Type_abstract -> false | Type_variant l -> List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) + | Type_generalized_variant l -> (* pretty sure this is wrong *) + List.exists l ~f:(fun (_, l, r) -> List.exists l ~f:matches || (match r with None -> false | Some x -> matches x)) | Type_record(l, rep) -> List.exists l ~f:(fun (_, _, t) -> matches t) end diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 8cae99593..5b0fe71fd 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -170,7 +170,7 @@ let search_pos_type_decl td ~pos ~env = Ptype_abstract -> () | Ptype_variant dl -> List.iter dl - ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) + ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) (* might be false *) | Ptype_record dl -> List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in search_tkind td.ptype_kind; diff --git a/parsing/parser.mly b/parsing/parser.mly index 4f9bcc58b..87cb9ddec 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1284,12 +1284,26 @@ constructor_declarations: | constructor_declarations BAR constructor_declaration { $3 :: $1 } ; constructor_declaration: - constr_ident constructor_arguments { ($1, $2, symbol_rloc()) } + constr_ident constructor_arguments { ($1, $2, None, symbol_rloc()) } ; + +constructor_declaration: + constr_ident generalized_constructor_arguments + { let arg_types,ret_type = $2 in + ($1, arg_types,Some ret_type, symbol_rloc()) } +; + constructor_arguments: /*empty*/ { [] } | OF core_type_list { List.rev $2 } ; + +generalized_constructor_arguments: + | COLON core_type_list MINUSGREATER simple_core_type + { (List.rev $2,$4) } +; + + label_declarations: label_declaration { [$1] } | label_declarations SEMI label_declaration { $3 :: $1 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 05f92bd03..53ba2e527 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -46,7 +46,7 @@ and core_field_desc = | Pfield_var and row_field = - Rtag of label * bool * core_type list + Rtag of label * bool * core_type list | Rinherit of core_type (* Type expressions for the class language *) @@ -138,7 +138,7 @@ and type_declaration = and type_kind = Ptype_abstract - | Ptype_variant of (string * core_type list * Location.t) list + | Ptype_variant of (string * core_type list * core_type option * Location.t) list | Ptype_record of (string * mutable_flag * core_type * Location.t) list diff --git a/parsing/printast.ml b/parsing/printast.ml index f63e21b87..e173dcb50 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -347,7 +347,7 @@ and type_declaration i ppf x = line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; -and type_kind i ppf x = +and type_kind i ppf x = (* GAH: why doesn't this module use Format?? *) match x with | Ptype_abstract -> line i ppf "Ptype_abstract\n" @@ -663,9 +663,17 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; -and string_x_core_type_list_x_location i ppf (s, l, loc) = - line i ppf "\"%s\" %a\n" s fmt_location loc; - list (i+1) core_type ppf l; +and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) = + match r_opt with + | None -> + line i ppf "\"%s\" %a\n" s fmt_location loc; + list (i+1) core_type ppf l; + | Some ret_type -> (* GAH: this is definately wrong *) + line i ppf "\"%s\" %a\n" s fmt_location loc; + list (i+1) core_type ppf l; + core_type i ppf ret_type + + and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) = line i ppf "\"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; @@ -734,3 +742,8 @@ let interface ppf x = list 0 signature_item ppf x;; let implementation ppf x = list 0 structure_item ppf x;; let top_phrase ppf x = toplevel_phrase 0 ppf x;; + +let print_expression = expression 0 ;; + +let print_pattern = pattern 0 ;; + diff --git a/parsing/printast.mli b/parsing/printast.mli index 7ea148678..4bf4635cc 100644 --- a/parsing/printast.mli +++ b/parsing/printast.mli @@ -18,3 +18,5 @@ open Format;; val interface : formatter -> signature_item list -> unit;; val implementation : formatter -> structure_item list -> unit;; val top_phrase : formatter -> toplevel_phrase -> unit;; +val print_expression : formatter -> expression -> unit;; +val print_pattern : formatter -> pattern -> unit;; diff --git a/stdlib/arg.ml b/stdlib/arg.ml index 009e20375..716ae45e9 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -208,6 +208,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg = let parse l f msg = try + parse_argv Sys.argv l f msg; with | Bad msg -> eprintf "%s" msg; exit 2; diff --git a/tools/depend.ml b/tools/depend.ml index 44e85702b..4117fe675 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -67,7 +67,7 @@ let add_opt add_fn bv = function None -> () | Some x -> add_fn bv x -let add_type_declaration bv td = +let add_type_declaration bv td = (* GAH: no idea if this is correct *) List.iter (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) td.ptype_cstrs; @@ -75,7 +75,7 @@ let add_type_declaration bv td = let rec add_tkind = function Ptype_abstract -> () | Ptype_variant cstrs -> - List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs + List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs | Ptype_record lbls -> List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in add_tkind td.ptype_kind diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 327700400..5ac0e03fd 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -235,19 +235,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct | Tconstr(path, ty_list, _) -> begin try let decl = Env.find_type path env in - match decl with - | {type_kind = Type_abstract; type_manifest = None} -> - Oval_stuff "<abstr>" - | {type_kind = Type_abstract; type_manifest = Some body} -> - tree_of_val depth obj - (try Ctype.apply env decl.type_params body ty_list with - Ctype.Cannot_apply -> abstract_type) - | {type_kind = Type_variant constr_list} -> + let process_variants constr_list = let tag = if O.is_block obj then Cstr_block(O.tag obj) else Cstr_constant(O.obj obj) in - let (constr_name, constr_args) = + let (constr_name, constr_args,_) = (* GAH: this is definately wrong *) Datarepr.find_constr_by_tag tag constr_list in let ty_args = List.map @@ -257,6 +250,18 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct constr_args in tree_of_constr_with_args (tree_of_constr env path) constr_name 0 depth obj ty_args + in + match decl with + | {type_kind = Type_abstract; type_manifest = None} -> + Oval_stuff "<abstr>" + | {type_kind = Type_abstract; type_manifest = Some body} -> + tree_of_val depth obj + (try Ctype.apply env decl.type_params body ty_list with + Ctype.Cannot_apply -> abstract_type) + | {type_kind = Type_variant constr_list} -> + process_variants (List.map (fun (a,b) -> (a,b,None)) constr_list) + | {type_kind = Type_generalized_variant constr_list} -> + process_variants constr_list | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x diff --git a/typing/btype.ml b/typing/btype.ml index 16254e622..759ed50f5 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -314,7 +314,16 @@ let unmark_type_decl decl = begin match decl.type_kind with Type_abstract -> () | Type_variant cstrs -> - List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs + List.iter + (fun (c, tl) -> + List.iter unmark_type tl) + cstrs (* GAH: WHAT DOES UNMARK DO??? *) + | Type_generalized_variant cstrs -> + List.iter + (fun (c, tl,ret_type_opt) -> + List.iter unmark_type tl; + Misc.may unmark_type ret_type_opt) + cstrs (* GAH: WHAT DOES UNMARK DO??? *) | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; @@ -514,5 +523,6 @@ let backtrack (changes, old) = (**** Sets, maps and hashtables of types ****) module TypeSet = Set.Make(TypeOps) +module TypeSetPair = Set.Make(struct type t = TypeOps.t * TypeOps.t let compare (x1,x2) (y1,y2) = let r = TypeOps.compare x1 y1 in if r == 0 then TypeOps.compare x2 y2 else r end) module TypeMap = Map.Make (TypeOps) module TypeHash = Hashtbl.Make(TypeOps) diff --git a/typing/btype.mli b/typing/btype.mli index cd22e8fee..f230b2f2d 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -157,5 +157,6 @@ val log_type: type_expr -> unit (**** Sets, maps and hashtables of types ****) module TypeSet : Set.S with type elt = type_expr +module TypeSetPair : Set.S with type elt = type_expr * type_expr module TypeMap : Map.S with type key = type_expr module TypeHash : Hashtbl.S with type key = type_expr diff --git a/typing/ctype.ml b/typing/ctype.ml index 17549e853..bfc9b1243 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -457,8 +457,19 @@ let closed_type_decl decl = begin match decl.type_kind with Type_abstract -> () + | Type_generalized_variant v -> + List.iter + (fun (_, tyl,ret_type_opt) -> + match ret_type_opt with + | Some _ -> () + | None -> + List.iter closed_type tyl) + v (* GAH: is this correct ? *) | Type_variant v -> - List.iter (fun (_, tyl) -> List.iter closed_type tyl) v + List.iter + (fun (_, tyl) -> + List.iter closed_type tyl) + v (* GAH: is this correct ? *) | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; @@ -1539,60 +1550,91 @@ let deep_occur t0 ty = abbreviated. It would be possible to check whether some information is indeed lost, but it probably does not worth it. *) + +let pattern_unification = ref false +let local_unifier = ref [] + + +let set_unification_type x = + match x with + | `Pattern -> + pattern_unification := true + | `Expression -> + pattern_unification := false + +let get_unification_type () = + match !pattern_unification with + | true -> `Pattern + | false -> `Expression + +let reset_local_unifier () = + local_unifier := [] + +let get_local_unifier () = !local_unifier +let uni_equalities = ref TypeSetPair.empty +let uni_eq t1 t2 = t1 == t2 || TypeSetPair.mem (t1,t2) !uni_equalities || TypeSetPair.mem (t2,t1) !uni_equalities +let add_equality t1 t2 = + uni_equalities := TypeSetPair.add (t1, t2) !uni_equalities + + let rec unify env t1 t2 = (* First step: special cases (optimizations) *) - if t1 == t2 then () else + if uni_eq t1 t2 then () else let t1 = repr t1 in let t2 = repr t2 in - if t1 == t2 then () else - + if uni_eq t1 t2 then () else try type_changed := true; match (t1.desc, t2.desc) with - (Tvar, Tconstr _) when deep_occur t1 t2 -> + | (Tvar, Tconstr _) when deep_occur t1 t2 -> unify2 env t1 t2 - | (Tconstr _, Tvar) when deep_occur t2 t1 -> + | (Tconstr _, Tvar) when deep_occur t2 t1 -> unify2 env t1 t2 - | (Tvar, _) -> + | (Tvar, _) -> occur env t1 t2; occur_univar env t2; update_level env t1.level t2; link_type t1 t2 - | (_, Tvar) -> + | (_, Tvar) -> occur env t2 t1; occur_univar env t1; update_level env t2.level t1; link_type t2 t1 - | (Tunivar, Tunivar) -> + | (Tunivar, Tunivar) -> (* GAH : ask garrigue: when do we unify univars? *) 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 (* 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) -> + || has_cached_expansion p2 !a2) -> update_level env t1.level t2; link_type t1 t2 - | _ -> + + + | _ -> unify2 env t1 t2 with Unify trace -> raise (Unify ((t1, t2)::trace)) and unify2 env t1 t2 = + + + (* Second step: expansion of abbreviations *) let rec expand_both t1'' t2'' = let t1' = expand_head_unif env t1 in let t2' = expand_head_unif env t2 in (* Expansion may have changed the representative of the types... *) - if t1' == t1'' && t2' == t2'' then (t1',t2') else + if uni_eq t1' t1'' && uni_eq t2' t2'' then (t1',t2') else expand_both t1' t2' in let t1', t2' = expand_both t1 t2 in - if t1' == t2' then () else - + if uni_eq t1' t2' then () else let t1 = repr t1 and t2 = repr t2 in - if (t1 == t1') || (t2 != t2') then + if (uni_eq t1 t1') || (not (uni_eq t2 t2')) then (* GAH: ask garrigue why this code seems so strange *) unify3 env t1 t1' t2 t2' else try unify3 env t2 t2' t1 t1' with Unify trace -> @@ -1606,16 +1648,22 @@ and unify3 env t1 t1' t2 t2' = let create_recursion = (t2 != t2') && (deep_occur t1' t2) in occur env t1' t2; update_level env t1'.level t2; - link_type t1' t2; + add_equality t1' t2; + + + try begin match (d1, d2) with (Tvar, _) -> + link_type t1' t2; occur_univar env t2 | (_, Tvar) -> - let td1 = newgenty d1 in + link_type t2' t1; + occur_univar env t1; +(* let td1 = newgenty d1 in occur env t2' td1; - occur_univar env td1; + if t1 == t1' then begin (* The variable must be instantiated... *) let ty = newty2 t1'.level d1 in @@ -1626,7 +1674,7 @@ and unify3 env t1 t1' t2 t2' = t1'.desc <- d1; update_level env t2'.level t1; link_type t2' t1 - end + end*) | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> unify env t1 t2; unify env u1 u2; @@ -1669,6 +1717,18 @@ and unify3 env t1 t1' t2 t2' = enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env) | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 -> unify_list env tl1 tl2 + | (Tunivar,_) -> + + if !pattern_unification then + local_unifier:= (t1,t2) :: !local_unifier + else + raise (Unify []) + | (_,Tunivar) -> + + if !pattern_unification then + local_unifier:= (t2,t1) :: !local_unifier + else + ( raise (Unify []) ) | (_, _) -> raise (Unify []) end; @@ -1887,13 +1947,19 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = set_row_field e2 f1 | _ -> raise (Unify []) +;; + let unify env ty1 ty2 = try - unify env ty1 ty2 + uni_equalities := TypeSetPair.empty; + unify env ty1 ty2; + uni_equalities := TypeSetPair.empty; with Unify trace -> + uni_equalities := TypeSetPair.empty; raise (Unify (expand_trace env trace)) + let unify_var env t1 t2 = let t1 = repr t1 and t2 = repr t2 in if t1 == t2 then () else @@ -3371,7 +3437,17 @@ let nondep_type_decl env mid id is_covariant decl = | Type_variant cstrs -> Type_variant (List.map - (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl)) + (fun (c, tl) -> + (c, List.map (nondep_type_rec env mid) tl)) (* GAH: HERE TOO? *) + cstrs) + | Type_generalized_variant cstrs -> + Type_generalized_variant + (List.map + (fun (c, tl,ret_type_opt) -> + let ret_type_opt = + may_map (nondep_type_rec env mid) ret_type_opt + in + (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) (* GAH: HERE TOO? *) cstrs) | Type_record(lbls, rep) -> Type_record @@ -3478,3 +3554,11 @@ let rec collapse_conj env visited ty = let collapse_conj_params env params = List.iter (collapse_conj env []) params + + + + + + + + diff --git a/typing/ctype.mli b/typing/ctype.mli index 21a45fb82..108b251a1 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -250,3 +250,7 @@ val arity: type_expr -> int val collapse_conj_params: Env.t -> type_expr list -> unit (* Collapse conjunctive types in class parameters *) +val reset_local_unifier: unit -> unit +val get_local_unifier: unit -> (type_expr * type_expr) list +val set_unification_type : [`Pattern | `Expression] -> unit +val get_unification_type : unit -> [`Pattern | `Expression] diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 80b94132d..2482059c5 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -22,20 +22,34 @@ open Types let constructor_descrs ty_res cstrs priv = let num_consts = ref 0 and num_nonconsts = ref 0 in List.iter - (function (name, []) -> incr num_consts - | (name, _) -> incr num_nonconsts) + (function (name, [],_) -> incr num_consts + | (name, _,_) -> incr num_nonconsts) cstrs; let rec describe_constructors idx_const idx_nonconst = function [] -> [] - | (name, ty_args) :: rem -> + | (name, ty_args, ty_res_opt) :: rem -> + let ty_res = + match ty_res_opt with + | Some ty_res -> ty_res + | None -> ty_res + in let (tag, descr_rem) = match ty_args with [] -> (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 existentials = + match ty_res_opt with + | None -> [] + | Some type_ret -> + let res_vars = List.fold_right Btype.TypeSet.add (free_vars type_ret) Btype.TypeSet.empty in + let other_types +*) + let cstr = - { cstr_res = ty_res; + { cstr_res = ty_res; + cstr_existentials = [] ; (* GAH: HOW DO I GET THE EXISTENTIALS OF A TYPE?? *) cstr_args = ty_args; cstr_arity = List.length ty_args; cstr_tag = tag; @@ -47,6 +61,7 @@ let constructor_descrs ty_res cstrs priv = let exception_descr path_exc decl = { cstr_res = Predef.type_exn; + cstr_existentials = [] ; (* GAH: is this correct? *) cstr_args = decl; cstr_arity = List.length decl; cstr_tag = Cstr_exception path_exc; @@ -81,16 +96,16 @@ let label_descrs ty_res lbls repres priv = exception Constr_not_found -let rec find_constr tag num_const num_nonconst = function +let rec find_constr tag num_const num_nonconst = function (* GAH: is this correct? *) [] -> raise Constr_not_found - | (name, [] as cstr) :: rem -> + | (name, ([] as cstr),(_ as ret_type_opt)) :: rem -> if tag = Cstr_constant num_const - then cstr + then (name,cstr,ret_type_opt) else find_constr tag (num_const + 1) num_nonconst rem - | (name, _ as cstr) :: rem -> + | (name, (_ as cstr),(_ as ret_type_opt)) :: rem -> if tag = Cstr_block num_nonconst - then cstr + then (name,cstr,ret_type_opt) else find_constr tag num_const (num_nonconst + 1) rem let find_constr_by_tag tag cstrlist = diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 283dbd294..81b3a7e83 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -17,9 +17,9 @@ open Asttypes open Types - + val constructor_descrs: - type_expr -> (string * type_expr list) list -> private_flag -> + type_expr -> (string * type_expr list * type_expr option) list -> private_flag -> (string * constructor_description) list val exception_descr: Path.t -> type_expr list -> constructor_description @@ -31,4 +31,4 @@ val label_descrs: exception Constr_not_found val find_constr_by_tag: - constructor_tag -> (string * type_expr list) list -> string * type_expr list + constructor_tag -> (string * type_expr list * type_expr option) list -> string * type_expr list * type_expr option diff --git a/typing/env.ml b/typing/env.ml index 044247990..391a363f4 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -84,6 +84,8 @@ and functor_components = { fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *) } +let map_values f t = {t with values = Ident.map_tbl f t.values} + let empty = { values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty; labels = Ident.empty; types = Ident.empty; @@ -451,11 +453,15 @@ let rec scrape_modtype mty env = (* Compute constructor descriptions *) let constructors_of_type ty_path decl = - match decl.type_kind with - Type_variant cstrs -> + let handle_variants cstrs = Datarepr.constructor_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) cstrs decl.type_private + in + match decl.type_kind with + | Type_variant cstrs -> + handle_variants (List.map (fun (a,b) -> (a,b,None)) cstrs) + | Type_generalized_variant cstrs -> handle_variants cstrs | Type_record _ | Type_abstract -> [] (* Compute label descriptions *) @@ -466,7 +472,7 @@ let labels_of_type ty_path decl = Datarepr.label_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) labels rep decl.type_private - | Type_variant _ | Type_abstract -> [] + | Type_variant _ | Type_generalized_variant _ | Type_abstract -> [] (* Given a signature and a root path, prefix all idents in the signature by the root path and build the corresponding substitution. *) diff --git a/typing/env.mli b/typing/env.mli index 8f00972a6..857e4c07b 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -49,8 +49,12 @@ val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration val lookup_class: Longident.t -> t -> Path.t * class_declaration val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration +val map_values: (Path.t * value_description -> Path.t * value_description) -> t -> t + (* Insertion by identifier *) + + val add_value: Ident.t -> value_description -> t -> t val add_annot: Ident.t -> Annot.ident -> t -> t val add_type: Ident.t -> type_declaration -> t -> t diff --git a/typing/ident.ml b/typing/ident.ml index c5bc09f41..82603d7d5 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -95,6 +95,13 @@ and 'a data = data: 'a; previous: 'a data option } +let rec map_tbl f = (* GAH: THIS IS PROBABLY TOTALLY WRONG *) + function + | Empty -> Empty + | Node (t,{ident=id;data=d;previous=p},t',i) -> + Node(map_tbl f t,{ident=id;data=f d;previous=p},map_tbl f t',i) + + let empty = Empty (* Inline expansion of height for better speed diff --git a/typing/ident.mli b/typing/ident.mli index 03e2eee48..aef331f31 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -57,3 +57,4 @@ val add: t -> 'a -> 'a tbl -> 'a tbl val find_same: t -> 'a tbl -> 'a val find_name: string -> 'a tbl -> 'a val keys: 'a tbl -> t list +val map_tbl: ('a -> 'a) -> 'a tbl -> 'a tbl diff --git a/typing/includecore.ml b/typing/includecore.ml index a08831924..2f8ba110e 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -161,21 +161,29 @@ let report_type_mismatch first second decl ppf = Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = - match cstrs1, cstrs2 with + match cstrs1, cstrs2 with (* GAH: most likely wrong, but I don't know what this function does *) [], [] -> [] - | [], (cstr2,_)::_ -> [Field_missing (true, cstr2)] - | (cstr1,_)::_, [] -> [Field_missing (false, cstr1)] - | (cstr1, arg1)::rem1, (cstr2, arg2)::rem2 -> + | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)] + | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)] + | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 -> if cstr1 <> cstr2 then [Field_names (n, cstr1, cstr2)] else if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else - if Misc.for_all2 - (fun ty1 ty2 -> - Ctype.equal env true (ty1::decl1.type_params) - (ty2::decl2.type_params)) - arg1 arg2 - then compare_variants env decl1 decl2 (n+1) rem1 rem2 - else [Field_type cstr1] - + match ret1, ret2 with + | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> + [Field_type cstr1] + | Some _, None | None, Some _ -> + [Field_type cstr1] + | _ -> + if Misc.for_all2 + (fun ty1 ty2 -> + Ctype.equal env true (ty1::decl1.type_params) + (ty2::decl2.type_params)) + (arg1) (arg2) + then + compare_variants env decl1 decl2 (n+1) rem1 rem2 + else [Field_type cstr1] + + let rec compare_records env decl1 decl2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] @@ -195,6 +203,9 @@ let type_declarations env id decl1 decl2 = let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> [] | (Type_variant cstrs1, Type_variant cstrs2) -> + let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in + compare_variants env decl1 decl2 1 (gen_variants cstrs1) (gen_variants cstrs2) + | (Type_generalized_variant cstrs1, Type_generalized_variant cstrs2) -> compare_variants env decl1 decl2 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> let err = compare_records env decl1 decl2 1 labels1 labels2 in @@ -222,7 +233,7 @@ let type_declarations env id decl1 decl2 = in if err <> [] then err else if match decl2.type_kind with - | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private + | Type_record (_,_) | Type_generalized_variant _ | Type_variant _ -> decl2.type_private = Private | Type_abstract -> match decl2.type_manifest with | None -> true diff --git a/typing/oprint.ml b/typing/oprint.ml index ca5db71a6..f7a0c869f 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -350,7 +350,7 @@ and print_out_sig_item ppf = (if vir_flag then " virtual" else "") print_out_class_params params name !out_class_type clt | Osig_exception (id, tyl) -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) + fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None) | Osig_modtype (name, Omty_abstract) -> fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> @@ -428,12 +428,22 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = print_name_args print_out_tkind ty print_constraints constraints -and print_out_constr ppf (name, tyl) = - match tyl with - [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl +and print_out_constr ppf (name, tyl,ret_type_opt) = + match ret_type_opt with + | None -> + begin match tyl with + | [] -> fprintf ppf "%s" 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 (* GAH: IS THIS CORRECT? *) + | _ -> + fprintf ppf "@[<2>%s :@ %a -> %a@]" name + (print_typlist print_simple_out_type " *") tyl print_simple_out_type ret_type end + + and print_out_label ppf (name, mut, arg) = fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name !out_type arg diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 80c28ea08..490c6e089 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -54,7 +54,7 @@ type out_type = | Otyp_object of (string * out_type) list * bool option | Otyp_record of (string * bool * out_type) list | Otyp_stuff of string - | Otyp_sum of (string * out_type list) list + | Otyp_sum of (string * out_type list * out_type option) list (* GAH: was right thing to do? *) | Otyp_tuple of out_type list | Otyp_var of bool * string | Otyp_variant of diff --git a/typing/parmatch.ml b/typing/parmatch.ml index d73f79af6..266d42795 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -132,6 +132,9 @@ let rec get_type_descr ty tenv = let rec get_constr tag ty tenv = match get_type_descr ty tenv with | {type_kind=Type_variant constr_list} -> + let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in + Datarepr.find_constr_by_tag tag (gen_variants constr_list) + | {type_kind=Type_generalized_variant constr_list} -> Datarepr.find_constr_by_tag tag constr_list | {type_manifest = Some _} -> get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv @@ -162,7 +165,7 @@ let get_constr_name tag ty tenv = match tag with | Cstr_exception path -> Path.name path | _ -> try - let name,_ = get_constr tag ty tenv in name + let name,_,_ = get_constr tag ty tenv in name with | Datarepr.Constr_not_found -> "*Unknown constructor*" @@ -715,13 +718,19 @@ let complete_constrs p all_tags = match p.pat_desc with let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in List.map (fun tag -> - let _,targs = get_constr tag p.pat_type p.pat_env in + let _,targs,ret_type_opt = get_constr tag p.pat_type p.pat_env in (* GAH: is this correct? don't forget the existentials! *) + let ret_type = + match ret_type_opt with + | None -> c.cstr_res + | Some ret_type -> ret_type + in {c with - cstr_tag = tag ; - cstr_args = targs ; - cstr_arity = List.length targs}) + cstr_res = ret_type ; + cstr_tag = tag ; + cstr_args = targs ; + cstr_arity = List.length targs}) not_tags -with + with | Datarepr.Constr_not_found -> fatal_error "Parmatch.complete_constr: constr_not_found" end diff --git a/typing/predef.ml b/typing/predef.ml index 728eb5729..4b722a40f 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -95,7 +95,7 @@ let build_initial_env add_type add_exception empty_env = and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant(["false", []; "true", []]); + type_kind = Type_variant(["false", []; "true", []]); (* GAH: HOW DO I DEFINE THE BASIC BOOL TYPE? *) type_private = Public; type_manifest = None; type_variance = []} @@ -126,7 +126,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = - Type_variant(["[]", []; "::", [tvar; type_list tvar]]); + Type_variant(["[]", []; "::", [tvar; type_list tvar]]); (* GAH: IS THIS CORRECT? *) type_private = Public; type_manifest = None; type_variance = [true, false, false]} diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 76537b807..479ee0c31 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -534,8 +534,17 @@ let rec tree_of_type_decl id decl = begin match decl.type_kind with | Type_abstract -> () | Type_variant [] -> () + | Type_generalized_variant cstrs -> + List.iter + (fun (_, args,ret_type_opt) -> + List.iter mark_loops args; + may mark_loops ret_type_opt) + cstrs | Type_variant cstrs -> - List.iter (fun (_, args) -> List.iter mark_loops args) cstrs + List.iter + (fun (_, args) -> + List.iter mark_loops args) + cstrs | Type_record(l, rep) -> List.iter (fun (_, _, ty) -> mark_loops ty) l end; @@ -550,7 +559,7 @@ let rec tree_of_type_decl id decl = match decl.type_kind with Type_abstract -> decl.type_manifest = None || decl.type_private = Private - | Type_variant _ | Type_record _ -> + | Type_variant _ | Type_generalized_variant _ | Type_record _ -> decl.type_private = Private in let vari = @@ -581,14 +590,25 @@ let rec tree_of_type_decl id decl = | Type_variant cstrs -> tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), decl.type_private + | Type_generalized_variant cstrs -> + tree_of_manifest (Otyp_sum (List.map tree_of_generalized_constructor cstrs)), + decl.type_private | Type_record(lbls, rep) -> tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), decl.type_private in (name, args, ty, priv, constraints) +and tree_of_generalized_constructor (name, args,ret_type_opt) = + (name, tree_of_typlist false args,tree_of_constructor_ret ret_type_opt) + and tree_of_constructor (name, args) = - (name, tree_of_typlist false args) + (name, tree_of_typlist false args,None) + +and tree_of_constructor_ret = + function + | None -> None + | Some ret_type -> Some (tree_of_typexp false ret_type) (* GAH: WHY FALSE?? *) and tree_of_label (name, mut, arg) = (name, mut = Mutable, tree_of_typexp false arg) diff --git a/typing/subst.ml b/typing/subst.ml index 6aa276606..48956f9fd 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -168,18 +168,30 @@ let type_declaration s decl = Type_abstract -> Type_abstract | Type_variant cstrs -> Type_variant( - List.map (fun (n, args) -> (n, List.map (typexp s) args)) - cstrs) + List.map (fun (n, args) -> + (n, List.map (typexp s) args)) (* GAH: WHAT DOES typexp DO? *) + cstrs) + | Type_generalized_variant cstrs -> + Type_generalized_variant( + List.map (fun (n, args,ret_type_opt) -> + let ret_type_opt = + Misc.may_map (typexp s) ret_type_opt + in + (n, List.map (typexp s) args,ret_type_opt)) (* GAH: WHAT DOES typexp DO? *) + cstrs) | Type_record(lbls, rep) -> Type_record( List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls, rep) end; + type_manifest = - begin match decl.type_manifest with - None -> None - | Some ty -> Some(typexp s ty) + + begin + match decl.type_manifest with + None -> None + | Some ty -> Some(typexp s ty) end; type_private = decl.type_private; type_variance = decl.type_variance; diff --git a/typing/typecore.ml b/typing/typecore.ml index 90c33f9b2..c41912043 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -70,6 +70,12 @@ let type_module = let type_open = ref (fun _ -> assert false) +(*let print_local_unifier ?(s="") () = + Format.fprintf Format.std_formatter "%s local_unifier:\n[%a]\n%!" s + (fun ppf lst -> List.iter (fun (t,t') -> Format.fprintf ppf "%a = %a;" Printtyp.raw_type_expr t Printtyp.raw_type_expr t') lst) + (get_local_unifier ()) +;; +*) (* Forward declaration, to be filled in by Typeclass.class_structure *) let type_object = @@ -83,11 +89,11 @@ let type_object = called each time we create a record of type [Typedtree.expression] or [Typedtree.pattern] that will end up in the typed AST. *) -let re node = +let re node = Stypes.record (Stypes.Ti_expr node); node ;; -let rp node = +let rp node = Stypes.record (Stypes.Ti_pat node); node ;; @@ -106,25 +112,25 @@ let type_constant = function (* Specific version of type_option, using newty rather than newgenty *) -let type_option ty = +let type_option ty = newty (Tconstr(Predef.path_option,[ty], ref Mnil)) -let option_none ty loc = +let option_none ty loc = let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in { exp_desc = Texp_construct(cnone, []); exp_type = ty; exp_loc = loc; exp_env = Env.initial } -let option_some texp = +let option_some texp = let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in { exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc; exp_type = type_option texp.exp_type; exp_env = texp.exp_env } -let extract_option_type env ty = +let extract_option_type env ty = match expand_head env ty with {desc = Tconstr(path, [ty], _)} when Path.same path Predef.path_option -> ty | _ -> assert false -let rec extract_label_names sexp env ty = +let rec extract_label_names sexp env ty = let ty = repr ty in match ty.desc with | Tconstr (path, _, _) -> @@ -142,7 +148,7 @@ let rec extract_label_names sexp env ty = (* Typing of patterns *) (* Creating new conjunctive types is not allowed when typing patterns *) -let unify_pat env pat expected_ty = +let unify_pat env pat expected_ty = try unify env pat.pat_type expected_ty with @@ -152,7 +158,7 @@ let unify_pat env pat expected_ty = raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2))) (* make all Reither present in open variants *) -let finalize_variant pat = +let finalize_variant pat = match pat.pat_desc with Tpat_variant(tag, opat, r) -> let row = @@ -179,11 +185,11 @@ let finalize_variant pat = row_bound=(); row_fixed=false; row_name=None})); *) | _ -> () -let rec iter_pattern f p = +let rec iter_pattern f p = f p; iter_pattern_desc (iter_pattern f) p.pat_desc -let has_variants p = +let has_variants p = try iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ()) p; @@ -196,13 +202,13 @@ let has_variants p = let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list) let pattern_force = ref ([] : (unit -> unit) list) let pattern_scope = ref (None : Annot.ident option);; -let reset_pattern scope = +let reset_pattern scope = pattern_variables := []; pattern_force := []; pattern_scope := scope; ;; -let enter_variable loc name ty = +let enter_variable loc name ty = if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables then raise(Error(loc, Multiply_bound_variable name)); let id = Ident.create name in @@ -213,18 +219,18 @@ let enter_variable loc name ty = end; id -let sort_pattern_variables vs = +let sort_pattern_variables vs = List.sort (fun (x,_,_) (y,_,_) -> Pervasives.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 = match p1_vs, p2_vs with + let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 @@ -247,7 +253,7 @@ let enter_orpat_variables loc env p1_vs p2_vs = raise (Error (loc, Orpat_vars min_var)) in unify_vars p1_vs p2_vs -let rec build_as_type env p = +let rec build_as_type env p = match p.pat_desc with Tpat_alias(p1, _) -> build_as_type env p1 | Tpat_tuple pl -> @@ -270,7 +276,7 @@ let rec build_as_type env p = 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 do_label lbl = + 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 = @@ -299,7 +305,7 @@ let rec build_as_type env p = | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ | Tpat_lazy _ -> p.pat_type -let build_or_pat env loc lid = +let build_or_pat env loc lid = let path, decl = Typetexp.find_type env loc lid in let tyl = List.map (fun _ -> newvar()) decl.type_params in @@ -345,12 +351,12 @@ let build_or_pat env loc lid = pat pats in rp { r with pat_loc = loc } -let rec find_record_qual = function +let rec find_record_qual = function | [] -> None | (Longident.Ldot (modname, _), _) :: _ -> Some modname | _ :: rest -> find_record_qual rest -let type_label_a_list type_lid_a lid_a_list = +let type_label_a_list type_lid_a lid_a_list = match find_record_qual lid_a_list with | None -> List.map type_lid_a lid_a_list | Some modname -> @@ -364,7 +370,7 @@ let type_label_a_list type_lid_a lid_a_list = (* 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 = +let check_recordpat_labels loc lbl_pat_list closed = match lbl_pat_list with | [] -> () (* should not happen *) | (label1, _) :: _ -> @@ -391,18 +397,19 @@ let check_recordpat_labels loc lbl_pat_list closed = (* Typing of patterns *) -let rec type_pat env sp = +let rec type_pat env sp expected_ty = let loc = sp.ppat_loc in match sp.ppat_desc with - Ppat_any -> + |Ppat_any -> rp { pat_desc = Tpat_any; pat_loc = loc; - pat_type = newvar(); + pat_type = expected_ty; pat_env = env } - | Ppat_var name -> + |Ppat_var name -> let ty = newvar() in - let id = enter_variable loc name ty in + let id = enter_variable loc name ty in (* GAH : what does this do? *) + unify env ty expected_ty; rp { pat_desc = Tpat_var id; pat_loc = loc; @@ -414,7 +421,7 @@ let rec type_pat env sp = let ty, force = Typetexp.transl_simple_type_delayed env sty in pattern_force := force :: !pattern_force; begin match ty.desc with - | Tpoly (body, tyl) -> + |Tpoly (body, tyl) -> begin_def (); let _, ty' = instance_poly false tyl body in end_def (); @@ -426,8 +433,8 @@ let rec type_pat env sp = pat_env = env } | _ -> assert false end - | Ppat_alias(sq, name) -> - let q = type_pat env sq in + |Ppat_alias(sq, name) -> + let q = type_pat env sq expected_ty in (* GAH: no idea *) begin_def (); let ty_var = build_as_type env q in end_def (); @@ -438,20 +445,24 @@ let rec type_pat env sp = pat_loc = loc; pat_type = q.pat_type; pat_env = env } - | Ppat_constant cst -> + |Ppat_constant cst -> + (* GAH: dunno what to do here *) + unify env expected_ty (type_constant cst); rp { pat_desc = Tpat_constant cst; pat_loc = loc; - pat_type = type_constant cst; + pat_type = expected_ty; (*type_constant cst;*) pat_env = env } - | Ppat_tuple spl -> - let pl = List.map (type_pat env) spl in + |Ppat_tuple spl -> + let spl_ann = List.map (fun p -> (p,newvar ())) spl in + let pl = List.map (fun (p,t) -> type_pat env p t) spl_ann in + unify env expected_ty (newty (Ttuple(List.map snd spl_ann))); rp { pat_desc = Tpat_tuple pl; pat_loc = loc; - pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl)); + pat_type = expected_ty; pat_env = env } - | Ppat_construct(lid, sarg, explicit_arity) -> + |Ppat_construct(lid, sarg, explicit_arity) -> let constr = Typetexp.find_constructor env loc lid in let sargs = match sarg with @@ -461,22 +472,22 @@ let rec type_pat env sp = | 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; + Warnings.Wildcard_arg_to_constant_constr; (* GAH : why is this a warning ? *) replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then raise(Error(loc, Constructor_arity_mismatch(lid, constr.cstr_arity, List.length sargs))); - let args = List.map (type_pat env) sargs in let (ty_args, ty_res) = instance_constructor constr in - List.iter2 (unify_pat env) args ty_args; + unify env expected_ty ty_res; + let args: Typedtree.pattern list = List.map2 (fun p t -> type_pat env p t) sargs ty_args in (* GAH : might be wrong *) rp { pat_desc = Tpat_construct(constr, args); pat_loc = loc; pat_type = ty_res; pat_env = env } - | Ppat_variant(l, sarg) -> - let arg = may_map (type_pat env) sarg in + |Ppat_variant(l, sarg) -> + let arg = may_map (fun p -> type_pat env p (newvar())) sarg in (* GAH: this is certainly false *) let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in let row = { row_fields = [l, Reither(arg = None, arg_type, true, ref None)]; @@ -490,8 +501,8 @@ let rec type_pat env sp = pat_loc = loc; pat_type = newty (Tvariant row); pat_env = env } - | Ppat_record(lid_sp_list, closed) -> - let ty = newvar() in + |Ppat_record(lid_sp_list, closed) -> + let ty = expected_ty in let type_label_pat (lid, sarg) = let label = Typetexp.find_label env loc lid in begin_def (); @@ -502,13 +513,12 @@ let rec type_pat env sp = with Unify trace -> raise(Error(loc, Label_mismatch(lid, trace))) end; - let arg = type_pat env sarg in - unify_pat env arg ty_arg; + let arg = type_pat env sarg ty_arg in if vars <> [] then begin end_def (); generalize ty_arg; List.iter generalize vars; - let instantiated tv = + let instantiated tv = let tv = expand_head env tv in tv.desc <> Tvar || tv.level <> generic_level in if List.exists instantiated vars then @@ -523,21 +533,23 @@ let rec type_pat env sp = pat_loc = loc; pat_type = ty; pat_env = env } - | Ppat_array spl -> - let pl = List.map (type_pat env) spl in + |Ppat_array spl -> let ty_elt = newvar() in - List.iter (fun p -> unify_pat env p ty_elt) pl; + unify env expected_ty (instance (Predef.type_array ty_elt)); + let spl_ann = List.map (fun p -> (p,newvar())) spl in + let pl = List.map (fun (p,t) -> type_pat env p ty_elt) spl_ann in rp { pat_desc = Tpat_array pl; pat_loc = loc; - pat_type = instance (Predef.type_array ty_elt); + pat_type = expected_ty; pat_env = env } - | Ppat_or(sp1, sp2) -> + |Ppat_or(sp1, sp2) -> let initial_pattern_variables = !pattern_variables in - let p1 = type_pat env sp1 in + let nv = newvar() in + let p1 = type_pat env sp1 nv in (* GAH: so wrong *) let p1_variables = !pattern_variables in pattern_variables := initial_pattern_variables ; - let p2 = type_pat env sp2 in + let p2 = type_pat env sp2 nv in (* GAH: again, so wrong *) let p2_variables = !pattern_variables in unify_pat env p2 p1.pat_type; let alpha_env = @@ -548,26 +560,29 @@ let rec type_pat env sp = pat_loc = loc; pat_type = p1.pat_type; pat_env = env } - | Ppat_lazy sp1 -> - let p1 = type_pat env sp1 in + |Ppat_lazy sp1 -> + let nv = newvar () in + unify env expected_ty (instance (Predef.type_lazy_t nv)); + let p1 = type_pat env sp1 nv in rp { pat_desc = Tpat_lazy p1; pat_loc = loc; - pat_type = instance (Predef.type_lazy_t p1.pat_type); + pat_type = expected_ty; pat_env = env } - | Ppat_constraint(sp, sty) -> - let p = type_pat env sp in + |Ppat_constraint(sp, sty) -> + let nv = newvar () in + let p = type_pat env sp nv in (* GAH: so wrong *) let ty, force = Typetexp.transl_simple_type_delayed env sty in unify_pat env p ty; pattern_force := force :: !pattern_force; p - | Ppat_type lid -> + |Ppat_type lid -> build_or_pat env loc lid -let get_ref r = +let get_ref r = let v = !r in r := []; v -let add_pattern_variables env = +let add_pattern_variables env = let pv = get_ref pattern_variables in List.fold_right (fun (id, ty, loc) env -> @@ -576,21 +591,38 @@ let add_pattern_variables env = ) pv env -let type_pattern env spat scope = + +let type_pattern env spat scope expected_ty = reset_pattern scope; - let pat = type_pat env spat in + + let pat = type_pat env spat expected_ty in + let new_env = add_pattern_variables env in + (pat, new_env, get_ref pattern_force) -let type_pattern_list env spatl scope = - reset_pattern scope; - let patl = List.map (type_pat env) spatl in - let new_env = add_pattern_variables env in - (patl, new_env, get_ref pattern_force) -let type_class_arg_pattern cl_num val_env met_env l spat = +let type_pattern_list env spatl scope expected_tys = + + reset_local_unifier (); + set_unification_type `Pattern; + try_finally + (fun () -> + reset_pattern scope; + + let patl = List.map2 (fun p t -> type_pat env p t) spatl expected_tys in + let new_env = add_pattern_variables env in + + (patl, new_env, get_ref pattern_force)) + (fun () -> + set_unification_type `Expression) + +let type_class_arg_pattern cl_num val_env met_env l spat = + reset_pattern None; - let pat = type_pat val_env spat in + let nv = newvar () in + let pat = type_pat val_env spat nv in + if has_variants pat then begin Parmatch.pressure_variants val_env [pat]; iter_pattern finalize_variant pat @@ -610,15 +642,17 @@ let type_class_arg_pattern cl_num val_env met_env l spat = let val_env = add_pattern_variables val_env in (pat, pv, val_env, met_env) -let mkpat d = { ppat_desc = d; ppat_loc = Location.none } +let mkpat d = { ppat_desc = d; ppat_loc = Location.none } -let type_self_pattern cl_num privty val_env met_env par_env spat = +let type_self_pattern cl_num privty val_env met_env par_env spat = + let spat = mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")), "selfpat-" ^ cl_num)) in reset_pattern None; - let pat = type_pat val_env spat in + let nv = newvar() in + let pat = type_pat val_env spat nv in (* GAH: so wrong *) List.iter (fun f -> f()) (get_ref pattern_force); let meths = ref Meths.empty in let vars = ref Vars.empty in @@ -640,7 +674,7 @@ let delayed_checks = ref [] let reset_delayed_checks () = delayed_checks := []; set_free_univars TypeSet.empty (* Hook this here. Better name? *) -let add_delayed_check f = delayed_checks := f :: !delayed_checks +let add_delayed_check f = delayed_checks := f :: !delayed_checks let force_delayed_checks () = (* checks may change type levels *) let snap = Btype.snapshot () in @@ -651,7 +685,7 @@ let force_delayed_checks () = (* Generalization criterion for expressions *) -let rec is_nonexpansive exp = +let rec is_nonexpansive exp = match exp.exp_desc with Texp_ident(_,_) -> true | Texp_constant _ -> true @@ -696,7 +730,7 @@ let rec is_nonexpansive exp = is_nonexpansive_mod mexp | _ -> false -and is_nonexpansive_mod mexp = +and is_nonexpansive_mod mexp = match mexp.mod_desc with | Tmod_ident _ -> true | Tmod_functor _ -> true @@ -730,35 +764,35 @@ external string_to_format : external format_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" -let type_format loc fmt = +let type_format loc fmt = - let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in + let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in - let bad_conversion fmt i c = + let bad_conversion fmt i c = raise (Error (loc, Bad_conversion (fmt, i, c))) in - let incomplete_format fmt = + let incomplete_format fmt = raise (Error (loc, Incomplete_format fmt)) in - let range_closing_index fmt i = + let range_closing_index fmt i = let len = String.length fmt in - let find_closing j = + let find_closing j = if j >= len then incomplete_format fmt else try String.index_from fmt j ']' with | Not_found -> incomplete_format fmt in - let skip_pos j = + let skip_pos j = if j >= len then incomplete_format fmt else match fmt.[j] with | ']' -> find_closing (j + 1) | c -> find_closing j in - let rec skip_neg j = + let rec skip_neg j = if j >= len then incomplete_format fmt else match fmt.[j] with | '^' -> skip_pos (j + 1) | c -> skip_pos j in find_closing (skip_neg (i + 1)) in - let rec type_in_format fmt = + let rec type_in_format fmt = let len = String.length fmt in @@ -769,7 +803,7 @@ let type_format loc fmt = let meta = ref 0 in - let rec scan_format i = + let rec scan_format i = if i >= len then if !meta = 0 then ty_uresult, ty_result @@ -777,24 +811,24 @@ let type_format loc fmt = match fmt.[i] with | '%' -> scan_opts i (i + 1) | _ -> scan_format (i + 1) - and scan_opts i j = + and scan_opts i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '_' -> scan_rest true i (j + 1) | _ -> scan_rest false i j - and scan_rest skip i j = - let rec scan_flags i j = + and scan_rest skip i j = + let rec scan_flags i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1) | _ -> scan_width i j - and scan_width i j = scan_width_or_prec_value scan_precision i j - and scan_decimal_string scan i j = + and scan_width i j = scan_width_or_prec_value scan_precision i j + and scan_decimal_string scan i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '0' .. '9' -> scan_decimal_string scan i (j + 1) | _ -> scan i j - and scan_width_or_prec_value scan i j = + and scan_width_or_prec_value scan i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '*' -> @@ -802,28 +836,28 @@ let type_format loc fmt = ty_uresult, ty_arrow Predef.type_int ty_result | '-' | '+' -> scan_decimal_string scan i (j + 1) | _ -> scan_decimal_string scan i j - and scan_precision i j = + and scan_precision i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '.' -> scan_width_or_prec_value scan_conversion i (j + 1) | _ -> scan_conversion i j - and conversion j ty_arg = + and conversion j ty_arg = let ty_uresult, ty_result = scan_format (j + 1) in ty_uresult, if skip then ty_result else ty_arrow ty_arg ty_result - and conversion_a j ty_e ty_arg = + and conversion_a j ty_e ty_arg = let ty_uresult, ty_result = conversion j ty_arg in let ty_a = ty_arrow ty_input (ty_arrow ty_e ty_aresult) in ty_uresult, ty_arrow ty_a ty_result - and conversion_r j ty_e ty_arg = + and conversion_r j ty_e ty_arg = let ty_uresult, ty_result = conversion j ty_arg in let ty_r = ty_arrow ty_input ty_e in ty_arrow ty_r ty_uresult, ty_result - and scan_conversion i j = + and scan_conversion i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '%' | '!' | ',' -> scan_format (j + 1) @@ -898,7 +932,7 @@ let type_format loc fmt = (* Approximate the type of an expression, for better recursion *) -let rec approx_type env sty = +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 @@ -917,7 +951,7 @@ let rec approx_type env sty = approx_type env sty | _ -> newvar () -let rec type_approx env sexp = +let rec type_approx env sexp = match sexp.pexp_desc with Pexp_let (_, _, e) -> type_approx env e | Pexp_function (p,_,(_,e)::_) when is_optional p -> @@ -944,7 +978,7 @@ let rec type_approx env sexp = | _ -> 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 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 @@ -954,10 +988,10 @@ let rec list_labels_aux env visited ls ty_fun = | _ -> List.rev ls, ty.desc = Tvar -let list_labels env ty = list_labels_aux env [] [] ty +let list_labels env ty = list_labels_aux env [] [] ty (* Check that all univars are safe in a type *) -let check_univars env expans kind exp ty_expected vars = +let check_univars env expans kind exp ty_expected vars = if expans && not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; (* need to expand twice? cf. Ctype.unify2 *) @@ -976,8 +1010,9 @@ let check_univars env expans kind exp ty_expected vars = raise (Error (exp.exp_loc, 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 check_application_result env statement exp = let loc = exp.exp_loc in match (expand_head env exp.exp_type).desc with | Tarrow _ -> @@ -989,8 +1024,8 @@ let check_application_result env statement exp = 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 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 @@ -1003,7 +1038,7 @@ let generalizable level ty = let self_coercion = ref ([] : (Path.t * Location.t list ref) list) (* Helpers for packaged modules. *) -let create_package_type loc env (p, l) = +let create_package_type loc env (p, l) = let s = !Typetexp.transl_modtype_longident loc env p in newty (Tpackage (s, List.map fst l, @@ -1011,7 +1046,7 @@ let create_package_type loc env (p, l) = (* Typing of expressions *) -let unify_exp env exp expected_ty = +let unify_exp env exp expected_ty = (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type Printtyp.raw_type_expr expected_ty; *) try @@ -1022,14 +1057,14 @@ let unify_exp env exp expected_ty = | Tags(l1,l2) -> raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2))) -let rec type_exp env sexp = +let rec type_exp env sexp = let loc = sexp.pexp_loc in match sexp.pexp_desc with | Pexp_ident lid -> begin if !Clflags.annotations then begin try let (path, annot) = Env.lookup_annot lid env in - let rec name_of_path = function + let rec name_of_path = function | Path.Pident id -> Ident.name id | Path.Pdot(p, s, pos) -> if Oprint.parenthesized_ident s then @@ -1078,7 +1113,7 @@ let rec type_exp env sexp = | Default -> None in let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in - let body = type_exp new_env sbody in + let body = type_exp new_env sbody in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); exp_loc = loc; @@ -1094,7 +1129,7 @@ let rec type_exp env sexp = end_def (); generalize_structure funct.exp_type end; - let rec lower_args seen ty_fun = + let rec lower_args seen ty_fun = let ty = expand_head env ty_fun in if List.memq ty seen then () else match ty.desc with @@ -1118,9 +1153,12 @@ let rec type_exp env sexp = | Pexp_match(sarg, caselist) -> let arg = type_exp env sarg in let ty_res = newvar() in + Format.fprintf Format.std_formatter " match type before type_cases_gadt : %a\n%! " Printtyp.raw_type_expr ty_res ; let cases, partial = - type_cases env arg.exp_type ty_res (Some loc) caselist + type_cases_gadt env arg.exp_type ty_res (Some loc) caselist in + + Format.fprintf Format.std_formatter " match type : %a\n%! " Printtyp.raw_type_expr ty_res ; re { exp_desc = Texp_match(arg, cases, partial); exp_loc = loc; @@ -1162,7 +1200,7 @@ let rec type_exp env sexp = let ty = newvar () in let lbl_exp_list = type_label_a_list (type_label_exp true env loc ty) lid_sexp_list in - let rec check_duplicates seen_pos lid_sexp lbl_exp = + let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with ((lid, _) :: rem1, (lbl, _) :: rem2) -> if List.mem lbl.lbl_pos seen_pos @@ -1175,7 +1213,7 @@ let rec type_exp env sexp = None, _ -> None | Some sexp, (lbl, _) :: _ -> let ty_exp = newvar () in - let unify_kept lbl = + let unify_kept lbl = if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos) lbl_exp_list then begin @@ -1196,7 +1234,7 @@ let rec type_exp env sexp = let present_indices = List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in let label_names = extract_label_names sexp env ty in - let rec missing_labels n = function + let rec missing_labels n = function [] -> [] | lbl :: rem -> if List.mem n present_indices then missing_labels (n + 1) rem @@ -1611,7 +1649,7 @@ let rec type_exp env sexp = 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 = + let rec replace t = if Hashtbl.mem seen t.id then () else begin Hashtbl.add seen t.id (); @@ -1641,7 +1679,7 @@ let rec type_exp env sexp = | Pexp_open (lid, e) -> type_exp (!type_open env sexp.pexp_loc lid) e -and type_label_exp create env loc ty (lid, sarg) = +and type_label_exp create env loc ty (lid, sarg) = let label = Typetexp.find_label env sarg.pexp_loc lid in begin_def (); if !Clflags.principal then begin_def (); @@ -1683,9 +1721,9 @@ and type_label_exp create env loc ty (lid, sarg) = in (label, {arg with exp_type = instance arg.exp_type}) -and type_argument env sarg ty_expected' = +and type_argument env sarg ty_expected' = (* ty_expected' may be generic *) - let no_labels ty = + let no_labels ty = let ls, tvar = list_labels env ty in not tvar && List.for_all ((=) "") ls in @@ -1702,7 +1740,7 @@ and type_argument env sarg ty_expected' = end_def (); generalize_structure texp.exp_type end; - let rec make_args args ty_fun = + 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 -> make_args @@ -1726,7 +1764,7 @@ and type_argument env sarg ty_expected' = 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 var_pair name ty = let id = Ident.create name in {pat_desc = Tpat_var id; pat_type = ty; pat_loc = Location.none; pat_env = env}, @@ -1734,7 +1772,7 @@ and type_argument env sarg ty_expected' = Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})} in let eta_pat, eta_var = var_pair "eta" ty_arg in - let func texp = + let func texp = { texp with exp_type = ty_fun; exp_desc = Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc = Texp_apply (texp, args@ @@ -1751,19 +1789,19 @@ and type_argument env sarg ty_expected' = | _ -> type_expect env sarg ty_expected -and type_application env funct sargs = +and type_application env funct sargs = (* funct.exp_type may be generic *) - let result_type omitted ty_fun = + let result_type omitted ty_fun = List.fold_left (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok))) ty_fun omitted in - let has_label l ty_fun = + let has_label l ty_fun = let ls, tvar = list_labels env ty_fun in tvar || List.mem l ls in let ignored = ref [] in - let rec type_unknown_args args omitted ty_fun = function + let rec type_unknown_args args omitted ty_fun = function [] -> (List.map (function None, x -> None, x | Some f, x -> Some (f ()), x) @@ -1825,11 +1863,11 @@ and type_application env funct sargs = end in let warned = ref false in - let rec type_args args omitted ty_fun ty_old sargs more_sargs = + let rec type_args args omitted ty_fun ty_old sargs more_sargs = match expand_head env ty_fun with {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun' when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok -> - let may_warn loc w = + let may_warn loc w = if not !warned && !Clflags.principal && lv <> generic_level then begin warned := true; @@ -1924,7 +1962,7 @@ and type_application env funct sargs = else type_args [] [] ty ty sargs [] -and type_construct env loc lid sarg explicit_arity ty_expected = +and type_construct env loc lid sarg explicit_arity ty_expected = let constr = Typetexp.find_constructor env loc lid in let sargs = match sarg with @@ -1979,7 +2017,7 @@ and type_expect ?in_function env sexp ty_expected = type_construct env loc lid sarg explicit_arity ty_expected | Pexp_let(rec_flag, spat_sexp_list, sbody) -> let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in - let body = type_expect new_env sbody ty_expected in + let body = type_expect new_env sbody ty_expected in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); exp_loc = loc; @@ -2064,7 +2102,7 @@ and type_expect ?in_function env sexp ty_expected = let cases, partial = type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res (Some loc) caselist in - let not_function ty = + let not_function ty = let ls, tvar = list_labels env ty in ls = [] && not tvar in @@ -2091,7 +2129,7 @@ and type_expect ?in_function env sexp ty_expected = let ty = Typetexp.transl_simple_type env false sty in repr ty in - let set_type ty = + let set_type ty = unify_exp env { exp_desc = Texp_tuple []; exp_loc = loc; @@ -2115,6 +2153,19 @@ and type_expect ?in_function env sexp ty_expected = re { exp with exp_type = ty } | _ -> assert false end + + | Pexp_match(sarg, caselist) -> (* GAH : check with garrigue that this is ok *) + let arg = type_exp env sarg in + let cases, partial = + type_cases_gadt env arg.exp_type ty_expected (Some loc) caselist + in + re { + exp_desc = Texp_match(arg, cases, partial); + exp_loc = loc; + exp_type = ty_expected; + exp_env = env } + + | _ -> let exp = type_exp env sexp in unify_exp env exp ty_expected; @@ -2122,7 +2173,7 @@ and type_expect ?in_function env sexp ty_expected = (* Typing of statements (expressions whose values are discarded) *) -and type_statement env sexp = +and type_statement env sexp = let loc = sexp.pexp_loc in begin_def(); let exp = type_exp env sexp in @@ -2148,16 +2199,30 @@ and type_statement env sexp = (* Typing of match cases *) -and type_cases ?in_function env ty_arg ty_res partial_loc caselist = - let ty_arg' = newvar () in +and type_pattern_gadt env spat scope ty_arg = + reset_local_unifier (); + set_unification_type `Pattern; + try_finally + (fun () -> type_pattern env spat scope ty_arg ) + (fun () -> set_unification_type `Expression) + +and type_cases ?in_function ?(gadt=false) env ty_arg ty_res partial_loc caselist = +(* let ty_arg' = newvar () in *) (* GAH : must ask garrigue about this *) let pattern_force = ref [] in - let pat_env_list = + let pat_env_list = List.map (fun (spat, sexp) -> let loc = sexp.pexp_loc in if !Clflags.principal then begin_def (); let scope = Some (Annot.Idef loc) in - let (pat, ext_env, force) = type_pattern env spat scope in + + let (pat, ext_env, force) = + if gadt then + type_pattern_gadt env spat scope ty_arg + else + type_pattern env spat scope ty_arg + in + let local_unifier = get_local_unifier () in pattern_force := force @ !pattern_force; let pat = if !Clflags.principal then begin @@ -2166,26 +2231,35 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist = { pat with pat_type = instance pat.pat_type } end else pat in - unify_pat env pat ty_arg'; - (pat, ext_env)) + +(* unify_pat env pat ty_arg'; (* GAH: probably wrong. what in the blazes does ty_arg' do?? *)*) + (pat, ext_env,local_unifier)) caselist in (* Check for polymorphic variants to close *) - let patl = List.map fst pat_env_list in + + let fst3 (a,b,c) = a in + let patl = List.map fst3 pat_env_list in + if List.exists has_variants patl then begin Parmatch.pressure_variants env patl; List.iter (iter_pattern finalize_variant) patl end; (* `Contaminating' unifications start here *) List.iter (fun f -> f()) !pattern_force; - begin match pat_env_list with [] -> () - | (pat, _) :: _ -> unify_pat env pat ty_arg - end; + +(* begin match pat_env_list with [] -> () + | (pat, _) :: _ -> unify_pat env pat ty_arg (* GAH: probably incorrect; check with garrigue. if we readd this code then it doesn't work *) + end;*) let in_function = if List.length caselist = 1 then in_function else None in let cases = List.map2 - (fun (pat, ext_env) (spat, sexp) -> - let exp = type_expect ?in_function ext_env sexp ty_res in - (pat, exp)) + (fun (pat, ext_env,local_unifier) (spat, sexp) -> + List.iter (fun (t,t') -> t.desc <- Tlink t') local_unifier; + try_finally + (fun () -> + let exp = type_expect ?in_function ext_env sexp ty_res in + (pat, exp)) + (fun () -> List.iter (fun (t,_) -> t.desc <- Tunivar) local_unifier)) pat_env_list caselist in let partial = @@ -2196,13 +2270,18 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist = add_delayed_check (fun () -> Parmatch.check_unused env cases); cases, partial +and type_cases_gadt ?in_function env ty_arg ty_res partial_loc caselist = + type_cases ?in_function ~gadt:true env ty_arg ty_res partial_loc caselist + (* Typing of let bindings *) -and type_let env rec_flag spat_sexp_list scope = +and type_let env rec_flag spat_sexp_list scope = + begin_def(); if !Clflags.principal then begin_def (); let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in - let (pat_list, new_env, force) = type_pattern_list env spatl scope in + let nvs = List.map (fun _ -> newvar ()) spatl in (* GAH: so wrong *) + let (pat_list, new_env, force) = type_pattern_list env spatl scope nvs in if rec_flag = Recursive then List.iter2 (fun pat (_, sexp) -> @@ -2211,7 +2290,7 @@ and type_let env rec_flag spat_sexp_list scope = | Tpoly (ty, tl) -> {pat with pat_type = snd (instance_poly false tl ty)} | _ -> pat - in unify_pat env pat (type_approx env sexp)) + in unify_pat env pat (type_approx env sexp)) pat_list spat_sexp_list; let pat_list = if !Clflags.principal then begin @@ -2223,6 +2302,7 @@ and type_let env rec_flag spat_sexp_list scope = pat_list end else pat_list in (* Polymoprhic variant processing *) + List.iter (fun pat -> if has_variants pat then begin @@ -2265,13 +2345,13 @@ and type_let env rec_flag spat_sexp_list scope = (* Typing of toplevel bindings *) -let type_binding env rec_flag spat_sexp_list scope = +let type_binding env rec_flag spat_sexp_list scope = Typetexp.reset_type_variables(); type_let env rec_flag spat_sexp_list scope (* Typing of toplevel expressions *) -let type_expression env sexp = +let type_expression env sexp = Typetexp.reset_type_variables(); begin_def(); let exp = type_exp env sexp in @@ -2285,7 +2365,7 @@ let type_expression env sexp = open Format open Printtyp -let report_error ppf = function +let report_error ppf = function | Polymorphic_label lid -> fprintf ppf "@[The record field label %a is polymorphic.@ %s@]" longident lid "You cannot instantiate it in a pattern." @@ -2328,7 +2408,7 @@ let report_error ppf = function "This expression is not a function; it cannot be applied" end | Apply_wrong_label (l, ty) -> - let print_label ppf = function + let print_label ppf = function | "" -> fprintf ppf "without label" | l -> fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l @@ -2342,7 +2422,7 @@ let report_error ppf = function fprintf ppf "The record field label %a is defined several times" longident lid | Label_missing labels -> - let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in + let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in fprintf ppf "@[<hov>Some record field labels are undefined:%a@]" print_labels labels | Label_not_mutable lid -> diff --git a/typing/typedecl.ml b/typing/typedecl.ml index bc2986c41..d2531299a 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -145,19 +145,26 @@ let transl_declaration env (name, sdecl) id = | Ptype_variant cstrs -> let all_constrs = ref StringSet.empty in List.iter - (fun (name, args, loc) -> + (fun (name, _, _, loc) -> if StringSet.mem name !all_constrs then raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); all_constrs := StringSet.add name !all_constrs) cstrs; - if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs) + if List.length (List.filter (fun (_, args, _, _) -> args <> []) cstrs) (* GAH: MIGHT BE WRONG *) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); + if List.for_all (fun (_,_,x,_) -> match x with Some _ -> false | None -> true) cstrs then Type_variant (List.map - (fun (name, args, loc) -> + (fun (name, args,_, loc) -> (name, List.map (transl_simple_type env true) args)) cstrs) + else + Type_generalized_variant + (List.map + (fun (name, args,ret_type_opt, loc) -> + (name, List.map (transl_simple_type env true) args,may_map (transl_simple_type env true) ret_type_opt)) + cstrs) | Ptype_record lbls -> let all_labels = ref StringSet.empty in List.iter @@ -219,7 +226,9 @@ let generalize_decl decl = Type_abstract -> () | Type_variant v -> - List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v + List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v (* GAH: almost sure this is wrong *) + | Type_generalized_variant v -> + List.iter (fun (_, tyl,ret_type_opt) -> List.iter Ctype.generalize tyl; may Ctype.generalize ret_type_opt) v (* GAH: almost sure this is wrong *) | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r end; @@ -261,24 +270,36 @@ let rec check_constraints_rec env loc visited ty = let check_constraints env (_, sdecl) (_, decl) = let visited = ref TypeSet.empty in - begin match decl.type_kind with - | Type_abstract -> () - | Type_variant l -> + let process_variants l = let rec find_pl = function Ptype_variant pl -> pl | Ptype_record _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in List.iter - (fun (name, tyl) -> - let styl = - try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty + (fun (name, tyl,ret_type_opt) -> (* GAH: again, no idea *) + let styl,sret_type_opt = + try let (_,sty,ret_type_opt (* added by me *) ,_) = List.find (fun (n,_,_,_) -> n = name) pl in sty,ret_type_opt (* GAH: lord, I have no idea what this is about *) with Not_found -> assert false in List.iter2 (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty) - styl tyl) - l + styl tyl; + match sret_type_opt,ret_type_opt with + | Some sr,Some r -> + check_constraints_rec env sr.ptyp_loc visited r + | _ -> + ()) + l + in + begin match decl.type_kind with + | Type_abstract -> () + | Type_variant l -> + let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in + process_variants (gen_variants l) + | Type_generalized_variant l -> + process_variants l + | Type_record (l, _) -> let rec find_pl = function Ptype_record pl -> pl @@ -479,9 +500,12 @@ let compute_variance env tvl nega posi cntr ty = let make_variance ty = (ty, ref false, ref false, ref false) let whole_type decl = match decl.type_kind with - Type_variant tll -> + | Type_generalized_variant tll -> Btype.newgenty - (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) + (Ttuple (List.map (fun (_, tl,_ (* added by me *)) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*) + | Type_variant tll -> + Btype.newgenty + (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*) | Type_record (ftl, _) -> Btype.newgenty (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) @@ -503,15 +527,24 @@ let compute_variance_decl env check decl (required, loc) = let tvl2 = List.map make_variance fvl in let tvl = tvl0 @ tvl1 in begin match decl.type_kind with - Type_abstract -> + | Type_abstract -> begin match decl.type_manifest with None -> assert false | Some ty -> compute_variance env tvl true false false ty end - | Type_variant tll -> + | Type_variant tll -> (* GAH: what in the blazes *) List.iter (fun (_,tl) -> - List.iter (compute_variance env tvl true false false) tl) + List.iter (compute_variance env tvl true false false) tl) + tll + | Type_generalized_variant tll -> (* GAH: what in the blazes *) + List.iter + (fun (_,tl,ret_type_opt) -> + match ret_type_opt with + | None -> + List.iter (compute_variance env tvl true false false) tl + | Some ret_type -> + List.iter (compute_variance env tvl true true true) tl) (* GAH: variance calculation, is this right *) tll | Type_record (ftl, _) -> List.iter @@ -612,7 +645,7 @@ let check_duplicates name_sdecl_list = (fun (name, sdecl) -> match sdecl.ptype_kind with Ptype_variant cl -> List.iter - (fun (cname, _, loc) -> + (fun (cname, _, _, loc) -> (* probably right *) try let name' = Hashtbl.find constrs cname in Location.prerr_warning loc @@ -940,9 +973,14 @@ let report_error ppf = function 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 ppf ty tl (fun (_,tl) -> Btype.newgenty (Ttuple tl)) - "case" (fun (lab,_) -> lab ^ " of ") + | Type_generalized_variant tl, _ -> + explain_unbound ppf ty tl (fun (_,tl,_) -> + Btype.newgenty (Ttuple tl)) + "case" (fun (lab,_,_) -> lab ^ " of ") + | Type_variant tl, _ -> + explain_unbound ppf ty tl (fun (_,tl) -> + Btype.newgenty (Ttuple tl)) + "case" (fun (lab,_) -> lab ^ " of ") | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun (_,_,t) -> t) "field" (fun (lab,_,_) -> lab ^ ": ") diff --git a/typing/types.ml b/typing/types.ml index 5996719d4..d1ef644a3 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -106,6 +106,7 @@ and value_kind = type constructor_description = { 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 *) @@ -150,6 +151,7 @@ and type_kind = | Type_variant of (string * type_expr list) list | Type_record of (string * mutable_flag * type_expr) list * record_representation + | Type_generalized_variant of (string * type_expr list * type_expr option) list type exception_declaration = type_expr list diff --git a/typing/types.mli b/typing/types.mli index a4c640845..962dfd02e 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -103,6 +103,7 @@ and value_kind = type constructor_description = { 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 *) @@ -147,6 +148,7 @@ and type_kind = | Type_variant of (string * type_expr list) list | Type_record of (string * mutable_flag * type_expr) list * record_representation + | Type_generalized_variant of (string * type_expr list * type_expr option) list type exception_declaration = type_expr list |