summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/ctype.ml344
-rw-r--r--typing/ctype.mli58
-rw-r--r--typing/env.ml509
-rw-r--r--typing/env.mli78
-rw-r--r--typing/ident.ml156
-rw-r--r--typing/ident.mli39
-rw-r--r--typing/includecore.ml53
-rw-r--r--typing/includecore.mli10
-rw-r--r--typing/includemod.ml258
-rw-r--r--typing/includemod.mli19
-rw-r--r--typing/mtype.ml147
-rw-r--r--typing/mtype.mli15
-rw-r--r--typing/parmatch.ml263
-rw-r--r--typing/parmatch.mli6
-rw-r--r--typing/path.ml17
-rw-r--r--typing/path.mli10
-rw-r--r--typing/predef.ml97
-rw-r--r--typing/predef.mli39
-rw-r--r--typing/printtyp.ml214
-rw-r--r--typing/printtyp.mli17
-rw-r--r--typing/subst.ml96
-rw-r--r--typing/subst.mli21
-rw-r--r--typing/typecore.ml601
-rw-r--r--typing/typecore.mli32
-rw-r--r--typing/typedecl.ml131
-rw-r--r--typing/typedecl.mli20
-rw-r--r--typing/typedtree.ml186
-rw-r--r--typing/typedtree.mli161
-rw-r--r--typing/typemod.ml306
-rw-r--r--typing/typemod.mli23
-rw-r--r--typing/typetexp.ml86
-rw-r--r--typing/typetexp.mli19
32 files changed, 0 insertions, 4031 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml
deleted file mode 100644
index e8b42ed38a..0000000000
--- a/typing/ctype.ml
+++ /dev/null
@@ -1,344 +0,0 @@
-(* Operations on core types *)
-
-open Misc
-open Typedtree
-
-
-exception Unify
-
-let current_level = ref 0
-
-let generic_level = (-1)
-
-let begin_def () = incr current_level
-and end_def () = decr current_level
-
-let newvar () =
- Tvar { tvar_level = !current_level; tvar_link = None }
-
-let rec repr = function
- Tvar({tvar_link = Some ty} as v) ->
- let r = repr ty in
- if r != ty then v.tvar_link <- Some r;
- r
- | t -> t
-
-let rec generalize ty =
- match repr ty with
- Tvar v ->
- if v.tvar_level > !current_level then v.tvar_level <- generic_level
- | Tarrow(t1, t2) ->
- generalize t1; generalize t2
- | Ttuple tl ->
- List.iter generalize tl
- | Tconstr(p, []) ->
- ()
- | Tconstr(p, tl) ->
- List.iter generalize tl
-
-let rec make_nongen ty =
- match repr ty with
- Tvar v ->
- if v.tvar_level > !current_level then v.tvar_level <- !current_level
- | Tarrow(t1, t2) ->
- make_nongen t1; make_nongen t2
- | Ttuple tl ->
- List.iter make_nongen tl
- | Tconstr(p, []) ->
- ()
- | Tconstr(p, tl) ->
- List.iter make_nongen tl
-
-let inst_subst = ref ([] : (type_expr * type_expr) list)
-
-let rec copy ty =
- match repr ty with
- Tvar v as t ->
- if v.tvar_level = generic_level then begin
- try
- List.assq t !inst_subst
- with Not_found ->
- let t' = newvar() in
- inst_subst := (t, t') :: !inst_subst;
- t'
- end else t
- | Tarrow(t1, t2) ->
- Tarrow(copy t1, copy t2)
- | Ttuple tl ->
- Ttuple(List.map copy tl)
- | Tconstr(p, []) as t ->
- t
- | Tconstr(p, tl) ->
- Tconstr(p, List.map copy tl)
-
-let instance sch =
- inst_subst := [];
- let ty = copy sch in
- inst_subst := [];
- ty
-
-let instance_constructor cstr =
- inst_subst := [];
- let ty_res = copy cstr.cstr_res in
- let ty_args = List.map copy cstr.cstr_args in
- inst_subst := [];
- (ty_args, ty_res)
-
-let instance_label lbl =
- inst_subst := [];
- let ty_res = copy lbl.lbl_res in
- let ty_arg = copy lbl.lbl_arg in
- inst_subst := [];
- (ty_arg, ty_res)
-
-let substitute params args body =
- inst_subst := List.combine(params, args);
- let ty = copy body in
- inst_subst := [];
- ty
-
-exception Cannot_expand
-
-let expand_abbrev env path args =
- let decl = Env.find_type path env in
- match decl.type_kind with
- Type_manifest body -> substitute decl.type_params args body
- | _ -> raise Cannot_expand
-
-let rec occur tvar ty =
- match repr ty with
- Tvar v ->
- if v == tvar then raise Unify;
- if v.tvar_level > tvar.tvar_level then v.tvar_level <- tvar.tvar_level
- | Tarrow(t1, t2) ->
- occur tvar t1; occur tvar t2
- | Ttuple tl ->
- List.iter (occur tvar) tl
- | Tconstr(p, []) ->
- ()
- | Tconstr(p, tl) ->
- List.iter (occur tvar) tl
-
-let rec unify env t1 t2 =
- if t1 == t2 then () else begin
- let t1 = repr t1 in
- let t2 = repr t2 in
- if t1 == t2 then () else begin
- match (t1, t2) with
- (Tvar v, _) ->
- occur v t2; v.tvar_link <- Some t2
- | (_, Tvar v) ->
- occur v t1; v.tvar_link <- Some t1
- | (Tarrow(t1, u1), Tarrow(t2, u2)) ->
- unify env t1 t2; unify env u1 u2
- | (Ttuple tl1, Ttuple tl2) ->
- unify_list env tl1 tl2
- | (Tconstr(p1, tl1), Tconstr(p2, tl2)) ->
- if Path.same p1 p2 then
- unify_list env tl1 tl2
- else begin
- try
- unify env (expand_abbrev env p1 tl1) t2
- with Cannot_expand ->
- try
- unify env t1 (expand_abbrev env p2 tl2)
- with Cannot_expand ->
- raise Unify
- end
- | (Tconstr(p1, tl1), _) ->
- begin try
- unify env (expand_abbrev env p1 tl1) t2
- with Cannot_expand ->
- raise Unify
- end
- | (_, Tconstr(p2, tl2)) ->
- begin try
- unify env t1 (expand_abbrev env p2 tl2)
- with Cannot_expand ->
- raise Unify
- end
- | (_, _) ->
- raise Unify
- end
- end
-
-and unify_list env tl1 tl2 =
- match (tl1, tl2) with
- ([], []) -> ()
- | (t1::r1, t2::r2) -> unify env t1 t2; unify_list env r1 r2
- | (_, _) -> raise Unify
-
-let rec filter_arrow env t =
- match repr t with
- Tvar v ->
- let t1 = Tvar { tvar_level = v.tvar_level; tvar_link = None }
- and t2 = Tvar { tvar_level = v.tvar_level; tvar_link = None } in
- v.tvar_link <- Some(Tarrow(t1, t2));
- (t1, t2)
- | Tarrow(t1, t2) ->
- (t1, t2)
- | Tconstr(p, tl) ->
- begin try
- filter_arrow env (expand_abbrev env p tl)
- with Cannot_expand ->
- raise Unify
- end
- | _ ->
- raise Unify
-
-let rec filter env t1 t2 =
- if t1 == t2 then () else begin
- let t1 = repr t1 in
- let t2 = repr t2 in
- if t1 == t2 then () else begin
- match (t1, t2) with
- (Tvar v, _) ->
- if v.tvar_level = generic_level then raise Unify;
- occur v t2;
- v.tvar_link <- Some t2
- | (Tarrow(t1, u1), Tarrow(t2, u2)) ->
- filter env t1 t2; filter env u1 u2
- | (Ttuple tl1, Ttuple tl2) ->
- filter_list env tl1 tl2
- | (Tconstr(p1, tl1), Tconstr(p2, tl2)) ->
- if Path.same p1 p2 then
- filter_list env tl1 tl2
- else begin
- try
- filter env (expand_abbrev env p1 tl1) t2
- with Cannot_expand ->
- try
- filter env t1 (expand_abbrev env p2 tl2)
- with Cannot_expand ->
- raise Unify
- end
- | (Tconstr(p1, tl1), _) ->
- begin try
- filter env (expand_abbrev env p1 tl1) t2
- with Cannot_expand ->
- raise Unify
- end
- | (_, Tconstr(p2, tl2)) ->
- begin try
- filter env t1 (expand_abbrev env p2 tl2)
- with Cannot_expand ->
- raise Unify
- end
- | (_, _) ->
- raise Unify
- end
- end
-
-and filter_list env tl1 tl2 =
- match (tl1, tl2) with
- ([], []) -> ()
- | (t1::r1, t2::r2) -> filter env t1 t2; filter_list env r1 r2
- | (_, _) -> raise Unify
-
-let moregeneral env sch1 sch2 =
- try
- filter env (instance sch1) sch2; true
- with Unify ->
- false
-
-let equal env params1 ty1 params2 ty2 =
- let subst = List.combine (params1, params2) in
- let rec eqtype t1 t2 =
- let t1 = repr t1 in
- let t2 = repr t2 in
- match (t1, t2) with
- (Tvar _, Tvar _) ->
- begin try
- List.assq t1 subst == t2
- with Not_found ->
- fatal_error "Ctype.equal"
- end
- | (Tarrow(t1, u1), Tarrow(t2, u2)) ->
- eqtype t1 t2 & eqtype u1 u2
- | (Ttuple tl1, Ttuple tl2) ->
- eqtype_list tl1 tl2
- | (Tconstr(p1, tl1), Tconstr(p2, tl2)) ->
- if Path.same p1 p2 then
- eqtype_list tl1 tl2
- else begin
- try
- eqtype (expand_abbrev env p1 tl1) t2
- with Cannot_expand ->
- try
- eqtype t1 (expand_abbrev env p2 tl2)
- with Cannot_expand ->
- false
- end
- | (Tconstr(p1, tl1), _) ->
- begin try
- eqtype (expand_abbrev env p1 tl1) t2
- with Cannot_expand ->
- false
- end
- | (_, Tconstr(p2, tl2)) ->
- begin try
- eqtype t1 (expand_abbrev env p2 tl2)
- with Cannot_expand ->
- false
- end
- | (_, _) ->
- false
- and eqtype_list tl1 tl2 =
- match (tl1, tl2) with
- ([], []) -> true
- | (t1::r1, t2::r2) -> eqtype t1 t2 & eqtype_list r1 r2
- | (_, _) -> false
- in
- eqtype ty1 ty2
-
-let rec closed_schema ty =
- match repr ty with
- Tvar v -> v.tvar_level = generic_level
- | Tarrow(t1, t2) -> closed_schema t1 & closed_schema t2
- | Ttuple tl -> List.for_all closed_schema tl
- | Tconstr(p, tl) -> List.for_all closed_schema tl
-
-let rec nondep_type env id ty =
- match repr ty with
- Tvar v as tvar -> tvar
- | Tarrow(t1, t2) ->
- Tarrow(nondep_type env id t1, nondep_type env id t2)
- | Ttuple tl ->
- Ttuple(List.map (nondep_type env id) tl)
- | Tconstr(p, tl) ->
- if Path.isfree id p then begin
- let ty' =
- try
- expand_abbrev env p tl
- with Cannot_expand ->
- raise Not_found in
- nondep_type env id ty'
- end else
- Tconstr(p, List.map (nondep_type env id) tl)
-
-let rec free_type_ident env id ty =
- match repr ty with
- Tvar _ -> false
- | Tarrow(t1, t2) ->
- free_type_ident env id t1 or free_type_ident env id t2
- | Ttuple tl ->
- List.exists (free_type_ident env id) tl
- | Tconstr(p, tl) ->
- if Path.isfree id p then true else begin
- try
- free_type_ident env id (expand_abbrev env p tl)
- with Cannot_expand ->
- List.exists (free_type_ident env id) tl
- end
-
-let is_generic ty =
- match repr ty with
- Tvar v -> v.tvar_level = generic_level
- | _ -> fatal_error "Ctype.is_generic"
-
-let rec arity ty =
- match repr ty with
- Tarrow(t1, t2) -> 1 + arity t2
- | _ -> 0
-
-let none = Ttuple [] (* Clearly ill-formed type *)
diff --git a/typing/ctype.mli b/typing/ctype.mli
deleted file mode 100644
index 96a310137e..0000000000
--- a/typing/ctype.mli
+++ /dev/null
@@ -1,58 +0,0 @@
-(* Operations on core types *)
-
-open Typedtree
-
-val begin_def: unit -> unit
- (* Raise the variable level by one at the beginning of a definition. *)
-val end_def: unit -> unit
- (* Lower the variable level by one at the end of a definition *)
-val newvar: unit -> type_expr
- (* Return a fresh variable *)
-val repr: type_expr -> type_expr
- (* Return the canonical representative of a type. *)
-val generalize: type_expr -> unit
- (* Generalize in-place the given type *)
-val make_nongen: type_expr -> unit
- (* Make non-generalizable the given type *)
-val instance: type_expr -> type_expr
- (* Take an instance of a type scheme *)
-val instance_constructor:
- constructor_description -> type_expr list * type_expr
- (* Same, for a constructor *)
-val instance_label: label_description -> type_expr * type_expr
- (* Same, for a label *)
-val unify: Env.t -> type_expr -> type_expr -> unit
- (* Unify the two types given. Raise [Unify] if not possible. *)
-val filter_arrow: Env.t -> type_expr -> type_expr * type_expr
- (* A special case of unification (with 'a -> 'b). *)
-val moregeneral: Env.t -> type_expr -> type_expr -> bool
- (* Check if the first type scheme is more general than the second. *)
-val equal: Env.t -> type_expr list -> type_expr ->
- type_expr list -> type_expr -> bool
- (* [equal env [x1...xn] tau [y1...yn] sigma]
- checks whether the parameterized types
- [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *)
-val closed_schema: type_expr -> bool
- (* Check whether the given type scheme contains no non-generic
- type variables *)
-val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr
- (* Return a type equivalent to the given type but without
- references to the given module identifier. Raise [Not_found]
- if no such type List.exists. *)
-val free_type_ident: Env.t -> Ident.t -> type_expr -> bool
- (* Test whether the given type identifier occurs free
- in the given type expression. *)
-val is_generic: type_expr -> bool
- (* Test whether the given type variable is generic *)
-val arity: type_expr -> int
- (* Return the arity (as for curried functions) of the given type. *)
-val none: type_expr
- (* A dummy type expression *)
-val substitute:
- type_expr list -> type_expr list -> type_expr -> type_expr
- (* [substitute [v1...vN] [t1...tN] t]
- returns a copy of [t] where the [vi] are replaced
- by the [ti]. *)
-
-exception Unify
-
diff --git a/typing/env.ml b/typing/env.ml
deleted file mode 100644
index 1998a81cb9..0000000000
--- a/typing/env.ml
+++ /dev/null
@@ -1,509 +0,0 @@
-(* Environment handling *)
-
-open Format
-open Config
-open Misc
-open Asttypes
-open Longident
-open Path
-open Typedtree
-
-
-type error =
- Not_an_interface of string
- | Corrupted_interface of string
- | Illegal_renaming of string * string
-
-exception Error of error
-
-type t = {
- values: (Path.t * value_description) Ident.tbl;
- constrs: constructor_description Ident.tbl;
- labels: label_description Ident.tbl;
- types: (Path.t * type_declaration) Ident.tbl;
- modules: (Path.t * module_type) Ident.tbl;
- modtypes: (Path.t * modtype_declaration) Ident.tbl;
- components: (Path.t * structure_components) Ident.tbl
-}
-
-and structure_components = {
- mutable comp_values: (string, (value_description * int)) Tbl.t;
- mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
- mutable comp_labels: (string, (label_description * int)) Tbl.t;
- mutable comp_types: (string, (type_declaration * int)) Tbl.t;
- mutable comp_modules: (string, (module_type * int)) Tbl.t;
- mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
- mutable comp_components: (string, (structure_components * int)) Tbl.t
-}
-
-let empty = {
- values = Ident.empty; constrs = Ident.empty;
- labels = Ident.empty; types = Ident.empty;
- modules = Ident.empty; modtypes = Ident.empty;
- components = Ident.empty }
-
-(* Persistent structure descriptions *)
-
-type pers_struct =
- { ps_name: string;
- ps_crc: int;
- ps_sig: signature;
- ps_comps: structure_components }
-
-let persistent_structures =
- (Hashtbl.new 17 : (string, pers_struct) Hashtbl.t)
-
-let read_pers_struct modname filename =
- let ic = open_in_bin filename in
- try
- let buffer = String.create (String.length cmi_magic_number) in
- really_input ic buffer 0 (String.length cmi_magic_number);
- if buffer <> cmi_magic_number then raise(Error(Not_an_interface filename));
- let ps = (input_value ic : pers_struct) in
- if ps.ps_name <> modname then
- raise(Error(Illegal_renaming(modname, filename)));
- ps
- with End_of_file | Failure _ ->
- raise(Error(Corrupted_interface(filename)))
-
-let find_pers_struct name =
- try
- Hashtbl.find persistent_structures name
- with Not_found ->
- let ps =
- read_pers_struct name
- (find_in_path !load_path (lowercase name ^ ".cmi")) in
- Hashtbl.add persistent_structures name ps;
- ps
-
-let reset_cache() =
- Hashtbl.clear persistent_structures
-
-(* Lookup by identifier *)
-
-let rec find_module_descr path env =
- match path with
- Pident id ->
- begin try
- let (p, desc) = Ident.find_same id env.components
- in desc
- with Not_found ->
- if Ident.persistent id
- then (find_pers_struct (Ident.name id)).ps_comps
- else raise Not_found
- end
- | Pdot(p, s, pos) ->
- let descr_p = find_module_descr p env in
- let (descr, pos) = Tbl.find s descr_p.comp_components in
- descr
-
-let find proj1 proj2 path env =
- try
- match path with
- Pident id ->
- let (p, data) = Ident.find_same id (proj1 env)
- in data
- | Pdot(p, s, pos) ->
- let (data, pos) = Tbl.find s (proj2 (find_module_descr p env))
- in data
- with Not_found ->
- fatal_error "Env.find"
-
-let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values)
-and find_type = find (fun env -> env.types) (fun sc -> sc.comp_types)
-and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
-
-(* Lookup by name *)
-
-let rec lookup_module_descr lid env =
- match lid with
- Lident s ->
- begin try
- Ident.find_name s env.components
- with Not_found ->
- (Pident(Ident.new_persistent s), (find_pers_struct s).ps_comps)
- end
- | Ldot(p, s) ->
- let (path, descr_p) = lookup_module_descr p env in
- let (descr, pos) = Tbl.find s descr_p.comp_components in
- (Pdot(path, s, pos), descr)
-
-let lookup proj1 proj2 lid env =
- match lid with
- Lident s ->
- Ident.find_name s (proj1 env)
- | Ldot(p, s) ->
- let (path, descr) = lookup_module_descr p env in
- let (data, pos) = Tbl.find s (proj2 descr) in
- (Pdot(path, s, pos), data)
-
-let lookup_simple proj1 proj2 lid env =
- match lid with
- Lident s ->
- Ident.find_name s (proj1 env)
- | Ldot(p, s) ->
- let (path, descr) = lookup_module_descr p env in
- let (data, pos) = Tbl.find s (proj2 descr) in
- data
-
-let lookup_value =
- lookup (fun env -> env.values) (fun sc -> sc.comp_values)
-and lookup_constructor =
- lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
-and lookup_label =
- lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
-and lookup_type =
- lookup (fun env -> env.types) (fun sc -> sc.comp_types)
-and lookup_modtype =
- lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
-
-let lookup_module lid env =
- match lid with
- Lident s ->
- begin try
- Ident.find_name s env.modules
- with Not_found ->
- (Pident(Ident.new_persistent s),
- Tmty_signature(find_pers_struct s).ps_sig)
- end
- | Ldot(p, s) ->
- let (path, descr) = lookup_module_descr p env in
- let (data, pos) = Tbl.find s descr.comp_modules in
- (Pdot(path, s, pos), data)
-
-(* Scrape a module type *)
-
-let rec scrape_modtype mty env =
- match mty with
- Tmty_ident path ->
- begin match find_modtype path env with
- Tmodtype_manifest mty -> scrape_modtype mty env
- | Tmodtype_abstract -> mty
- end
- | _ -> mty
-
-(* Compute constructor descriptions *)
-
-let constructors_of_type ty_path decl =
- match decl.type_kind with
- Type_variant cstrs ->
- let ty_res = Tconstr(ty_path, decl.type_params) in
- let num_constrs = List.length cstrs in
- let rec describe_constructors num = function
- [] -> []
- | (name, ty_args) :: rest ->
- let cstr =
- { cstr_res = ty_res;
- cstr_args = ty_args;
- cstr_arity = List.length ty_args;
- cstr_tag = Cstr_tag num;
- cstr_span = num_constrs } in
- (name, cstr) :: describe_constructors (num+1) rest in
- describe_constructors 0 cstrs
- | _ -> []
-
-(* Compute a constructor description for an exception *)
-
-let constructor_exception path_exc decl =
- { cstr_res = Predef.type_exn;
- cstr_args = decl;
- cstr_arity = List.length decl;
- cstr_tag = Cstr_exception path_exc;
- cstr_span = -1 }
-
-(* Compute label descriptions *)
-
-let dummy_label =
- { lbl_res = Ttuple []; lbl_arg = Ttuple []; lbl_mut = Immutable;
- lbl_pos = (-1); lbl_all = [||] }
-
-let labels_of_type ty_path decl =
- match decl.type_kind with
- Type_record labels ->
- let ty_res = Tconstr(ty_path, decl.type_params) in
- let all_labels = Array.new (List.length labels) dummy_label in
- let rec describe_labels num = function
- [] -> []
- | (name, mut_flag, ty_arg) :: rest ->
- let lbl =
- { lbl_res = ty_res;
- lbl_arg = ty_arg;
- lbl_mut = mut_flag;
- lbl_pos = num;
- lbl_all = all_labels } in
- all_labels.(num) <- lbl;
- (name, lbl) :: describe_labels (num+1) rest in
- describe_labels 0 labels
- | _ -> []
-
-(* Given a signature and a root path, prefix all idents in the signature
- by the root path and build the corresponding substitution. *)
-
-let rec prefix_idents root pos sub = function
- [] -> ([], sub)
- | Tsig_value(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, pos) in
- let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
- (p::pl, final_sub)
- | Tsig_type(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, nopos) in
- let (pl, final_sub) =
- prefix_idents root pos (Subst.add_type id p sub) rem in
- (p::pl, final_sub)
- | Tsig_exception(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, pos) in
- let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
- (p::pl, final_sub)
- | Tsig_module(id, mty) :: rem ->
- let p = Pdot(root, Ident.name id, pos) in
- let (pl, final_sub) =
- prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
- (p::pl, final_sub)
- | Tsig_modtype(id, decl) :: rem ->
- let p = Pdot(root, Ident.name id, nopos) in
- let (pl, final_sub) =
- prefix_idents root pos
- (Subst.add_modtype id (Tmty_ident p) sub) rem in
- (p::pl, final_sub)
-
-(* Compute structure descriptions *)
-
-let rec components_of_module env path mty =
- let c =
- { comp_values = Tbl.empty; comp_constrs = Tbl.empty;
- comp_labels = Tbl.empty; comp_types = Tbl.empty;
- comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
- comp_components = Tbl.empty } in
- begin match scrape_modtype mty env with
- Tmty_signature sg ->
- let (pl, sub) = prefix_idents path 0 Subst.identity sg in
- let env = ref env in
- let pos = ref 0 in
- List.iter2 (fun item path ->
- match item with
- Tsig_value(id, decl) ->
- let decl' = Subst.value_description sub decl in
- c.comp_values <-
- Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
- incr pos
- | Tsig_type(id, decl) ->
- let decl' = Subst.type_declaration sub decl in
- c.comp_types <-
- Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
- List.iter
- (fun (name, descr) ->
- c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
- (constructors_of_type path decl');
- List.iter
- (fun (name, descr) ->
- c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
- (labels_of_type path decl')
- | Tsig_exception(id, decl) ->
- let decl' = Subst.exception_declaration sub decl in
- let cstr = constructor_exception path decl' in
- c.comp_constrs <-
- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
- incr pos
- | Tsig_module(id, mty) ->
- let mty' = Subst.modtype sub mty in
- c.comp_modules <-
- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
- let comps = components_of_module !env path mty' in
- c.comp_components <-
- Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
- env := store_components id path comps !env;
- incr pos
- | Tsig_modtype(id, decl) ->
- let decl' = Subst.modtype_declaration sub decl in
- c.comp_modtypes <-
- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
- env := store_modtype id path decl' !env)
- sg pl
- | _ -> ()
- end;
- c
-
-(* Insertion of bindings by identifier + path *)
-
-and store_value id path decl env =
- { values = Ident.add id (path, decl) env.values;
- constrs = env.constrs;
- labels = env.labels;
- types = env.types;
- modules = env.modules;
- modtypes = env.modtypes;
- components = env.components }
-
-and store_type id path info env =
- { values = env.values;
- constrs =
- List.fold_right
- (fun (name, descr) constrs ->
- Ident.add (Ident.new name) descr constrs)
- (constructors_of_type path info)
- env.constrs;
- labels =
- List.fold_right
- (fun (name, descr) labels ->
- Ident.add (Ident.new name) descr labels)
- (labels_of_type path info)
- env.labels;
- types = Ident.add id (path, info) env.types;
- modules = env.modules;
- modtypes = env.modtypes;
- components = env.components }
-
-and store_exception id path decl env =
- { values = env.values;
- constrs = Ident.add id (constructor_exception path decl) env.constrs;
- labels = env.labels;
- types = env.types;
- modules = env.modules;
- modtypes = env.modtypes;
- components = env.components }
-
-and store_module id path mty env =
- { values = env.values;
- constrs = env.constrs;
- labels = env.labels;
- types = env.types;
- modules = Ident.add id (path, mty) env.modules;
- modtypes = env.modtypes;
- components = Ident.add id (path, components_of_module env path mty)
- env.components }
-
-and store_modtype id path info env =
- { values = env.values;
- constrs = env.constrs;
- labels = env.labels;
- types = env.types;
- modules = env.modules;
- modtypes = Ident.add id (path, info) env.modtypes;
- components = env.components }
-
-and store_components id path comps env =
- { values = env.values;
- constrs = env.constrs;
- labels = env.labels;
- types = env.types;
- modules = env.modules;
- modtypes = env.modtypes;
- components = Ident.add id (path, comps) env.components }
-
-(* Insertion of bindings by identifier *)
-
-let add_value id desc env =
- store_value id (Pident id) desc env
-
-and add_type id info env =
- store_type id (Pident id) info env
-
-and add_exception id decl env =
- store_exception id (Pident id) decl env
-
-and add_module id mty env =
- store_module id (Pident id) mty env
-
-and add_modtype id info env =
- store_modtype id (Pident id) info env
-
-(* Insertion of bindings by name *)
-
-let enter store_fun name data env =
- let id = Ident.new name in (id, store_fun id (Pident id) data env)
-
-let enter_value = enter store_value
-and enter_type = enter store_type
-and enter_exception = enter store_exception
-and enter_module = enter store_module
-and enter_modtype = enter store_modtype
-
-(* Insertion of all components of a signature *)
-
-let add_signature_component comp env =
- match comp with
- Tsig_value(id, decl) -> add_value id decl env
- | Tsig_type(id, decl) -> add_type id decl env
- | Tsig_exception(id, decl) -> add_exception id decl env
- | Tsig_module(id, mty) -> add_module id mty env
- | Tsig_modtype(id, decl) -> add_modtype id decl env
-
-let add_signature = List.fold_right add_signature_component
-
-(* Open a signature path *)
-
-let open_signature root sg env =
- (* First build the paths and substitution *)
- let (pl, sub) = prefix_idents root 0 Subst.identity sg in
- (* Then enter the components in the environment after substitution *)
- List.fold_left2
- (fun env item p ->
- match item with
- Tsig_value(id, decl) ->
- store_value (Ident.hide id) p
- (Subst.value_description sub decl) env
- | Tsig_type(id, decl) ->
- store_type (Ident.hide id) p
- (Subst.type_declaration sub decl) env
- | Tsig_exception(id, decl) ->
- store_exception (Ident.hide id) p
- (Subst.exception_declaration sub decl) env
- | Tsig_module(id, mty) ->
- store_module (Ident.hide id) p (Subst.modtype sub mty) env
- | Tsig_modtype(id, decl) ->
- store_modtype (Ident.hide id) p
- (Subst.modtype_declaration sub decl) env)
- env sg pl
-
-(* Open a signature from a file *)
-
-let open_pers_signature name env =
- let ps = find_pers_struct name in
- open_signature (Pident(Ident.new_persistent name)) ps.ps_sig env
-
-(* Read a signature from a file *)
-
-let read_signature modname filename =
- let ps = read_pers_struct modname filename in (ps.ps_sig, ps.ps_crc)
-
-(* Save a signature to a file *)
-
-let save_signature sg modname crc filename =
- let ps =
- { ps_name = modname;
- ps_crc = crc;
- ps_sig = sg;
- ps_comps =
- components_of_module empty (Pident(Ident.new_persistent modname))
- (Tmty_signature sg) } in
- let oc = open_out_bin filename in
- output_string oc cmi_magic_number;
- output_value oc ps;
- close_out oc
-
-(* Make the initial environment *)
-
-let initial = Predef.build_initial_env add_type add_exception empty
-
-(* Return the list of imported interfaces with their CRCs *)
-
-let imported_units() =
- let l = ref [] in
- Hashtbl.iter
- (fun name ps -> l := (ps.ps_name, ps.ps_crc) :: !l) persistent_structures;
- !l
-
-(* Error report *)
-
-let report_error = function
- Not_an_interface filename ->
- print_string filename; print_space();
- print_string "is not a compiled interface."
- | Corrupted_interface filename ->
- print_string "Corrupted compiled interface"; print_space();
- print_string filename
- | Illegal_renaming(modname, filename) ->
- print_string filename; print_space();
- print_string "contains the compiled interface for"; print_space();
- print_string modname
-
diff --git a/typing/env.mli b/typing/env.mli
deleted file mode 100644
index 1003457016..0000000000
--- a/typing/env.mli
+++ /dev/null
@@ -1,78 +0,0 @@
-(* Environment handling *)
-
-open Typedtree
-
-type t
-
-val empty: t
-val initial: t
-
-(* Lookup by paths *)
-
-val find_value: Path.t -> t -> value_description
-val find_type: Path.t -> t -> type_declaration
-val find_modtype: Path.t -> t -> modtype_declaration
-
-(* Lookup by long identifiers *)
-
-val lookup_value: Longident.t -> t -> Path.t * value_description
-val lookup_constructor: Longident.t -> t -> constructor_description
-val lookup_label: Longident.t -> t -> label_description
-val lookup_type: Longident.t -> t -> Path.t * type_declaration
-val lookup_module: Longident.t -> t -> Path.t * module_type
-val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
-
-(* Insertion by identifier *)
-
-val add_value: Ident.t -> value_description -> t -> t
-val add_type: Ident.t -> type_declaration -> t -> t
-val add_exception: Ident.t -> exception_declaration -> t -> t
-val add_module: Ident.t -> module_type -> t -> t
-val add_modtype: Ident.t -> modtype_declaration -> t -> t
-
-(* Insertion of all fields of a signature. *)
-
-val add_signature: signature -> t -> t
-
-(* Insertion of all fields of a signature, relative to the given path.
- Used to implement open. *)
-
-val open_signature: Path.t -> signature -> t -> t
-val open_pers_signature: string -> t -> t
-
-(* Insertion by name *)
-
-val enter_value: string -> value_description -> t -> Ident.t * t
-val enter_type: string -> type_declaration -> t -> Ident.t * t
-val enter_exception: string -> exception_declaration -> t -> Ident.t * t
-val enter_module: string -> module_type -> t -> Ident.t * t
-val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t
-
-(* Reset the cache of in-core module interfaces.
- To be called in particular when load_path changes. *)
-
-val reset_cache: unit -> unit
-
-(* Read, save a signature to/from a file *)
-
-val read_signature: string -> string -> signature * int
- (* Arguments: module name, file name.
- Results: signature, CRC. *)
-val save_signature: signature -> string -> int -> string -> unit
- (* Arguments: signature, module name, CRC, file name. *)
-
-(* Return the set of compilation units imported, with their CRC *)
-
-val imported_units: unit -> (string * int) list
-
-(* Error report *)
-
-type error =
- Not_an_interface of string
- | Corrupted_interface of string
- | Illegal_renaming of string * string
-
-exception Error of error
-
-val report_error: error -> unit
-
diff --git a/typing/ident.ml b/typing/ident.ml
deleted file mode 100644
index fb58f25a7a..0000000000
--- a/typing/ident.ml
+++ /dev/null
@@ -1,156 +0,0 @@
-open Format
-
-type t = { mutable stamp: int; name: string; mutable global: bool }
-
-(* A stamp of 0 denotes a persistent identifier *)
-
-let currentstamp = ref 0
-
-let new s =
- incr currentstamp;
- { name = s; stamp = !currentstamp; global = false }
-
-let new_persistent s =
- { name = s; stamp = 0; global = true }
-
-let name i = i.name
-
-let persistent i = (i.stamp = 0)
-
-let equal i1 i2 = i1.name = i2.name
-
-let same i1 i2 = i1 = i2
- (* Possibly more efficient version (with a real compiler, at least):
- if i1.stamp <> 0
- then i1.stamp = i2.stamp
- else i2.stamp = 0 & i1.name = i2.name *)
-
-let identify i1 i2 f =
- let stamp1 = i1.stamp in
- try
- i1.stamp <- i2.stamp;
- let res = f () in
- i1.stamp <- stamp1;
- res
- with x ->
- i1.stamp <- stamp1;
- raise x
-
-let hide i =
- { stamp = -1; name = i.name; global = i.global }
-
-let make_global i =
- i.global <- true
-
-let global i =
- i.global
-
-let print i =
- print_string i.name;
- match i.stamp with
- 0 -> print_string "!"
- | -1 -> print_string "#"
- | n -> print_string "/"; print_int n; if i.global then print_string "g"
-
-type 'a tbl =
- Empty
- | Node of 'a tbl * 'a data * 'a tbl * int
-
-and 'a data =
- { ident: t;
- data: 'a;
- previous: 'a data option }
-
-let empty = Empty
-
-(* Inline expansion of height for better speed
- * let height = function
- * Empty -> 0
- * | Node(_,_,_,h) -> h
- *)
-
-let mknode l d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
- and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
- Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-let balance l d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h
- and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
- if hl > hr + 1 then
- let (Node(ll, ld, lr, _)) = l in
- if (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >=
- (match lr with Empty -> 0 | Node(_,_,_,h) -> h) then
- mknode ll ld (mknode lr d r)
- else
- let (Node(lrl, lrd, lrr, _)) = lr in
- mknode (mknode ll ld lrl) lrd (mknode lrr d r)
- else if hr > hl + 1 then
- let (Node(rl, rd, rr, _)) = r in
- if (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >=
- (match rl with Empty -> 0 | Node(_,_,_,h) -> h) then
- mknode (mknode l d rl) rd rr
- else
- let (Node(rll, rld, rlr, _)) = rl in
- mknode (mknode l d rll) rld (mknode rlr rd rr)
- else
- mknode l d r
-
-let rec add id data = function
- Empty ->
- Node(Empty, {ident = id; data = data; previous = None}, Empty, 1)
- | Node(l, k, r, h) ->
- let c = compare id.name k.ident.name in
- if c = 0 then
- Node(l, {ident = id; data = data; previous = Some k}, r, h)
- else if c < 0 then
- balance (add id data l) k r
- else
- balance l k (add id data r)
-
-let rec find_stamp s = function
- None ->
- raise Not_found
- | Some k ->
- if k.ident.stamp = s then k.data else find_stamp s k.previous
-
-let rec find_same id = function
- Empty ->
- raise Not_found
- | Node(l, k, r, _) ->
- let c = compare id.name k.ident.name in
- if c = 0 then
- if id.stamp = k.ident.stamp
- then k.data
- else find_stamp id.stamp k.previous
- else
- find_same id (if c < 0 then l else r)
-
-let rec find_name name = function
- Empty ->
- raise Not_found
- | Node(l, k, r, _) ->
- let c = compare name k.ident.name in
- if c = 0 then
- k.data
- else
- find_name name (if c < 0 then l else r)
-
-let print_tbl print_elt tbl =
- open_hovbox 2;
- print_string "[[";
- let rec print_tbl = function
- Empty -> ()
- | Node(l, k, r, _) ->
- print_tbl l;
- print_entry k;
- print_tbl r
- and print_entry k =
- open_hovbox 2;
- print k.ident; print_string " ->"; print_space(); print_elt k.data;
- print_string ";"; close_box(); print_space();
- match k.previous with None -> () | Some k -> print_entry k in
- print_tbl tbl;
- print_string "]]";
- close_box()
-
diff --git a/typing/ident.mli b/typing/ident.mli
deleted file mode 100644
index 8497451da9..0000000000
--- a/typing/ident.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(* Identifiers (unique names) *)
-
-type t
-
-val new: string -> t
-val new_persistent: string -> t
-val name: t -> string
-val persistent: t -> bool
-val equal: t -> t -> bool
- (* Compare identifiers by name. *)
-val same: t -> t -> bool
- (* Compare identifiers by binding location.
- Two identifiers are the same either if they are both
- non-persistent and have been created by the same call to
- [new], or if they are both persistent and have the same
- name. *)
-val identify: t -> t -> (unit -> 'a) -> 'a
- (* [identify id1 id2 f] temporarily makes [id1] and [id2] the same
- during the evaluation of [f ()]. *)
-val hide: t -> t
- (* Return an identifier with same name as the given identifier,
- but stamp different from any stamp returns by new.
- When put in a 'a tbl, this identifier can only be looked
- up by name. *)
-
-val make_global: t -> unit
-val global: t -> bool
-
-val print: t -> unit
-
-type 'a tbl
- (* Association tables from identifiers to type 'a. *)
-
-val empty: 'a tbl
-val add: t -> 'a -> 'a tbl -> 'a tbl
-val find_same: t -> 'a tbl -> 'a
-val find_name: string -> 'a tbl -> 'a
-
-val print_tbl: ('a -> unit) -> 'a tbl -> unit
diff --git a/typing/includecore.ml b/typing/includecore.ml
deleted file mode 100644
index 781abf166c..0000000000
--- a/typing/includecore.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-(* Inclusion checks for the core language *)
-
-open Misc
-open Path
-open Typedtree
-
-
-(* Inclusion between value descriptions *)
-
-let value_descriptions env vd1 vd2 =
- Ctype.moregeneral env vd1.val_type vd2.val_type &
- begin match (vd1.val_prim, vd2.val_prim) with
- (Primitive(p1, ar1), Primitive(p2, ar2)) -> p1 = p2 & ar1 = ar2
- | (Not_prim, Primitive(p, ar)) -> false
- | _ -> true
- end
-
-(* Inclusion between type declarations *)
-
-let type_declarations env id decl1 decl2 =
- decl1.type_arity = decl2.type_arity &
- begin match (decl1.type_kind, decl2.type_kind) with
- (_, Type_abstract) ->
- true
- | (Type_manifest ty1, Type_manifest ty2) ->
- Ctype.equal env decl1.type_params ty1 decl2.type_params ty2
- | (Type_variant cstrs1, Type_variant cstrs2) ->
- for_all2
- (fun (cstr1, arg1) (cstr2, arg2) ->
- cstr1 = cstr2 &
- for_all2
- (fun ty1 ty2 ->
- Ctype.equal env decl1.type_params ty1 decl2.type_params ty2)
- arg1 arg2)
- cstrs1 cstrs2
- | (Type_record labels1, Type_record labels2) ->
- for_all2
- (fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) ->
- lbl1 = lbl2 & mut1 = mut2 &
- Ctype.equal env decl1.type_params ty1 decl2.type_params ty2)
- labels1 labels2
- | (_, Type_manifest ty2) ->
- let ty1 = Tconstr(Pident id, decl2.type_params) in
- Ctype.equal env [] ty1 [] ty2
- | (_, _) ->
- false
- end
-
-(* Inclusion between exception declarations *)
-
-let exception_declarations env ed1 ed2 =
- for_all2 (fun ty1 ty2 -> Ctype.equal env [] ty1 [] ty2) ed1 ed2
-
diff --git a/typing/includecore.mli b/typing/includecore.mli
deleted file mode 100644
index 6c6e6417c2..0000000000
--- a/typing/includecore.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-(* Inclusion checks for the core language *)
-
-open Typedtree
-
-val value_descriptions:
- Env.t -> value_description -> value_description -> bool
-val type_declarations:
- Env.t -> Ident.t -> type_declaration -> type_declaration -> bool
-val exception_declarations:
- Env.t -> exception_declaration -> exception_declaration -> bool
diff --git a/typing/includemod.ml b/typing/includemod.ml
deleted file mode 100644
index 35f5928f87..0000000000
--- a/typing/includemod.ml
+++ /dev/null
@@ -1,258 +0,0 @@
-(* Inclusion checks for the module language *)
-
-open Misc
-open Path
-open Typedtree
-
-
-type error =
- Missing_field of Ident.t
- | Value_descriptions of Ident.t * value_description * value_description
- | Type_declarations of Ident.t * type_declaration * type_declaration
- | Exception_declarations of
- Ident.t * exception_declaration * exception_declaration
- | Module_types of module_type * module_type
- | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
-
-exception Error of error list
-
-(* All functions "blah env x1 x2" check that x1 is included in x2,
- i.e. that x1 is the type of an implementation that fulfills the
- specification x2. If not, Error is raised with a backtrace of the error. *)
-
-(* Inclusion between value descriptions *)
-
-let value_descriptions env id vd1 vd2 =
- if Includecore.value_descriptions env vd1 vd2
- then ()
- else raise(Error[Value_descriptions(id, vd1, vd2)])
-
-(* Inclusion between type declarations *)
-
-let type_declarations env id decl1 decl2 =
- if Includecore.type_declarations env id decl1 decl2
- then ()
- else raise(Error[Type_declarations(id, decl1, decl2)])
-
-(* Inclusion between exception declarations *)
-
-let exception_declarations env id decl1 decl2 =
- if Includecore.exception_declarations env decl1 decl2
- then ()
- else raise(Error[Exception_declarations(id, decl1, decl2)])
-
-(* Expand a module type identifier when possible *)
-
-exception Dont_match
-
-let expand_module_path env path =
- match Env.find_modtype path env with
- Tmodtype_abstract -> raise Dont_match
- | Tmodtype_manifest mty -> mty
-
-(* Extract name, kind and ident from a signature item *)
-
-type field_desc =
- Field_value of string
- | Field_type of string
- | Field_exception of string
- | Field_module of string
- | Field_modtype of string
-
-let item_ident_name = function
- Tsig_value(id, _) -> (id, Field_value(Ident.name id))
- | Tsig_type(id, _) -> (id, Field_type(Ident.name id))
- | Tsig_exception(id, _) -> (id, Field_exception(Ident.name id))
- | Tsig_module(id, _) -> (id, Field_module(Ident.name id))
- | Tsig_modtype(id, _) -> (id, Field_modtype(Ident.name id))
-
-(* Simplify a structure coercion *)
-
-let simplify_structure_coercion cc =
- let pos = ref 0 in
- try
- List.iter
- (fun (n, c) ->
- if n <> !pos or c <> Tcoerce_none then raise Exit;
- incr pos)
- cc;
- Tcoerce_none
- with Exit ->
- Tcoerce_structure cc
-
-(* Inclusion between module types.
- Return the restriction that transforms a value of the smaller type
- into a value of the bigger type. *)
-
-let rec modtypes env mty1 mty2 =
- try
- try_modtypes env mty1 mty2
- with
- Dont_match ->
- raise(Error[Module_types(mty1, mty2)])
- | Error reasons ->
- raise(Error(Module_types(mty1, mty2) :: reasons))
-
-and try_modtypes env mty1 mty2 =
- match (mty1, mty2) with
- (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
- Tcoerce_none
- | (Tmty_ident p1, _) ->
- try_modtypes env (expand_module_path env p1) mty2
- | (_, Tmty_ident p2) ->
- try_modtypes env mty1 (expand_module_path env p2)
- | (Tmty_signature sig1, Tmty_signature sig2) ->
- signatures env sig1 sig2
- | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
- let cc_arg =
- modtypes env arg2 arg1 in
- let cc_res =
- Ident.identify param2 param1
- (fun () -> modtypes (Env.add_module param1 arg1 env) res1 res2) in
- begin match (cc_arg, cc_res) with
- (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
- | _ -> Tcoerce_functor(cc_arg, cc_res)
- end
- | (_, _) ->
- raise Dont_match
-
-(* Inclusion between signatures *)
-
-and signatures env sig1 sig2 =
- (* Environment used to check inclusion of components *)
- let new_env =
- Env.add_signature sig1 env in
- (* Build a table of the components of sig1, along with their positions.
- The table is indexed by kind and name of component *)
- let rec build_component_table pos tbl = function
- [] -> tbl
- | item :: rem ->
- let (id, name) = item_ident_name item in
- let nextpos =
- match item with
- Tsig_value(_,_) | Tsig_exception(_,_) | Tsig_module(_,_) -> pos+1
- | Tsig_type(_,_) | Tsig_modtype(_,_) -> pos in
- build_component_table nextpos
- (Tbl.add name (id, item, pos) tbl) rem in
- let comps1 =
- build_component_table 0 Tbl.empty sig1 in
- (* Pair each component of sig2 with a component of sig1,
- identifying the names along the way.
- Return a coercion list indicating, for all run-time components
- of sig2, the position of the matching run-time components of sig1
- and the coercion to be applied to it. *)
- let rec pair_components paired unpaired = function
- [] ->
- begin match unpaired with
- [] -> signature_components new_env (List.rev paired)
- | _ -> raise(Error unpaired)
- end
- | item2 :: rem ->
- let (id2, name2) = item_ident_name item2 in
- begin try
- let (id1, item1, pos1) = Tbl.find name2 comps1 in
- Ident.identify id1 id2
- (fun () ->
- pair_components ((item1, item2, pos1) :: paired) unpaired rem)
- with Not_found ->
- pair_components paired (Missing_field id2 :: unpaired) rem
- end in
- (* Do the pairing and checking, and return the final coercion *)
- simplify_structure_coercion(pair_components [] [] sig2)
-
-(* Inclusion between signature components *)
-
-and signature_components env = function
- [] -> []
- | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
- value_descriptions env id1 valdecl1 valdecl2;
- (pos, Tcoerce_none) :: signature_components env rem
- | (Tsig_type(id1, tydecl1), Tsig_type(id2, tydecl2), pos) :: rem ->
- type_declarations env id1 tydecl1 tydecl2;
- signature_components env rem
- | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
- :: rem ->
- exception_declarations env id1 excdecl1 excdecl2;
- (pos, Tcoerce_none) :: signature_components env rem
- | (Tsig_module(id1, mty1), Tsig_module(id2, mty2), pos) :: rem ->
- let cc = modtypes env mty1 mty2 in
- (pos, cc) :: signature_components env rem
- | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
- modtype_infos env id1 info1 info2;
- signature_components env rem
- | _ ->
- fatal_error "Includemod.signature_components"
-
-(* Inclusion between module type specifications *)
-
-and modtype_infos env id info1 info2 =
- try
- match (info1, info2) with
- (Tmodtype_abstract, Tmodtype_abstract) -> ()
- | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
- | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
- modtypes env mty1 mty2; modtypes env mty2 mty1; ()
- | (_, Tmodtype_manifest mty2) ->
- let mty1 = Tmty_ident(Pident id) in
- modtypes env mty1 mty2; modtypes env mty2 mty1; ()
- with Error reasons ->
- raise(Error(Modtype_infos(id, info1, info2) :: reasons))
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let include_err = function
- Missing_field id ->
- print_string "Missing field "; ident id
- | Value_descriptions(id, d1, d2) ->
- open_hvbox 2;
- print_string "Values do not match:"; print_space();
- value_description id d1;
- print_break(1, -2);
- print_string "is not included in"; print_space();
- value_description id d2;
- close_box()
- | Type_declarations(id, d1, d2) ->
- open_hvbox 2;
- print_string "Type declarations do not match:"; print_space();
- type_declaration id d1;
- print_break(1, -2);
- print_string "is not included in"; print_space();
- type_declaration id d2;
- close_box()
- | Exception_declarations(id, d1, d2) ->
- open_hvbox 2;
- print_string "Exception declarations do not match:"; print_space();
- exception_declaration id d1;
- print_break(1, -2);
- print_string "is not included in"; print_space();
- exception_declaration id d2;
- close_box()
- | Module_types(mty1, mty2)->
- open_hvbox 2;
- print_string "Modules do not match:"; print_space();
- modtype mty1;
- print_break(1, -2);
- print_string "is not included in"; print_space();
- modtype mty2;
- close_box()
- | Modtype_infos(id, d1, d2) ->
- open_hvbox 2;
- print_string "Module type declarations do not match:"; print_space();
- modtype_declaration id d1;
- print_break(1, -2);
- print_string "is not included in"; print_space();
- modtype_declaration id d2;
- close_box()
-
-let report_error errlist =
- match List.rev errlist with
- [] -> ()
- | err :: rem ->
- open_vbox 0;
- include_err err;
- List.iter (fun err -> print_space(); include_err err) rem;
- close_box()
-
diff --git a/typing/includemod.mli b/typing/includemod.mli
deleted file mode 100644
index 2a6ca3e0a4..0000000000
--- a/typing/includemod.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* Inclusion checks for the module language *)
-
-open Typedtree
-
-val modtypes: Env.t -> module_type -> module_type -> module_coercion
-val signatures: Env.t -> signature -> signature -> module_coercion
-
-type error =
- Missing_field of Ident.t
- | Value_descriptions of Ident.t * value_description * value_description
- | Type_declarations of Ident.t * type_declaration * type_declaration
- | Exception_declarations of
- Ident.t * exception_declaration * exception_declaration
- | Module_types of module_type * module_type
- | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration
-
-exception Error of error list
-
-val report_error: error list -> unit
diff --git a/typing/mtype.ml b/typing/mtype.ml
deleted file mode 100644
index e68a3ff001..0000000000
--- a/typing/mtype.ml
+++ /dev/null
@@ -1,147 +0,0 @@
-(* Operations on module types *)
-
-open Path
-open Typedtree
-
-
-let rec scrape env mty =
- match mty with
- Tmty_ident p ->
- begin match Env.find_modtype p env with
- Tmodtype_abstract -> mty
- | Tmodtype_manifest mty' -> scrape env mty'
- end
- | _ -> mty
-
-let rec strengthen env mty p =
- match scrape env mty with
- Tmty_signature sg ->
- Tmty_signature(strengthen_sig env sg p)
- | mty ->
- mty
-
-and strengthen_sig env sg p =
- match sg with
- [] -> []
- | (Tsig_value(id, desc) as sigelt) :: rem ->
- sigelt :: strengthen_sig env rem p
- | Tsig_type(id, decl) :: rem ->
- let newdecl =
- match decl.type_kind with
- Type_abstract ->
- { type_params = decl.type_params;
- type_arity = decl.type_arity;
- type_kind = Type_manifest(Tconstr(Pdot(p, Ident.name id, nopos),
- decl.type_params)) }
- | _ -> decl in
- Tsig_type(id, newdecl) :: strengthen_sig env rem p
- | (Tsig_exception(id, d) as sigelt) :: rem ->
- sigelt :: strengthen_sig env rem p
- | Tsig_module(id, mty) :: rem ->
- Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos))) ::
- strengthen_sig (Env.add_module id mty env) rem p
- (* Need to add the module in case it defines manifest module types *)
- | Tsig_modtype(id, decl) :: rem ->
- let newdecl =
- match decl with
- Tmodtype_abstract ->
- Tmodtype_manifest(Tmty_ident(Pdot(p, Ident.name id, nopos)))
- | Tmodtype_manifest _ ->
- decl in
- Tsig_modtype(id, newdecl) ::
- strengthen_sig (Env.add_modtype id decl env) rem p
- (* Need to add the module type in case it is manifest *)
-
-(* In nondep_supertype, env is only used for the type it assigns to id.
- Hence there is no need to keep env up-to-date by adding the bindings
- traversed. *)
-
-type variance = Co | Contra | Strict
-
-let nondep_supertype env mid mty =
-
- let rec nondep_mty var mty =
- match mty with
- Tmty_ident p ->
- if Path.isfree mid p then begin
- match Env.find_modtype p env with
- Tmodtype_abstract -> raise Not_found
- | Tmodtype_manifest mty -> nondep_mty var mty
- end else mty
- | Tmty_signature sg ->
- Tmty_signature(nondep_sig var sg)
- | Tmty_functor(param, arg, res) ->
- let var_inv =
- match var with Co -> Contra | Contra -> Co | Strict -> Strict in
- Tmty_functor(param, nondep_mty var_inv arg, nondep_mty var res)
-
- and nondep_sig var = function
- [] -> []
- | item :: rem ->
- let rem' = nondep_sig var rem in
- match item with
- Tsig_value(id, d) ->
- begin try
- Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
- val_prim = d.val_prim}) :: rem'
- with Not_found ->
- match var with Co -> rem' | _ -> raise Not_found
- end
- | Tsig_type(id, d) ->
- begin try
- Tsig_type(id, nondep_type_decl d) :: rem'
- with Not_found ->
- match var with
- Co -> Tsig_type(id, abstract_type_decl d) :: rem'
- | _ -> raise Not_found
- end
- | Tsig_exception(id, d) ->
- begin try
- Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
- with Not_found ->
- match var with Co -> rem' | _ -> raise Not_found
- end
- | Tsig_module(id, mty) ->
- begin try
- Tsig_module(id, nondep_mty var mty) :: rem'
- with Not_found ->
- match var with Co -> rem' | _ -> raise Not_found
- end
- | Tsig_modtype(id, d) ->
- begin try
- Tsig_modtype(id, nondep_modtype_decl d) :: rem'
- with Not_found ->
- match var with
- Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem'
- | _ -> raise Not_found
- end
-
- and nondep_type_decl d =
- {type_params = d.type_params;
- type_arity = d.type_arity;
- type_kind =
- match d.type_kind with
- Type_abstract ->
- Type_abstract
- | Type_manifest ty ->
- Type_manifest(Ctype.nondep_type env mid ty)
- | Type_variant cstrs ->
- Type_variant(List.map
- (fun (c, tl) -> (c, List.map (Ctype.nondep_type env mid) tl))
- cstrs)
- | Type_record lbls ->
- Type_record(List.map
- (fun (c, mut, t) -> (c, mut, Ctype.nondep_type env mid t))
- lbls)}
-
- and abstract_type_decl d =
- {type_params = d.type_params;
- type_arity = d.type_arity;
- type_kind = Type_abstract}
-
- and nondep_modtype_decl = function
- Tmodtype_abstract -> Tmodtype_abstract
- | Tmodtype_manifest mty -> Tmodtype_manifest(nondep_mty Strict mty)
-
- in
- nondep_mty Co mty
diff --git a/typing/mtype.mli b/typing/mtype.mli
deleted file mode 100644
index ca2016fb57..0000000000
--- a/typing/mtype.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-(* Operations on module types *)
-
-open Typedtree
-
-val scrape: Env.t -> module_type -> module_type
- (* Expand toplevel module type abbreviations
- till hitting a "hard" module type (signature, functor,
- or abstract module type ident. *)
-val strengthen: Env.t -> module_type -> Path.t -> module_type
- (* Strengthen abstract type components relative to the
- given path. *)
-val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
- (* Return the smallest supertype of the given type
- in which the given ident does not appear.
- Raise [Not_found] if no such type List.exists. *)
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
deleted file mode 100644
index 8d3ee419bc..0000000000
--- a/typing/parmatch.ml
+++ /dev/null
@@ -1,263 +0,0 @@
-(* Detection of partial matches and unused match cases. *)
-
-open Misc
-open Asttypes
-open Typedtree
-
-
-let make_pat desc ty =
- {pat_desc = desc; pat_loc = Location.none; pat_type = ty}
-
-let omega = make_pat Tpat_any Ctype.none
-
-let rec omegas i =
- if i <= 0 then [] else omega :: omegas (i-1)
-
-let omega_list l = omegas(List.length l)
-
-let has_guard act =
- match act.exp_desc with
- Texp_when(_, _) -> true
- | _ -> false
-
-let simple_match p1 p2 =
- match p1.pat_desc, p2.pat_desc with
- Tpat_construct(c1, _), Tpat_construct(c2, _) ->
- c1.cstr_tag = c2.cstr_tag
- | Tpat_constant(c1), Tpat_constant(c2) ->
- c1 = c2
- | Tpat_tuple(_), Tpat_tuple(_) -> true
- | Tpat_record(_), Tpat_record(_) -> true
- | _, (Tpat_any | Tpat_var(_)) -> true
- | _, _ -> false
-
-(* Return the set of labels and number of fields for a record pattern. *)
-
-let record_labels p =
- match p.pat_desc with
- Tpat_record((lbl1, pat1) :: rem) -> Array.to_list lbl1.lbl_all
- | _ -> fatal_error "Parmatch.record_labels"
-
-let record_num_fields p =
- match p.pat_desc with
- Tpat_record((lbl1, pat1) :: rem) -> Array.length lbl1.lbl_all
- | _ -> fatal_error "Parmatch.record_num_fields"
-
-let set_fields size l =
- let v = Array.new size omega in
- let rec change_rec l = match l with
- (lbl,p)::l -> v.(lbl.lbl_pos) <- p ; change_rec l
- | [] -> () in
- change_rec l;
- Array.to_list v
-
-let simple_match_args p1 p2 =
- match p2.pat_desc with
- Tpat_construct(cstr, args) -> args
- | Tpat_tuple(args) -> args
- | Tpat_record(args) -> set_fields (record_num_fields p1) args
- | (Tpat_any | Tpat_var(_)) ->
- begin match p1.pat_desc with
- Tpat_construct(_, args) -> omega_list args
- | Tpat_tuple(args) -> omega_list args
- | Tpat_record(args) -> omega_list args
- | _ -> []
- end
- | _ -> []
-
-(*
- Computes the discriminating pattern for matching by the first
- column of pss, that is:
- checks for a tuple or a record when q is a variable.
-*)
-
-let rec simple_pat q pss = match pss with
- ({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
- simple_pat q ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2)}::ps)::pss ->
- simple_pat q ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss ->
- simple_pat q pss
- | (({pat_desc = Tpat_tuple(args)} as p)::_)::_ ->
- make_pat (Tpat_tuple(omega_list args)) p.pat_type
- | (({pat_desc = Tpat_record(args)} as p)::_)::pss ->
- make_pat (Tpat_record (List.map (fun lbl -> (lbl,omega)) (record_labels p)))
- p.pat_type
- | _ -> q
-
-let filter_one q pss =
- let rec filter_rec = function
- ({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
- filter_rec ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2)}::ps)::pss ->
- filter_rec ((p1::ps)::(p2::ps)::pss)
- | (p::ps)::pss ->
- if simple_match q p
- then (simple_match_args q p @ ps) :: filter_rec pss
- else filter_rec pss
- | _ -> [] in
- filter_rec pss
-
-let filter_extra pss =
- let rec filter_rec = function
- ({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
- filter_rec ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2)}::ps)::pss ->
- filter_rec ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss ->
- qs :: filter_rec pss
- | _::pss -> filter_rec pss
- | [] -> [] in
- filter_rec pss
-
-let filter_all pat0 pss =
-
- let rec insert q qs env =
- match env with
- [] -> [q, [simple_match_args q q @ qs]]
- | ((p,pss) as c)::env ->
- if simple_match q p
- then (p, ((simple_match_args p q @ qs) :: pss)) :: env
- else c :: insert q qs env in
-
- let rec filter_rec env = function
- ({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
- filter_rec env ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2)}::ps)::pss ->
- filter_rec env ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss ->
- filter_rec env pss
- | (p::ps)::pss ->
- filter_rec (insert p ps env) pss
- | _ -> env
-
- and filter_omega env = function
- ({pat_desc = Tpat_alias(p,_)}::ps)::pss ->
- filter_omega env ((p::ps)::pss)
- | ({pat_desc = Tpat_or(p1,p2)}::ps)::pss ->
- filter_omega env ((p1::ps)::(p2::ps)::pss)
- | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss ->
- filter_omega
- (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) env)
- pss
- | _::pss -> filter_omega env pss
- | [] -> env in
-
- filter_omega
- (filter_rec
- (match pat0.pat_desc with
- (Tpat_record(_) | Tpat_tuple(_)) -> [pat0,[]]
- | _ -> [])
- pss)
- pss
-
-
-let full_match env =
- match env with
- ({pat_desc = Tpat_construct(c,_)},_) :: _ ->
- List.length env = c.cstr_span
- | ({pat_desc = Tpat_constant(Const_char _)},_) :: _ ->
- List.length env = 256
- | ({pat_desc = Tpat_constant(_)},_) :: _ -> false
- | ({pat_desc = Tpat_tuple(_)},_) :: _ -> true
- | ({pat_desc = Tpat_record(_)},_) :: _ -> true
- | _ -> fatal_error "Parmatch.full_match"
-
-(*
- Is the last row of pattern matrix pss + qs satisfiable ?
- That is :
- Does there List.exists at least one value vector, es such that :
- 1/ for all ps in pss ps # es (ps and es are not compatible)
- 2/ qs <= es (es matches qs)
-*)
-
-let rec satisfiable pss qs =
- match pss with
- [] -> true
- | _ ->
- match qs with
- [] -> false
- | {pat_desc = Tpat_or(q1,q2)}::qs ->
- satisfiable pss (q1::qs) or satisfiable pss (q2::qs)
- | {pat_desc = Tpat_alias(q,_)}::qs ->
- satisfiable pss (q::qs)
- | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
- let q0 = simple_pat omega pss in
- begin match filter_all q0 pss with
- (* first column of pss is made of variables only *)
- [] -> satisfiable (filter_extra pss) qs
- | constrs ->
- let try_non_omega (p,pss) =
- satisfiable pss (simple_match_args p omega @ qs) in
- if full_match constrs
- then List.exists try_non_omega constrs
- else satisfiable (filter_extra pss) qs or
- List.exists try_non_omega constrs
- end
- | q::qs ->
- let q0 = simple_pat q pss in
- satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
-
-let rec initial_matrix = function
- [] -> []
- | (pat, act) :: rem ->
- if has_guard act
- then initial_matrix rem
- else [pat] :: initial_matrix rem
-
-let rec le_pat p q =
- match (p.pat_desc, q.pat_desc) with
- (Tpat_var _ | Tpat_any), _ -> true
- | Tpat_alias(p,_), _ -> le_pat p q
- | _, Tpat_alias(q,_) -> le_pat p q
- | Tpat_or(p1,p2), _ -> le_pat p1 q or le_pat p2 q
- | _, Tpat_or(q1,q2) -> le_pat p q1 & le_pat p q2
- | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
- | Tpat_construct(c1,ps), Tpat_construct(c2,qs) ->
- c1.cstr_tag = c2.cstr_tag & le_pats ps qs
- | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
- | Tpat_record(l1), Tpat_record(l2) ->
- let size = record_num_fields p in
- le_pats (set_fields size l1) (set_fields size l2)
- | _, _ -> false
-
-and le_pats ps qs =
- match ps,qs with
- p::ps, q::qs -> le_pat p q & le_pats ps qs
- | _, _ -> true
-
-let get_mins ps =
- let rec select_rec r = function
- [] -> r
- | p::ps ->
- if List.exists (fun p0 -> le_pats p0 p) ps
- then select_rec r ps
- else select_rec (p::r) ps in
- select_rec [] (select_rec [] ps)
-
-let check_partial loc casel =
- let pss = get_mins (initial_matrix casel) in
- if match pss with
- [] -> true
- | ps::_ -> satisfiable pss (List.map (fun _ -> omega) ps)
- then Location.print_warning loc "this pattern-matching is not exhaustive"
-
-let location_of_clause = function
- pat :: _ -> pat.pat_loc
- | _ -> fatal_error "Parmatch.location_of_clause"
-
-let check_unused casel =
- let prefs =
- List.fold_right
- (fun (pat,act as clause) r ->
- if has_guard act
- then ([], ([pat], act)) :: r
- else ([], ([pat], act)) ::
- List.map (fun (pss,clause) -> [pat]::pss,clause) r)
- casel [] in
- List.iter
- (fun (pss, ((qs, _) as clause)) ->
- if not (satisfiable pss qs) then
- Location.print_warning (location_of_clause qs)
- "this match case is unused.")
- prefs
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
deleted file mode 100644
index 93aa55957c..0000000000
--- a/typing/parmatch.mli
+++ /dev/null
@@ -1,6 +0,0 @@
-(* Detection of partial matches and unused match cases. *)
-
-open Typedtree
-
-val check_partial: Location.t -> (pattern * expression) list -> unit
-val check_unused: (pattern * expression) list -> unit
diff --git a/typing/path.ml b/typing/path.ml
deleted file mode 100644
index d67a619454..0000000000
--- a/typing/path.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-type t =
- Pident of Ident.t
- | Pdot of t * string * int
-
-let nopos = -1
-
-let rec same p1 p2 =
- match (p1, p2) with
- (Pident id1, Pident id2) -> Ident.same id1 id2
- | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 & same p1 p2
- | (_, _) -> false
-
-let rec root = function
- Pident id -> id
- | Pdot(p, s, pos) -> root p
-
-let isfree id p = Ident.same id (root p)
diff --git a/typing/path.mli b/typing/path.mli
deleted file mode 100644
index 51a0ac96cd..0000000000
--- a/typing/path.mli
+++ /dev/null
@@ -1,10 +0,0 @@
-(* Access paths *)
-
-type t =
- Pident of Ident.t
- | Pdot of t * string * int
-
-val same: t -> t -> bool
-val isfree: Ident.t -> t -> bool
-
-val nopos: int
diff --git a/typing/predef.ml b/typing/predef.ml
deleted file mode 100644
index b1c91c3b97..0000000000
--- a/typing/predef.ml
+++ /dev/null
@@ -1,97 +0,0 @@
-(* Predefined type constructors (with special typing rules in typecore) *)
-
-open Path
-open Typedtree
-
-
-let ident_int = Ident.new "int"
-and ident_char = Ident.new "char"
-and ident_string = Ident.new "string"
-and ident_float = Ident.new "float"
-and ident_bool = Ident.new "bool"
-and ident_unit = Ident.new "unit"
-and ident_exn = Ident.new "exn"
-and ident_array = Ident.new "array"
-and ident_list = Ident.new "list"
-and ident_format = Ident.new "format"
-
-let path_int = Pident ident_int
-and path_char = Pident ident_char
-and path_string = Pident ident_string
-and path_float = Pident ident_float
-and path_bool = Pident ident_bool
-and path_unit = Pident ident_unit
-and path_exn = Pident ident_exn
-and path_array = Pident ident_array
-and path_list = Pident ident_list
-and path_format = Pident ident_format
-
-let type_int = Tconstr(Pident ident_int, [])
-and type_char = Tconstr(Pident ident_char, [])
-and type_string = Tconstr(Pident ident_string, [])
-and type_float = Tconstr(Pident ident_float, [])
-and type_bool = Tconstr(Pident ident_bool, [])
-and type_unit = Tconstr(Pident ident_unit, [])
-and type_exn = Tconstr(Pident ident_exn, [])
-and type_array t = Tconstr(path_array, [t])
-and type_list t = Tconstr(path_list, [t])
-
-let ident_match_failure = Ident.new "Match_failure"
-and ident_out_of_memory = Ident.new "Out_of_memory"
-and ident_invalid_argument = Ident.new "Invalid_argument"
-and ident_failure = Ident.new "Failure"
-and ident_not_found = Ident.new "Not_found"
-and ident_sys_error = Ident.new "Sys_error"
-and ident_end_of_file = Ident.new "End_of_file"
-and ident_division_by_zero = Ident.new "Division_by_zero"
-
-let path_match_failure = Pident ident_match_failure
-
-let build_initial_env add_type add_exception empty_env =
- let newvar() =
- (* Cannot call Ctype.newvar here because ctype imports predef via env *)
- Tvar{tvar_level = -1 (*generic_level*); tvar_link = None} in
- let decl_abstr =
- {type_params = []; type_arity = 0; type_kind = Type_abstract}
- and decl_bool =
- {type_params = []; type_arity = 0;
- type_kind = Type_variant["false",[]; "true",[]]}
- and decl_unit =
- {type_params = []; type_arity = 0; type_kind = Type_variant["()",[]]}
- and decl_exn =
- {type_params = []; type_arity = 0; type_kind = Type_variant[]}
- and decl_array =
- let tvar = newvar() in
- {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract}
- and decl_list =
- let tvar = newvar() in
- {type_params = [tvar]; type_arity = 1;
- type_kind = Type_variant["[]", []; "::", [tvar; type_list tvar]]}
- and decl_format =
- {type_params = [newvar(); newvar(); newvar()]; type_arity = 3;
- type_kind = Type_abstract} in
- add_exception ident_match_failure [Ttuple[type_string; type_int; type_int]] (
- add_exception ident_out_of_memory [] (
- add_exception ident_invalid_argument [type_string] (
- add_exception ident_failure [type_string] (
- add_exception ident_not_found [] (
- add_exception ident_sys_error [type_string] (
- add_exception ident_end_of_file [] (
- add_exception ident_division_by_zero [] (
- add_type ident_format decl_format (
- add_type ident_list decl_list (
- add_type ident_array decl_array (
- add_type ident_exn decl_exn (
- add_type ident_unit decl_unit (
- add_type ident_bool decl_bool (
- add_type ident_float decl_abstr (
- add_type ident_string decl_abstr (
- add_type ident_char decl_abstr (
- add_type ident_int decl_abstr (
- empty_env))))))))))))))))))
-
-let builtin_values =
- List.map (fun id -> Ident.make_global id; (Ident.name id, id))
- [ident_match_failure; ident_out_of_memory; ident_invalid_argument;
- ident_failure; ident_not_found; ident_sys_error; ident_end_of_file;
- ident_division_by_zero]
diff --git a/typing/predef.mli b/typing/predef.mli
deleted file mode 100644
index da2d17ae0e..0000000000
--- a/typing/predef.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(* Predefined type constructors (with special typing rules in typecore) *)
-
-open Typedtree
-
-val type_int: type_expr
-val type_char: type_expr
-val type_string: type_expr
-val type_float: type_expr
-val type_bool: type_expr
-val type_unit: type_expr
-val type_exn: type_expr
-val type_array: type_expr -> type_expr
-val type_list: type_expr -> type_expr
-
-val path_int: Path.t
-val path_char: Path.t
-val path_string: Path.t
-val path_float: Path.t
-val path_bool: Path.t
-val path_unit: Path.t
-val path_exn: Path.t
-val path_array: Path.t
-val path_list: Path.t
-val path_format: Path.t
-
-val path_match_failure: Path.t
-
-(* To build the initial environment. Since there is a nasty mutual
- recursion between predef and env, we break it by parameterizing
- over Env.t, Env.add_type and Env.add_exception. *)
-
-val build_initial_env:
- (Ident.t -> type_declaration -> 'a -> 'a) ->
- (Ident.t -> exception_declaration -> 'a -> 'a) ->
- 'a -> 'a
-
-(* To initialize linker tables *)
-
-val builtin_values: (string * Ident.t) list
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
deleted file mode 100644
index a898b8c03e..0000000000
--- a/typing/printtyp.ml
+++ /dev/null
@@ -1,214 +0,0 @@
-(* Printing functions *)
-
-open Format
-open Longident
-open Path
-open Asttypes
-open Typedtree
-
-
-(* Print a long identifier *)
-
-let rec longident = function
- Lident s -> print_string s
- | Ldot(p, s) -> longident p; print_string "."; print_string s
-
-(* Print an identifier *)
-
-let ident id =
- print_string(Ident.name id)
-
-(* Print a path *)
-
-let ident_pervasive = Ident.new_persistent "Pervasives"
-
-let rec path = function
- Pident id ->
- ident id
- | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
- print_string s
- | Pdot(p, s, pos) ->
- path p; print_string "."; print_string s
-
-(* Print a type expression *)
-
-let var_names = ref ([] : (type_expr * string) list)
-let var_counter = ref 0
-
-let reset_var_names () = var_names := []; var_counter := 0
-
-let name_of_var v =
- try
- List.assq v !var_names
- with Not_found ->
- let name =
- if !var_counter < 26
- then String.make 1 (Char.chr(97 + !var_counter))
- else String.make 1 (Char.chr(97 + !var_counter mod 26)) ^
- string_of_int(!var_counter / 26) in
- var_names := (v, name) :: !var_names;
- incr var_counter;
- name
-
-let rec typexp sch prio = function
- Tvar {tvar_link = Some ty} ->
- typexp sch prio ty
- | Tvar {tvar_link = None; tvar_level = lvl} as v ->
- if not sch or lvl = -1 (* generic *)
- then print_string "'"
- else print_string "'_";
- print_string(name_of_var v)
- | Tarrow(ty1, ty2) ->
- if prio >= 1 then begin open_hovbox 1; print_string "(" end
- else open_hovbox 0;
- typexp sch 1 ty1;
- print_string " ->"; print_space();
- typexp sch 0 ty2;
- if prio >= 1 then print_string ")";
- close_box()
- | Ttuple tyl ->
- if prio >= 2 then begin open_hovbox 1; print_string "(" end
- else open_hovbox 0;
- typlist sch 2 " *" tyl;
- if prio >= 2 then print_string ")";
- close_box()
- | Tconstr(p, tyl) ->
- open_hovbox 0;
- begin match tyl with
- [] -> ()
- | [ty1] ->
- typexp sch 2 ty1; print_space()
- | tyl ->
- open_hovbox 1; print_string "("; typlist sch 0 "," tyl;
- print_string ")"; close_box(); print_space()
- end;
- path p;
- close_box()
-
-and typlist sch prio sep = function
- [] -> ()
- | [ty] -> typexp sch prio ty
- | ty::tyl ->
- typexp sch prio ty; print_string sep; print_space();
- typlist sch prio sep tyl
-
-let type_expr ty = typexp false 0 ty
-and type_scheme ty = reset_var_names(); typexp true 0 ty
-
-(* Print one type declaration *)
-
-let rec type_declaration id decl =
- reset_var_names();
- open_hvbox 2;
- print_string "type ";
- type_expr (Tconstr(Pident id, decl.type_params));
- begin match decl.type_kind with
- Type_abstract -> ()
- | Type_manifest ty ->
- print_string " ="; print_space(); type_expr ty
- | Type_variant (cstr1 :: cstrs) ->
- print_string " ="; print_break(1,2);
- constructor cstr1;
- List.iter (fun cstr -> print_space(); print_string "| "; constructor cstr)
- cstrs
- | Type_record (lbl1 :: lbls) ->
- print_string " ="; print_space();
- print_string "{ "; label lbl1;
- List.iter (fun lbl -> print_string ";"; print_break(1,2); label lbl)
- lbls;
- print_string " }"
- | _ ->
- () (* A fatal error actually, except when printing type exn... *)
- end;
- close_box()
-
-and constructor (name, args) =
- print_string name;
- match args with
- [] -> ()
- | _ -> print_string " of ";
- open_hovbox 2; typlist false 2 " *" args; close_box()
-
-and label (name, mut, arg) =
- begin match mut with
- Immutable -> ()
- | Mutable -> print_string "mutable "
- end;
- print_string name;
- print_string ": ";
- type_expr arg
-
-(* Print an exception declaration *)
-
-let exception_declaration id decl =
- print_string "exception "; constructor (Ident.name id, decl)
-
-(* Print a value declaration *)
-
-let value_description id decl =
- open_hovbox 2;
- begin match decl.val_prim with
- Not_prim ->
- print_string "val "; ident id; print_string " :"; print_space();
- type_scheme decl.val_type
- | Primitive(p, ar) ->
- print_string "val "; ident id; print_string " :"; print_space();
- type_scheme decl.val_type; print_space();
- print_string "= \""; print_string p; print_string "\""
- end;
- close_box()
-
-(* Print a module type *)
-
-let rec modtype = function
- Tmty_ident p ->
- path p
- | Tmty_signature [] ->
- print_string "sig end"
- | Tmty_signature(item :: rem) ->
- open_hvbox 2;
- print_string "sig"; print_space();
- signature_item item;
- List.iter
- (fun item -> print_space(); signature_item item)
- rem;
- print_break(1, -2); print_string "end";
- close_box()
- | Tmty_functor(param, ty_arg, ty_res) ->
- open_hovbox 2;
- print_string "functor"; print_cut();
- print_string "("; ident param; print_string " : ";
- modtype ty_arg;
- print_string ") ->"; print_space();
- modtype ty_res;
- close_box()
-
-and signature_item = function
- Tsig_value(id, decl) ->
- value_description id decl
- | Tsig_type(id, decl) ->
- type_declaration id decl
- | Tsig_exception(id, decl) ->
- exception_declaration id decl
- | Tsig_module(id, mty) ->
- open_hovbox 2; print_string "module "; ident id; print_string " :";
- print_space(); modtype mty; close_box()
- | Tsig_modtype(id, decl) ->
- modtype_declaration id decl
-
-and modtype_declaration id decl =
- open_hovbox 2; print_string "module type "; ident id;
- begin match decl with
- Tmodtype_abstract -> ()
- | Tmodtype_manifest mty ->
- print_string " ="; print_space(); modtype mty
- end;
- close_box()
-
-(* Print a signature body (used when compiling a .mli and printing results
- in interactive use). *)
-
-let signature sg =
- open_vbox 0;
- List.iter (fun item -> signature_item item; print_space()) sg;
- close_box()
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
deleted file mode 100644
index 2a99c48d7e..0000000000
--- a/typing/printtyp.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(* Printing functions *)
-
-open Typedtree
-
-val longident: Longident.t -> unit
-val ident: Ident.t -> unit
-val path: Path.t -> unit
-val reset_var_names: unit -> unit
-val type_expr: type_expr -> unit
-val type_scheme: type_expr -> unit
-val value_description: Ident.t -> value_description -> unit
-val type_declaration: Ident.t -> type_declaration -> unit
-val exception_declaration: Ident.t -> exception_declaration -> unit
-val modtype: module_type -> unit
-val signature: signature -> unit
-val signature_item: signature_item -> unit
-val modtype_declaration: Ident.t -> modtype_declaration -> unit
diff --git a/typing/subst.ml b/typing/subst.ml
deleted file mode 100644
index 97a5aab938..0000000000
--- a/typing/subst.ml
+++ /dev/null
@@ -1,96 +0,0 @@
-(* Substitutions *)
-
-open Path
-open Typedtree
-
-
-type t =
- { types: Path.t Ident.tbl;
- modules: Path.t Ident.tbl;
- modtypes: module_type Ident.tbl }
-
-let identity =
- { types = Ident.empty; modules = Ident.empty; modtypes = Ident.empty }
-
-let add_type id p s =
- { types = Ident.add id p s.types;
- modules = s.modules;
- modtypes = s.modtypes }
-
-let add_module id p s =
- { types = s.types;
- modules = Ident.add id p s.modules;
- modtypes = s.modtypes }
-
-let add_modtype id ty s =
- { types = s.types;
- modules = s.modules;
- modtypes = Ident.add id ty s.modtypes }
-
-let rec module_path s = function
- Pident id as p ->
- begin try Ident.find_same id s.modules with Not_found -> p end
- | Pdot(p, n, pos) ->
- Pdot(module_path s p, n, pos)
-
-let type_path s = function
- Pident id as p ->
- begin try Ident.find_same id s.types with Not_found -> p end
- | Pdot(p, n, pos) ->
- Pdot(module_path s p, n, pos)
-
-let rec type_expr s = function
- Tvar{tvar_link = None} as ty -> ty
- | Tvar{tvar_link = Some ty} -> type_expr s ty
- | Tarrow(t1, t2) -> Tarrow(type_expr s t1, type_expr s t2)
- | Ttuple tl -> Ttuple(List.map (type_expr s) tl)
- | Tconstr(p, []) -> Tconstr(type_path s p, [])
- | Tconstr(p, tl) -> Tconstr(type_path s p, List.map (type_expr s) tl)
-
-let value_description s descr =
- { val_type = type_expr s descr.val_type;
- val_prim = descr.val_prim }
-
-let type_declaration s decl =
- { type_params = decl.type_params;
- type_arity = decl.type_arity;
- type_kind =
- match decl.type_kind with
- Type_abstract -> Type_abstract
- | Type_manifest ty -> Type_manifest(type_expr s ty)
- | Type_variant cstrs ->
- Type_variant(List.map (fun (n, args) -> (n, List.map (type_expr s) args))
- cstrs)
- | Type_record lbls ->
- Type_record(List.map (fun (n, mut, arg) -> (n, mut, type_expr s arg))
- lbls)
- }
-
-let exception_declaration s tyl =
- List.map (type_expr s) tyl
-
-let rec modtype s = function
- Tmty_ident p as mty ->
- begin match p with
- Pident id ->
- begin try Ident.find_same id s.modtypes with Not_found -> mty end
- | Pdot(p, n, pos) ->
- Tmty_ident(Pdot(module_path s p, n, pos))
- end
- | Tmty_signature sg ->
- Tmty_signature(signature s sg)
- | Tmty_functor(id, arg, res) ->
- Tmty_functor(id, modtype s arg, modtype s res)
-
-and signature s sg = List.map (signature_item s) sg
-
-and signature_item s = function
- Tsig_value(id, d) -> Tsig_value(id, value_description s d)
- | Tsig_type(id, d) -> Tsig_type(id, type_declaration s d)
- | Tsig_exception(id, d) -> Tsig_exception(id, exception_declaration s d)
- | Tsig_module(id, mty) -> Tsig_module(id, modtype s mty)
- | Tsig_modtype(id, d) -> Tsig_modtype(id, modtype_declaration s d)
-
-and modtype_declaration s = function
- Tmodtype_abstract -> Tmodtype_abstract
- | Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty)
diff --git a/typing/subst.mli b/typing/subst.mli
deleted file mode 100644
index 52caf5238e..0000000000
--- a/typing/subst.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(* Substitutions *)
-
-open Typedtree
-
-type t
-
-val identity: t
-
-val add_type: Ident.t -> Path.t -> t -> t
-val add_module: Ident.t -> Path.t -> t -> t
-val add_modtype: Ident.t -> module_type -> t -> t
-
-val type_expr: t -> type_expr -> type_expr
-val value_description: t -> value_description -> value_description
-val type_declaration: t -> type_declaration -> type_declaration
-val exception_declaration:
- t -> exception_declaration -> exception_declaration
-val modtype: t -> module_type -> module_type
-val signature: t -> signature -> signature
-val modtype_declaration: t -> modtype_declaration -> modtype_declaration
-
diff --git a/typing/typecore.ml b/typing/typecore.ml
deleted file mode 100644
index f56de5dcfe..0000000000
--- a/typing/typecore.ml
+++ /dev/null
@@ -1,601 +0,0 @@
-(* Typechecking for the core language *)
-
-open Asttypes
-open Parsetree
-open Typedtree
-open Ctype
-
-
-type error =
- Unbound_value of Longident.t
- | Unbound_constructor of Longident.t
- | Unbound_label of Longident.t
- | Constructor_arity_mismatch of Longident.t * int * int
- | Label_mismatch of Longident.t * type_expr * type_expr
- | Pattern_type_clash of type_expr * type_expr
- | Multiply_bound_variable
- | Orpat_not_closed
- | Expr_type_clash of type_expr * type_expr
- | Apply_non_function of type_expr
- | Label_multiply_defined of Longident.t
- | Label_missing
- | Label_not_mutable of Longident.t
- | Non_generalizable of type_expr
- | Bad_format_letter of char
-
-exception Error of Location.t * error
-
-(* Typing of constants *)
-
-let type_constant = function
- Const_int _ -> Predef.type_int
- | Const_char _ -> Predef.type_char
- | Const_string _ -> Predef.type_string
- | Const_float _ -> Predef.type_float
-
-(* Typing of patterns *)
-
-let unify_pat env pat expected_ty =
- try
- unify env pat.pat_type expected_ty
- with Unify ->
- raise(Error(pat.pat_loc, Pattern_type_clash(pat.pat_type, expected_ty)))
-
-let pattern_variables = ref ([]: (Ident.t * type_expr) list)
-
-let enter_variable loc name ty =
- if List.exists (fun (id, ty) -> Ident.name id = name) !pattern_variables
- then raise(Error(loc, Multiply_bound_variable));
- let id = Ident.new name in
- pattern_variables := (id, ty) :: !pattern_variables;
- id
-
-let rec type_pat env sp =
- match sp.ppat_desc with
- Ppat_any ->
- { pat_desc = Tpat_any;
- pat_loc = sp.ppat_loc;
- pat_type = newvar() }
- | Ppat_var name ->
- let ty = newvar() in
- let id = enter_variable sp.ppat_loc name ty in
- { pat_desc = Tpat_var id;
- pat_loc = sp.ppat_loc;
- pat_type = ty }
- | Ppat_alias(sp, name) ->
- let p = type_pat env sp in
- let id = enter_variable sp.ppat_loc name p.pat_type in
- { pat_desc = Tpat_alias(p, id);
- pat_loc = sp.ppat_loc;
- pat_type = p.pat_type }
- | Ppat_constant cst ->
- { pat_desc = Tpat_constant cst;
- pat_loc = sp.ppat_loc;
- pat_type = type_constant cst }
- | Ppat_tuple spl ->
- let pl = List.map (type_pat env) spl in
- { pat_desc = Tpat_tuple pl;
- pat_loc = sp.ppat_loc;
- pat_type = Ttuple(List.map (fun p -> p.pat_type) pl) }
- | Ppat_construct(lid, sarg) ->
- let constr =
- try
- Env.lookup_constructor lid env
- with Not_found ->
- raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
- let sargs =
- match sarg with
- None -> []
- | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl
- | Some sp -> [sp] in
- if List.length sargs <> constr.cstr_arity then
- raise(Error(sp.ppat_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;
- { pat_desc = Tpat_construct(constr, args);
- pat_loc = sp.ppat_loc;
- pat_type = ty_res }
- | Ppat_record lid_sp_list ->
- let ty = newvar() in
- let type_label_pat (lid, sarg) =
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sp.ppat_loc, Unbound_label lid)) in
- let (ty_arg, ty_res) = instance_label label in
- begin try
- unify env ty_res ty
- with Unify ->
- raise(Error(sp.ppat_loc, Label_mismatch(lid, ty_res, ty)))
- end;
- let arg = type_pat env sarg in
- unify_pat env arg ty_arg;
- (label, arg)
- in
- { pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
- pat_loc = sp.ppat_loc;
- pat_type = ty }
- | Ppat_or(sp1, sp2) ->
- let initial_pattern_variables = !pattern_variables in
- let p1 = type_pat env sp1 in
- let p2 = type_pat env sp2 in
- if !pattern_variables != initial_pattern_variables then
- raise(Error(sp.ppat_loc, Orpat_not_closed));
- unify_pat env p2 p1.pat_type;
- { pat_desc = Tpat_or(p1, p2);
- pat_loc = sp.ppat_loc;
- pat_type = p1.pat_type }
- | Ppat_constraint(sp, sty) ->
- let p = type_pat env sp in
- let ty = Typetexp.transl_simple_type env false sty in
- unify_pat env p ty;
- p
-
-let add_pattern_variables env =
- let pv = !pattern_variables in
- pattern_variables := [];
- List.fold_right
- (fun (id, ty) env ->
- Env.add_value id {val_type = ty; val_prim = Not_prim} env)
- pv env
-
-let type_pattern env spat =
- pattern_variables := [];
- let pat = type_pat env spat in
- let new_env = add_pattern_variables env in
- (pat, new_env)
-
-let type_pattern_list env spatl =
- pattern_variables := [];
- let patl = List.map (type_pat env) spatl in
- let new_env = add_pattern_variables env in
- (patl, new_env)
-
-(* Generalization criterion for expressions *)
-
-let rec is_nonexpansive exp =
- match exp.exp_desc with
- Texp_ident(_,_) -> true
- | Texp_constant _ -> true
- | Texp_let(rec_flag, pat_exp_list, body) ->
- List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &
- is_nonexpansive body
- | Texp_function _ -> true
- | Texp_tuple el ->
- List.for_all is_nonexpansive el
- | Texp_construct(_, el) ->
- List.for_all is_nonexpansive el
- | Texp_record lbl_exp_list ->
- List.for_all (fun (lbl, exp) -> lbl.lbl_mut = Immutable & is_nonexpansive exp)
- lbl_exp_list
- | Texp_field(exp, lbl) -> is_nonexpansive exp
- | Texp_array [] -> true
- | _ -> false
-
-(* Typing of printf formats *)
-
-let type_format loc fmt =
- let len = String.length fmt in
- let ty_input = newvar()
- and ty_result = newvar() in
- let rec skip_args j =
- if j >= len then j else
- match fmt.[j] with
- '0' .. '9' | ' ' | '.' | '-' -> skip_args (j+1)
- | _ -> j in
- let rec scan_format i =
- if i >= len then ty_result else
- match fmt.[i] with
- '%' ->
- let j = skip_args(i+1) in
- begin match fmt.[j] with
- '%' ->
- scan_format (j+1)
- | 's' ->
- Tarrow(Predef.type_string, scan_format (j+1))
- | 'c' ->
- Tarrow(Predef.type_char, scan_format (j+1))
- | 'd' | 'o' | 'x' | 'X' | 'u' ->
- Tarrow(Predef.type_int, scan_format (j+1))
- | 'f' | 'e' | 'E' | 'g' | 'G' ->
- Tarrow(Predef.type_float, scan_format (j+1))
- | 'b' ->
- Tarrow(Predef.type_bool, scan_format (j+1))
- | 'a' ->
- let ty_arg = newvar() in
- Tarrow (Tarrow(ty_input, Tarrow (ty_arg, ty_result)),
- Tarrow (ty_arg, scan_format (j+1)))
- | 't' ->
- Tarrow(Tarrow(ty_input, ty_result), scan_format (j+1))
- | c ->
- raise(Error(loc, Bad_format_letter c))
- end
- | _ -> scan_format (i+1) in
- Tconstr(Predef.path_format, [scan_format 0; ty_input; ty_result])
-
-(* Typing of expressions *)
-
-let unify_exp env exp expected_ty =
- try
- unify env exp.exp_type expected_ty
- with Unify ->
- raise(Error(exp.exp_loc, Expr_type_clash(exp.exp_type, expected_ty)))
-
-let rec type_exp env sexp =
- match sexp.pexp_desc with
- Pexp_ident lid ->
- begin try
- let (path, desc) = Env.lookup_value lid env in
- { exp_desc = Texp_ident(path, desc);
- exp_loc = sexp.pexp_loc;
- exp_type = instance desc.val_type }
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_value lid))
- end
- | Pexp_constant cst ->
- { exp_desc = Texp_constant cst;
- exp_loc = sexp.pexp_loc;
- exp_type = type_constant cst }
- | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
- let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
- let body = type_exp new_env sbody in
- { exp_desc = Texp_let(rec_flag, pat_exp_list, body);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type }
- | Pexp_function caselist ->
- let ty_arg = newvar() and ty_res = newvar() in
- let cases = type_cases env ty_arg ty_res caselist in
- Parmatch.check_unused cases;
- Parmatch.check_partial sexp.pexp_loc cases;
- { exp_desc = Texp_function cases;
- exp_loc = sexp.pexp_loc;
- exp_type = Tarrow(ty_arg, ty_res) }
- | Pexp_apply(sfunct, sargs) ->
- let funct = type_exp env sfunct in
- let rec type_args ty_fun = function
- [] ->
- ([], ty_fun)
- | sarg1 :: sargl ->
- let (ty1, ty2) =
- try
- filter_arrow env ty_fun
- with Unify ->
- raise(Error(sfunct.pexp_loc,
- Apply_non_function funct.exp_type)) in
- let arg1 = type_expect env sarg1 ty1 in
- let (argl, ty_res) = type_args ty2 sargl in
- (arg1 :: argl, ty_res) in
- let (args, ty_res) = type_args funct.exp_type sargs in
- { exp_desc = Texp_apply(funct, args);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res }
- | Pexp_match(sarg, caselist) ->
- let arg = type_exp env sarg in
- let ty_res = newvar() in
- let cases = type_cases env arg.exp_type ty_res caselist in
- Parmatch.check_unused cases;
- Parmatch.check_partial sexp.pexp_loc cases;
- { exp_desc = Texp_match(arg, cases);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res }
- | Pexp_try(sbody, caselist) ->
- let body = type_exp env sbody in
- let cases = type_cases env Predef.type_exn body.exp_type caselist in
- Parmatch.check_unused cases;
- { exp_desc = Texp_try(body, cases);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type }
- | Pexp_tuple sexpl ->
- let expl = List.map (type_exp env) sexpl in
- { exp_desc = Texp_tuple expl;
- exp_loc = sexp.pexp_loc;
- exp_type = Ttuple(List.map (fun exp -> exp.exp_type) expl) }
- | Pexp_construct(lid, sarg) ->
- let constr =
- try
- Env.lookup_constructor lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_constructor lid)) in
- let sargs =
- match sarg with
- None -> []
- | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
- | Some se -> [se] in
- if List.length sargs <> constr.cstr_arity then
- raise(Error(sexp.pexp_loc, Constructor_arity_mismatch(lid,
- constr.cstr_arity, List.length sargs)));
- let (ty_args, ty_res) = instance_constructor constr in
- let args = List.map2 (type_expect env) sargs ty_args in
- { exp_desc = Texp_construct(constr, args);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_res }
- | Pexp_record lid_sexp_list ->
- let ty = newvar() in
- let num_fields = ref 0 in
- let type_label_exp (lid, sarg) =
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_label lid)) in
- let (ty_arg, ty_res) = instance_label label in
- begin try
- unify env ty_res ty
- with Unify ->
- raise(Error(sexp.pexp_loc, Label_mismatch(lid, ty_res, ty)))
- end;
- let arg = type_expect env sarg ty_arg in
- num_fields := Array.length label.lbl_all;
- (label, arg) in
- let lbl_exp_list = List.map type_label_exp lid_sexp_list in
- let rec check_duplicates = function
- [] -> ()
- | (lid, sarg) :: remainder ->
- if List.mem_assoc lid remainder
- then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
- else check_duplicates remainder in
- check_duplicates lid_sexp_list;
- if List.length lid_sexp_list <> !num_fields then
- raise(Error(sexp.pexp_loc, Label_missing));
- { exp_desc = Texp_record lbl_exp_list;
- exp_loc = sexp.pexp_loc;
- exp_type = ty }
- | Pexp_field(sarg, lid) ->
- let arg = type_exp env sarg in
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_label lid)) in
- let (ty_arg, ty_res) = instance_label label in
- unify_exp env arg ty_res;
- { exp_desc = Texp_field(arg, label);
- exp_loc = sexp.pexp_loc;
- exp_type = ty_arg }
- | Pexp_setfield(srecord, lid, snewval) ->
- let record = type_exp env srecord in
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sexp.pexp_loc, Unbound_label lid)) in
- if label.lbl_mut = Immutable then
- raise(Error(sexp.pexp_loc, Label_not_mutable lid));
- let (ty_arg, ty_res) = instance_label label in
- unify_exp env record ty_res;
- let newval = type_expect env snewval ty_arg in
- { exp_desc = Texp_setfield(record, label, newval);
- exp_loc = sexp.pexp_loc;
- exp_type = Predef.type_unit }
- | Pexp_array(sargl) ->
- let ty = newvar() in
- let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
- { exp_desc = Texp_array argl;
- exp_loc = sexp.pexp_loc;
- exp_type = Predef.type_array ty }
- | Pexp_ifthenelse(scond, sifso, sifnot) ->
- let cond = type_expect env scond Predef.type_bool in
- begin match sifnot with
- None ->
- let ifso = type_expect env sifso Predef.type_unit in
- { exp_desc = Texp_ifthenelse(cond, ifso, None);
- exp_loc = sexp.pexp_loc;
- exp_type = Predef.type_unit }
- | Some sexp ->
- let ifso = type_exp env sifso in
- let ifnot = type_expect env sexp ifso.exp_type in
- { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
- exp_loc = sexp.pexp_loc;
- exp_type = ifso.exp_type }
- end
- | Pexp_sequence(sexp1, sexp2) ->
- let exp1 = type_statement env sexp1 in
- let exp2 = type_exp env sexp2 in
- { exp_desc = Texp_sequence(exp1, exp2);
- exp_loc = sexp.pexp_loc;
- exp_type = exp2.exp_type }
- | Pexp_while(scond, sbody) ->
- let cond = type_expect env scond Predef.type_bool in
- let body = type_statement env sbody in
- { exp_desc = Texp_while(cond, body);
- exp_loc = sexp.pexp_loc;
- exp_type = Predef.type_unit }
- | Pexp_for(param, slow, shigh, dir, sbody) ->
- let low = type_expect env slow Predef.type_int in
- let high = type_expect env shigh Predef.type_int in
- let (id, new_env) =
- Env.enter_value param {val_type = Predef.type_int;
- val_prim = Not_prim} env in
- let body = type_statement new_env sbody in
- { exp_desc = Texp_for(id, low, high, dir, body);
- exp_loc = sexp.pexp_loc;
- exp_type = Predef.type_unit }
- | Pexp_constraint(sarg, sty) ->
- let ty = Typetexp.transl_simple_type env false sty in
- let arg = type_expect env sarg ty in
- { exp_desc = arg.exp_desc;
- exp_loc = arg.exp_loc;
- exp_type = ty }
- | Pexp_when(scond, sbody) ->
- let cond = type_expect env scond Predef.type_bool in
- let body = type_exp env sbody in
- { exp_desc = Texp_when(cond, body);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type }
-
-(* Typing of an expression with an expected type.
- Some constructs are treated specially to provide better error messages. *)
-
-and type_expect env sexp ty_expected =
- match sexp.pexp_desc with
- Pexp_constant(Const_string s as cst) ->
- let exp =
- { exp_desc = Texp_constant cst;
- exp_loc = sexp.pexp_loc;
- exp_type =
- (* Terrible hack for format strings *)
- match Ctype.repr ty_expected with
- Tconstr(path, _) when Path.same path Predef.path_format ->
- type_format sexp.pexp_loc s
- | _ -> Predef.type_string } in
- unify_exp env exp ty_expected;
- exp
- | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
- let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
- let body = type_expect new_env sbody ty_expected in
- { exp_desc = Texp_let(rec_flag, pat_exp_list, body);
- exp_loc = sexp.pexp_loc;
- exp_type = body.exp_type }
- | Pexp_sequence(sexp1, sexp2) ->
- let exp1 = type_statement env sexp1 in
- let exp2 = type_expect env sexp2 ty_expected in
- { exp_desc = Texp_sequence(exp1, exp2);
- exp_loc = sexp.pexp_loc;
- exp_type = exp2.exp_type }
- | _ ->
- let exp = type_exp env sexp in
- unify_exp env exp ty_expected;
- exp
-
-(* Typing of statements (expressions whose values are discarded) *)
-
-and type_statement env sexp =
- let exp = type_exp env sexp in
- match Ctype.repr exp.exp_type with
- Tarrow(_, _) ->
- Location.print_warning sexp.pexp_loc
- "this function application is partial,\n\
- maybe some arguments are missing.";
- exp
- | _ -> exp
-
-(* Typing of match cases *)
-
-and type_cases env ty_arg ty_res caselist =
- List.map
- (fun (spat, sexp) ->
- let (pat, ext_env) = type_pattern env spat in
- unify_pat env pat ty_arg;
- let exp = type_expect ext_env sexp ty_res in
- (pat, exp))
- caselist
-
-(* Typing of let bindings *)
-
-and type_let env rec_flag spat_sexp_list =
- begin_def();
- let (pat_list, new_env) =
- type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list) in
- let exp_env =
- match rec_flag with Nonrecursive -> env | Recursive -> new_env in
- let exp_list =
- List.map (fun (spat, sexp) -> type_exp exp_env sexp) spat_sexp_list in
- List.iter2
- (fun pat exp -> unify_pat env pat exp.exp_type)
- pat_list exp_list;
- List.iter2
- (fun pat exp -> Parmatch.check_partial pat.pat_loc [pat, exp])
- pat_list exp_list;
- end_def();
- List.iter
- (fun exp -> if not (is_nonexpansive exp) then make_nongen exp.exp_type)
- exp_list;
- List.iter
- (fun exp -> generalize exp.exp_type)
- exp_list;
- (List.combine(pat_list, exp_list), new_env)
-
-(* Typing of toplevel bindings *)
-
-let type_binding env rec_flag spat_sexp_list =
- Typetexp.reset_type_variables();
- let (pat_exp_list, new_env as result) =
- type_let env rec_flag spat_sexp_list in
- List.iter
- (fun (pat, exp) ->
- if not (closed_schema exp.exp_type) then
- raise(Error(exp.exp_loc, Non_generalizable exp.exp_type)))
- pat_exp_list;
- result
-
-(* Typing of toplevel expressions *)
-
-let type_expression env sexp =
- Typetexp.reset_type_variables();
- begin_def();
- let exp = type_exp env sexp in
- end_def();
- if is_nonexpansive exp then generalize exp.exp_type;
- exp
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let report_error = function
- Unbound_value lid ->
- print_string "Unbound value "; longident lid
- | Unbound_constructor lid ->
- print_string "Unbound constructor "; longident lid
- | Unbound_label lid ->
- print_string "Unbound label "; longident lid
- | Constructor_arity_mismatch(lid, expected, provided) ->
- open_hovbox 0;
- print_string "The constructor "; longident lid;
- print_space(); print_string "expects "; print_int expected;
- print_string " argument(s),"; print_space();
- print_string "but is here applied to "; print_int provided;
- print_string " argument(s)";
- close_box()
- | Label_mismatch(lid, actual, expected) ->
- open_hovbox 0;
- print_string "The label "; longident lid;
- print_space(); print_string "belongs to the type"; print_space();
- type_expr actual; print_space();
- print_string "but is here mixed with labels of type"; print_space();
- type_expr expected;
- close_box()
- | Pattern_type_clash(inferred, expected) ->
- open_hovbox 0;
- print_string "This pattern matches values of type"; print_space();
- type_expr inferred; print_space();
- print_string "but is here used to match values of type"; print_space();
- type_expr expected;
- close_box()
- | Multiply_bound_variable ->
- print_string "This variable is bound several times in this matching"
- | Orpat_not_closed ->
- print_string "A pattern with | must not bind variables"
- | Expr_type_clash(inferred, expected) ->
- open_hovbox 0;
- print_string "This expression has type"; print_space();
- type_expr inferred; print_space();
- print_string "but is here used with type"; print_space();
- type_expr expected;
- close_box()
- | Apply_non_function typ ->
- begin match Ctype.repr typ with
- Tarrow(_, _) ->
- print_string "This function is applied to too many arguments"
- | _ ->
- print_string "This expression is not a function, it cannot be applied"
- end
- | Label_multiply_defined lid ->
- print_string "The label "; longident lid;
- print_string " is defined several times"
- | Label_missing ->
- print_string "Some labels are undefined"
- | Label_not_mutable lid ->
- print_string "The label "; longident lid;
- print_string " is not mutable"
- | Non_generalizable typ ->
- open_hovbox 0;
- print_string "The type of this expression,"; print_space();
- type_scheme typ; print_string ","; print_space();
- print_string "contains type variables that cannot be generalized"
- | Bad_format_letter c ->
- print_string "Bad format letter `%"; print_char c; print_string "'"
diff --git a/typing/typecore.mli b/typing/typecore.mli
deleted file mode 100644
index 56fa562c62..0000000000
--- a/typing/typecore.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(* Type inference for the core language *)
-
-open Asttypes
-open Typedtree
-
-val type_binding:
- Env.t -> rec_flag ->
- (Parsetree.pattern * Parsetree.expression) list ->
- (Typedtree.pattern * Typedtree.expression) list * Env.t
-val type_expression:
- Env.t -> Parsetree.expression -> Typedtree.expression
-
-type error =
- Unbound_value of Longident.t
- | Unbound_constructor of Longident.t
- | Unbound_label of Longident.t
- | Constructor_arity_mismatch of Longident.t * int * int
- | Label_mismatch of Longident.t * type_expr * type_expr
- | Pattern_type_clash of type_expr * type_expr
- | Multiply_bound_variable
- | Orpat_not_closed
- | Expr_type_clash of type_expr * type_expr
- | Apply_non_function of type_expr
- | Label_multiply_defined of Longident.t
- | Label_missing
- | Label_not_mutable of Longident.t
- | Non_generalizable of type_expr
- | Bad_format_letter of char
-
-exception Error of Location.t * error
-
-val report_error: error -> unit
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
deleted file mode 100644
index 453bd6ecc8..0000000000
--- a/typing/typedecl.ml
+++ /dev/null
@@ -1,131 +0,0 @@
-(* Typing of type definitions *)
-
-open Parsetree
-open Typedtree
-open Typetexp
-
-
-type error =
- Repeated_parameter
- | Duplicate_constructor of string
- | Too_many_constructors
- | Duplicate_label of string
- | Recursive_abbrev of string
-
-exception Error of Location.t * error
-
-(* Enter all declared types in the environment as abstract types *)
-
-let rec enter_types env = function
- [] ->
- ([], env)
- | (name, sdecl) :: srem ->
- let decl =
- { type_params = []; (*this field is unused when kind = Type_abstract*)
- type_arity = List.length sdecl.ptype_params;
- type_kind = Type_abstract } in
- let (id, extenv) = Env.enter_type name decl env in
- let (rem_id, final_env) = enter_types extenv srem in
- (id :: rem_id, final_env)
-
-(* Translate one type declaration *)
-
-module StringSet =
- Set.Make(struct
- type t = string
- let compare = compare
- end)
-
-let transl_declaration env (name, sdecl) id =
- Ctype.begin_def();
- reset_type_variables();
- let params =
- try
- List.map enter_type_variable sdecl.ptype_params
- with Already_bound ->
- raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
- let kind =
- match sdecl.ptype_kind with
- Ptype_abstract ->
- Type_abstract
- | Ptype_manifest sty ->
- Type_manifest(transl_simple_type env true sty)
- | Ptype_variant cstrs ->
- let all_constrs = ref StringSet.empty in
- List.iter
- (fun (name, args) ->
- 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 cstrs > Config.max_tag then
- raise(Error(sdecl.ptype_loc, Too_many_constructors));
- Type_variant(List.map
- (fun (name, args) ->
- (name, List.map (transl_simple_type env true) args))
- cstrs)
- | Ptype_record lbls ->
- let all_labels = ref StringSet.empty in
- List.iter
- (fun (name, mut, arg) ->
- if StringSet.mem name !all_labels then
- raise(Error(sdecl.ptype_loc, Duplicate_label name));
- all_labels := StringSet.add name !all_labels)
- lbls;
- Type_record(List.map
- (fun (name, mut, arg) ->
- (name, mut, transl_simple_type env true arg))
- lbls) in
- Ctype.end_def();
- List.iter Ctype.generalize params;
- (id,
- {type_params = params; type_arity = List.length params; type_kind = kind})
-
-(* Check for recursive abbrevs *)
-
-let check_recursive_abbrev env (name, sdecl) (id, decl) =
- match decl.type_kind with
- Type_manifest ty ->
- if Ctype.free_type_ident env id ty
- then raise(Error(sdecl.ptype_loc, Recursive_abbrev name))
- | _ -> ()
-
-(* Translate a set of mutually recursive type declarations *)
-
-let transl_type_decl env name_sdecl_list =
- (* Enter the types as abstract *)
- let (id_list, temp_env) = enter_types env name_sdecl_list in
- (* Translate each declaration *)
- let decls = List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
- (* Build the final env *)
- let newenv =
- List.fold_right (fun (id, decl) env -> Env.add_type id decl env) decls env in
- (* Check for recursive abbrevs *)
- List.iter2 (check_recursive_abbrev newenv) name_sdecl_list decls;
- (* Done *)
- (decls, newenv)
-
-(* Translate an exception declaration *)
-
-let transl_exception env excdecl =
- reset_type_variables();
- List.map (transl_simple_type env true) excdecl
-
-(* Error report *)
-
-open Format
-
-let report_error = function
- Repeated_parameter ->
- print_string "A type parameter occurs several times"
- | Duplicate_constructor s ->
- print_string "Two constructors are named "; print_string s
- | Too_many_constructors ->
- print_string "Too many constructors -- maximum is ";
- print_int Config.max_tag; print_string " constructors"
- | Duplicate_label s ->
- print_string "Two labels are named "; print_string s
- | Recursive_abbrev s ->
- print_string "The type abbreviation "; print_string s;
- print_string " is cyclic"
-
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
deleted file mode 100644
index 2507e6fc87..0000000000
--- a/typing/typedecl.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(* Typing of type definitions *)
-
-open Typedtree
-
-val transl_type_decl:
- Env.t -> (string * Parsetree.type_declaration) list ->
- (Ident.t * type_declaration) list * Env.t
-val transl_exception:
- Env.t -> Parsetree.exception_declaration -> exception_declaration
-
-type error =
- Repeated_parameter
- | Duplicate_constructor of string
- | Too_many_constructors
- | Duplicate_label of string
- | Recursive_abbrev of string
-
-exception Error of Location.t * error
-
-val report_error: error -> unit
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
deleted file mode 100644
index 2390d9fbb1..0000000000
--- a/typing/typedtree.ml
+++ /dev/null
@@ -1,186 +0,0 @@
-(* Abstract syntax tree after typing *)
-
-open Misc
-open Asttypes
-
-(* Type expressions for the core language *)
-
-type type_expr =
- Tvar of type_variable
- | Tarrow of type_expr * type_expr
- | Ttuple of type_expr list
- | Tconstr of Path.t * type_expr list
-
-and type_variable =
- { mutable tvar_level: int;
- mutable tvar_link: type_expr option }
-
-(* Value descriptions *)
-
-type value_description =
- { val_type: type_expr; (* Type of the value *)
- val_prim: primitive_description } (* Is this a primitive? *)
-and primitive_description =
- Not_prim
- | Primitive of string * int
-
-(* Constructor descriptions *)
-
-type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
- cstr_args: type_expr list; (* Type of the arguments *)
- cstr_arity: int; (* Number of arguments *)
- cstr_tag: constructor_tag; (* Tag for heap blocks *)
- cstr_span: int } (* Number of constructors in type *)
-
-and constructor_tag =
- Cstr_tag of int (* Regular constructor *)
- | Cstr_exception of Path.t (* Exception constructor *)
-
-(* Record label descriptions *)
-
-type label_description =
- { lbl_res: type_expr; (* Type of the result *)
- lbl_arg: type_expr; (* Type of the argument *)
- lbl_mut: mutable_flag; (* Is this a mutable field? *)
- lbl_pos: int; (* Position in block *)
- lbl_all: label_description array (* All the labels in this type *)
- }
-
-(* Value expressions for the core language *)
-
-type pattern =
- { pat_desc: pattern_desc;
- pat_loc: Location.t;
- pat_type: type_expr }
-
-and pattern_desc =
- Tpat_any
- | Tpat_var of Ident.t
- | Tpat_alias of pattern * Ident.t
- | Tpat_constant of constant
- | Tpat_tuple of pattern list
- | Tpat_construct of constructor_description * pattern list
- | Tpat_record of (label_description * pattern) list
- | Tpat_or of pattern * pattern
-
-type expression =
- { exp_desc: expression_desc;
- exp_loc: Location.t;
- exp_type: type_expr }
-
-and expression_desc =
- Texp_ident of Path.t * value_description
- | Texp_constant of constant
- | Texp_let of rec_flag * (pattern * expression) list * expression
- | Texp_function of (pattern * expression) list
- | Texp_apply of expression * expression list
- | Texp_match of expression * (pattern * expression) list
- | Texp_try of expression * (pattern * expression) list
- | Texp_tuple of expression list
- | Texp_construct of constructor_description * expression list
- | Texp_record of (label_description * expression) list
- | Texp_field of expression * label_description
- | Texp_setfield of expression * label_description * expression
- | Texp_array of expression list
- | Texp_ifthenelse of expression * expression * expression option
- | Texp_sequence of expression * expression
- | Texp_while of expression * expression
- | Texp_for of
- Ident.t * expression * expression * direction_flag * expression
- | Texp_when of expression * expression
-
-(* Type definitions *)
-
-type type_declaration =
- { mutable type_params: type_expr list;
- type_arity: int;
- mutable type_kind: type_kind }
-
-and type_kind =
- Type_abstract
- | Type_manifest of type_expr
- | Type_variant of (string * type_expr list) list
- | Type_record of (string * mutable_flag * type_expr) list
-
-type exception_declaration = type_expr list
-
-(* Type expressions for the module language *)
-
-type module_type =
- Tmty_ident of Path.t
- | Tmty_signature of signature
- | Tmty_functor of Ident.t * module_type * module_type
-
-and signature = signature_item list
-
-and signature_item =
- Tsig_value of Ident.t * value_description
- | Tsig_type of Ident.t * type_declaration
- | Tsig_exception of Ident.t * exception_declaration
- | Tsig_module of Ident.t * module_type
- | Tsig_modtype of Ident.t * modtype_declaration
-
-and modtype_declaration =
- Tmodtype_abstract
- | Tmodtype_manifest of module_type
-
-(* Value expressions for the module language *)
-
-type module_expr =
- { mod_desc: module_expr_desc;
- mod_loc: Location.t;
- mod_type: module_type }
-
-and module_expr_desc =
- Tmod_ident of Path.t
- | Tmod_structure of structure
- | Tmod_functor of Ident.t * module_type * module_expr
- | Tmod_apply of module_expr * module_expr * module_coercion
- | Tmod_constraint of module_expr * module_type * module_coercion
-
-and structure = structure_item list
-
-and structure_item =
- Tstr_eval of expression
- | Tstr_value of rec_flag * (pattern * expression) list
- | Tstr_primitive of Ident.t * value_description
- | Tstr_type of (Ident.t * type_declaration) list
- | Tstr_exception of Ident.t * exception_declaration
- | Tstr_module of Ident.t * module_expr
- | Tstr_modtype of Ident.t * module_type
- | Tstr_open of Path.t
-
-and module_coercion =
- Tcoerce_none
- | Tcoerce_structure of (int * module_coercion) list
- | Tcoerce_functor of module_coercion * module_coercion
-
-(* Auxiliary functions over the a.s.t. *)
-
-(* List the identifiers bound by a pattern or a let *)
-
-let idents = ref([]: Ident.t list)
-
-let rec bound_idents pat =
- match pat.pat_desc with
- Tpat_any -> ()
- | Tpat_var id -> idents := id :: !idents
- | Tpat_alias(p, id) -> bound_idents p; idents := id :: !idents
- | Tpat_constant cst -> ()
- | Tpat_tuple patl -> List.iter bound_idents patl
- | Tpat_construct(cstr, patl) -> List.iter bound_idents patl
- | Tpat_record lbl_pat_list ->
- List.iter (fun (lbl, pat) -> bound_idents pat) lbl_pat_list
- | Tpat_or(p1, p2) -> bound_idents p1; bound_idents p2
-
-let pat_bound_idents pat =
- idents := []; bound_idents pat; let res = !idents in idents := []; res
-
-let let_bound_idents pat_expr_list =
- idents := [];
- List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list;
- let res = !idents in idents := []; res
-
-
-
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
deleted file mode 100644
index fc572cd244..0000000000
--- a/typing/typedtree.mli
+++ /dev/null
@@ -1,161 +0,0 @@
-(* Abstract syntax tree after typing *)
-
-open Asttypes
-
-(* Type expressions for the core language *)
-
-type type_expr =
- Tvar of type_variable
- | Tarrow of type_expr * type_expr
- | Ttuple of type_expr list
- | Tconstr of Path.t * type_expr list
-
-and type_variable =
- { mutable tvar_level: int;
- mutable tvar_link: type_expr option }
-
-(* Value descriptions *)
-
-type value_description =
- { val_type: type_expr; (* Type of the val *)
- val_prim: primitive_description } (* Is this a primitive? *)
-and primitive_description =
- Not_prim
- | Primitive of string * int
-
-(* Constructor descriptions *)
-
-type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
- cstr_args: type_expr list; (* Type of the arguments *)
- cstr_arity: int; (* Number of arguments *)
- cstr_tag: constructor_tag; (* Tag for heap blocks *)
- cstr_span: int } (* Number of constructors in type *)
-
-and constructor_tag =
- Cstr_tag of int (* Regular constructor *)
- | Cstr_exception of Path.t (* Exception constructor *)
-
-(* Record label descriptions *)
-
-type label_description =
- { lbl_res: type_expr; (* Type of the result *)
- lbl_arg: type_expr; (* Type of the argument *)
- lbl_mut: mutable_flag; (* Is this a mutable field? *)
- lbl_pos: int; (* Position in block *)
- lbl_all: label_description array (* All the labels in this type *)
- }
-
-(* Value expressions for the core language *)
-
-type pattern =
- { pat_desc: pattern_desc;
- pat_loc: Location.t;
- pat_type: type_expr }
-
-and pattern_desc =
- Tpat_any
- | Tpat_var of Ident.t
- | Tpat_alias of pattern * Ident.t
- | Tpat_constant of constant
- | Tpat_tuple of pattern list
- | Tpat_construct of constructor_description * pattern list
- | Tpat_record of (label_description * pattern) list
- | Tpat_or of pattern * pattern
-
-type expression =
- { exp_desc: expression_desc;
- exp_loc: Location.t;
- exp_type: type_expr }
-
-and expression_desc =
- Texp_ident of Path.t * value_description
- | Texp_constant of constant
- | Texp_let of rec_flag * (pattern * expression) list * expression
- | Texp_function of (pattern * expression) list
- | Texp_apply of expression * expression list
- | Texp_match of expression * (pattern * expression) list
- | Texp_try of expression * (pattern * expression) list
- | Texp_tuple of expression list
- | Texp_construct of constructor_description * expression list
- | Texp_record of (label_description * expression) list
- | Texp_field of expression * label_description
- | Texp_setfield of expression * label_description * expression
- | Texp_array of expression list
- | Texp_ifthenelse of expression * expression * expression option
- | Texp_sequence of expression * expression
- | Texp_while of expression * expression
- | Texp_for of
- Ident.t * expression * expression * direction_flag * expression
- | Texp_when of expression * expression
-
-(* Type definitions *)
-
-type type_declaration =
- { mutable type_params: type_expr list;
- type_arity: int;
- mutable type_kind: type_kind }
-
-and type_kind =
- Type_abstract
- | Type_manifest of type_expr
- | Type_variant of (string * type_expr list) list
- | Type_record of (string * mutable_flag * type_expr) list
-
-type exception_declaration = type_expr list
-
-(* Type expressions for the module language *)
-
-type module_type =
- Tmty_ident of Path.t
- | Tmty_signature of signature
- | Tmty_functor of Ident.t * module_type * module_type
-
-and signature = signature_item list
-
-and signature_item =
- Tsig_value of Ident.t * value_description
- | Tsig_type of Ident.t * type_declaration
- | Tsig_exception of Ident.t * exception_declaration
- | Tsig_module of Ident.t * module_type
- | Tsig_modtype of Ident.t * modtype_declaration
-
-and modtype_declaration =
- Tmodtype_abstract
- | Tmodtype_manifest of module_type
-
-(* Value expressions for the module language *)
-
-type module_expr =
- { mod_desc: module_expr_desc;
- mod_loc: Location.t;
- mod_type: module_type }
-
-and module_expr_desc =
- Tmod_ident of Path.t
- | Tmod_structure of structure
- | Tmod_functor of Ident.t * module_type * module_expr
- | Tmod_apply of module_expr * module_expr * module_coercion
- | Tmod_constraint of module_expr * module_type * module_coercion
-
-and structure = structure_item list
-
-and structure_item =
- Tstr_eval of expression
- | Tstr_value of rec_flag * (pattern * expression) list
- | Tstr_primitive of Ident.t * value_description
- | Tstr_type of (Ident.t * type_declaration) list
- | Tstr_exception of Ident.t * exception_declaration
- | Tstr_module of Ident.t * module_expr
- | Tstr_modtype of Ident.t * module_type
- | Tstr_open of Path.t
-
-and module_coercion =
- Tcoerce_none
- | Tcoerce_structure of (int * module_coercion) list
- | Tcoerce_functor of module_coercion * module_coercion
-
-(* Auxiliary functions over the a.s.t. *)
-
-val pat_bound_idents: pattern -> Ident.t list
-val let_bound_idents: (pattern * expression) list -> Ident.t list
diff --git a/typing/typemod.ml b/typing/typemod.ml
deleted file mode 100644
index 139a8806ce..0000000000
--- a/typing/typemod.ml
+++ /dev/null
@@ -1,306 +0,0 @@
-(* Type-checking of the module language *)
-
-open Misc
-open Path
-open Parsetree
-open Typedtree
-
-
-type error =
- Unbound_module of Longident.t
- | Unbound_modtype of Longident.t
- | Cannot_apply of module_type
- | Not_included of Includemod.error list
- | Cannot_eliminate_dependency of module_type
- | Signature_expected
- | Structure_expected of module_type
- | With_not_abstract of string
- | With_arity_mismatch of string
-
-exception Error of Location.t * error
-
-(* Merge a set of type definitions in a signature *)
-
-let merge_constraints loc env sg decls =
- let sub = ref Subst.identity in
- let rec merge_one_constraint id decl = function
- [] ->
- [Tsig_type(id, decl)]
- | (Tsig_type(id', decl') as item) :: rem ->
- if Ident.equal id id' then begin
- if decl'.type_kind <> Type_abstract then
- raise(Error(loc, With_not_abstract(Ident.name id)));
- if decl'.type_arity <> decl.type_arity then
- raise(Error(loc, With_arity_mismatch(Ident.name id)));
- sub := Subst.add_type id (Pident id') !sub;
- Tsig_type(id', decl) :: rem
- end else
- item :: merge_one_constraint id decl rem
- | item :: rem ->
- item :: merge_one_constraint id decl rem in
- let rec merge_all_constraints sg = function
- [] ->
- sg
- | (id, decl) :: rem ->
- merge_all_constraints (merge_one_constraint id decl sg) rem in
- let newsig = merge_all_constraints sg decls in
- Subst.signature !sub newsig
-
-(* Lookup and strengthen the type of a module path *)
-
-let type_module_path env loc lid =
- try
- Env.lookup_module lid env
- with Not_found ->
- raise(Error(loc, Unbound_module lid))
-
-(* Extract a signature from a module type *)
-
-let extract_sig env loc mty =
- match Mtype.scrape env mty with
- Tmty_signature sg -> sg
- | _ -> raise(Error(loc, Signature_expected))
-
-let extract_sig_open env loc mty =
- match Mtype.scrape env mty with
- Tmty_signature sg -> sg
- | _ -> raise(Error(loc, Structure_expected mty))
-
-(* Check and translate a module type expression *)
-
-let rec transl_modtype env smty =
- match smty.pmty_desc with
- Pmty_ident lid ->
- begin try
- let (path, info) = Env.lookup_modtype lid env in
- Tmty_ident path
- with Not_found ->
- raise(Error(smty.pmty_loc, Unbound_modtype lid))
- end
- | Pmty_signature sg ->
- Tmty_signature (transl_signature env sg)
- | Pmty_functor(param, sarg, sres) ->
- let arg = transl_modtype env sarg in
- let (id, newenv) = Env.enter_module param arg env in
- let res = transl_modtype newenv sres in
- Tmty_functor(id, arg, res)
- | Pmty_with(sbody, sdecls) ->
- let body = transl_modtype env sbody in
- let sg = extract_sig env sbody.pmty_loc body in
- let (decls, newenv) =
- Typedecl.transl_type_decl env sdecls in
- Tmty_signature(merge_constraints smty.pmty_loc env sg decls)
-
-and transl_signature env sg =
- match sg with
- [] -> []
- | Psig_value(name, sdesc) :: srem ->
- let ty = Typetexp.transl_type_scheme env sdesc.pval_type in
- let prim =
- match sdesc.pval_prim with
- None -> Not_prim
- | Some p -> Primitive(p, Ctype.arity ty) in
- let desc = { val_type = ty; val_prim = prim } in
- let (id, newenv) = Env.enter_value name desc env in
- let rem = transl_signature newenv srem in
- Tsig_value(id, desc) :: rem
- | Psig_type sdecls :: srem ->
- let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
- let rem = transl_signature newenv srem in
- map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
- | Psig_exception(name, sarg) :: srem ->
- let arg = Typedecl.transl_exception env sarg in
- let (id, newenv) = Env.enter_exception name arg env in
- let rem = transl_signature newenv srem in
- Tsig_exception(id, arg) :: rem
- | Psig_module(name, smty) :: srem ->
- let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_module name mty env in
- let rem = transl_signature newenv srem in
- Tsig_module(id, mty) :: rem
- | Psig_modtype(name, sinfo) :: srem ->
- let info = transl_modtype_info env sinfo in
- let (id, newenv) = Env.enter_modtype name info env in
- let rem = transl_signature newenv srem in
- Tsig_modtype(id, info) :: rem
- | Psig_open(lid, loc) :: srem ->
- let (path, mty) = type_module_path env loc lid in
- let sg = extract_sig_open env loc mty in
- let newenv = Env.open_signature path sg env in
- transl_signature newenv srem
- | Psig_include smty :: srem ->
- let mty = transl_modtype env smty in
- let sg = extract_sig env smty.pmty_loc mty in
- let newenv = Env.add_signature sg env in
- let rem = transl_signature newenv srem in
- sg @ rem
-
-and transl_modtype_info env sinfo =
- match sinfo with
- Pmodtype_abstract ->
- Tmodtype_abstract
- | Pmodtype_manifest smty ->
- Tmodtype_manifest(transl_modtype env smty)
-
-(* Type a module value expression *)
-
-let rec type_module env smod =
- match smod.pmod_desc with
- Pmod_ident lid ->
- let (path, mty) = type_module_path env smod.pmod_loc lid in
- { mod_desc = Tmod_ident path;
- mod_type = Mtype.strengthen env mty path;
- mod_loc = smod.pmod_loc }
- | Pmod_structure sstr ->
- let (str, sg, _) = type_structure env sstr in
- { mod_desc = Tmod_structure str;
- mod_type = Tmty_signature sg;
- mod_loc = smod.pmod_loc }
- | Pmod_functor(name, smty, sbody) ->
- let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_module name mty env in
- let body = type_module newenv sbody in
- { mod_desc = Tmod_functor(id, mty, body);
- mod_type = Tmty_functor(id, mty, body.mod_type);
- mod_loc = smod.pmod_loc }
- | Pmod_apply(sfunct, sarg) ->
- let funct = type_module env sfunct in
- let arg = type_module env sarg in
- begin match Mtype.scrape env funct.mod_type with
- Tmty_functor(param, mty_param, mty_res) as mty_functor ->
- let coercion =
- try
- Includemod.modtypes env arg.mod_type mty_param
- with Includemod.Error msg ->
- raise(Error(sarg.pmod_loc, Not_included msg)) in
- let mty_appl =
- match arg with
- {mod_desc = Tmod_ident path} ->
- Subst.modtype (Subst.add_module param path Subst.identity)
- mty_res
- | _ ->
- try
- Mtype.nondep_supertype
- (Env.add_module param arg.mod_type env) param mty_res
- with Not_found ->
- raise(Error(smod.pmod_loc,
- Cannot_eliminate_dependency mty_functor)) in
- { mod_desc = Tmod_apply(funct, arg, coercion);
- mod_type = mty_appl;
- mod_loc = smod.pmod_loc }
- | _ ->
- raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
- end
- | Pmod_constraint(sarg, smty) ->
- let arg = type_module env sarg in
- let mty = transl_modtype env smty in
- let coercion =
- try
- Includemod.modtypes env arg.mod_type mty
- with Includemod.Error msg ->
- raise(Error(sarg.pmod_loc, Not_included msg)) in
- { mod_desc = Tmod_constraint(arg, mty, coercion);
- mod_type = mty;
- mod_loc = smod.pmod_loc }
-
-and type_structure env = function
- [] ->
- ([], [], env)
- | Pstr_eval sexpr :: srem ->
- let expr = Typecore.type_expression env sexpr in
- let (str_rem, sig_rem, final_env) = type_structure env srem in
- (Tstr_eval expr :: str_rem, sig_rem, final_env)
- | Pstr_value(rec_flag, sdefs) :: srem ->
- let (defs, newenv) =
- Typecore.type_binding env rec_flag sdefs in
- let (str_rem, sig_rem, final_env) = type_structure newenv srem in
- let bound_idents = List.rev(let_bound_idents defs) in
- let make_sig_value id =
- Tsig_value(id, Env.find_value (Pident id) newenv) in
- (Tstr_value(rec_flag, defs) :: str_rem,
- map_end make_sig_value bound_idents sig_rem,
- final_env)
- | Pstr_primitive(name, sdesc) :: srem ->
- let ty = Typetexp.transl_type_scheme env sdesc.pval_type in
- let prim =
- match sdesc.pval_prim with
- None -> Not_prim
- | Some p -> Primitive(p, Ctype.arity ty) in
- let desc = { val_type = ty; val_prim = prim } in
- let (id, newenv) = Env.enter_value name desc env in
- let (str_rem, sig_rem, final_env) = type_structure newenv srem in
- (Tstr_primitive(id, desc) :: str_rem,
- Tsig_value(id, desc) :: sig_rem,
- final_env)
- | Pstr_type sdecls :: srem ->
- let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
- let (str_rem, sig_rem, final_env) = type_structure newenv srem in
- (Tstr_type decls :: str_rem,
- map_end (fun (id, info) -> Tsig_type(id, info)) decls sig_rem,
- final_env)
- | Pstr_exception(name, sarg) :: srem ->
- let arg = Typedecl.transl_exception env sarg in
- let (id, newenv) = Env.enter_exception name arg env in
- let (str_rem, sig_rem, final_env) = type_structure newenv srem in
- (Tstr_exception(id, arg) :: str_rem,
- Tsig_exception(id, arg) :: sig_rem,
- final_env)
- | Pstr_module(name, smodl) :: srem ->
- let modl = type_module env smodl in
- let (id, newenv) = Env.enter_module name modl.mod_type env in
- let (str_rem, sig_rem, final_env) = type_structure newenv srem in
- (Tstr_module(id, modl) :: str_rem,
- Tsig_module(id, modl.mod_type) :: sig_rem,
- final_env)
- | Pstr_modtype(name, smty) :: srem ->
- let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_modtype name (Tmodtype_manifest mty) env in
- let (str_rem, sig_rem, final_env) = type_structure newenv srem in
- (Tstr_modtype(id, mty) :: str_rem,
- Tsig_modtype(id, Tmodtype_manifest mty) :: sig_rem,
- final_env)
- | Pstr_open(lid, loc) :: srem ->
- let (path, mty) = type_module_path env loc lid in
- let sg = extract_sig_open env loc mty in
- type_structure (Env.open_signature path sg env) srem
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let report_error = function
- Unbound_module lid ->
- print_string "Unbound module "; longident lid
- | Unbound_modtype lid ->
- print_string "Unbound module type "; longident lid
- | Cannot_apply mty ->
- open_hovbox 0;
- print_string "This module is not a functor; it has type";
- print_space(); modtype mty;
- close_box()
- | Not_included errs ->
- open_vbox 0;
- print_string "Signature mismatch:"; print_space();
- Includemod.report_error errs;
- close_box()
- | Cannot_eliminate_dependency mty ->
- open_hovbox 0;
- print_string "This functor has type";
- print_space(); modtype mty; print_space();
- print_string "The parameter cannot be eliminated in the result type.";
- print_space();
- print_string "Please bind the argument to a module identifier.";
- close_box()
- | Signature_expected ->
- print_string "This module type is not a signature"
- | Structure_expected mty ->
- open_hovbox 0;
- print_string "This module is not a structure; it has type";
- print_space(); modtype mty;
- close_box()
- | With_not_abstract s ->
- print_string "The type "; print_string s; print_string " is not abstract"
- | With_arity_mismatch s ->
- print_string "Arity mismatch in `with' constraint over type ";
- print_string s
diff --git a/typing/typemod.mli b/typing/typemod.mli
deleted file mode 100644
index 4a138eebe9..0000000000
--- a/typing/typemod.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(* Type-checking of the module language *)
-
-open Typedtree
-
-val type_structure:
- Env.t -> Parsetree.structure -> structure * signature * Env.t
-val transl_signature:
- Env.t -> Parsetree.signature -> signature
-
-type error =
- Unbound_module of Longident.t
- | Unbound_modtype of Longident.t
- | Cannot_apply of module_type
- | Not_included of Includemod.error list
- | Cannot_eliminate_dependency of module_type
- | Signature_expected
- | Structure_expected of module_type
- | With_not_abstract of string
- | With_arity_mismatch of string
-
-exception Error of Location.t * error
-
-val report_error: error -> unit
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
deleted file mode 100644
index e214682d93..0000000000
--- a/typing/typetexp.ml
+++ /dev/null
@@ -1,86 +0,0 @@
-(* Typechecking of type expressions for the core language *)
-
-open Parsetree
-open Typedtree
-open Ctype
-
-exception Already_bound
-
-type error =
- Unbound_type_variable of string
- | Unbound_type_constructor of Longident.t
- | Type_arity_mismatch of Longident.t * int * int
-
-exception Error of Location.t * error
-
-(* Translation of type expressions *)
-
-let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
-
-let reset_type_variables () =
- type_variables := Tbl.empty
-
-let enter_type_variable name =
- try
- Tbl.find name !type_variables; raise Already_bound
- with Not_found ->
- let v = newvar() in
- type_variables := Tbl.add name v !type_variables;
- v
-
-let rec transl_simple_type env fixed styp =
- match styp.ptyp_desc with
- Ptyp_var name ->
- begin try
- Tbl.find name !type_variables
- with Not_found ->
- if fixed then
- raise(Error(styp.ptyp_loc, Unbound_type_variable name))
- else begin
- let v = newvar() in
- type_variables := Tbl.add name v !type_variables;
- v
- end
- end
- | Ptyp_arrow(st1, st2) ->
- Tarrow(transl_simple_type env fixed st1,
- transl_simple_type env fixed st2)
- | Ptyp_tuple stl ->
- Ttuple(List.map (transl_simple_type env fixed) stl)
- | Ptyp_constr(lid, stl) ->
- let (path, decl) =
- try
- Env.lookup_type lid env
- with Not_found ->
- raise(Error(styp.ptyp_loc, Unbound_type_constructor lid)) in
- if List.length stl <> decl.type_arity then
- raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
- List.length stl)));
- Tconstr(path, List.map (transl_simple_type env fixed) stl)
-
-let transl_type_scheme env styp =
- reset_type_variables();
- begin_def();
- let typ = transl_simple_type env false styp in
- end_def();
- generalize typ;
- typ
-
-(* Error report *)
-
-open Format
-open Printtyp
-
-let report_error = function
- Unbound_type_variable name ->
- print_string "Unbound type parameter "; print_string name
- | Unbound_type_constructor lid ->
- print_string "Unbound type constructor "; longident lid
- | Type_arity_mismatch(lid, expected, provided) ->
- open_hovbox 0;
- print_string "The type constructor "; longident lid;
- print_space(); print_string "expects "; print_int expected;
- print_string " argument(s),"; print_space();
- print_string "but is here applied to "; print_int provided;
- print_string " argument(s)";
- close_box()
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
deleted file mode 100644
index 57fb18d245..0000000000
--- a/typing/typetexp.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* Typechecking of type expressions for the core language *)
-
-val transl_simple_type:
- Env.t -> bool -> Parsetree.core_type -> Typedtree.type_expr
-val transl_type_scheme:
- Env.t -> Parsetree.core_type -> Typedtree.type_expr
-val reset_type_variables: unit -> unit
-val enter_type_variable: string -> Typedtree.type_expr
-
-exception Already_bound
-
-type error =
- Unbound_type_variable of string
- | Unbound_type_constructor of Longident.t
- | Type_arity_mismatch of Longident.t * int * int
-
-exception Error of Location.t * error
-
-val report_error: error -> unit
View Lorry Controller Status