summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/ctype.ml12
-rw-r--r--typing/ctype.mli1
-rw-r--r--typing/mtype.ml5
-rw-r--r--typing/oprint.ml6
-rw-r--r--typing/printtyp.ml3
-rw-r--r--typing/typeclass.ml32
-rw-r--r--typing/typecore.ml109
-rw-r--r--typing/typedecl.ml9
-rw-r--r--typing/typedtree.ml2
-rw-r--r--typing/typedtree.mli2
-rw-r--r--typing/unused_var.ml1
11 files changed, 87 insertions, 95 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 5e27441eaa..cbd9ec1440 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1176,9 +1176,15 @@ let rec copy_sep fixed free bound visited ty =
t
end
-let instance_poly fixed univars sch =
- let vars = List.map (fun _ -> newvar ()) univars in
- let pairs = List.map2 (fun u v -> repr u, (v, [])) univars vars in
+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 ()
+ | _ -> assert false
+ in
+ let vars = List.map copy_var univars 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;
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 0c42edafdf..c4d4ff13a3 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -128,6 +128,7 @@ 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:
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 404dda95bc..57ed4e2901 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -48,8 +48,9 @@ and strengthen_sig env sg p =
sigelt :: strengthen_sig env rem p
| Tsig_type(id, decl, rs) :: rem ->
let newdecl =
- match decl.type_manifest with
- Some ty when decl.type_private = Public -> decl
+ 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),
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 21ef160806..0bfd8797cd 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -265,9 +265,9 @@ let out_type = ref print_out_type
(* Class types *)
let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- (*if co then if cn then "!" else "+" else if cn then "-" else "?"*)
- ty
+ fprintf ppf "%s%s"
+ (if not cn then "+" else if not co then "-" else "")
+ (if ty = "_" then ty else "'"^ty)
let print_out_class_params ppf =
function
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index ed8b2e75f9..2b5470ea48 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -236,7 +236,8 @@ let name_of_type t =
(* No name available, create a new one *)
new_name ()
in
- names := (t, name) :: !names;
+ (* Exception for type declarations *)
+ if name <> "_" then names := (t, name) :: !names;
name
let check_name_of_type t = ignore(name_of_type t)
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 34b651e186..512f7cf8b2 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -569,38 +569,6 @@ let rec class_field cl_num self_type meths vars
type_constraint val_env sty sty' loc;
(val_env, met_env, par_env, fields, concr_meths, warn_vals, inher)
- | Pcf_let (rec_flag, sdefs, loc) ->
- let (defs, val_env) =
- try
- Typecore.type_let val_env rec_flag sdefs None
- with Ctype.Unify [(ty, _)] ->
- raise(Error(loc, Make_nongen_seltype ty))
- in
- let (vals, met_env, par_env) =
- List.fold_right
- (fun id (vals, met_env, par_env) ->
- let expr =
- Typecore.type_exp val_env
- {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
- pexp_loc = Location.none}
- in
- let desc =
- {val_type = expr.exp_type;
- val_kind = Val_ivar (Immutable, cl_num);
- val_loc = Location.none;
- }
- in
- let id' = Ident.create (Ident.name id) in
- ((id', expr)
- :: vals,
- Env.add_value id' desc met_env,
- Env.add_value id' desc par_env))
- (let_bound_idents defs)
- ([], met_env, par_env)
- in
- (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
- concr_meths, warn_vals, inher)
-
| Pcf_init expr ->
let expr = make_method cl_num expr in
let vars_local = !vars in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index a400bc23ea..9a7a1d849e 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -521,7 +521,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
begin match ty.desc with
| Tpoly (body, tyl) ->
begin_def ();
- let _, ty' = instance_poly false tyl body in
+ let _, ty' = instance_poly ~keep_names:true false tyl body in
end_def ();
generalize ty';
let id = enter_variable loc name ty' in
@@ -870,7 +870,7 @@ let rec is_nonexpansive exp =
Cf_meth _ -> true
| Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
| Cf_init e -> is_nonexpansive e
- | Cf_inher _ | Cf_let _ -> false)
+ | Cf_inher _ -> false)
fields &&
Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
vars true &&
@@ -907,7 +907,7 @@ and is_nonexpansive_opt = function
(* Typing format strings for printing or reading.
- This format strings are used by functions in modules Printf, Format, and
+ These format strings are used by functions in modules Printf, Format, and
Scanf.
(Handling of * modifiers contributed by Thorsten Ohl.) *)
@@ -926,25 +926,6 @@ let type_format loc fmt =
let incomplete_format fmt =
raise (Error (loc, Incomplete_format fmt)) in
- let range_closing_index fmt i =
-
- let len = String.length fmt in
- 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 =
- 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 =
- 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 len = String.length fmt in
@@ -963,14 +944,7 @@ let type_format loc fmt =
else incomplete_format fmt else
match fmt.[i] with
| '%' -> scan_opts i (i + 1)
- | '@' -> skip_indication (i + 1)
| _ -> scan_format (i + 1)
- and skip_indication i =
- if i >= len then incomplete_format fmt else
- match fmt.[i] with
- | '@' | '%' -> scan_format (i + 1)
- | _ -> scan_format i
-
and scan_opts i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
@@ -1001,6 +975,48 @@ let type_format loc fmt =
match fmt.[j] with
| '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
| _ -> scan_conversion i j
+ and scan_indication j =
+ if j >= len then j - 1 else
+ match fmt.[j] with
+ | '@' ->
+ let k = j + 1 in
+ if k >= len then j - 1 else
+ begin match fmt.[k] with
+ | '%' ->
+ let k = k + 1 in
+ if k >= len then j - 1 else
+ begin match fmt.[k] with
+ | '%' | '@' -> k
+ | _c -> j - 1
+ end
+ | _c -> k
+ end
+ | _c -> j - 1
+ and scan_range j =
+ let rec scan_closing j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | ']' -> j
+ | '%' ->
+ let j = j + 1 in
+ if j >= len then incomplete_format fmt else
+ begin match fmt.[j] with
+ | '%' | '@' -> scan_closing (j + 1)
+ | c -> bad_conversion fmt j c
+ end
+ | c -> scan_closing (j + 1) in
+ let scan_first_pos j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | ']' -> scan_closing (j + 1)
+ | c -> scan_closing j in
+ let rec scan_first_neg j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '^' -> scan_first_pos (j + 1)
+ | c -> scan_first_pos j in
+
+ scan_first_neg j
and conversion j ty_arg =
let ty_uresult, ty_result = scan_format (j + 1) in
@@ -1020,13 +1036,16 @@ let type_format loc fmt =
and scan_conversion i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
- | '%' | '!' | ',' -> scan_format (j + 1)
- | 's' | 'S' -> conversion j Predef.type_string
+ | '%' | '@' | '!' | ',' -> scan_format (j + 1)
+ | 's' | 'S' ->
+ let j = scan_indication (j + 1) in
+ conversion j Predef.type_string
| '[' ->
- let j = range_closing_index fmt j in
+ let j = scan_range (j + 1) in
+ let j = scan_indication (j + 1) in
conversion j Predef.type_string
| 'c' | 'C' -> conversion j Predef.type_char
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
+ | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' ->
conversion j Predef.type_int
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
| 'B' | 'b' -> conversion j Predef.type_bool
@@ -1055,7 +1074,7 @@ let type_format loc fmt =
let j = j + 1 in
if j >= len then conversion (j - 1) Predef.type_int else begin
match fmt.[j] with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+ | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
let ty_arg =
match c with
| 'l' -> Predef.type_int32
@@ -1084,9 +1103,10 @@ let type_format loc fmt =
let ty_ureader, ty_args = scan_format 0 in
newty
(Tconstr
- (Predef.path_format6,
- [ty_args; ty_input; ty_aresult; ty_ureader; ty_uresult; ty_result],
- ref Mnil)) in
+ (Predef.path_format6,
+ [ ty_args; ty_input; ty_aresult;
+ ty_ureader; ty_uresult; ty_result; ],
+ ref Mnil)) in
type_in_format fmt
@@ -2633,7 +2653,8 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s ->
let pat =
match pat.pat_type.desc with
| Tpoly (ty, tl) ->
- {pat with pat_type = snd (instance_poly 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 sexp))
pat_list spat_sexp_list;
@@ -2722,7 +2743,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s ->
| Tpoly (ty, tl) ->
begin_def ();
if !Clflags.principal then begin_def ();
- let vars, ty' = instance_poly true tl ty in
+ let vars, ty' = instance_poly ~keep_names:true true tl ty in
if !Clflags.principal then begin
end_def ();
generalize_structure ty'
@@ -2744,8 +2765,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s ->
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)
+ (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
pat_list;
(List.combine pat_list exp_list, new_env, unpacks)
@@ -2775,7 +2795,12 @@ let type_expression env sexp =
end_def();
if is_nonexpansive exp then generalize exp.exp_type
else generalize_expansive env exp.exp_type;
- exp
+ 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 env in
+ {exp with exp_type = desc.val_type}
+ | _ -> exp
(* Error report *)
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 94e09cc574..315e066d16 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -125,16 +125,11 @@ module StringSet =
end)
let make_params sdecl =
- let param_counter = ref 0 in
try
List.map
(function
- None ->
- incr param_counter ;
- enter_type_variable true sdecl.ptype_loc
- (Printf.sprintf "*%d" !param_counter)
- | Some x ->
- enter_type_variable true sdecl.ptype_loc x)
+ None -> Ctype.new_global_var ~name:"_" ()
+ | Some x -> enter_type_variable true sdecl.ptype_loc x)
sdecl.ptype_params
with Already_bound ->
raise(Error(sdecl.ptype_loc, Repeated_parameter))
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 3b43d1d80f..0feca199a3 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -110,8 +110,6 @@ and class_field =
Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
| Cf_val of string * Ident.t * expression option * bool
| Cf_meth of string * expression
- | Cf_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list
| Cf_init of expression
(* Value expressions for the module language *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 15acb6ac59..0c5efa8ea8 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -112,8 +112,6 @@ and class_field =
| Cf_val of string * Ident.t * expression option * bool
(* None = virtual, true = override *)
| Cf_meth of string * expression
- | Cf_let of rec_flag * (pattern * expression) list *
- (Ident.t * expression) list
| Cf_init of expression
(* Value expressions for the module language *)
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 61123eff50..3a6eeaeb50 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -274,7 +274,6 @@ and class_field ppf tbl cf =
| Pcf_virt _ | Pcf_valvirt _ -> ()
| Pcf_meth (_, _, _, e, _) -> expression ppf tbl e;
| Pcf_cstr _ -> ()
- | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
| Pcf_init e -> expression ppf tbl e;
;;
View Lorry Controller Status