summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--typing/ctype.ml1
-rw-r--r--typing/datarepr.ml58
-rw-r--r--typing/datarepr.mli14
-rw-r--r--typing/env.ml58
-rw-r--r--typing/includecore.ml4
-rw-r--r--typing/predef.ml43
-rw-r--r--typing/printtyp.ml10
-rw-r--r--typing/typecore.ml4
-rw-r--r--typing/typecore.mli2
-rw-r--r--typing/typedecl.ml19
-rw-r--r--typing/typedecl.mli5
-rw-r--r--typing/typedtree.ml11
-rw-r--r--typing/typedtree.mli11
-rw-r--r--typing/typemod.ml14
14 files changed, 152 insertions, 102 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 60fb7a415..cbebe7f2a 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -342,3 +342,4 @@ let rec arity ty =
| _ -> 0
let none = Ttuple [] (* Clearly ill-formed type *)
+
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
new file mode 100644
index 000000000..ab61b0fb9
--- /dev/null
+++ b/typing/datarepr.ml
@@ -0,0 +1,58 @@
+(* Compute constructor and label descriptions from type declarations,
+ determining their representation. *)
+
+open Misc
+open Asttypes
+open Typedtree
+
+let constructor_descrs ty_res cstrs =
+ let num_consts = ref 0 and num_nonconsts = ref 0 in
+ List.iter
+ (function (name, []) -> incr num_consts
+ | (name, _) -> incr num_nonconsts)
+ cstrs;
+ let rec describe_constructors idx_const idx_nonconst = function
+ [] -> []
+ | (name, ty_args) :: rem ->
+ let (tag, descr_rem) =
+ match ty_args with
+ [] -> (Cstr_constant idx_const,
+ describe_constructors (idx_const+1) idx_nonconst rem)
+ | _ -> (Cstr_block idx_nonconst,
+ describe_constructors idx_const (idx_nonconst+1) rem) in
+ let cstr =
+ { cstr_res = ty_res;
+ cstr_args = ty_args;
+ cstr_arity = List.length ty_args;
+ cstr_tag = tag;
+ cstr_consts = !num_consts;
+ cstr_nonconsts = !num_nonconsts } in
+ (name, cstr) :: descr_rem in
+ describe_constructors 0 0 cstrs
+
+let exception_descr path_exc decl =
+ { cstr_res = Predef.type_exn;
+ cstr_args = decl;
+ cstr_arity = List.length decl;
+ cstr_tag = Cstr_exception path_exc;
+ cstr_consts = -1;
+ cstr_nonconsts = -1 }
+
+let dummy_label =
+ { lbl_res = Ttuple []; lbl_arg = Ttuple []; lbl_mut = Immutable;
+ lbl_pos = (-1); lbl_all = [||] }
+
+let label_descrs ty_res lbls =
+ let all_labels = Array.new (List.length lbls) 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 lbls
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
new file mode 100644
index 000000000..ee8bebade
--- /dev/null
+++ b/typing/datarepr.mli
@@ -0,0 +1,14 @@
+(* Compute constructor and label descriptions from type declarations,
+ determining their representation. *)
+
+open Asttypes
+open Typedtree
+
+val constructor_descrs:
+ type_expr -> (string * type_expr list) list ->
+ (string * constructor_description) list
+val exception_descr:
+ Path.t -> type_expr list -> constructor_description
+val label_descrs:
+ type_expr -> (string * mutable_flag * type_expr) list ->
+ (string * label_description) list
diff --git a/typing/env.ml b/typing/env.ml
index 3418a4f92..b970a235f 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -196,65 +196,15 @@ let rec scrape_modtype mty env =
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_consts = ref 0 and num_nonconsts = ref 0 in
- List.iter
- (function (name, []) -> incr num_consts
- | (name, _) -> incr num_nonconsts)
- cstrs;
- let rec describe_constructors idx_const idx_nonconst = function
- [] -> []
- | (name, ty_args) :: rem ->
- let (tag, descr_rem) =
- match ty_args with
- [] -> (Cstr_constant idx_const,
- describe_constructors (idx_const+1) idx_nonconst rem)
- | _ -> (Cstr_block idx_nonconst,
- describe_constructors idx_const (idx_nonconst+1) rem) in
- let cstr =
- { cstr_res = ty_res;
- cstr_args = ty_args;
- cstr_arity = List.length ty_args;
- cstr_tag = tag;
- cstr_consts = !num_consts;
- cstr_nonconsts = !num_nonconsts } in
- (name, cstr) :: descr_rem in
- describe_constructors 0 0 cstrs
+ Datarepr.constructor_descrs (Tconstr(ty_path, decl.type_params)) 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_consts = -1;
- cstr_nonconsts = -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
+ Datarepr.label_descrs (Tconstr(ty_path, decl.type_params)) labels
| _ -> []
(* Given a signature and a root path, prefix all idents in the signature
@@ -321,7 +271,7 @@ let rec components_of_module env path mty =
(labels_of_type path decl')
| Tsig_exception(id, decl) ->
let decl' = Subst.exception_declaration sub decl in
- let cstr = constructor_exception path decl' in
+ let cstr = Datarepr.exception_descr path decl' in
c.comp_constrs <-
Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
incr pos
@@ -376,7 +326,7 @@ and store_type id path info env =
and store_exception id path decl env =
{ values = env.values;
- constrs = Ident.add id (constructor_exception path decl) env.constrs;
+ constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
labels = env.labels;
types = env.types;
modules = env.modules;
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 781abf166..4e06cccef 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -10,8 +10,8 @@ open Typedtree
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
+ (Some p1, Some p2) -> p1 = p2
+ | (None, Some p) -> false
| _ -> true
end
diff --git a/typing/predef.ml b/typing/predef.ml
index fdc3d82ee..4a471d912 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -26,13 +26,13 @@ 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, [])
+let type_int = Tconstr(path_int, [])
+and type_char = Tconstr(path_char, [])
+and type_string = Tconstr(path_string, [])
+and type_float = Tconstr(path_float, [])
+and type_bool = Tconstr(path_bool, [])
+and type_unit = Tconstr(path_unit, [])
+and type_exn = Tconstr(path_exn, [])
and type_array t = Tconstr(path_array, [t])
and type_list t = Tconstr(path_list, [t])
@@ -49,27 +49,40 @@ let path_match_failure = Pident ident_match_failure
let build_initial_env add_type add_exception empty_env =
let newvar() =
- (* Cannot call newvar here because ctype imports predef via env *)
+ (* Cannot call the real newvar from ctype 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}
+ {type_params = [];
+ type_arity = 0;
+ type_kind = Type_abstract}
and decl_bool =
- {type_params = []; type_arity = 0;
+ {type_params = [];
+ type_arity = 0;
type_kind = Type_variant["false",[]; "true",[]]}
and decl_unit =
- {type_params = []; type_arity = 0; type_kind = Type_variant["()",[]]}
+ {type_params = [];
+ type_arity = 0;
+ type_kind = Type_variant["()",[]]}
and decl_exn =
- {type_params = []; type_arity = 0; type_kind = Type_variant[]}
+ {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}
+ {type_params = [tvar];
+ type_arity = 1;
+ type_kind = Type_abstract}
and decl_list =
let tvar = newvar() in
- {type_params = [tvar]; type_arity = 1;
+ {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_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] (
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 3b99e70e3..1191b5b6b 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -145,16 +145,20 @@ let exception_declaration id decl =
(* Print a value declaration *)
+let primitive_description p =
+ print_string "\""; print_string p.prim_name; print_string "\"";
+ if not p.prim_alloc then print_string " \"noalloc\""
+
let value_description id decl =
open_hovbox 2;
begin match decl.val_prim with
- Not_prim ->
+ None ->
print_string "val "; ident id; print_string " :"; print_space();
type_scheme decl.val_type
- | Primitive(p, ar) ->
+ | Some p ->
print_string "val "; ident id; print_string " :"; print_space();
type_scheme decl.val_type; print_space();
- print_string "= \""; print_string p; print_string "\""
+ print_string "= "; primitive_description p
end;
close_box()
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 860d361a5..45763cc4a 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -139,7 +139,7 @@ let add_pattern_variables env =
pattern_variables := [];
List.fold_right
(fun (id, ty) env ->
- Env.add_value id {val_type = ty; val_prim = Not_prim} env)
+ Env.add_value id {val_type = ty; val_prim = None} env)
pv env
let type_pattern env spat =
@@ -408,7 +408,7 @@ let rec type_exp env sexp =
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
+ val_prim = None} env in
let body = type_statement new_env sbody in
{ exp_desc = Texp_for(id, low, high, dir, body);
exp_loc = sexp.pexp_loc;
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 56fa562c6..05575fc0a 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -9,7 +9,7 @@ val type_binding:
(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
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 453bd6ecc..d7272e250 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -78,8 +78,9 @@ let transl_declaration env (name, sdecl) id =
lbls) in
Ctype.end_def();
List.iter Ctype.generalize params;
- (id,
- {type_params = params; type_arity = List.length params; type_kind = kind})
+ (id, {type_params = params;
+ type_arity = List.length params;
+ type_kind = kind })
(* Check for recursive abbrevs *)
@@ -111,6 +112,20 @@ let transl_exception env excdecl =
reset_type_variables();
List.map (transl_simple_type env true) excdecl
+(* Translate a value declaration *)
+
+let transl_value_decl env valdecl =
+ let ty = Typetexp.transl_type_scheme env valdecl.pval_type in
+ let arity = Ctype.arity ty in
+ let prim =
+ match valdecl.pval_prim with
+ name :: "noalloc" :: _ ->
+ Some { prim_name = name; prim_arity = arity; prim_alloc = false }
+ | name :: _ ->
+ Some { prim_name = name; prim_arity = arity; prim_alloc = true }
+ | [] -> None in
+ { val_type = ty; val_prim = prim }
+
(* Error report *)
open Format
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 2507e6fc8..c31fe8e90 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -1,4 +1,4 @@
-(* Typing of type definitions *)
+(* Typing of type definitions and primitive definitions *)
open Typedtree
@@ -8,6 +8,9 @@ val transl_type_decl:
val transl_exception:
Env.t -> Parsetree.exception_declaration -> exception_declaration
+val transl_value_decl:
+ Env.t -> Parsetree.value_description -> value_description
+
type error =
Repeated_parameter
| Duplicate_constructor of string
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 2f170a1c6..9860ff5f8 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -18,11 +18,12 @@ and type_variable =
(* Value descriptions *)
type value_description =
- { val_type: type_expr; (* Type of the value *)
- val_prim: primitive_description } (* Is this a primitive? *)
+ { val_type: type_expr; (* Type of the val *)
+ val_prim: primitive_description option } (* Is this a primitive? *)
and primitive_description =
- Not_prim
- | Primitive of string * int
+ { prim_name: string;
+ prim_arity: int;
+ prim_alloc: bool }
(* Constructor descriptions *)
@@ -46,7 +47,7 @@ type label_description =
lbl_arg: type_expr; (* Type of the argument *)
lbl_mut: mutable_flag; (* Is this a mutable field? *)
lbl_pos: int; (* Position in block *)
- lbl_all: label_description array (* All the labels in this type *)
+ lbl_all: label_description array (* All the labels in this type *)
}
(* Value expressions for the core language *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index d9a8b0fc7..7cf701d95 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -17,11 +17,12 @@ and type_variable =
(* Value descriptions *)
type value_description =
- { val_type: type_expr; (* Type of the val *)
- val_prim: primitive_description } (* Is this a primitive? *)
+ { val_type: type_expr; (* Type of the val *)
+ val_prim: primitive_description option } (* Is this a primitive? *)
and primitive_description =
- Not_prim
- | Primitive of string * int
+ { prim_name: string;
+ prim_arity: int;
+ prim_alloc: bool }
(* Constructor descriptions *)
@@ -45,7 +46,7 @@ type label_description =
lbl_arg: type_expr; (* Type of the argument *)
lbl_mut: mutable_flag; (* Is this a mutable field? *)
lbl_pos: int; (* Position in block *)
- lbl_all: label_description array (* All the labels in this type *)
+ lbl_all: label_description array (* All the labels in this type *)
}
(* Value expressions for the core language *)
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 139a8806c..0be7ad855 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -95,12 +95,7 @@ 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 desc = Typedecl.transl_value_decl env sdesc in
let (id, newenv) = Env.enter_value name desc env in
let rem = transl_signature newenv srem in
Tsig_value(id, desc) :: rem
@@ -221,12 +216,7 @@ and type_structure env = function
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 desc = Typedecl.transl_value_decl env sdesc 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,
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-04-04 00:26:01 +0000