Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

first commit 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/gadts@10679 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Le Normand 2010-09-13 05:28:30 +00:00
parent 4fd6cd8275
commit 6de25fef2f
36 changed files with 668 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
bytecomp/bytepackager.ml
View File

@ -222,18 +222,19 @@ let package_object_files files targetfile targetname coercion =
(* The entry point *)
let package_files files targetfile =
let files =
let files =
List.map
(fun f ->
(fun f ->
try find_in_path !Config.load_path f
with Not_found -> raise(Error(File_not_found f)))
files in
let prefix = chop_extensions targetfile in
let targetcmi = prefix ^ ".cmi" in
let targetname = String.capitalize(Filename.basename prefix) in
try
let coercion = Typemod.package_units files targetcmi targetname in
package_object_files files targetfile targetname coercion
files in
let prefix = chop_extensions targetfile in
let targetcmi = prefix ^ ".cmi" in
let targetname = String.capitalize(Filename.basename prefix) in
try
let coercion = Typemod.package_units files targetcmi targetname in
let ret = package_object_files files targetfile targetname coercion in
ret
with x ->
remove_file targetfile; raise x

12
bytecomp/typeopt.ml
View File

@ -37,9 +37,12 @@ let maybe_pointer exp =
not (Path.same p Predef.path_char) &&
begin try
match Env.find_type p exp.exp_env with
{type_kind = Type_variant []} -> true (* type exn *)
| {type_kind = Type_variant []} -> true (* type exn *)
| {type_kind = Type_generalized_variant []} -> true (* type exn *)
| {type_kind = Type_variant cstrs} ->
List.exists (fun (name, args) -> args <> []) cstrs
List.exists (fun (name, args) -> args <> []) cstrs (* GAH: dunno what's going on *)
| {type_kind = Type_generalized_variant cstrs} ->
List.exists (fun (name, args,_) -> args <> []) cstrs (* GAH: dunno what's going on *)
| _ -> true
with Not_found -> true
(* This can happen due to e.g. missing -I options,
@ -69,7 +72,10 @@ let array_element_kind env ty =
{type_kind = Type_abstract} ->
Pgenarray
| {type_kind = Type_variant cstrs}
when List.for_all (fun (name, args) -> args = []) cstrs ->
when List.for_all (fun (name, args) -> args = []) cstrs -> (* GAH: guess? *)
Pintarray
| {type_kind = Type_generalized_variant cstrs}
when List.for_all (fun (name, args,_) -> args = []) cstrs -> (* GAH: guess? *)
Pintarray
| {type_kind = _} ->
Paddrarray

4
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -319,9 +319,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
| _ -> assert False (*FIXME*) ];
value mkvariant =
fun
[ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc)
[ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc) (* GAH : pretty sure this is wrong *)
| <:ctyp@loc< $uid:s$ of $t$ >> ->
(conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc)
(conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc) (* GAH: dunno what I'm doing *)
| _ -> assert False (*FIXME*) ];
value rec type_decl tl cl loc m pflag =
fun

4
camlp4/boot/Camlp4.ml
View File

@ -14520,9 +14520,9 @@ module Struct =
let mkvariant =
function
| Ast.TyId (loc, (Ast.IdUid (_, s))) ->
((conv_con s), [], (mkloc loc))
((conv_con s), [], None,(mkloc loc)) (* GAH: probably wrong *)
| Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
((conv_con s), (List.map ctyp (list_of_ctyp t [])),
((conv_con s), (List.map ctyp (list_of_ctyp t [])),None, (* GAH: probably wrong *)
(mkloc loc))
| _ -> assert false

8
driver/main.ml
View File

@ -165,16 +165,18 @@ let main () =
fatal "Option -i is incompatible with -pack, -a, -output-obj"
else
fatal "Please specify at most one of -pack, -a, -c, -output-obj";
if !make_archive then begin
Compile.init_path();
Bytelibrarian.create_archive (List.rev !objfiles)
(extract_output !output_name)
end
else if !make_package then begin
Compile.init_path();
Bytepackager.package_files (List.rev !objfiles)
(extract_output !output_name)
let exctracted_output = extract_output !output_name in
let revd = List.rev !objfiles in
Bytepackager.package_files (revd)
(exctracted_output)
end
else if not !compile_only && !objfiles <> [] then begin
let target =

22
ocamldoc/odoc_sig.ml
View File

@ -179,21 +179,21 @@ module Analyser =
match cons_core_type_list_list with
[] ->
(0, acc)
| (name, core_type_list, loc) :: [] ->
| (name, (_ : Parsetree.core_type list),(_:Parsetree.core_type option), loc) :: [] ->
let s = get_string_of_file
loc.Location.loc_end.Lexing.pos_cnum
pos_limit
in
let (len, comment_opt) = My_ir.just_after_special !file_name s in
(len, acc @ [ (name, comment_opt) ])
| (name, core_type_list, loc) :: (name2, core_type_list2, loc2)
| (name, core_type_list, _, loc) :: (name2, core_type_list2, (ret_type2:Parsetree.core_type option), loc2)
:: q ->
let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in
let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in
let s = get_string_of_file pos_end_first pos_start_second in
let (_,comment_opt) = My_ir.just_after_special !file_name s in
f (acc @ [name, comment_opt])
((name2, core_type_list2, loc2) :: q)
((name2, core_type_list2, ret_type2, loc2) :: q)
in
f [] cons_core_type_list_list
@ -236,6 +236,22 @@ module Analyser =
}
in
Odoc_type.Type_variant (List.map f l)
| Types.Type_generalized_variant l ->
let f (constructor_name, type_expr_list,(_:Parsetree.core_type option)) =
let comment_opt =
try
match List.assoc constructor_name name_comment_list with
None -> None
| Some d -> d.Odoc_types.i_desc
with Not_found -> None
in
{
vc_name = constructor_name ;
vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
vc_text = comment_opt
}
in
Odoc_type.Type_variant (List.map f l)
| Types.Type_record (l, _) ->
let f (field_name, mutable_flag, type_expr) =

2
otherlibs/labltk/browser/searchid.ml
View File

@ -230,6 +230,8 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
Type_abstract -> false
| Type_variant l ->
List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
| Type_generalized_variant l -> (* pretty sure this is wrong *)
List.exists l ~f:(fun (_, l, r) -> List.exists l ~f:matches || (match r with None -> false | Some x -> matches x))
| Type_record(l, rep) ->
List.exists l ~f:(fun (_, _, t) -> matches t)
end

2
otherlibs/labltk/browser/searchpos.ml
View File

@ -170,7 +170,7 @@ let search_pos_type_decl td ~pos ~env =
Ptype_abstract -> ()
| Ptype_variant dl ->
List.iter dl
~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) (* might be false *)
| Ptype_record dl ->
List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
search_tkind td.ptype_kind;

16
parsing/parser.mly
View File

@ -1284,12 +1284,26 @@ constructor_declarations:
| constructor_declarations BAR constructor_declaration { $3 :: $1 }
;
constructor_declaration:
constr_ident constructor_arguments { ($1, $2, symbol_rloc()) }
constr_ident constructor_arguments { ($1, $2, None, symbol_rloc()) }
;
constructor_declaration:
constr_ident generalized_constructor_arguments
{ let arg_types,ret_type = $2 in
($1, arg_types,Some ret_type, symbol_rloc()) }
;
constructor_arguments:
/*empty*/ { [] }
| OF core_type_list { List.rev $2 }
;
generalized_constructor_arguments:
| COLON core_type_list MINUSGREATER simple_core_type
{ (List.rev $2,$4) }
;
label_declarations:
label_declaration { [$1] }
| label_declarations SEMI label_declaration { $3 :: $1 }

4
parsing/parsetree.mli
View File

@ -46,7 +46,7 @@ and core_field_desc =
| Pfield_var
and row_field =
Rtag of label * bool * core_type list
Rtag of label * bool * core_type list
| Rinherit of core_type
(* Type expressions for the class language *)
@ -138,7 +138,7 @@ and type_declaration =
and type_kind =
Ptype_abstract
| Ptype_variant of (string * core_type list * Location.t) list
| Ptype_variant of (string * core_type list * core_type option * Location.t) list
| Ptype_record of
(string * mutable_flag * core_type * Location.t) list

21
parsing/printast.ml
View File

@ -347,7 +347,7 @@ and type_declaration i ppf x =
line i ppf "ptype_manifest =\n";
option (i+1) core_type ppf x.ptype_manifest;
and type_kind i ppf x =
and type_kind i ppf x = (* GAH: why doesn't this module use Format?? *)
match x with
| Ptype_abstract ->
line i ppf "Ptype_abstract\n"
@ -663,9 +663,17 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
and string_x_core_type_list_x_location i ppf (s, l, loc) =
line i ppf "\"%s\" %a\n" s fmt_location loc;
list (i+1) core_type ppf l;
and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) =
match r_opt with
| None ->
line i ppf "\"%s\" %a\n" s fmt_location loc;
list (i+1) core_type ppf l;
| Some ret_type -> (* GAH: this is definately wrong *)
line i ppf "\"%s\" %a\n" s fmt_location loc;
list (i+1) core_type ppf l;
core_type i ppf ret_type
and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
line i ppf "\"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
@ -734,3 +742,8 @@ let interface ppf x = list 0 signature_item ppf x;;
let implementation ppf x = list 0 structure_item ppf x;;
let top_phrase ppf x = toplevel_phrase 0 ppf x;;
let print_expression = expression 0 ;;
let print_pattern = pattern 0 ;;

2
parsing/printast.mli
View File

@ -18,3 +18,5 @@ open Format;;
val interface : formatter -> signature_item list -> unit;;
val implementation : formatter -> structure_item list -> unit;;
val top_phrase : formatter -> toplevel_phrase -> unit;;
val print_expression : formatter -> expression -> unit;;
val print_pattern : formatter -> pattern -> unit;;

1
stdlib/arg.ml
View File

@ -208,6 +208,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
let parse l f msg =
try
parse_argv Sys.argv l f msg;
with
| Bad msg -> eprintf "%s" msg; exit 2;

4
tools/depend.ml
View File

@ -67,7 +67,7 @@ let add_opt add_fn bv = function
None -> ()
| Some x -> add_fn bv x
let add_type_declaration bv td =
let add_type_declaration bv td = (* GAH: no idea if this is correct *)
List.iter
(fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
td.ptype_cstrs;
@ -75,7 +75,7 @@ let add_type_declaration bv td =
let rec add_tkind = function
Ptype_abstract -> ()
| Ptype_variant cstrs ->
List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs
| Ptype_record lbls ->
List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
add_tkind td.ptype_kind

23
toplevel/genprintval.ml
View File

@ -235,19 +235,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
| Tconstr(path, ty_list, _) ->
begin try
let decl = Env.find_type path env in
match decl with
| {type_kind = Type_abstract; type_manifest = None} ->
Oval_stuff "<abstr>"
| {type_kind = Type_abstract; type_manifest = Some body} ->
tree_of_val depth obj
(try Ctype.apply env decl.type_params body ty_list with
Ctype.Cannot_apply -> abstract_type)
| {type_kind = Type_variant constr_list} ->
let process_variants constr_list =
let tag =
if O.is_block obj
then Cstr_block(O.tag obj)
else Cstr_constant(O.obj obj) in
let (constr_name, constr_args) =
let (constr_name, constr_args,_) = (* GAH: this is definately wrong *)
Datarepr.find_constr_by_tag tag constr_list in
let ty_args =
List.map
@ -257,6 +250,18 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
constr_args in
tree_of_constr_with_args (tree_of_constr env path)
constr_name 0 depth obj ty_args
in
match decl with
| {type_kind = Type_abstract; type_manifest = None} ->
Oval_stuff "<abstr>"
| {type_kind = Type_abstract; type_manifest = Some body} ->
tree_of_val depth obj
(try Ctype.apply env decl.type_params body ty_list with
Ctype.Cannot_apply -> abstract_type)
| {type_kind = Type_variant constr_list} ->
process_variants (List.map (fun (a,b) -> (a,b,None)) constr_list)
| {type_kind = Type_generalized_variant constr_list} ->
process_variants constr_list
| {type_kind = Type_record(lbl_list, rep)} ->
begin match check_depth depth obj ty with
Some x -> x

12
typing/btype.ml
View File

@ -314,7 +314,16 @@ let unmark_type_decl decl =
begin match decl.type_kind with
Type_abstract -> ()
| Type_variant cstrs ->
List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
List.iter
(fun (c, tl) ->
List.iter unmark_type tl)
cstrs (* GAH: WHAT DOES UNMARK DO??? *)
| Type_generalized_variant cstrs ->
List.iter
(fun (c, tl,ret_type_opt) ->
List.iter unmark_type tl;
Misc.may unmark_type ret_type_opt)
cstrs (* GAH: WHAT DOES UNMARK DO??? *)
| Type_record(lbls, rep) ->
List.iter (fun (c, mut, t) -> unmark_type t) lbls
end;
@ -514,5 +523,6 @@ let backtrack (changes, old) =
(**** Sets, maps and hashtables of types ****)
module TypeSet = Set.Make(TypeOps)
module TypeSetPair = Set.Make(struct type t = TypeOps.t * TypeOps.t let compare (x1,x2) (y1,y2) = let r = TypeOps.compare x1 y1 in if r == 0 then TypeOps.compare x2 y2 else r end)
module TypeMap = Map.Make (TypeOps)
module TypeHash = Hashtbl.Make(TypeOps)

1
typing/btype.mli
View File

@ -157,5 +157,6 @@ val log_type: type_expr -> unit
(**** Sets, maps and hashtables of types ****)
module TypeSet : Set.S with type elt = type_expr
module TypeSetPair : Set.S with type elt = type_expr * type_expr
module TypeMap : Map.S with type key = type_expr
module TypeHash : Hashtbl.S with type key = type_expr

126
typing/ctype.ml
View File

@ -457,8 +457,19 @@ let closed_type_decl decl =
begin match decl.type_kind with
Type_abstract ->
()
| Type_generalized_variant v ->
List.iter
(fun (_, tyl,ret_type_opt) ->
match ret_type_opt with
| Some _ -> ()
| None ->
List.iter closed_type tyl)
v (* GAH: is this correct ? *)
| Type_variant v ->
List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
List.iter
(fun (_, tyl) ->
List.iter closed_type tyl)
v (* GAH: is this correct ? *)
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> closed_type ty) r
end;
@ -1539,60 +1550,91 @@ let deep_occur t0 ty =
abbreviated. It would be possible to check whether some
information is indeed lost, but it probably does not worth it.
*)
let pattern_unification = ref false
let local_unifier = ref []
let set_unification_type x =
match x with
| `Pattern ->
pattern_unification := true
| `Expression ->
pattern_unification := false
let get_unification_type () =
match !pattern_unification with
| true -> `Pattern
| false -> `Expression
let reset_local_unifier () =
local_unifier := []
let get_local_unifier () = !local_unifier
let uni_equalities = ref TypeSetPair.empty
let uni_eq t1 t2 = t1 == t2 || TypeSetPair.mem (t1,t2) !uni_equalities || TypeSetPair.mem (t2,t1) !uni_equalities
let add_equality t1 t2 =
uni_equalities := TypeSetPair.add (t1, t2) !uni_equalities
let rec unify env t1 t2 =
(* First step: special cases (optimizations) *)
if t1 == t2 then () else
if uni_eq t1 t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
if t1 == t2 then () else
if uni_eq t1 t2 then () else
try
type_changed := true;
match (t1.desc, t2.desc) with
(Tvar, Tconstr _) when deep_occur t1 t2 ->
| (Tvar, Tconstr _) when deep_occur t1 t2 ->
unify2 env t1 t2
| (Tconstr _, Tvar) when deep_occur t2 t1 ->
| (Tconstr _, Tvar) when deep_occur t2 t1 ->
unify2 env t1 t2
| (Tvar, _) ->
| (Tvar, _) ->
occur env t1 t2; occur_univar env t2;
update_level env t1.level t2;
link_type t1 t2
| (_, Tvar) ->
| (_, Tvar) ->
occur env t2 t1; occur_univar env t1;
update_level env t2.level t1;
link_type t2 t1
| (Tunivar, Tunivar) ->
| (Tunivar, Tunivar) -> (* GAH : ask garrigue: when do we unify univars? *)
unify_univar t1 t2 !univar_pairs;
update_level env t1.level t2;
link_type t1 t2
| (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
when Path.same p1 p2
(* This optimization assumes that t1 does not expand to t2
(and conversely), so we fall back to the general case
when any of the types has a cached expansion. *)
&& not (has_cached_expansion p1 !a1
|| has_cached_expansion p2 !a2) ->
|| has_cached_expansion p2 !a2) ->
update_level env t1.level t2;
link_type t1 t2
| _ ->
| _ ->
unify2 env t1 t2
with Unify trace ->
raise (Unify ((t1, t2)::trace))
and unify2 env t1 t2 =
(* Second step: expansion of abbreviations *)
let rec expand_both t1'' t2'' =
let t1' = expand_head_unif env t1 in
let t2' = expand_head_unif env t2 in
(* Expansion may have changed the representative of the types... *)
if t1' == t1'' && t2' == t2'' then (t1',t2') else
if uni_eq t1' t1'' && uni_eq t2' t2'' then (t1',t2') else
expand_both t1' t2'
in
let t1', t2' = expand_both t1 t2 in
if t1' == t2' then () else
if uni_eq t1' t2' then () else
let t1 = repr t1 and t2 = repr t2 in
if (t1 == t1') || (t2 != t2') then
if (uni_eq t1 t1') || (not (uni_eq t2 t2')) then (* GAH: ask garrigue why this code seems so strange *)
unify3 env t1 t1' t2 t2'
else
try unify3 env t2 t2' t1 t1' with Unify trace ->
@ -1606,16 +1648,22 @@ and unify3 env t1 t1' t2 t2' =
let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
occur env t1' t2;
update_level env t1'.level t2;
link_type t1' t2;
add_equality t1' t2;
try
begin match (d1, d2) with
(Tvar, _) ->
link_type t1' t2;
occur_univar env t2
| (_, Tvar) ->
let td1 = newgenty d1 in
link_type t2' t1;
occur_univar env t1;
(* let td1 = newgenty d1 in
occur env t2' td1;
occur_univar env td1;
if t1 == t1' then begin
(* The variable must be instantiated... *)
let ty = newty2 t1'.level d1 in
@ -1626,7 +1674,7 @@ and unify3 env t1 t1' t2 t2' =
t1'.desc <- d1;
update_level env t2'.level t1;
link_type t2' t1
end
end*)
| (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
|| !Clflags.classic && not (is_optional l1 || is_optional l2) ->
unify env t1 t2; unify env u1 u2;
@ -1669,6 +1717,18 @@ and unify3 env t1 t1' t2 t2' =
enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env)
| (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 ->
unify_list env tl1 tl2
| (Tunivar,_) ->
if !pattern_unification then
local_unifier:= (t1,t2) :: !local_unifier
else
raise (Unify [])
| (_,Tunivar) ->
if !pattern_unification then
local_unifier:= (t2,t1) :: !local_unifier
else
( raise (Unify []) )
| (_, _) ->
raise (Unify [])
end;
@ -1887,13 +1947,19 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
set_row_field e2 f1
| _ -> raise (Unify [])
;;
let unify env ty1 ty2 =
try
unify env ty1 ty2
uni_equalities := TypeSetPair.empty;
unify env ty1 ty2;
uni_equalities := TypeSetPair.empty;
with Unify trace ->
uni_equalities := TypeSetPair.empty;
raise (Unify (expand_trace env trace))
let unify_var env t1 t2 =
let t1 = repr t1 and t2 = repr t2 in
if t1 == t2 then () else
@ -3371,7 +3437,17 @@ let nondep_type_decl env mid id is_covariant decl =
| Type_variant cstrs ->
Type_variant
(List.map
(fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl))
(fun (c, tl) ->
(c, List.map (nondep_type_rec env mid) tl)) (* GAH: HERE TOO? *)
cstrs)
| Type_generalized_variant cstrs ->
Type_generalized_variant
(List.map
(fun (c, tl,ret_type_opt) ->
let ret_type_opt =
may_map (nondep_type_rec env mid) ret_type_opt
in
(c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) (* GAH: HERE TOO? *)
cstrs)
| Type_record(lbls, rep) ->
Type_record
@ -3478,3 +3554,11 @@ let rec collapse_conj env visited ty =
let collapse_conj_params env params =
List.iter (collapse_conj env []) params

4
typing/ctype.mli
View File

@ -250,3 +250,7 @@ val arity: type_expr -> int
val collapse_conj_params: Env.t -> type_expr list -> unit
(* Collapse conjunctive types in class parameters *)
val reset_local_unifier: unit -> unit
val get_local_unifier: unit -> (type_expr * type_expr) list
val set_unification_type : [`Pattern | `Expression] -> unit
val get_unification_type : unit -> [`Pattern | `Expression]

33
typing/datarepr.ml
View File

@ -22,20 +22,34 @@ open Types
let constructor_descrs ty_res cstrs priv =
let num_consts = ref 0 and num_nonconsts = ref 0 in
List.iter
(function (name, []) -> incr num_consts
| (name, _) -> incr num_nonconsts)
(function (name, [],_) -> incr num_consts
| (name, _,_) -> incr num_nonconsts)
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
| (name, ty_args) :: rem ->
| (name, ty_args, ty_res_opt) :: rem ->
let ty_res =
match ty_res_opt with
| Some ty_res -> ty_res
| None -> ty_res
in
let (tag, descr_rem) =
match ty_args with
[] -> (Cstr_constant idx_const,
describe_constructors (idx_const+1) idx_nonconst rem)
| _ -> (Cstr_block idx_nonconst,
describe_constructors idx_const (idx_nonconst+1) rem) in
(* let existentials =
match ty_res_opt with
| None -> []
| Some type_ret ->
let res_vars = List.fold_right Btype.TypeSet.add (free_vars type_ret) Btype.TypeSet.empty in
let other_types
*)
let cstr =
{ cstr_res = ty_res;
{ cstr_res = ty_res;
cstr_existentials = [] ; (* GAH: HOW DO I GET THE EXISTENTIALS OF A TYPE?? *)
cstr_args = ty_args;
cstr_arity = List.length ty_args;
cstr_tag = tag;
@ -47,6 +61,7 @@ let constructor_descrs ty_res cstrs priv =
let exception_descr path_exc decl =
{ cstr_res = Predef.type_exn;
cstr_existentials = [] ; (* GAH: is this correct? *)
cstr_args = decl;
cstr_arity = List.length decl;
cstr_tag = Cstr_exception path_exc;
@ -81,16 +96,16 @@ let label_descrs ty_res lbls repres priv =
exception Constr_not_found
let rec find_constr tag num_const num_nonconst = function
let rec find_constr tag num_const num_nonconst = function (* GAH: is this correct? *)
[] ->
raise Constr_not_found
| (name, [] as cstr) :: rem ->
| (name, ([] as cstr),(_ as ret_type_opt)) :: rem ->
if tag = Cstr_constant num_const
then cstr
then (name,cstr,ret_type_opt)
else find_constr tag (num_const + 1) num_nonconst rem
| (name, _ as cstr) :: rem ->
| (name, (_ as cstr),(_ as ret_type_opt)) :: rem ->
if tag = Cstr_block num_nonconst
then cstr
then (name,cstr,ret_type_opt)
else find_constr tag num_const (num_nonconst + 1) rem
let find_constr_by_tag tag cstrlist =

6
typing/datarepr.mli
View File

@ -17,9 +17,9 @@
open Asttypes
open Types
val constructor_descrs:
type_expr -> (string * type_expr list) list -> private_flag ->
type_expr -> (string * type_expr list * type_expr option) list -> private_flag ->
(string * constructor_description) list
val exception_descr:
Path.t -> type_expr list -> constructor_description
@ -31,4 +31,4 @@ val label_descrs:
exception Constr_not_found
val find_constr_by_tag:
constructor_tag -> (string * type_expr list) list -> string * type_expr list
constructor_tag -> (string * type_expr list * type_expr option) list -> string * type_expr list * type_expr option

12
typing/env.ml
View File

@ -84,6 +84,8 @@ and functor_components = {
fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *)
}
let map_values f t = {t with values = Ident.map_tbl f t.values}
let empty = {
values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
labels = Ident.empty; types = Ident.empty;
@ -451,11 +453,15 @@ let rec scrape_modtype mty env =
(* Compute constructor descriptions *)
let constructors_of_type ty_path decl =
match decl.type_kind with
Type_variant cstrs ->
let handle_variants cstrs =
Datarepr.constructor_descrs
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
cstrs decl.type_private
in
match decl.type_kind with
| Type_variant cstrs ->
handle_variants (List.map (fun (a,b) -> (a,b,None)) cstrs)
| Type_generalized_variant cstrs -> handle_variants cstrs
| Type_record _ | Type_abstract -> []
(* Compute label descriptions *)
@ -466,7 +472,7 @@ let labels_of_type ty_path decl =
Datarepr.label_descrs
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
labels rep decl.type_private
| Type_variant _ | Type_abstract -> []
| Type_variant _ | Type_generalized_variant _ | Type_abstract -> []
(* Given a signature and a root path, prefix all idents in the signature
by the root path and build the corresponding substitution. *)

4
typing/env.mli
View File

@ -49,8 +49,12 @@ val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
val lookup_class: Longident.t -> t -> Path.t * class_declaration
val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
val map_values: (Path.t * value_description -> Path.t * value_description) -> t -> t
(* Insertion by identifier *)
val add_value: Ident.t -> value_description -> t -> t
val add_annot: Ident.t -> Annot.ident -> t -> t
val add_type: Ident.t -> type_declaration -> t -> t

7
typing/ident.ml
View File

@ -95,6 +95,13 @@ and 'a data =
data: 'a;
previous: 'a data option }
let rec map_tbl f = (* GAH: THIS IS PROBABLY TOTALLY WRONG *)
function
| Empty -> Empty
| Node (t,{ident=id;data=d;previous=p},t',i) ->
Node(map_tbl f t,{ident=id;data=f d;previous=p},map_tbl f t',i)
let empty = Empty
(* Inline expansion of height for better speed

1
typing/ident.mli
View File

@ -57,3 +57,4 @@ val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> 'a
val keys: 'a tbl -> t list
val map_tbl: ('a -> 'a) -> 'a tbl -> 'a tbl

37
typing/includecore.ml
View File

@ -161,21 +161,29 @@ let report_type_mismatch first second decl ppf =
Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
match cstrs1, cstrs2 with
match cstrs1, cstrs2 with (* GAH: most likely wrong, but I don't know what this function does *)
[], [] -> []
| [], (cstr2,_)::_ -> [Field_missing (true, cstr2)]
| (cstr1,_)::_, [] -> [Field_missing (false, cstr1)]
| (cstr1, arg1)::rem1, (cstr2, arg2)::rem2 ->
| [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)]
| (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)]
| (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 ->
if cstr1 <> cstr2 then [Field_names (n, cstr1, cstr2)] else
if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else
if Misc.for_all2
(fun ty1 ty2 ->
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params))
arg1 arg2
then compare_variants env decl1 decl2 (n+1) rem1 rem2
else [Field_type cstr1]
match ret1, ret2 with
| Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) ->
[Field_type cstr1]
| Some _, None | None, Some _ ->
[Field_type cstr1]
| _ ->
if Misc.for_all2
(fun ty1 ty2 ->
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params))
(arg1) (arg2)
then
compare_variants env decl1 decl2 (n+1) rem1 rem2
else [Field_type cstr1]
let rec compare_records env decl1 decl2 n labels1 labels2 =
match labels1, labels2 with
[], [] -> []
@ -195,6 +203,9 @@ let type_declarations env id decl1 decl2 =
let err = match (decl1.type_kind, decl2.type_kind) with
(_, Type_abstract) -> []
| (Type_variant cstrs1, Type_variant cstrs2) ->
let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in
compare_variants env decl1 decl2 1 (gen_variants cstrs1) (gen_variants cstrs2)
| (Type_generalized_variant cstrs1, Type_generalized_variant cstrs2) ->
compare_variants env decl1 decl2 1 cstrs1 cstrs2
| (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
let err = compare_records env decl1 decl2 1 labels1 labels2 in
@ -222,7 +233,7 @@ let type_declarations env id decl1 decl2 =
in
if err <> [] then err else
if match decl2.type_kind with
| Type_record (_,_) | Type_variant _ -> decl2.type_private = Private
| Type_record (_,_) | Type_generalized_variant _ | Type_variant _ -> decl2.type_private = Private
| Type_abstract ->
match decl2.type_manifest with
| None -> true

24
typing/oprint.ml
View File

@ -350,7 +350,7 @@ and print_out_sig_item ppf =
(if vir_flag then " virtual" else "") print_out_class_params params
name !out_class_type clt
| Osig_exception (id, tyl) ->
fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None)
| Osig_modtype (name, Omty_abstract) ->
fprintf ppf "@[<2>module type %s@]" name
| Osig_modtype (name, mty) ->
@ -428,12 +428,22 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
print_name_args
print_out_tkind ty
print_constraints constraints
and print_out_constr ppf (name, tyl) =
match tyl with
[] -> fprintf ppf "%s" name
| _ ->
fprintf ppf "@[<2>%s of@ %a@]" name
(print_typlist print_simple_out_type " *") tyl
and print_out_constr ppf (name, tyl,ret_type_opt) =
match ret_type_opt with
| None ->
begin match tyl with
| [] -> fprintf ppf "%s" name
| _ ->
fprintf ppf "@[<2>%s of@ %a@]" name
(print_typlist print_simple_out_type " *") tyl end
| Some ret_type ->
begin match tyl with
| [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type (* GAH: IS THIS CORRECT? *)
| _ ->
fprintf ppf "@[<2>%s :@ %a -> %a@]" name
(print_typlist print_simple_out_type " *") tyl print_simple_out_type ret_type end
and print_out_label ppf (name, mut, arg) =
fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
!out_type arg

2
typing/outcometree.mli
View File

@ -54,7 +54,7 @@ type out_type =
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list) list
| Otyp_sum of (string * out_type list * out_type option) list (* GAH: was right thing to do? *)
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of

21
typing/parmatch.ml
View File

@ -132,6 +132,9 @@ let rec get_type_descr ty tenv =
let rec get_constr tag ty tenv =
match get_type_descr ty tenv with
| {type_kind=Type_variant constr_list} ->
let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in
Datarepr.find_constr_by_tag tag (gen_variants constr_list)
| {type_kind=Type_generalized_variant constr_list} ->
Datarepr.find_constr_by_tag tag constr_list
| {type_manifest = Some _} ->
get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv
@ -162,7 +165,7 @@ let get_constr_name tag ty tenv = match tag with
| Cstr_exception path -> Path.name path
| _ ->
try
let name,_ = get_constr tag ty tenv in name
let name,_,_ = get_constr tag ty tenv in name
with
| Datarepr.Constr_not_found -> "*Unknown constructor*"
@ -715,13 +718,19 @@ let complete_constrs p all_tags = match p.pat_desc with
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
List.map
(fun tag ->
let _,targs = get_constr tag p.pat_type p.pat_env in
let _,targs,ret_type_opt = get_constr tag p.pat_type p.pat_env in (* GAH: is this correct? don't forget the existentials! *)
let ret_type =
match ret_type_opt with
| None -> c.cstr_res
| Some ret_type -> ret_type
in
{c with
cstr_tag = tag ;
cstr_args = targs ;
cstr_arity = List.length targs})
cstr_res = ret_type ;
cstr_tag = tag ;
cstr_args = targs ;
cstr_arity = List.length targs})
not_tags
with
with
| Datarepr.Constr_not_found ->
fatal_error "Parmatch.complete_constr: constr_not_found"
end

4
typing/predef.ml
View File

@ -95,7 +95,7 @@ let build_initial_env add_type add_exception empty_env =
and decl_bool =
{type_params = [];
type_arity = 0;
type_kind = Type_variant(["false", []; "true", []]);
type_kind = Type_variant(["false", []; "true", []]); (* GAH: HOW DO I DEFINE THE BASIC BOOL TYPE? *)
type_private = Public;
type_manifest = None;
type_variance = []}
@ -126,7 +126,7 @@ let build_initial_env add_type add_exception empty_env =
{type_params = [tvar];
type_arity = 1;
type_kind =
Type_variant(["[]", []; "::", [tvar; type_list tvar]]);
Type_variant(["[]", []; "::", [tvar; type_list tvar]]); (* GAH: IS THIS CORRECT? *)
type_private = Public;
type_manifest = None;
type_variance = [true, false, false]}

26
typing/printtyp.ml
View File

@ -534,8 +534,17 @@ let rec tree_of_type_decl id decl =
begin match decl.type_kind with
| Type_abstract -> ()
| Type_variant [] -> ()
| Type_generalized_variant cstrs ->
List.iter
(fun (_, args,ret_type_opt) ->
List.iter mark_loops args;
may mark_loops ret_type_opt)
cstrs
| Type_variant cstrs ->
List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
List.iter
(fun (_, args) ->
List.iter mark_loops args)
cstrs
| Type_record(l, rep) ->
List.iter (fun (_, _, ty) -> mark_loops ty) l
end;
@ -550,7 +559,7 @@ let rec tree_of_type_decl id decl =
match decl.type_kind with
Type_abstract ->
decl.type_manifest = None || decl.type_private = Private
| Type_variant _ | Type_record _ ->
| Type_variant _ | Type_generalized_variant _ | Type_record _ ->
decl.type_private = Private
in
let vari =
@ -581,14 +590,25 @@ let rec tree_of_type_decl id decl =
| Type_variant cstrs ->
tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
decl.type_private
| Type_generalized_variant cstrs ->
tree_of_manifest (Otyp_sum (List.map tree_of_generalized_constructor cstrs)),
decl.type_private
| Type_record(lbls, rep) ->
tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
decl.type_private
in
(name, args, ty, priv, constraints)
and tree_of_generalized_constructor (name, args,ret_type_opt) =
(name, tree_of_typlist false args,tree_of_constructor_ret ret_type_opt)
and tree_of_constructor (name, args) =
(name, tree_of_typlist false args)
(name, tree_of_typlist false args,None)
and tree_of_constructor_ret =
function
| None -> None
| Some ret_type -> Some (tree_of_typexp false ret_type) (* GAH: WHY FALSE?? *)
and tree_of_label (name, mut, arg) =
(name, mut = Mutable, tree_of_typexp false arg)

22
typing/subst.ml
View File

@ -168,18 +168,30 @@ let type_declaration s decl =
Type_abstract -> Type_abstract
| Type_variant cstrs ->
Type_variant(
List.map (fun (n, args) -> (n, List.map (typexp s) args))
cstrs)
List.map (fun (n, args) ->
(n, List.map (typexp s) args)) (* GAH: WHAT DOES typexp DO? *)
cstrs)
| Type_generalized_variant cstrs ->
Type_generalized_variant(
List.map (fun (n, args,ret_type_opt) ->
let ret_type_opt =
Misc.may_map (typexp s) ret_type_opt
in
(n, List.map (typexp s) args,ret_type_opt)) (* GAH: WHAT DOES typexp DO? *)
cstrs)
| Type_record(lbls, rep) ->
Type_record(
List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
lbls,
rep)
end;
type_manifest =
begin match decl.type_manifest with
None -> None
| Some ty -> Some(typexp s ty)
begin
match decl.type_manifest with
None -> None
| Some ty -> Some(typexp s ty)
end;
type_private = decl.type_private;
type_variance = decl.type_variance;

388
typing/typecore.ml
View File

File diff suppressed because it is too large Load Diff

80
typing/typedecl.ml
View File

@ -145,19 +145,26 @@ let transl_declaration env (name, sdecl) id =
| Ptype_variant cstrs ->
let all_constrs = ref StringSet.empty in
List.iter
(fun (name, args, loc) ->
(fun (name, _, _, loc) ->
if StringSet.mem name !all_constrs then
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := StringSet.add name !all_constrs)
cstrs;
if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
if List.length (List.filter (fun (_, args, _, _) -> args <> []) cstrs) (* GAH: MIGHT BE WRONG *)
> (Config.max_tag + 1) then
raise(Error(sdecl.ptype_loc, Too_many_constructors));
if List.for_all (fun (_,_,x,_) -> match x with Some _ -> false | None -> true) cstrs then
Type_variant
(List.map
(fun (name, args, loc) ->
(fun (name, args,_, loc) ->
(name, List.map (transl_simple_type env true) args))
cstrs)
else
Type_generalized_variant
(List.map
(fun (name, args,ret_type_opt, loc) ->
(name, List.map (transl_simple_type env true) args,may_map (transl_simple_type env true) ret_type_opt))
cstrs)
| Ptype_record lbls ->
let all_labels = ref StringSet.empty in
List.iter
@ -219,7 +226,9 @@ let generalize_decl decl =
Type_abstract ->
()
| Type_variant v ->
List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v (* GAH: almost sure this is wrong *)
| Type_generalized_variant v ->
List.iter (fun (_, tyl,ret_type_opt) -> List.iter Ctype.generalize tyl; may Ctype.generalize ret_type_opt) v (* GAH: almost sure this is wrong *)
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
end;
@ -261,24 +270,36 @@ let rec check_constraints_rec env loc visited ty =
let check_constraints env (_, sdecl) (_, decl) =
let visited = ref TypeSet.empty in
begin match decl.type_kind with
| Type_abstract -> ()
| Type_variant l ->
let process_variants l =
let rec find_pl = function
Ptype_variant pl -> pl
| Ptype_record _ | Ptype_abstract -> assert false
in
let pl = find_pl sdecl.ptype_kind in
List.iter
(fun (name, tyl) ->
let styl =
try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
(fun (name, tyl,ret_type_opt) -> (* GAH: again, no idea *)
let styl,sret_type_opt =
try let (_,sty,ret_type_opt (* added by me *) ,_) = List.find (fun (n,_,_,_) -> n = name) pl in sty,ret_type_opt (* GAH: lord, I have no idea what this is about *)
with Not_found -> assert false in
List.iter2
(fun sty ty ->
check_constraints_rec env sty.ptyp_loc visited ty)
styl tyl)
l
styl tyl;
match sret_type_opt,ret_type_opt with
| Some sr,Some r ->
check_constraints_rec env sr.ptyp_loc visited r
| _ ->
())
l
in
begin match decl.type_kind with
| Type_abstract -> ()
| Type_variant l ->
let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in
process_variants (gen_variants l)
| Type_generalized_variant l ->
process_variants l
| Type_record (l, _) ->
let rec find_pl = function
Ptype_record pl -> pl
@ -479,9 +500,12 @@ let compute_variance env tvl nega posi cntr ty =
let make_variance ty = (ty, ref false, ref false, ref false)
let whole_type decl =
match decl.type_kind with
Type_variant tll ->
| Type_generalized_variant tll ->
Btype.newgenty
(Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll))
(Ttuple (List.map (fun (_, tl,_ (* added by me *)) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*)
| Type_variant tll ->
Btype.newgenty
(Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*)
| Type_record (ftl, _) ->
Btype.newgenty
(Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
@ -503,15 +527,24 @@ let compute_variance_decl env check decl (required, loc) =
let tvl2 = List.map make_variance fvl in
let tvl = tvl0 @ tvl1 in
begin match decl.type_kind with
Type_abstract ->
| Type_abstract ->
begin match decl.type_manifest with
None -> assert false
| Some ty -> compute_variance env tvl true false false ty
end
| Type_variant tll ->
| Type_variant tll -> (* GAH: what in the blazes *)
List.iter
(fun (_,tl) ->
List.iter (compute_variance env tvl true false false) tl)
List.iter (compute_variance env tvl true false false) tl)
tll
| Type_generalized_variant tll -> (* GAH: what in the blazes *)
List.iter
(fun (_,tl,ret_type_opt) ->
match ret_type_opt with
| None ->
List.iter (compute_variance env tvl true false false) tl
| Some ret_type ->
List.iter (compute_variance env tvl true true true) tl) (* GAH: variance calculation, is this right *)
tll
| Type_record (ftl, _) ->
List.iter
@ -612,7 +645,7 @@ let check_duplicates name_sdecl_list =
(fun (name, sdecl) -> match sdecl.ptype_kind with
Ptype_variant cl ->
List.iter
(fun (cname, _, loc) ->
(fun (cname, _, _, loc) -> (* probably right *)
try
let name' = Hashtbl.find constrs cname in
Location.prerr_warning loc
@ -940,9 +973,14 @@ let report_error ppf = function
fprintf ppf "A type variable is unbound in this type declaration";
let ty = Ctype.repr ty in
begin match decl.type_kind, decl.type_manifest with
Type_variant tl, _ ->
explain_unbound ppf ty tl (fun (_,tl) -> Btype.newgenty (Ttuple tl))
"case" (fun (lab,_) -> lab ^ " of ")
| Type_generalized_variant tl, _ ->
explain_unbound ppf ty tl (fun (_,tl,_) ->
Btype.newgenty (Ttuple tl))
"case" (fun (lab,_,_) -> lab ^ " of ")
| Type_variant tl, _ ->
explain_unbound ppf ty tl (fun (_,tl) ->
Btype.newgenty (Ttuple tl))
"case" (fun (lab,_) -> lab ^ " of ")
| Type_record (tl, _), _ ->
explain_unbound ppf ty tl (fun (_,_,t) -> t)
"field" (fun (lab,_,_) -> lab ^ ": ")

2
typing/types.ml
View File

@ -106,6 +106,7 @@ and value_kind =
type constructor_description =
{ cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
cstr_tag: constructor_tag; (* Tag for heap blocks *)
@ -150,6 +151,7 @@ and type_kind =
| Type_variant of (string * type_expr list) list
| Type_record of
(string * mutable_flag * type_expr) list * record_representation
| Type_generalized_variant of (string * type_expr list * type_expr option) list
type exception_declaration = type_expr list

2
typing/types.mli
View File

@ -103,6 +103,7 @@ and value_kind =
type constructor_description =
{ cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
cstr_tag: constructor_tag; (* Tag for heap blocks *)
@ -147,6 +148,7 @@ and type_kind =
| Type_variant of (string * type_expr list) list
| Type_record of
(string * mutable_flag * type_expr) list * record_representation
| Type_generalized_variant of (string * type_expr list * type_expr option) list
type exception_declaration = type_expr list