1995-08-09 08:06:35 -07:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* *)
1996-04-30 07:53:58 -07:00
(* Objective Caml *)
1995-08-09 08:06:35 -07:00
(* *)
1996-04-29 06:24:25 -07:00
(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
1995-08-09 08:06:35 -07:00
(* *)
1996-04-30 07:53:58 -07:00
(* Copyright 1996 Institut National de Recherche en Informatique et *)
1999-11-17 10:59:06 -08:00
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
1995-08-09 08:06:35 -07:00
(* *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* $Id$ *)
1995-05-04 03:15:53 -07:00
(* Operations on core types *)
open Misc
1996-04-22 04:15:41 -07:00
open Asttypes
1996-09-23 04:33:27 -07:00
open Types
1997-03-24 12:12:00 -08:00
open Btype
1995-05-04 03:15:53 -07:00
1997-03-13 13:18:06 -08:00
(*
Type manipulation after type inference
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
1997-03-14 07:19:48 -08:00
If one wants to manipulate a type after type inference ( for
1997-03-13 13:18:06 -08:00
instance , during code generation or in the debugger ) , one must
first make sure that the type levels are correct , using the
1997-03-14 07:19:48 -08:00
function [ correct_levels ] . Then , this type can be correctely
1997-06-29 06:16:47 -07:00
manipulated by [ apply ] , [ expand_head ] and [ moregeneral ] .
1997-03-13 13:18:06 -08:00
* )
1997-02-20 12:39:02 -08:00
(*
General notes
= = = = = = = = = = = = =
1997-01-20 09:11:47 -08:00
- As much sharing as possible should be kept : it makes types
smaller and better abbreviated .
When necessary , some sharing can be lost . Types will still be
1997-03-18 13:05:15 -08:00
printed correctly ( + + + TO DO . . . ) , and abbreviations defined by a
class do not depend on sharing thanks to constrained
abbreviations . ( Of course , even if some sharing is lost , typing
will still be correct . )
1997-02-20 12:39:02 -08:00
- All nodes of a type have a level : that way , one know whether a
node need to be duplicated or not when instantiating a type .
1997-03-07 14:44:02 -08:00
- Levels of a type are decreasing ( generic level being considered
as greatest ) .
1997-02-20 12:39:02 -08:00
- The level of a type constructor is superior to the binding
1997-01-20 09:11:47 -08:00
time of its path .
1997-03-08 14:05:39 -08:00
- Recursive types without limitation should be handled ( even if
1997-03-18 13:05:15 -08:00
there is still an occur check ) . This avoid treating specially the
case for objects , for instance . Furthermore , the occur check
policy can then be easily changed .
1997-01-20 09:11:47 -08:00
* )
1997-02-20 12:39:02 -08:00
(*
A faire
= = = = = = =
1997-01-20 09:11:47 -08:00
- Revoir affichage des types .
1997-02-20 12:39:02 -08:00
- Etendre la portee d'un alias [ .. . as ' a ] a tout le type englobant .
1997-01-20 09:11:47 -08:00
- # - type implementes comme de vraies abreviations .
1997-02-20 12:39:02 -08:00
- Niveaux plus fins pour les identificateurs :
Champ [ global ] renomme en [ level ] ;
Niveau - 1 : global
0 : module toplevel
1 : module contenu dans module toplevel
.. .
En fait , incrementer le niveau a chaque fois que l'on rentre dans
un module .
3 4 6
\ / /
1 2 5
\ | /
0
[ Subst ] doit ecreter les niveaux ( pour qu'un variable non
generalisable dans un module de niveau 2 ne se retrouve pas
generalisable lorsque l'on l'utilise au niveau 0 ) .
- Traitement de la trace de l'unification separe de la fonction
[ unify ] .
1997-01-20 09:11:47 -08:00
* )
1997-01-21 05:38:42 -08:00
(* * * * Errors * * * *)
exception Unify of ( type_expr * type_expr ) list
1999-11-30 08:07:38 -08:00
exception Tags of label * label
1996-05-26 06:42:34 -07:00
exception Subtype of
( type_expr * type_expr ) list * ( type_expr * type_expr ) list
1995-05-04 03:15:53 -07:00
1997-01-23 04:46:46 -08:00
exception Cannot_expand
1997-03-18 13:05:15 -08:00
exception Cannot_apply
1997-03-08 14:05:39 -08:00
exception Recursive_abbrev
1997-01-21 05:38:42 -08:00
(* * * * Type level management * * * *)
1995-05-04 03:15:53 -07:00
let current_level = ref 0
1998-06-24 12:22:26 -07:00
let nongen_level = ref 0
1996-04-22 04:15:41 -07:00
let global_level = ref 1
1998-06-24 12:22:26 -07:00
let saved_level = ref []
2010-10-04 01:38:22 -07:00
let get_current_level () = ! current_level
1998-06-24 12:22:26 -07:00
let init_def level = current_level := level ; nongen_level := level
let begin_def () =
saved_level := ( ! current_level , ! nongen_level ) :: ! saved_level ;
incr current_level ; nongen_level := ! current_level
let begin_class_def () =
saved_level := ( ! current_level , ! nongen_level ) :: ! saved_level ;
incr current_level
let raise_nongen_level () =
saved_level := ( ! current_level , ! nongen_level ) :: ! saved_level ;
nongen_level := ! current_level
let end_def () =
let ( cl , nl ) = List . hd ! saved_level in
saved_level := List . tl ! saved_level ;
current_level := cl ; nongen_level := nl
1995-05-04 03:15:53 -07:00
1996-04-22 04:15:41 -07:00
let reset_global_level () =
2008-04-22 08:45:55 -07:00
global_level := ! current_level + 1
1998-06-24 12:22:26 -07:00
let increase_global_level () =
2002-08-04 22:57:24 -07:00
let gl = ! global_level in
global_level := ! current_level ;
gl
let restore_global_level gl =
global_level := gl
1995-05-04 03:15:53 -07:00
2010-08-02 07:37:22 -07:00
(* * * * Whether a path points to an object type ( with hidden row variable ) * * * *)
let is_object_type path =
let name =
match path with Path . Pident id -> Ident . name id
| Path . Pdot ( _ , s , _ ) -> s
| Path . Papply _ -> assert false
in name . [ 0 ] = '#'
(* * * * Abbreviations without parameters * * * *)
2002-04-18 00:27:47 -07:00
(* Shall reset after generalizing *)
let simple_abbrevs = ref Mnil
2002-04-18 01:06:13 -07:00
let proper_abbrevs path tl abbrev =
2010-08-02 07:37:22 -07:00
if ! Clflags . principal | | tl < > [] | | is_object_type path then abbrev
else simple_abbrevs
2002-04-18 00:27:47 -07:00
1997-01-21 05:38:42 -08:00
(* * * * Some type creators * * * *)
1997-03-24 12:12:00 -08:00
(* Re-export generic type creators *)
1998-07-03 10:40:39 -07:00
let newty2 = Btype . newty2
let newty desc = newty2 ! current_level desc
let new_global_ty desc = newty2 ! global_level desc
let newvar () = newty2 ! current_level Tvar
let newvar2 level = newty2 level Tvar
let new_global_var () = newty2 ! global_level Tvar
1997-01-21 05:38:42 -08:00
1997-03-08 14:05:39 -08:00
let newobj fields = newty ( Tobject ( fields , ref None ) )
1998-06-24 12:22:26 -07:00
let newconstr path tyl = newty ( Tconstr ( path , tyl , ref Mnil ) )
1997-01-21 05:38:42 -08:00
let none = newty ( Ttuple [] ) (* Clearly ill-formed type *)
(* * * * Representative of a type * * * *)
1997-03-24 12:12:00 -08:00
(* Re-export repr *)
let repr = repr
1997-03-09 08:52:49 -08:00
1998-07-03 10:40:39 -07:00
(* * * * Type maps * * * *)
module TypePairs =
Hashtbl . Make ( struct
type t = type_expr * type_expr
1998-07-31 00:54:17 -07:00
let equal ( t1 , t1' ) ( t2 , t2' ) = ( t1 = = t2 ) && ( t1' = = t2' )
1998-07-03 10:40:39 -07:00
let hash ( t , t' ) = t . id + 93 * t' . id
end )
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Miscellaneous operations on object types *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
1996-04-22 04:15:41 -07:00
1997-01-20 09:11:47 -08:00
(* * * * Object field manipulation. * * * *)
2003-11-25 01:20:45 -08:00
let dummy_method = " *dummy method* "
1998-06-24 12:22:26 -07:00
let object_fields ty =
match ( repr ty ) . desc with
Tobject ( fields , _ ) -> fields
| _ -> assert false
1996-04-22 04:15:41 -07:00
let flatten_fields ty =
let rec flatten l ty =
let ty = repr ty in
match ty . desc with
1998-06-24 12:22:26 -07:00
Tfield ( s , k , ty1 , ty2 ) ->
flatten ( ( s , k , ty1 ) :: l ) ty2
1996-04-22 04:15:41 -07:00
| _ ->
1997-03-07 14:44:02 -08:00
( l , ty )
1996-04-22 04:15:41 -07:00
in
let ( l , r ) = flatten [] ty in
1998-06-24 12:22:26 -07:00
( Sort . list ( fun ( n , _ , _ ) ( n' , _ , _ ) -> n < n' ) l , r )
1996-04-22 04:15:41 -07:00
1998-06-24 12:22:26 -07:00
let build_fields level =
List . fold_right
( fun ( s , k , ty1 ) ty2 -> newty2 level ( Tfield ( s , k , ty1 , ty2 ) ) )
1996-04-22 04:15:41 -07:00
let associate_fields fields1 fields2 =
let rec associate p s s' =
function
( l , [] ) ->
( List . rev p , ( List . rev s ) @ l , List . rev s' )
| ( [] , l' ) ->
( List . rev p , List . rev s , ( List . rev s' ) @ l' )
1997-05-11 14:35:00 -07:00
| ( ( n , k , t ) :: r , ( n' , k' , t' ) :: r' ) when n = n' ->
1998-06-24 12:22:26 -07:00
associate ( ( n , k , t , k' , t' ) :: p ) s s' ( r , r' )
1997-05-11 14:35:00 -07:00
| ( ( n , k , t ) :: r , ( ( n' , k' , t' ) :: _ as l' ) ) when n < n' ->
associate p ( ( n , k , t ) :: s ) s' ( r , l' )
| ( ( ( n , k , t ) :: r as l ) , ( n' , k' , t' ) :: r' ) (* when n > n' *) ->
associate p s ( ( n' , k' , t' ) :: s' ) ( l , r' )
1998-06-24 12:22:26 -07:00
in
associate [] [] [] ( fields1 , fields2 )
1996-04-22 04:15:41 -07:00
1997-01-20 09:11:47 -08:00
(* * * * Check whether an object is open * * * *)
1996-04-22 04:15:41 -07:00
1997-03-08 14:05:39 -08:00
(* +++ Il faudra penser a eventuellement expanser l'abreviation *)
2005-08-16 22:38:23 -07:00
let rec object_row ty =
let ty = repr ty in
match ty . desc with
Tobject ( t , _ ) -> object_row t
| Tfield ( _ , _ , _ , t ) -> object_row t
| _ -> ty
let opened_object ty =
match ( object_row ty ) . desc with
1997-05-11 14:35:00 -07:00
| Tvar -> true
2004-07-13 05:25:21 -07:00
| Tunivar -> true
2005-03-22 19:08:37 -08:00
| Tconstr _ -> true
1997-05-11 14:35:00 -07:00
| _ -> false
1996-04-22 04:15:41 -07:00
1997-01-21 05:38:42 -08:00
(* * * * Close an object * * * *)
let close_object ty =
let rec close ty =
let ty = repr ty in
match ty . desc with
2002-11-20 21:39:01 -08:00
Tvar ->
link_type ty ( newty2 ty . level Tnil )
1998-06-24 12:22:26 -07:00
| Tfield ( _ , _ , _ , ty' ) -> close ty'
| _ -> assert false
1997-01-21 05:38:42 -08:00
in
match ( repr ty ) . desc with
Tobject ( ty , _ ) -> close ty
1998-06-24 12:22:26 -07:00
| _ -> assert false
(* * * * Row variable of an object type * * * *)
1997-01-21 05:38:42 -08:00
1998-06-24 12:22:26 -07:00
let row_variable ty =
let rec find ty =
let ty = repr ty in
match ty . desc with
Tfield ( _ , _ , _ , ty ) -> find ty
| Tvar -> ty
| _ -> assert false
in
match ( repr ty ) . desc with
Tobject ( fi , _ ) -> find fi
| _ -> assert false
1997-01-21 05:38:42 -08:00
(* * * * Object name manipulation * * * *)
1997-03-08 14:05:39 -08:00
(* +++ Bientot obsolete *)
1997-01-21 05:38:42 -08:00
1998-06-24 12:22:26 -07:00
let set_object_name id rv params ty =
1997-01-21 05:38:42 -08:00
match ( repr ty ) . desc with
Tobject ( fi , nm ) ->
2002-11-20 22:22:02 -08:00
set_name nm ( Some ( Path . Pident id , rv :: params ) )
1997-01-21 05:38:42 -08:00
| _ ->
1998-06-24 12:22:26 -07:00
assert false
1997-01-21 05:38:42 -08:00
let remove_object_name ty =
match ( repr ty ) . desc with
2002-11-20 22:22:02 -08:00
Tobject ( _ , nm ) -> set_name nm None
1997-01-21 05:38:42 -08:00
| Tconstr ( _ , _ , _ ) -> ()
| _ -> fatal_error " Ctype.remove_object_name "
1997-05-11 14:35:00 -07:00
(* * * * Hiding of private methods * * * *)
let hide_private_methods ty =
2005-09-19 21:08:49 -07:00
match ( repr ty ) . desc with
Tobject ( fi , nm ) ->
nm := None ;
let ( fl , _ ) = flatten_fields fi in
List . iter
( function ( _ , k , _ ) ->
match field_kind_repr k with
Fvar r -> set_kind r Fabsent
| _ -> () )
fl
| _ ->
assert false
1998-06-24 12:22:26 -07:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Operations on class types *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
let rec signature_of_class_type =
function
Tcty_constr ( _ , _ , cty ) -> signature_of_class_type cty
| Tcty_signature sign -> sign
1999-11-30 08:07:38 -08:00
| Tcty_fun ( _ , ty , cty ) -> signature_of_class_type cty
1998-06-24 12:22:26 -07:00
let self_type cty =
repr ( signature_of_class_type cty ) . cty_self
let rec class_type_arity =
function
Tcty_constr ( _ , _ , cty ) -> class_type_arity cty
| Tcty_signature _ -> 0
1999-11-30 08:07:38 -08:00
| Tcty_fun ( _ , _ , cty ) -> 1 + class_type_arity cty
1998-06-24 12:22:26 -07:00
1999-11-30 08:07:38 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Miscellaneous operations on row types *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
let sort_row_fields = Sort . list ( fun ( p , _ ) ( q , _ ) -> p < q )
2008-01-11 08:13:18 -08:00
let rec merge_rf r1 r2 pairs fi1 fi2 =
match fi1 , fi2 with
( l1 , f1 as p1 ) :: fi1' , ( l2 , f2 as p2 ) :: fi2' ->
if l1 = l2 then merge_rf r1 r2 ( ( l1 , f1 , f2 ) :: pairs ) fi1' fi2' else
if l1 < l2 then merge_rf ( p1 :: r1 ) r2 pairs fi1' fi2 else
merge_rf r1 ( p2 :: r2 ) pairs fi1 fi2'
| [] , _ -> ( List . rev r1 , List . rev_append r2 fi2 , pairs )
| _ , [] -> ( List . rev_append r1 fi1 , List . rev r2 , pairs )
1999-11-30 08:07:38 -08:00
let merge_row_fields fi1 fi2 =
2008-01-11 08:13:18 -08:00
match fi1 , fi2 with
[] , _ | _ , [] -> ( fi1 , fi2 , [] )
| [ p1 ] , _ when not ( List . mem_assoc ( fst p1 ) fi2 ) -> ( fi1 , fi2 , [] )
| _ , [ p2 ] when not ( List . mem_assoc ( fst p2 ) fi1 ) -> ( fi1 , fi2 , [] )
| _ -> merge_rf [] [] [] ( sort_row_fields fi1 ) ( sort_row_fields fi2 )
1999-11-30 08:07:38 -08:00
let rec filter_row_fields erase = function
[] -> []
| ( l , f as p ) :: fi ->
let fi = filter_row_fields erase fi in
match row_field_repr f with
Rabsent -> fi
2002-11-20 21:39:01 -08:00
| Reither ( _ , _ , false , e ) when erase -> set_row_field e Rabsent ; fi
1999-11-30 08:07:38 -08:00
| _ -> p :: fi
1998-06-24 12:22:26 -07:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Check genericity of type schemes *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
exception Non_closed
let rec closed_schema_rec ty =
1997-05-11 14:35:00 -07:00
let ty = repr ty in
1998-06-24 12:22:26 -07:00
if ty . level > = lowest_level then begin
let level = ty . level in
ty . level <- pivot_level - level ;
match ty . desc with
Tvar when level < > generic_level ->
raise Non_closed
| Tfield ( _ , kind , t1 , t2 ) ->
if field_kind_repr kind = Fpresent then
closed_schema_rec t1 ;
closed_schema_rec t2
2002-05-29 23:24:45 -07:00
| Tvariant row ->
let row = row_repr row in
2008-01-11 08:13:18 -08:00
iter_row closed_schema_rec row ;
2002-05-29 23:24:45 -07:00
if not ( static_row row ) then closed_schema_rec row . row_more
1998-06-24 12:22:26 -07:00
| _ ->
iter_type_expr closed_schema_rec ty
end
(* Return whether all variables of type [ty] are generic. *)
let closed_schema ty =
try
closed_schema_rec ty ;
unmark_type ty ;
true
with Non_closed ->
unmark_type ty ;
false
1998-11-30 05:06:53 -08:00
exception Non_closed of type_expr * bool
1998-06-24 12:22:26 -07:00
let free_variables = ref []
2009-05-20 04:52:42 -07:00
let really_closed = ref None
1998-06-24 12:22:26 -07:00
1998-11-30 05:06:53 -08:00
let rec free_vars_rec real ty =
1998-06-24 12:22:26 -07:00
let ty = repr ty in
if ty . level > = lowest_level then begin
1998-11-30 05:06:53 -08:00
ty . level <- pivot_level - ty . level ;
2009-05-20 04:52:42 -07:00
begin match ty . desc , ! really_closed with
Tvar , _ ->
1998-11-30 05:06:53 -08:00
free_variables := ( ty , real ) :: ! free_variables
2009-05-20 04:52:42 -07:00
| Tconstr ( path , tl , _ ) , Some env ->
begin try
let ( _ , body ) = Env . find_type_expansion path env in
if ( repr body ) . level < > generic_level then
free_variables := ( ty , real ) :: ! free_variables
with Not_found -> ()
end ;
List . iter ( free_vars_rec true ) tl
2000-05-10 19:22:54 -07:00
(* Do not count "virtual" free variables
1998-11-30 05:06:53 -08:00
| Tobject ( ty , { contents = Some ( _ , p ) } ) ->
free_vars_rec false ty ; List . iter ( free_vars_rec true ) p
2000-05-10 19:22:54 -07:00
* )
2009-05-20 04:52:42 -07:00
| Tobject ( ty , _ ) , _ ->
1998-11-30 05:06:53 -08:00
free_vars_rec false ty
2009-05-20 04:52:42 -07:00
| Tfield ( _ , _ , ty1 , ty2 ) , _ ->
1998-11-30 05:06:53 -08:00
free_vars_rec true ty1 ; free_vars_rec false ty2
2009-05-20 04:52:42 -07:00
| Tvariant row , _ ->
2000-05-10 19:22:54 -07:00
let row = row_repr row in
2008-01-11 08:13:18 -08:00
iter_row ( free_vars_rec true ) row ;
2002-04-18 00:27:47 -07:00
if not ( static_row row ) then free_vars_rec false row . row_more
1998-11-30 05:06:53 -08:00
| _ ->
iter_type_expr ( free_vars_rec true ) ty
1998-06-24 12:22:26 -07:00
end ;
end
2009-05-20 04:52:42 -07:00
let free_vars ? env ty =
1998-06-24 12:22:26 -07:00
free_variables := [] ;
2009-05-20 04:52:42 -07:00
really_closed := env ;
1998-11-30 05:06:53 -08:00
free_vars_rec true ty ;
1998-06-24 12:22:26 -07:00
let res = ! free_variables in
free_variables := [] ;
2009-05-20 04:52:42 -07:00
really_closed := None ;
1998-06-24 12:22:26 -07:00
res
2009-05-20 04:52:42 -07:00
let free_variables ? env ty =
let tl = List . map fst ( free_vars ? env ty ) in
2010-09-26 22:38:32 -07:00
unmark_type ty ;
2004-12-09 04:40:53 -08:00
tl
1998-06-24 12:22:26 -07:00
let rec closed_type ty =
match free_vars ty with
1998-11-30 05:06:53 -08:00
[] -> ()
| ( v , real ) :: _ -> raise ( Non_closed ( v , real ) )
1998-06-24 12:22:26 -07:00
let closed_parameterized_type params ty =
List . iter mark_type params ;
2007-10-08 07:19:34 -07:00
let ok =
try closed_type ty ; true with Non_closed _ -> false in
List . iter unmark_type params ;
unmark_type ty ;
ok
1998-06-24 12:22:26 -07:00
let closed_type_decl decl =
try
List . iter mark_type decl . type_params ;
2003-07-02 02:14:35 -07:00
begin match decl . type_kind with
1998-06-24 12:22:26 -07:00
Type_abstract ->
()
2010-09-12 22:28:30 -07:00
| 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 ? *)
2007-10-09 03:29:37 -07:00
| Type_variant v ->
2010-09-12 22:28:30 -07:00
List . iter
( fun ( _ , tyl ) ->
List . iter closed_type tyl )
v (* GAH: is this correct ? *)
2007-10-09 03:29:37 -07:00
| Type_record ( r , rep ) ->
1998-06-24 12:22:26 -07:00
List . iter ( fun ( _ , _ , ty ) -> closed_type ty ) r
2003-07-02 02:14:35 -07:00
end ;
1998-06-24 12:22:26 -07:00
begin match decl . type_manifest with
None -> ()
| Some ty -> closed_type ty
end ;
unmark_type_decl decl ;
None
1998-11-30 05:06:53 -08:00
with Non_closed ( ty , _ ) ->
1998-06-24 12:22:26 -07:00
unmark_type_decl decl ;
Some ty
type closed_class_failure =
1998-11-30 05:06:53 -08:00
CC_Method of type_expr * bool * string * type_expr
| CC_Value of type_expr * bool * string * type_expr
1998-06-24 12:22:26 -07:00
exception Failure of closed_class_failure
let closed_class params sign =
let ty = object_fields ( repr sign . cty_self ) in
let ( fields , rest ) = flatten_fields ty in
List . iter mark_type params ;
mark_type rest ;
List . iter
2003-11-25 01:20:45 -08:00
( fun ( lab , _ , ty ) -> if lab = dummy_method then mark_type ty )
1998-06-24 12:22:26 -07:00
fields ;
try
1998-10-10 10:57:27 -07:00
mark_type_node ( repr sign . cty_self ) ;
1998-08-15 22:36:15 -07:00
List . iter
( fun ( lab , kind , ty ) ->
if field_kind_repr kind = Fpresent then
1998-11-30 05:06:53 -08:00
try closed_type ty with Non_closed ( ty0 , real ) ->
raise ( Failure ( CC_Method ( ty0 , real , lab , ty ) ) ) )
1998-08-15 22:36:15 -07:00
fields ;
1998-10-10 10:57:27 -07:00
mark_type_params ( repr sign . cty_self ) ;
1998-06-24 12:22:26 -07:00
List . iter unmark_type params ;
unmark_class_signature sign ;
None
with Failure reason ->
1998-11-30 05:06:53 -08:00
mark_type_params ( repr sign . cty_self ) ;
1998-06-24 12:22:26 -07:00
List . iter unmark_type params ;
unmark_class_signature sign ;
Some reason
(* * * * * * * * * * * * * * * * * * * * * *)
(* Type duplication *)
(* * * * * * * * * * * * * * * * * * * * * *)
(* Duplicate a type, preserving only type variables *)
let duplicate_type ty =
Subst . type_expr Subst . identity ty
(* Same, for class types *)
let duplicate_class_type ty =
Subst . class_type Subst . identity ty
1997-05-11 14:35:00 -07:00
1997-01-23 04:46:46 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Type level manipulation *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
1997-02-20 12:39:02 -08:00
(*
It would be a bit more efficient to remove abbreviation expansions
rather than generalizing them : these expansions will usually not be
used anymore . However , this is not possible in the general case , as
[ expand_abbrev ] ( via [ subst ] ) requires these expansions to be
preserved . Does it worth duplicating this code ?
* )
1998-06-24 12:22:26 -07:00
let rec iter_generalize tyl ty =
1997-01-24 12:54:56 -08:00
let ty = repr ty in
1997-03-24 12:12:00 -08:00
if ( ty . level > ! current_level ) && ( ty . level < > generic_level ) then begin
2002-11-20 21:39:01 -08:00
set_level ty generic_level ;
1997-01-24 12:54:56 -08:00
begin match ty . desc with
Tconstr ( _ , _ , abbrev ) ->
2002-04-18 00:27:47 -07:00
iter_abbrev ( iter_generalize tyl ) ! abbrev
1997-01-24 12:54:56 -08:00
| _ -> ()
end ;
1998-06-24 12:22:26 -07:00
iter_type_expr ( iter_generalize tyl ) ty
end else
tyl := ty :: ! tyl
1997-01-24 12:54:56 -08:00
2002-04-18 00:27:47 -07:00
let iter_generalize tyl ty =
simple_abbrevs := Mnil ;
iter_generalize tyl ty
1998-06-24 12:22:26 -07:00
2002-04-18 00:27:47 -07:00
let generalize ty =
1998-06-24 12:22:26 -07:00
iter_generalize ( ref [] ) ty
(* Efficient repeated generalisation of the same type *)
let iterative_generalization min_level tyl =
let tyl' = ref [] in
List . iter ( iter_generalize tyl' ) tyl ;
List . fold_right ( fun ty l -> if ty . level < = min_level then l else ty :: l )
! tyl' []
1997-01-24 12:54:56 -08:00
2002-04-18 00:27:47 -07:00
(* Generalize the structure and lower the variables *)
let rec generalize_structure var_level ty =
let ty = repr ty in
if ty . level < > generic_level then begin
if ty . desc = Tvar && ty . level > var_level then
2002-11-20 21:39:01 -08:00
set_level ty var_level
2002-04-18 00:27:47 -07:00
else if ty . level > ! current_level then begin
2002-11-20 21:39:01 -08:00
set_level ty generic_level ;
2002-04-18 00:27:47 -07:00
begin match ty . desc with
2002-12-02 18:57:23 -08:00
Tconstr ( _ , _ , abbrev ) -> abbrev := Mnil
2002-04-18 00:27:47 -07:00
| _ -> ()
end ;
iter_type_expr ( generalize_structure var_level ) ty
end
end
let generalize_structure var_level ty =
simple_abbrevs := Mnil ;
generalize_structure var_level ty
2002-12-02 18:57:23 -08:00
(* let generalize_expansive ty = generalize_structure !nongen_level ty *)
2002-04-18 00:27:47 -07:00
let generalize_global ty = generalize_structure ! global_level ty
let generalize_structure ty = generalize_structure ! current_level ty
(* Generalize the spine of a function, if the level >= !current_level *)
let rec generalize_spine ty =
let ty = repr ty in
if ty . level < ! current_level | | ty . level = generic_level then () else
match ty . desc with
Tarrow ( _ , _ , ty' , _ ) | Tpoly ( ty' , _ ) ->
2002-11-20 21:39:01 -08:00
set_level ty generic_level ;
2002-04-18 00:27:47 -07:00
generalize_spine ty'
| _ -> ()
2007-11-01 11:36:43 -07:00
let forward_try_expand_once = (* Forward declaration *)
1997-06-29 06:16:47 -07:00
ref ( fun env ty -> raise Cannot_expand )
1997-01-23 04:46:46 -08:00
1997-02-20 12:39:02 -08:00
(*
1997-03-07 14:44:02 -08:00
Lower the levels of a type ( assume [ level ] is not
[ generic_level ] ) .
* )
(*
The level of a type constructor must be greater than its binding
1997-02-20 12:39:02 -08:00
time . That way , a type constructor cannot escape the scope of its
definition , as would be the case in
let x = ref []
module M = struct type t let _ = ( x : t list ref ) end
1997-03-18 13:05:15 -08:00
( without this constraint , the type system would actually be unsound . )
1997-02-20 12:39:02 -08:00
* )
1997-01-23 04:46:46 -08:00
let rec update_level env level ty =
1996-04-22 04:15:41 -07:00
let ty = repr ty in
1997-01-21 05:38:42 -08:00
if ty . level > level then begin
begin match ty . desc with
1997-01-23 04:46:46 -08:00
Tconstr ( p , tl , abbrev ) when level < Path . binding_time p ->
1997-01-24 12:54:56 -08:00
(* Try first to replace an abbreviation by its expansion. *)
1997-01-23 04:46:46 -08:00
begin try
2007-11-01 11:36:43 -07:00
link_type ty ( ! forward_try_expand_once env ty ) ;
1997-03-07 14:44:02 -08:00
update_level env level ty
1997-01-23 04:46:46 -08:00
with Cannot_expand ->
1997-03-09 16:19:08 -08:00
(* +++ Levels should be restored... *)
1998-06-24 12:22:26 -07:00
raise ( Unify [ ( ty , newvar2 level ) ] )
1997-01-23 04:46:46 -08:00
end
2009-10-26 03:53:16 -07:00
| Tpackage ( p , _ , _ ) when level < Path . binding_time p ->
raise ( Unify [ ( ty , newvar2 level ) ] )
2002-06-07 16:08:33 -07:00
| Tobject ( _ , ( { contents = Some ( p , tl ) } as nm ) )
when level < Path . binding_time p ->
2002-11-20 22:22:02 -08:00
set_name nm None ;
2002-06-07 16:08:33 -07:00
update_level env level ty
| Tvariant row ->
let row = row_repr row in
begin match row . row_name with
| Some ( p , tl ) when level < Path . binding_time p ->
2002-11-20 21:39:01 -08:00
log_type ty ;
2002-06-07 16:08:33 -07:00
ty . desc <- Tvariant { row with row_name = None }
| _ -> ()
end ;
2002-11-20 21:39:01 -08:00
set_level ty level ;
2002-06-07 16:08:33 -07:00
iter_type_expr ( update_level env level ) ty
2003-11-25 01:20:45 -08:00
| Tfield ( lab , _ , _ , _ ) when lab = dummy_method ->
raise ( Unify [ ( ty , newvar2 level ) ] )
1997-01-24 12:54:56 -08:00
| _ ->
2002-11-20 21:39:01 -08:00
set_level ty level ;
2002-12-02 18:57:23 -08:00
(* XXX what about abbreviations in Tconstr ? *)
1997-01-24 12:54:56 -08:00
iter_type_expr ( update_level env level ) ty
1997-03-08 04:14:57 -08:00
end
1996-04-22 04:15:41 -07:00
end
2002-12-02 18:57:23 -08:00
(* Generalize and lower levels of contravariant branches simultaneously *)
let rec generalize_expansive env var_level ty =
let ty = repr ty in
if ty . level < > generic_level then begin
if ty . level > var_level then begin
set_level ty generic_level ;
match ty . desc with
Tconstr ( path , tyl , abbrev ) ->
let variance =
try ( Env . find_type path env ) . type_variance
2003-05-21 02:04:54 -07:00
with Not_found -> List . map ( fun _ -> ( true , true , true ) ) tyl in
2002-12-02 18:57:23 -08:00
abbrev := Mnil ;
List . iter2
2003-05-21 02:04:54 -07:00
( fun ( co , cn , ct ) t ->
if ct then update_level env var_level t
2002-12-02 18:57:23 -08:00
else generalize_expansive env var_level t )
variance tyl
2009-10-26 03:53:16 -07:00
| Tpackage ( _ , _ , tyl ) ->
List . iter ( update_level env var_level ) tyl
2002-12-02 18:57:23 -08:00
| Tarrow ( _ , t1 , t2 , _ ) ->
update_level env var_level t1 ;
generalize_expansive env var_level t2
| _ ->
iter_type_expr ( generalize_expansive env var_level ) ty
end
end
let generalize_expansive env ty =
simple_abbrevs := Mnil ;
1998-06-24 12:22:26 -07:00
try
2002-12-02 18:57:23 -08:00
generalize_expansive env ! nongen_level ty
1998-06-24 12:22:26 -07:00
with Unify [ _ , ty' ] ->
raise ( Unify [ ty , ty' ] )
1996-04-22 04:15:41 -07:00
1997-03-14 07:19:48 -08:00
(* Correct the levels of type [ty]. *)
1997-03-24 12:12:00 -08:00
let correct_levels ty =
1998-06-24 12:22:26 -07:00
duplicate_type ty
(* Only generalize the type ty0 in ty *)
let limited_generalize ty0 ty =
let ty0 = repr ty0 in
let graph = Hashtbl . create 17 in
let idx = ref lowest_level in
let roots = ref [] in
let rec inverse pty ty =
let ty = repr ty in
if ( ty . level > ! current_level ) | | ( ty . level = generic_level ) then begin
decr idx ;
Hashtbl . add graph ! idx ( ty , ref pty ) ;
if ( ty . level = generic_level ) | | ( ty = = ty0 ) then
roots := ty :: ! roots ;
2002-11-20 21:39:01 -08:00
set_level ty ! idx ;
2001-11-23 06:28:21 -08:00
iter_type_expr ( inverse [ ty ] ) ty
1998-06-24 12:22:26 -07:00
end else if ty . level < lowest_level then begin
let ( _ , parents ) = Hashtbl . find graph ty . level in
parents := pty @ ! parents
end
and generalize_parents ty =
let idx = ty . level in
if idx < > generic_level then begin
2002-11-20 21:39:01 -08:00
set_level ty generic_level ;
2004-09-21 05:08:12 -07:00
List . iter generalize_parents ! ( snd ( Hashtbl . find graph idx ) ) ;
(* Special case for rows: must generalize the row variable *)
match ty . desc with
Tvariant row ->
let more = row_more row in
2005-11-14 00:07:12 -08:00
let lv = more . level in
if ( lv < lowest_level | | lv > ! current_level )
&& lv < > generic_level then set_level more generic_level
2004-09-21 05:08:12 -07:00
| _ -> ()
1998-06-24 12:22:26 -07:00
end
in
inverse [] ty ;
if ty0 . level < lowest_level then
iter_type_expr ( inverse [] ) ty0 ;
List . iter generalize_parents ! roots ;
Hashtbl . iter
( fun _ ( ty , _ ) ->
2002-11-20 21:39:01 -08:00
if ty . level < > generic_level then set_level ty ! current_level )
1998-06-24 12:22:26 -07:00
graph
1997-03-13 13:18:06 -08:00
1995-05-04 03:15:53 -07:00
1997-01-20 09:11:47 -08:00
(* * * * * * * * * * * * * * * * * * *)
(* Instantiation *)
(* * * * * * * * * * * * * * * * * * *)
1997-01-21 09:43:53 -08:00
1998-06-24 12:22:26 -07:00
let rec find_repr p1 =
function
Mnil ->
None
2008-07-18 19:13:09 -07:00
| Mcons ( Public , p2 , ty , _ , _ ) when Path . same p1 p2 ->
1998-06-24 12:22:26 -07:00
Some ty
2008-07-18 19:13:09 -07:00
| Mcons ( _ , _ , _ , _ , rem ) ->
1998-06-24 12:22:26 -07:00
find_repr p1 rem
| Mlink { contents = rem } ->
find_repr p1 rem
1997-01-21 05:38:42 -08:00
(*
Generic nodes are duplicated , while non - generic nodes are left
1997-03-24 12:12:00 -08:00
as - is .
1997-01-21 05:38:42 -08:00
During instantiation , the description of a generic node is first
1999-11-30 08:07:38 -08:00
replaced by a link to a stub ( [ Tsubst ( newvar () ) ] ) . Once the
1997-03-24 12:12:00 -08:00
copy is made , it replaces the stub .
1997-01-21 05:38:42 -08:00
After instantiation , the description of generic node , which was
1997-03-24 12:12:00 -08:00
stored by [ save_desc ] , must be put back , using [ cleanup_types ] .
1997-01-21 05:38:42 -08:00
* )
1995-11-16 05:27:53 -08:00
1997-01-21 09:43:53 -08:00
let abbreviations = ref ( ref Mnil )
1997-01-21 05:38:42 -08:00
(* Abbreviation memorized. *)
1997-03-14 07:19:48 -08:00
let rec copy ty =
1997-03-07 14:44:02 -08:00
let ty = repr ty in
1999-11-30 08:07:38 -08:00
match ty . desc with
Tsubst ty -> ty
| _ ->
if ty . level < > generic_level then ty else
1997-03-07 14:44:02 -08:00
let desc = ty . desc in
1997-03-24 12:12:00 -08:00
save_desc ty desc ;
1999-11-30 08:07:38 -08:00
let t = newvar () in (* Stub *)
ty . desc <- Tsubst t ;
1997-03-07 14:44:02 -08:00
t . desc <-
begin match desc with
| Tconstr ( p , tl , _ ) ->
2002-04-18 01:06:13 -07:00
let abbrevs = proper_abbrevs p tl ! abbreviations in
2002-04-18 00:27:47 -07:00
begin match find_repr p ! abbrevs with
1998-08-15 06:43:10 -07:00
Some ty when repr ty != t -> (* XXX Commentaire... *)
1998-06-24 12:22:26 -07:00
Tlink ty
| _ ->
1997-03-07 14:44:02 -08:00
(*
One must allocate a new reference , so that abbrevia -
tions belonging to different branches of a type are
independent .
Moreover , a reference containing a [ Mcons ] must be
shared , so that the memorized expansion of an abbrevi -
ation can be released by changing the content of just
one reference .
* )
1998-06-24 12:22:26 -07:00
Tconstr ( p , List . map copy tl ,
ref ( match ! ( ! abbreviations ) with
Mcons _ -> Mlink ! abbreviations
| abbrev -> abbrev ) )
end
1999-11-30 08:07:38 -08:00
| Tvariant row0 ->
let row = row_repr row0 in
let more = repr row . row_more in
(* We must substitute in a subtle way *)
2003-06-25 00:52:27 -07:00
(* Tsubst takes a tuple containing the row var and the variant *)
1999-11-30 08:07:38 -08:00
begin match more . desc with
2003-06-25 00:52:27 -07:00
Tsubst { desc = Ttuple [ _ ; ty2 ] } ->
1999-11-30 08:07:38 -08:00
(* This variant type has been already copied *)
ty . desc <- Tsubst ty2 ; (* avoid Tlink in the new type *)
Tlink ty2
| _ ->
2001-11-23 06:28:21 -08:00
(* If the row variable is not generic, we must keep it *)
let keep = more . level < > generic_level in
2002-09-10 23:09:26 -07:00
let more' =
2005-03-22 19:08:37 -08:00
match more . desc with
2006-09-20 04:14:37 -07:00
Tsubst ty -> ty
| Tconstr _ ->
if keep then save_desc more more . desc ;
copy more
2005-03-22 19:08:37 -08:00
| Tvar | Tunivar ->
2002-09-10 23:09:26 -07:00
save_desc more more . desc ;
if keep then more else newty more . desc
2006-09-20 04:14:37 -07:00
| _ -> assert false
2002-09-10 23:09:26 -07:00
in
2001-11-15 23:26:56 -08:00
(* Register new type first for recursion *)
2003-06-25 00:52:27 -07:00
more . desc <- Tsubst ( newgenty ( Ttuple [ more' ; t ] ) ) ;
2001-11-22 02:41:29 -08:00
(* Return a new copy *)
2002-04-18 00:27:47 -07:00
Tvariant ( copy_row copy true row keep more' )
1997-05-11 14:35:00 -07:00
end
2006-01-04 08:55:50 -08:00
| Tfield ( p , k , ty1 , ty2 ) ->
begin match field_kind_repr k with
Fabsent -> Tlink ( copy ty2 )
| Fpresent -> copy_type_desc copy desc
| Fvar r ->
dup_kind r ;
copy_type_desc copy desc
end
2001-11-22 02:41:29 -08:00
| _ -> copy_type_desc copy desc
1997-03-07 14:44:02 -08:00
end ;
t
1996-04-22 04:15:41 -07:00
1997-01-21 05:38:42 -08:00
(* * * * Variants of instantiations * * * *)
1995-05-04 03:15:53 -07:00
let instance sch =
1997-03-14 07:19:48 -08:00
let ty = copy sch in
1997-01-21 05:38:42 -08:00
cleanup_types () ;
1995-05-04 03:15:53 -07:00
ty
1997-02-20 12:39:02 -08:00
let instance_list schl =
1997-03-14 07:19:48 -08:00
let tyl = List . map copy schl in
1997-02-20 12:39:02 -08:00
cleanup_types () ;
tyl
2010-09-22 00:52:36 -07:00
let reified_var_counter = ref 0
let get_new_abstract_name () =
let ret = Printf . sprintf " &x%d " ! reified_var_counter in
incr reified_var_counter ;
ret
let instance_constructor ? ( in_pattern = None ) cstr = (* GAH : how the blazes does this work?? *)
1997-03-14 07:19:48 -08:00
let ty_res = copy cstr . cstr_res in
let ty_args = List . map copy cstr . cstr_args in
2010-09-22 00:52:36 -07:00
begin match in_pattern with
| None -> ()
| Some env ->
let existentials = List . map copy cstr . cstr_existentials in
let process existential =
let decl = {
type_params = [] ;
type_arity = 0 ;
type_kind = Type_abstract ;
type_private = Public ;
type_manifest = None ;
type_variance = [] ;
2010-10-07 00:12:50 -07:00
type_newtype = false ;
2010-09-22 00:52:36 -07:00
}
in
let ( id , new_env ) = Env . enter_type ( get_new_abstract_name () ) decl ! env in
2010-09-26 22:38:32 -07:00
let to_unify = newty ( Tconstr ( Path . Pident id , [] , ref Mnil ) ) in
2010-09-22 00:52:36 -07:00
link_type existential to_unify
in
List . iter process existentials end ;
1997-01-21 05:38:42 -08:00
cleanup_types () ;
1995-05-04 03:15:53 -07:00
( ty_args , ty_res )
1996-04-22 04:15:41 -07:00
let instance_parameterized_type sch_args sch =
1997-03-14 07:19:48 -08:00
let ty_args = List . map copy sch_args in
let ty = copy sch in
1997-01-21 05:38:42 -08:00
cleanup_types () ;
1996-04-22 04:15:41 -07:00
( ty_args , ty )
let instance_parameterized_type_2 sch_args sch_lst sch =
1997-03-14 07:19:48 -08:00
let ty_args = List . map copy sch_args in
let ty_lst = List . map copy sch_lst in
let ty = copy sch in
1997-01-21 05:38:42 -08:00
cleanup_types () ;
1996-04-22 04:15:41 -07:00
( ty_args , ty_lst , ty )
1998-06-24 12:22:26 -07:00
let instance_class params cty =
let rec copy_class_type =
function
Tcty_constr ( path , tyl , cty ) ->
Tcty_constr ( path , List . map copy tyl , copy_class_type cty )
| Tcty_signature sign ->
Tcty_signature
{ cty_self = copy sign . cty_self ;
cty_vars =
2006-04-04 19:28:13 -07:00
Vars . map ( function ( m , v , ty ) -> ( m , v , copy ty ) ) sign . cty_vars ;
2004-05-18 06:28:00 -07:00
cty_concr = sign . cty_concr ;
cty_inher =
List . map ( fun ( p , tl ) -> ( p , List . map copy tl ) ) sign . cty_inher }
1999-11-30 08:07:38 -08:00
| Tcty_fun ( l , ty , cty ) ->
Tcty_fun ( l , copy ty , copy_class_type cty )
1998-06-24 12:22:26 -07:00
in
let params' = List . map copy params in
let cty' = copy_class_type cty in
1997-01-21 05:38:42 -08:00
cleanup_types () ;
1998-06-24 12:22:26 -07:00
( params' , cty' )
1996-04-22 04:15:41 -07:00
2002-04-18 00:27:47 -07:00
(* * * * Instanciation for types with free universal variables * * * *)
type inv_type_expr =
{ inv_type : type_expr ;
mutable inv_parents : inv_type_expr list }
let rec inv_type hash pty ty =
let ty = repr ty in
try
let inv = TypeHash . find hash ty in
inv . inv_parents <- pty @ inv . inv_parents
with Not_found ->
let inv = { inv_type = ty ; inv_parents = pty } in
TypeHash . add hash ty inv ;
iter_type_expr ( inv_type hash [ inv ] ) ty
let compute_univars ty =
let inverted = TypeHash . create 17 in
inv_type inverted [] ty ;
let node_univars = TypeHash . create 17 in
let rec add_univar univ inv =
match inv . inv_type . desc with
Tpoly ( ty , tl ) when List . memq univ ( List . map repr tl ) -> ()
| _ ->
try
let univs = TypeHash . find node_univars inv . inv_type in
if not ( TypeSet . mem univ ! univs ) then begin
univs := TypeSet . add univ ! univs ;
List . iter ( add_univar univ ) inv . inv_parents
end
with Not_found ->
TypeHash . add node_univars inv . inv_type ( ref ( TypeSet . singleton univ ) ) ;
List . iter ( add_univar univ ) inv . inv_parents
in
2004-10-13 02:33:09 -07:00
TypeHash . iter ( fun ty inv -> if ty . desc = Tunivar then add_univar ty inv )
2002-04-18 00:27:47 -07:00
inverted ;
fun ty ->
try ! ( TypeHash . find node_univars ty ) with Not_found -> TypeSet . empty
2004-10-13 02:33:09 -07:00
2002-04-18 00:27:47 -07:00
let rec diff_list l1 l2 =
if l1 = = l2 then [] else
match l1 with [] -> invalid_arg " Ctype.diff_list "
| a :: l1 -> a :: diff_list l1 l2
let conflicts free bound =
let bound = List . map repr bound in
TypeSet . exists ( fun t -> List . memq ( repr t ) bound ) free
let delayed_copy = ref []
(* copying to do later *)
(* Copy without sharing until there are no free univars left *)
(* all free univars must be included in [visited] *)
let rec copy_sep fixed free bound visited ty =
let ty = repr ty in
let univars = free ty in
2006-09-20 04:14:37 -07:00
if TypeSet . is_empty univars then
2002-04-18 00:27:47 -07:00
if ty . level < > generic_level then ty else
let t = newvar () in
delayed_copy :=
lazy ( t . desc <- Tlink ( copy ty ) )
:: ! delayed_copy ;
t
else try
let t , bound_t = List . assq ty visited in
let dl = if ty . desc = Tunivar then [] else diff_list bound bound_t in
if dl < > [] && conflicts univars dl then raise Not_found ;
t
with Not_found -> begin
let t = newvar () in (* Stub *)
let visited =
match ty . desc with
2009-10-26 03:53:16 -07:00
Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ ->
2002-04-18 00:27:47 -07:00
( ty , ( t , bound ) ) :: visited
2002-07-23 07:12:03 -07:00
| _ -> visited in
2002-04-18 00:27:47 -07:00
let copy_rec = copy_sep fixed free bound visited in
t . desc <-
begin match ty . desc with
| Tvariant row0 ->
let row = row_repr row0 in
let more = repr row . row_more in
(* We shall really check the level on the row variable *)
let keep = more . desc = Tvar && more . level < > generic_level in
let more' = copy_rec more in
2010-09-21 00:25:08 -07:00
let fixed' = fixed && ( repr more' ) . desc = Tvar in
2005-03-22 19:08:37 -08:00
let row = copy_row copy_rec fixed' row keep more' in
2002-04-18 00:27:47 -07:00
Tvariant row
2002-07-23 07:12:03 -07:00
| Tpoly ( t1 , tl ) ->
let tl = List . map repr tl in
let tl' = List . map ( fun t -> newty Tunivar ) tl in
let bound = tl @ bound in
let visited =
List . map2 ( fun ty t -> ty , ( t , bound ) ) tl tl' @ visited in
2003-03-25 23:24:17 -08:00
Tpoly ( copy_sep fixed free bound visited t1 , tl' )
2002-04-18 00:27:47 -07:00
| _ -> copy_type_desc copy_rec ty . desc
end ;
t
end
let instance_poly fixed univars sch =
2010-09-21 00:25:08 -07:00
let vars = List . map ( fun _ -> newvar () ) univars in
2002-04-18 00:27:47 -07:00
let pairs = List . map2 ( fun u v -> repr u , ( v , [] ) ) univars vars in
delayed_copy := [] ;
let ty = copy_sep fixed ( compute_univars sch ) [] pairs sch in
List . iter Lazy . force ! delayed_copy ;
delayed_copy := [] ;
cleanup_types () ;
vars , ty
let instance_label fixed lbl =
let ty_res = copy lbl . lbl_res in
let vars , ty_arg =
match repr lbl . lbl_arg with
{ desc = Tpoly ( ty , tl ) } ->
instance_poly fixed tl ty
| ty ->
[] , copy lbl . lbl_arg
in
cleanup_types () ;
( vars , ty_arg , ty_res )
1997-01-23 04:46:46 -08:00
(* * * * Instantiation with parameter substitution * * * *)
1997-01-21 05:38:42 -08:00
1997-02-20 12:39:02 -08:00
let unify' = (* Forward declaration *)
ref ( fun env ty1 ty2 -> raise ( Unify [] ) )
2008-07-18 19:13:09 -07:00
let rec subst env level priv abbrev ty params args body =
2002-08-04 22:57:24 -07:00
if List . length params < > List . length args then raise ( Unify [] ) ;
1997-03-24 12:12:00 -08:00
let old_level = ! current_level in
current_level := level ;
try
1997-02-20 12:39:02 -08:00
let body0 = newvar () in (* Stub *)
1998-06-24 12:22:26 -07:00
begin match ty with
1997-02-20 12:39:02 -08:00
None -> ()
2002-04-18 00:27:47 -07:00
| Some ( { desc = Tconstr ( path , tl , _ ) } as ty ) ->
2002-04-18 01:06:13 -07:00
let abbrev = proper_abbrevs path tl abbrev in
2008-07-18 19:13:09 -07:00
memorize_abbrev abbrev priv path ty body0
1998-06-24 12:22:26 -07:00
| _ ->
assert false
1997-02-20 12:39:02 -08:00
end ;
1997-01-21 05:38:42 -08:00
abbreviations := abbrev ;
1997-02-20 12:39:02 -08:00
let ( params' , body' ) = instance_parameterized_type params body in
1997-01-21 09:43:53 -08:00
abbreviations := ref Mnil ;
1997-02-20 12:39:02 -08:00
! unify' env body0 body' ;
List . iter2 ( ! unify' env ) params' args ;
1997-01-24 12:54:56 -08:00
current_level := old_level ;
1997-02-20 12:39:02 -08:00
body'
1997-03-24 12:12:00 -08:00
with Unify _ as exn ->
current_level := old_level ;
raise exn
1997-01-20 09:11:47 -08:00
1997-02-20 12:39:02 -08:00
(*
Only the shape of the type matters , not whether is is generic or
not . [ generic_level ] might be somewhat slower , but it ensures
invariants on types are enforced ( decreasing levels . ) , and we don't
care about efficiency here .
* )
1997-03-18 13:05:15 -08:00
let apply env params body args =
try
2008-07-18 19:13:09 -07:00
subst env generic_level Public ( ref Mnil ) None params args body
1997-03-18 13:05:15 -08:00
with
Unify _ -> raise Cannot_apply
1997-01-20 09:11:47 -08:00
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Abbreviation expansion *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * *)
1997-01-20 09:11:47 -08:00
2006-09-20 04:14:37 -07:00
(*
2003-05-07 18:44:22 -07:00
If the environnement has changed , memorized expansions might not
be correct anymore , and so we flush the cache . This is safe but
quite pessimistic : it would be enough to flush the cache when a
2010-05-21 05:00:49 -07:00
type or module definition is overridden in the environnement .
2003-05-07 18:44:22 -07:00
* )
1997-01-21 09:43:53 -08:00
let previous_env = ref Env . empty
2008-07-18 19:13:09 -07:00
let string_of_kind = function Public -> " public " | Private -> " private "
let check_abbrev_env env =
if env != ! previous_env then begin
(* prerr_endline "cleanup expansion cache"; *)
2003-05-07 18:44:22 -07:00
cleanup_abbrev () ;
2008-07-18 19:13:09 -07:00
previous_env := env
2003-05-07 18:44:22 -07:00
end
1996-04-22 04:15:41 -07:00
1997-01-23 04:46:46 -08:00
(* Expand an abbreviation. The expansion is memorized. *)
2006-09-20 04:14:37 -07:00
(*
1997-03-07 14:44:02 -08:00
Assume the level is greater than the path binding time of the
expanded abbreviation .
* )
1997-03-18 13:05:15 -08:00
(*
An abbreviation expansion will fail in either of these cases :
1 . The type constructor does not correspond to a manifest type .
2 . The type constructor is defined in an external file , and this
file is not in the path ( missing - I options ) .
3 . The type constructor is not in the " local " environment . This can
happens when a non - generic type variable has been instantiated
afterwards to the not yet defined type constructor . ( Actually ,
this cannot happen at the moment due to the strong constraints
between type levels and constructor binding time . )
4 . The expansion requires the expansion of another abbreviation ,
and this other expansion fails .
* )
2008-07-18 06:45:02 -07:00
let expand_abbrev_gen kind find_type_expansion env ty =
2008-07-18 19:13:09 -07:00
check_abbrev_env env ;
1998-06-24 12:22:26 -07:00
match ty with
{ desc = Tconstr ( path , args , abbrev ) ; level = level } ->
2002-04-18 01:06:13 -07:00
let lookup_abbrev = proper_abbrevs path args abbrev in
2008-07-18 19:13:09 -07:00
begin match find_expans kind path ! lookup_abbrev with
1998-06-24 12:22:26 -07:00
Some ty ->
2008-07-18 19:13:09 -07:00
(* prerr_endline
( " found a " ^ string_of_kind kind ^ " expansion for " ^ Path . name path ) ; * )
1998-06-24 12:22:26 -07:00
if level < > generic_level then
1998-11-30 05:06:53 -08:00
begin try
update_level env level ty
with Unify _ ->
(* XXX This should not happen.
However , levels are not correctly restored after a
typing error * )
()
end ;
1998-06-24 12:22:26 -07:00
ty
| None ->
let ( params , body ) =
2007-11-01 11:36:43 -07:00
try find_type_expansion path env with Not_found ->
1998-06-24 12:22:26 -07:00
raise Cannot_expand
in
2008-07-18 19:13:09 -07:00
(* prerr_endline
( " add a " ^ string_of_kind kind ^ " expansion for " ^ Path . name path ) ; * )
let ty' = subst env level kind abbrev ( Some ty ) params args body in
1999-11-30 08:07:38 -08:00
(* Hack to name the variant type *)
begin match repr ty' with
{ desc = Tvariant row } as ty when static_row row ->
ty . desc <- Tvariant { row with row_name = Some ( path , args ) }
| _ -> ()
end ;
ty'
1998-06-24 12:22:26 -07:00
end
| _ ->
assert false
1996-04-22 04:15:41 -07:00
2008-07-18 19:13:09 -07:00
let expand_abbrev = expand_abbrev_gen Public Env . find_type_expansion
2007-11-01 11:36:43 -07:00
2006-09-20 04:14:37 -07:00
let safe_abbrev env ty =
let snap = Btype . snapshot () in
try ignore ( expand_abbrev env ty ) ; true
with Cannot_expand | Unify _ ->
Btype . backtrack snap ;
false
2006-11-01 18:19:49 -08:00
let try_expand_once env ty =
let ty = repr ty in
match ty . desc with
Tconstr _ -> repr ( expand_abbrev env ty )
| _ -> raise Cannot_expand
2007-11-01 11:36:43 -07:00
let _ = forward_try_expand_once := try_expand_once
2006-11-01 18:19:49 -08:00
2006-01-04 08:55:50 -08:00
(* Fully expand the head of a type.
Raise Cannot_expand if the type cannot be expanded .
May raise Unify , if a recursion was hidden in the type . * )
1997-06-29 06:16:47 -07:00
let rec try_expand_head env ty =
2006-11-01 18:19:49 -08:00
let ty' = try_expand_once env ty in
begin try
try_expand_head env ty'
with Cannot_expand ->
ty'
end
1997-06-29 06:16:47 -07:00
2003-06-19 08:53:53 -07:00
(* Expand once the head of a type *)
let expand_head_once env ty =
try expand_abbrev env ( repr ty ) with Cannot_expand -> assert false
1997-06-29 06:16:47 -07:00
(* Fully expand the head of a type. *)
2006-09-20 04:14:37 -07:00
let expand_head_unif env ty =
try try_expand_head env ty with Cannot_expand -> repr ty
let expand_head env ty =
2006-01-04 08:55:50 -08:00
let snap = Btype . snapshot () in
try try_expand_head env ty
with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
Btype . backtrack snap ;
repr ty
1996-05-20 09:43:29 -07:00
2007-11-01 11:36:43 -07:00
(* Implementing function [expand_head_opt], the compiler's own version of
[ expand_head ] used for type - based optimisations .
[ expand_head_opt ] uses [ Env . find_type_expansion_opt ] to access the
2007-11-28 14:26:05 -08:00
manifest type information of private abstract data types which is
normally hidden to the type - checker out of the implementation module of
the private abbreviation . * )
2007-11-01 11:36:43 -07:00
2008-07-18 19:13:09 -07:00
let expand_abbrev_opt = expand_abbrev_gen Private Env . find_type_expansion_opt
2007-11-01 11:36:43 -07:00
let try_expand_once_opt env ty =
let ty = repr ty in
match ty . desc with
Tconstr _ -> repr ( expand_abbrev_opt env ty )
| _ -> raise Cannot_expand
let rec try_expand_head_opt env ty =
let ty' = try_expand_once_opt env ty in
begin try
try_expand_head_opt env ty'
with Cannot_expand ->
ty'
end
let expand_head_opt env ty =
let snap = Btype . snapshot () in
try try_expand_head_opt env ty
with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
Btype . backtrack snap ;
repr ty
1999-11-08 15:05:03 -08:00
(* Make sure that the type parameters of the type constructor [ty]
respect the type constraints * )
let enforce_constraints env ty =
match ty with
{ desc = Tconstr ( path , args , abbrev ) ; level = level } ->
let decl = Env . find_type path env in
ignore
2008-07-18 19:13:09 -07:00
( subst env level Public ( ref Mnil ) None decl . type_params args
( newvar2 level ) )
1999-11-08 15:05:03 -08:00
| _ ->
assert false
1997-03-07 14:44:02 -08:00
(* Recursively expand the head of a type.
1997-01-20 09:11:47 -08:00
Also expand # - types . * )
1996-05-20 09:43:29 -07:00
let rec full_expand env ty =
1997-03-07 14:44:02 -08:00
let ty = repr ( expand_head env ty ) in
1996-05-20 09:43:29 -07:00
match ty . desc with
1996-05-26 06:42:34 -07:00
Tobject ( fi , { contents = Some ( _ , v :: _ ) } ) when ( repr v ) . desc = Tvar ->
1998-07-03 10:40:39 -07:00
newty2 ty . level ( Tobject ( fi , ref None ) )
1996-05-20 09:43:29 -07:00
| _ ->
ty
1997-02-20 12:39:02 -08:00
(*
Check whether the abbreviation expands to a well - defined type .
1997-01-20 09:11:47 -08:00
During the typing of a class , abbreviations for correspondings
1997-02-20 12:39:02 -08:00
types expand to non - generic types .
* )
1996-04-22 04:15:41 -07:00
let generic_abbrev env path =
1995-11-03 05:23:03 -08:00
try
1997-04-01 12:52:21 -08:00
let ( _ , body ) = Env . find_type_expansion path env in
( repr body ) . level = generic_level
1996-04-22 04:15:41 -07:00
with
Not_found ->
false
1995-05-04 03:15:53 -07:00
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * *)
1997-03-18 13:05:15 -08:00
(* Occur check *)
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * *)
1997-03-18 13:05:15 -08:00
exception Occur
1997-01-21 05:38:42 -08:00
1997-03-24 12:12:00 -08:00
(* The marks are already used by [expand_abbrev]... *)
let visited = ref []
1996-10-28 09:51:55 -08:00
2000-08-03 20:29:42 -07:00
let rec non_recursive_abbrev env ty0 ty =
1997-03-18 13:05:15 -08:00
let ty = repr ty in
2000-08-03 20:29:42 -07:00
if ty = = repr ty0 then raise Recursive_abbrev ;
1997-03-24 12:12:00 -08:00
if not ( List . memq ty ! visited ) then begin
visited := ty :: ! visited ;
1997-03-18 13:05:15 -08:00
match ty . desc with
1997-03-24 12:12:00 -08:00
Tconstr ( p , args , abbrev ) ->
1997-03-18 13:05:15 -08:00
begin try
2010-04-26 01:55:20 -07:00
non_recursive_abbrev env ty0 ( try_expand_once_opt env ty )
1997-05-12 04:15:51 -07:00
with Cannot_expand ->
2001-09-27 16:48:37 -07:00
if ! Clflags . recursive_types then () else
2000-08-03 20:29:42 -07:00
iter_type_expr ( non_recursive_abbrev env ty0 ) ty
1997-05-12 04:15:51 -07:00
end
1999-11-30 08:07:38 -08:00
| Tobject _ | Tvariant _ ->
1997-03-18 13:05:15 -08:00
()
| _ ->
2001-09-27 16:48:37 -07:00
if ! Clflags . recursive_types then () else
2000-08-03 20:29:42 -07:00
iter_type_expr ( non_recursive_abbrev env ty0 ) ty
1997-03-18 13:05:15 -08:00
end
2003-07-01 06:05:43 -07:00
let correct_abbrev env path params ty =
2008-07-18 19:13:09 -07:00
check_abbrev_env env ;
2001-09-27 16:48:37 -07:00
let ty0 = newgenvar () in
visited := [] ;
2008-07-18 19:13:09 -07:00
let abbrev = Mcons ( Public , path , ty0 , ty0 , Mnil ) in
2002-06-09 19:38:31 -07:00
simple_abbrevs := abbrev ;
try
non_recursive_abbrev env ty0
2008-07-18 19:13:09 -07:00
( subst env generic_level Public ( ref abbrev ) None [] [] ty ) ;
2002-06-09 19:38:31 -07:00
simple_abbrevs := Mnil ;
visited := []
with exn ->
simple_abbrevs := Mnil ;
visited := [] ;
raise exn
1997-02-20 12:39:02 -08:00
1997-11-18 07:14:56 -08:00
let rec occur_rec env visited ty0 ty =
1997-06-29 06:16:47 -07:00
if ty = = ty0 then raise Occur ;
match ty . desc with
Tconstr ( p , tl , abbrev ) ->
begin try
2005-06-02 18:42:00 -07:00
if List . memq ty visited | | ! Clflags . recursive_types then raise Occur ;
iter_type_expr ( occur_rec env ( ty :: visited ) ty0 ) ty
2003-08-09 04:47:57 -07:00
with Occur -> try
let ty' = try_expand_head env ty in
1999-11-25 14:38:15 -08:00
(* Maybe we could simply make a recursive call here,
but it seems it could make the occur check loop
( see change in rev . 1 . 58 ) * )
if ty' = = ty0 | | List . memq ty' visited then raise Occur ;
match ty' . desc with
2000-02-24 19:33:54 -08:00
Tobject _ | Tvariant _ -> ()
2003-06-28 03:46:32 -07:00
| _ ->
if not ! Clflags . recursive_types then
iter_type_expr ( occur_rec env ( ty' :: visited ) ty0 ) ty'
2005-06-02 18:42:00 -07:00
with Cannot_expand ->
if not ! Clflags . recursive_types then raise Occur
1997-06-29 06:16:47 -07:00
end
1999-11-30 08:07:38 -08:00
| Tobject _ | Tvariant _ ->
1997-06-29 06:16:47 -07:00
()
| _ ->
2003-06-28 03:46:32 -07:00
if not ! Clflags . recursive_types then
iter_type_expr ( occur_rec env visited ty0 ) ty
1997-06-29 06:16:47 -07:00
2002-01-31 18:49:48 -08:00
let type_changed = ref false (* trace possible changes to the studied type *)
2002-02-01 02:03:12 -08:00
let merge r b = if b then r := true
1996-04-22 04:15:41 -07:00
let occur env ty0 ty =
2003-06-28 03:46:32 -07:00
let old = ! type_changed in
try
while type_changed := false ; occur_rec env [] ty0 ty ; ! type_changed
do () (* prerr_endline "changed" *) done ;
merge type_changed old
with exn ->
merge type_changed old ;
raise ( match exn with Occur -> Unify [] | _ -> exn )
1996-04-22 04:15:41 -07:00
1997-03-18 13:05:15 -08:00
2002-04-18 00:27:47 -07:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Polymorphic Unification *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Since we cannot duplicate universal variables, unification must
be done at meta - level , using bindings in univar_pairs * )
2010-09-26 23:24:35 -07:00
let rec unify_univar t1 t2 = function
2002-04-18 00:27:47 -07:00
( cl1 , cl2 ) :: rem ->
2004-06-07 23:34:56 -07:00
let find_univ t cl =
try
let ( _ , r ) = List . find ( fun ( t' , _ ) -> t = = repr t' ) cl in
Some r
with Not_found -> None
in
begin match find_univ t1 cl1 , find_univ t2 cl2 with
Some { contents = Some t'2 } , Some _ when t2 = = repr t'2 ->
()
| Some ( { contents = None } as r1 ) , Some ( { contents = None } as r2 ) ->
2010-09-26 22:38:32 -07:00
set_univar r1 t2 ; set_univar r2 t1
2004-06-07 23:34:56 -07:00
| None , None ->
unify_univar t1 t2 rem
| _ ->
raise ( Unify [] )
2002-04-18 00:27:47 -07:00
end
| [] -> raise ( Unify [] )
(* Test the occurence of free univars in a type *)
(* that's way too expansive. Must do some kind of cacheing *)
2004-10-13 19:36:19 -07:00
let occur_univar env ty =
2002-04-18 00:27:47 -07:00
let visited = ref TypeMap . empty in
let rec occur_rec bound ty =
let ty = repr ty in
if ty . level > = lowest_level &&
if TypeSet . is_empty bound then
( ty . level <- pivot_level - ty . level ; true )
else try
let bound' = TypeMap . find ty ! visited in
if TypeSet . exists ( fun x -> not ( TypeSet . mem x bound ) ) bound' then
( visited := TypeMap . add ty ( TypeSet . inter bound bound' ) ! visited ;
true )
else false
with Not_found ->
visited := TypeMap . add ty bound ! visited ;
true
then
match ty . desc with
2002-07-23 07:12:03 -07:00
Tunivar ->
2010-09-21 00:25:08 -07:00
if not ( TypeSet . mem ty bound ) then raise ( Unify [ ty , newgenvar () ] )
2002-07-23 07:12:03 -07:00
| Tpoly ( ty , tyl ) ->
2002-04-18 00:27:47 -07:00
let bound = List . fold_right TypeSet . add ( List . map repr tyl ) bound in
occur_rec bound ty
2004-10-13 19:36:19 -07:00
| Tconstr ( _ , [] , _ ) -> ()
| Tconstr ( p , tl , _ ) ->
begin try
let td = Env . find_type p env in
List . iter2
( fun t ( pos , neg , _ ) -> if pos | | neg then occur_rec bound t )
tl td . type_variance
with Not_found ->
List . iter ( occur_rec bound ) tl
end
2002-07-23 07:12:03 -07:00
| _ -> iter_type_expr ( occur_rec bound ) ty
2002-04-18 00:27:47 -07:00
in
try
occur_rec TypeSet . empty ty ; unmark_type ty
2002-06-18 03:47:33 -07:00
with exn ->
unmark_type ty ; raise exn
2002-04-18 00:27:47 -07:00
2006-09-20 04:14:37 -07:00
(* Grouping univars by families according to their binders *)
2004-10-13 02:33:09 -07:00
let add_univars =
List . fold_left ( fun s ( t , _ ) -> TypeSet . add ( repr t ) s )
let get_univar_family univar_pairs univars =
2004-10-13 17:54:20 -07:00
if univars = [] then TypeSet . empty else
2004-10-13 02:33:09 -07:00
let rec insert s = function
2004-10-15 05:28:48 -07:00
cl1 , ( _ :: _ as cl2 ) ->
if List . exists ( fun ( t1 , _ ) -> TypeSet . mem ( repr t1 ) s ) cl1 then
2004-10-13 02:33:09 -07:00
add_univars s cl2
else s
2004-10-13 17:54:20 -07:00
| _ -> s
2004-10-13 02:33:09 -07:00
in
2005-03-10 00:20:08 -08:00
let s = List . fold_right TypeSet . add univars TypeSet . empty in
List . fold_left insert s univar_pairs
2004-10-13 02:33:09 -07:00
(* Whether a family of univars escapes from a type *)
2004-10-14 20:15:34 -07:00
let univars_escape env univar_pairs vl ty =
let family = get_univar_family univar_pairs vl in
2004-10-13 02:33:09 -07:00
let visited = ref TypeSet . empty in
let rec occur t =
let t = repr t in
if TypeSet . mem t ! visited then () else begin
visited := TypeSet . add t ! visited ;
match t . desc with
2004-10-15 05:28:48 -07:00
Tpoly ( t , tl ) ->
if List . exists ( fun t -> TypeSet . mem ( repr t ) family ) tl then ()
else occur t
2004-10-13 02:33:09 -07:00
| Tunivar ->
if TypeSet . mem t family then raise Occur
2004-10-13 17:54:20 -07:00
| Tconstr ( _ , [] , _ ) -> ()
| Tconstr ( p , tl , _ ) ->
begin try
let td = Env . find_type p env in
List . iter2 ( fun t ( pos , neg , _ ) -> if pos | | neg then occur t )
tl td . type_variance
with Not_found ->
List . iter occur tl
end
2004-10-13 02:33:09 -07:00
| _ ->
iter_type_expr occur t
end
in
try occur ty ; false with Occur -> true
2004-10-13 03:05:26 -07:00
(* Wrapper checking that no variable escapes and updating univar_pairs *)
2004-10-13 17:54:20 -07:00
let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
2004-10-13 03:05:26 -07:00
let old_univars = ! univar_pairs in
let known_univars =
List . fold_left ( fun s ( cl , _ ) -> add_univars s cl )
TypeSet . empty old_univars
in
2005-03-10 00:20:08 -08:00
let tl1 = List . map repr tl1 and tl2 = List . map repr tl2 in
if List . exists ( fun t -> TypeSet . mem t known_univars ) tl1 &&
2004-10-14 20:15:34 -07:00
univars_escape env old_univars tl1 ( newty ( Tpoly ( t2 , tl2 ) ) )
2005-03-10 00:20:08 -08:00
| | List . exists ( fun t -> TypeSet . mem t known_univars ) tl2 &&
2004-10-14 20:15:34 -07:00
univars_escape env old_univars tl2 ( newty ( Tpoly ( t1 , tl1 ) ) )
then raise ( Unify [] ) ;
2004-10-13 03:05:26 -07:00
let cl1 = List . map ( fun t -> t , ref None ) tl1
and cl2 = List . map ( fun t -> t , ref None ) tl2 in
univar_pairs := ( cl1 , cl2 ) :: ( cl2 , cl1 ) :: old_univars ;
try let res = f t1 t2 in univar_pairs := old_univars ; res
with exn -> univar_pairs := old_univars ; raise exn
2002-04-18 00:27:47 -07:00
let univar_pairs = ref []
1997-03-18 13:05:15 -08:00
(* * * * * * * * * * * * * * * * *)
(* Unification *)
(* * * * * * * * * * * * * * * * *)
2001-02-20 14:16:02 -08:00
let rec has_cached_expansion p abbrev =
match abbrev with
Mnil -> false
2008-07-18 19:13:09 -07:00
| Mcons ( _ , p' , _ , _ , rem ) -> Path . same p p' | | has_cached_expansion p rem
2001-02-20 14:16:02 -08:00
| Mlink rem -> has_cached_expansion p ! rem
1997-01-20 09:11:47 -08:00
(* * * * Transform error trace * * * *)
1997-03-08 14:05:39 -08:00
(* +++ Move it to some other place ? *)
1997-01-20 09:11:47 -08:00
let expand_trace env trace =
List . fold_right
( fun ( t1 , t2 ) rem ->
( repr t1 , full_expand env t1 ) :: ( repr t2 , full_expand env t2 ) :: rem )
trace []
2004-04-27 00:37:30 -07:00
(* build a dummy variant type *)
let mkvariant fields closed =
newgenty
( Tvariant
{ row_fields = fields ; row_closed = closed ; row_more = newvar () ;
2008-01-11 08:13:18 -08:00
row_bound = () ; row_fixed = false ; row_name = None } )
2004-04-27 00:37:30 -07:00
2008-10-08 06:09:39 -07:00
(* force unification in Reither when one side has as non-conjunctive type *)
let rigid_variants = ref false
1997-01-20 09:11:47 -08:00
(* * * * Unification * * * *)
1997-03-07 14:44:02 -08:00
(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
1997-02-20 12:39:02 -08:00
let deep_occur t0 ty =
let rec occur_rec ty =
let ty = repr ty in
1997-03-08 14:05:39 -08:00
if ty . level > = lowest_level then begin
1997-02-20 12:39:02 -08:00
if ty = = t0 then raise Occur ;
1997-03-08 14:05:39 -08:00
ty . level <- pivot_level - ty . level ;
1997-02-20 12:39:02 -08:00
iter_type_expr occur_rec ty
end
in
try
1997-03-07 14:44:02 -08:00
occur_rec ty ; unmark_type ty ; false
1997-02-20 12:39:02 -08:00
with Occur ->
1997-03-07 14:44:02 -08:00
unmark_type ty ; true
1997-02-20 12:39:02 -08:00
(*
1 . When unifying two non - abbreviated types , one type is made a link
to the other . When unifying an abbreviated type with a
non - abbreviated type , the non - abbreviated type is made a link to
the other one . When unifying to abbreviated types , these two
types are kept distincts , but they are made to ( temporally )
expand to the same type .
2 . Abbreviations with at least one parameter are systematically
expanded . The overhead does not seem to high , and that way
abbreviations where some parameters does not appear in the
expansion , such as [ ' a t = int ] , are correctly handled . In
particular , for this example , unifying [ ' a t ] with [ ' b t ] keeps
[ ' a ] and [ ' b ] distincts . ( Is it really important ? )
3 . Unifying an abbreviation [ ' a t = ' a ] with [ ' a ] should not yield
[ ' a t as ' a ] . Indeed , the type variable would otherwise be lost .
This problem occurs for abbreviations expanding to a type
variable , but also to many other constrained abbreviations ( for
instance , [ ( < x : ' a > -> unit ) t = < x : ' a >] ) . The solution is
that , if an abbreviation is unified with some subpart of its
parameters , then the parameter actually does not get
abbreviated . It would be possible to check whether some
information is indeed lost , but it probably does not worth it .
* )
2010-09-12 22:28:30 -07:00
let pattern_unification = ref false
2010-10-04 01:38:22 -07:00
let pattern_level = ref None
2010-09-26 22:38:32 -07:00
let reify env t =
2010-10-04 01:38:22 -07:00
let pattern_level =
match ! pattern_level with
2010-10-07 00:12:50 -07:00
| None -> print_endline " asserting false " ; assert false
2010-10-04 01:38:22 -07:00
| Some x -> x
in
2010-09-18 21:55:40 -07:00
let rec iterator ty =
match ( repr ty ) . desc with
| Tvar ->
let decl = {
type_params = [] ;
type_arity = 0 ;
type_kind = Type_abstract ;
type_private = Public ;
type_manifest = None ;
type_variance = [] ;
2010-10-07 00:12:50 -07:00
type_newtype = true ;
2010-09-18 21:55:40 -07:00
}
in
2010-09-26 22:38:32 -07:00
let ( id , new_env ) = Env . enter_type ( get_new_abstract_name () ) decl ! env in
2010-10-04 01:38:22 -07:00
let to_unify = newty2 pattern_level ( Tconstr ( Path . Pident id , [] , ref Mnil ) ) in
2010-09-26 22:38:32 -07:00
env := new_env ;
link_type ty to_unify
2010-09-18 21:55:40 -07:00
| _ ->
iter_type_expr iterator ty
in
iter_type_expr iterator ( full_expand ! env t )
let unify_eq_set = Btype . TypeHash . create 10
let add_type_equality t1 t2 =
try
let set = TypeHash . find unify_eq_set t1 in
set := Btype . TypeSet . add t2 ! set
with
| Not_found ->
TypeHash . add unify_eq_set t1 ( ref ( TypeSet . add t2 TypeSet . empty ) )
2010-10-07 00:12:50 -07:00
let is_newtype env p =
try
let decl = Env . find_type p env in
decl . type_newtype
with
| Not_found ->
(* if it is not in the environment then it was necessarily added by a newtype *)
true
let incompatible_types env p1 p2 =
let is_abstract p =
try
let decl = Env . find_type p env in
match decl . type_manifest with
| Some _ -> false
| None ->
match decl . type_kind with
| Type_abstract -> true
| ( Type_variant _ | Type_record _ | Type_generalized_variant _ ) -> false
with
| Not_found ->
(* must be a newtype *)
true
in
let in_current_module =
function
| Path . Pident _ -> true
| ( Path . Pdot _ | Path . Papply _ ) -> false
in
( not ( Path . same p1 p2 ) ) && is_abstract p1 && is_abstract p2 &&
in_current_module p1 && in_current_module p2
2010-09-18 21:55:40 -07:00
2010-09-12 22:28:30 -07:00
2010-09-18 21:55:40 -07:00
let unify_eq t1 t2 =
let test t1 t2 =
try
Btype . TypeSet . mem t2 ! ( TypeHash . find unify_eq_set t1 ) ;
with
| Not_found -> false
in
t1 = = t2 | | test t1 t2 | | test t2 t1
2010-09-12 22:28:30 -07:00
2010-09-18 21:55:40 -07:00
let rec unify ( env : Env . t ref ) t1 t2 =
1997-02-20 12:39:02 -08:00
(* First step: special cases ( optimizations ) *)
2010-09-18 21:55:40 -07:00
if unify_eq t1 t2 then () else
1997-01-20 09:11:47 -08:00
let t1 = repr t1 in
let t2 = repr t2 in
2010-09-18 21:55:40 -07:00
if unify_eq t1 t2 then () else
1996-05-20 09:43:29 -07:00
try
2002-01-31 18:49:48 -08:00
type_changed := true ;
1996-05-20 09:43:29 -07:00
match ( t1 . desc , t2 . desc ) with
2010-09-18 21:55:40 -07:00
( Tvar , Tconstr _ ) when deep_occur t1 t2 ->
1997-02-20 12:39:02 -08:00
unify2 env t1 t2
2010-09-18 21:55:40 -07:00
| ( Tconstr _ , Tvar ) when deep_occur t2 t1 ->
1997-02-20 12:39:02 -08:00
unify2 env t1 t2
2010-09-18 21:55:40 -07:00
| ( Tvar , _ ) ->
occur ! env t1 t2 ; occur_univar ! env t2 ;
2010-09-26 22:38:32 -07:00
link_type t1 t2 ;
update_level ! env t1 . level t2
2010-09-18 21:55:40 -07:00
| ( _ , Tvar ) ->
occur ! env t2 t1 ; occur_univar ! env t1 ;
2010-09-26 22:38:32 -07:00
link_type t2 t1 ;
update_level ! env t2 . level t1
2010-09-18 21:55:40 -07:00
| ( Tunivar , Tunivar ) ->
2002-07-23 07:12:03 -07:00
unify_univar t1 t2 ! univar_pairs ;
2010-09-18 21:55:40 -07:00
update_level ! env t1 . level t2 ;
2002-11-20 21:39:01 -08:00
link_type t1 t2
2001-02-20 14:16:02 -08:00
| ( 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
2010-09-18 21:55:40 -07:00
| | has_cached_expansion p2 ! a2 ) ->
update_level ! env t1 . level t2 ;
2002-11-20 21:39:01 -08:00
link_type t1 t2
2010-09-18 21:55:40 -07:00
| _ ->
1997-02-20 12:39:02 -08:00
unify2 env t1 t2
with Unify trace ->
raise ( Unify ( ( t1 , t2 ) :: trace ) )
and unify2 env t1 t2 =
(* Second step: expansion of abbreviations *)
2003-11-07 00:19:29 -08:00
let rec expand_both t1'' t2'' =
2010-09-18 21:55:40 -07:00
let t1' = expand_head_unif ! env t1 in
let t2' = expand_head_unif ! env t2 in
2003-11-06 17:06:55 -08:00
(* Expansion may have changed the representative of the types... *)
2010-09-18 21:55:40 -07:00
if unify_eq t1' t1'' && unify_eq t2' t2'' then ( t1' , t2' ) else
2003-11-06 17:06:55 -08:00
expand_both t1' t2'
in
let t1' , t2' = expand_both t1 t2 in
2010-09-18 21:55:40 -07:00
if unify_eq t1' t2' then () else
2003-11-07 00:19:29 -08:00
let t1 = repr t1 and t2 = repr t2 in
2010-09-18 21:55:40 -07:00
if unify_eq t1 t1' | | not ( unify_eq t2 t2' ) then
1997-02-20 12:39:02 -08:00
unify3 env t1 t1' t2 t2'
else
try unify3 env t2 t2' t1 t1' with Unify trace ->
raise ( Unify ( List . map ( fun ( x , y ) -> ( y , x ) ) trace ) )
and unify3 env t1 t1' t2 t2' =
(* Third step: truly unification *)
(* Assumes either [t1 == t1'] or [t2 != t2'] *)
let d1 = t1' . desc and d2 = t2' . desc in
1998-06-24 12:22:26 -07:00
let create_recursion = ( t2 != t2' ) && ( deep_occur t1' t2 ) in
2010-10-04 01:38:22 -07:00
occur ! env t1' t2' ;
add_type_equality t1' t2' ;
1996-04-22 04:15:41 -07:00
try
1997-02-20 12:39:02 -08:00
begin match ( d1 , d2 ) with
( Tvar , _ ) ->
2010-10-04 01:38:22 -07:00
update_level ! env t1' . level t2 ;
2010-09-12 22:28:30 -07:00
link_type t1' t2 ;
2010-10-04 01:38:22 -07:00
occur_univar ! env t2
1997-02-20 12:39:02 -08:00
| ( _ , Tvar ) ->
2010-10-04 01:38:22 -07:00
update_level ! env t2' . level t1 ;
2010-09-12 22:28:30 -07:00
link_type t2' t1 ;
2010-10-04 01:38:22 -07:00
occur_univar ! env t1
2001-04-19 01:34:21 -07:00
| ( Tarrow ( l1 , t1 , u1 , c1 ) , Tarrow ( l2 , t2 , u2 , c2 ) ) when l1 = l2
2000-12-28 05:07:42 -08:00
| | ! Clflags . classic && not ( is_optional l1 | | is_optional l2 ) ->
2010-09-18 21:55:40 -07:00
unify env t1 t2 ; unify env u1 u2 ;
2001-04-19 01:34:21 -07:00
begin match commu_repr c1 , commu_repr c2 with
2002-11-20 21:39:01 -08:00
Clink r , c2 -> set_commu r c2
| c1 , Clink r -> set_commu r c1
2001-04-19 01:34:21 -07:00
| _ -> ()
end
1996-04-22 04:15:41 -07:00
| ( Ttuple tl1 , Ttuple tl2 ) ->
unify_list env tl1 tl2
1997-02-20 12:39:02 -08:00
| ( Tconstr ( p1 , tl1 , _ ) , Tconstr ( p2 , tl2 , _ ) ) when Path . same p1 p2 ->
1996-04-22 04:15:41 -07:00
unify_list env tl1 tl2
2010-10-07 00:12:50 -07:00
(* | _, ( Tconstr ( Path.Pident p,[],_ ) ) when not !pattern_unification -> (* GAH : must be abstract or else it would have been expanded, ask garrigue *)
raise ( Unify [] ) * )
(* | ( Tconstr ( p1, tl1, _ ) , Tconstr ( p2, tl2, _ ) ) when incompatible_types !env p1 p2 -> raise ( Unify [] ) *)
| ( Tconstr ( ( Path . Pident p ) as path , [] , _ ) ) , _ when is_newtype ! env path && ! pattern_unification -> (* GAH : must be abstract or else it would have been expanded, ask garrigue *)
2010-09-18 21:55:40 -07:00
let t2 = copy t2 in
reify env t2 ;
let decl = {
type_params = [] ;
type_arity = 0 ;
type_kind = Type_abstract ;
type_private = Public ;
type_manifest = Some t2 ;
type_variance = [] ;
2010-10-07 00:12:50 -07:00
type_newtype = false ;
2010-09-18 21:55:40 -07:00
}
in
let new_env = Env . add_type p decl ! env in
env := new_env
2010-10-07 00:12:50 -07:00
| _ , ( Tconstr ( ( Path . Pident p ) as path , [] , _ ) ) when is_newtype ! env path && ! pattern_unification ->
2010-09-18 21:55:40 -07:00
let t1 = copy t1 in
reify env t1 ;
let decl = {
type_params = [] ;
type_arity = 0 ;
type_kind = Type_abstract ;
type_private = Public ;
type_manifest = Some t1 ;
type_variance = [] ;
2010-10-07 00:12:50 -07:00
type_newtype = false ;
2010-09-18 21:55:40 -07:00
}
in
let new_env = Env . add_type p decl ! env in
env := new_env
2010-09-20 22:30:25 -07:00
2010-10-07 00:12:50 -07:00
| Tconstr ( p1 , _ , _ ) , Tconstr ( p2 , _ , _ ) when ! pattern_unification && not ( incompatible_types ! env p1 p2 ) ->
2010-09-20 22:30:25 -07:00
reify env t1 ;
reify env t2
1997-05-11 14:35:00 -07:00
| ( Tobject ( fi1 , nm1 ) , Tobject ( fi2 , _ ) ) ->
1996-09-23 10:15:59 -07:00
unify_fields env fi1 fi2 ;
1997-05-11 14:35:00 -07:00
(* Type [t2'] may have been instantiated by [unify_fields] *)
(* XXX One should do some kind of unification... *)
begin match ( repr t2' ) . desc with
Tobject ( _ , { contents = Some ( _ , va :: _ ) } )
2003-11-25 01:20:45 -08:00
when let va = repr va in List . mem va . desc [ Tvar ; Tunivar ; Tnil ] ->
2002-04-18 00:27:47 -07:00
()
1997-05-11 14:35:00 -07:00
| Tobject ( _ , nm2 ) ->
2002-11-20 22:22:02 -08:00
set_name nm2 ! nm1
1997-05-11 14:35:00 -07:00
| _ ->
()
1996-04-22 04:15:41 -07:00
end
1999-11-30 08:07:38 -08:00
| ( Tvariant row1 , Tvariant row2 ) ->
unify_row env row1 row2
1997-03-08 14:05:39 -08:00
| ( Tfield _ , Tfield _ ) -> (* Actually unused *)
1997-05-11 14:35:00 -07:00
unify_fields env t1' t2'
2004-05-23 02:06:58 -07:00
| ( Tfield ( f , kind , _ , rem ) , Tnil ) | ( Tnil , Tfield ( f , kind , _ , rem ) ) ->
2003-11-25 01:20:45 -08:00
begin match field_kind_repr kind with
2004-05-23 02:06:58 -07:00
Fvar r when f < > dummy_method -> set_kind r Fabsent
2003-11-25 01:20:45 -08:00
| _ -> raise ( Unify [] )
end
1997-01-20 09:11:47 -08:00
| ( Tnil , Tnil ) ->
()
2002-04-18 00:27:47 -07:00
| ( Tpoly ( t1 , [] ) , Tpoly ( t2 , [] ) ) ->
2010-09-26 23:24:35 -07:00
unify env t1 t2
2002-04-18 00:27:47 -07:00
| ( Tpoly ( t1 , tl1 ) , Tpoly ( t2 , tl2 ) ) ->
2010-09-18 21:55:40 -07:00
enter_poly ! env univar_pairs t1 tl1 t2 tl2 ( unify env )
2009-10-26 03:53:16 -07:00
| ( Tpackage ( p1 , n1 , tl1 ) , Tpackage ( p2 , n2 , tl2 ) ) when Path . same p1 p2 && n1 = n2 ->
unify_list env tl1 tl2
1996-04-22 04:15:41 -07:00
| ( _ , _ ) ->
1996-05-20 09:43:29 -07:00
raise ( Unify [] )
1998-06-24 12:22:26 -07:00
end ;
(* XXX Commentaires + changer "create_recursion" *)
if create_recursion then begin
match t2 . desc with
Tconstr ( p , tl , abbrev ) ->
forget_abbrev abbrev p ;
2010-09-18 21:55:40 -07:00
let t2'' = expand_head_unif ! env t2 in
1998-06-24 12:22:26 -07:00
if not ( closed_parameterized_type tl t2'' ) then
2002-11-20 21:39:01 -08:00
link_type ( repr t2 ) ( repr t2' )
1998-06-24 12:22:26 -07:00
| _ ->
2006-01-04 08:55:50 -08:00
() (* t2 has already been expanded by update_level *)
1997-03-08 04:14:57 -08:00
end
1998-06-24 12:22:26 -07:00
1997-02-20 12:39:02 -08:00
(*
2006-09-20 04:14:37 -07:00
(*
1997-02-20 12:39:02 -08:00
Can only be done afterwards , once the row variable has
( possibly ) been instantiated .
* )
if t1 != t1' (* && t2 != t2' *) then begin
match ( t1 . desc , t2 . desc ) with
( Tconstr ( p , ty :: _ , _ ) , _ )
1997-03-24 12:12:00 -08:00
when ( ( repr ty ) . desc < > Tvar )
1997-02-20 12:39:02 -08:00
&& weak_abbrev p
&& not ( deep_occur t1 t2 ) ->
update_level env t1 . level t2 ;
2002-11-20 21:39:01 -08:00
link_type t1 t2
1997-02-20 12:39:02 -08:00
| ( _ , Tconstr ( p , ty :: _ , _ ) )
1997-03-24 12:12:00 -08:00
when ( ( repr ty ) . desc < > Tvar )
1997-02-20 12:39:02 -08:00
&& weak_abbrev p
&& not ( deep_occur t2 t1 ) ->
update_level env t2 . level t1 ;
2002-11-20 21:39:01 -08:00
link_type t2 t1 ;
link_type t1' t2'
1997-02-20 12:39:02 -08:00
| _ ->
()
end
* )
with Unify trace ->
t1' . desc <- d1 ;
raise ( Unify trace )
1995-05-04 03:15:53 -07:00
and unify_list env tl1 tl2 =
1996-05-31 05:27:03 -07:00
if List . length tl1 < > List . length tl2 then
raise ( Unify [] ) ;
1997-02-20 12:39:02 -08:00
List . iter2 ( unify env ) tl1 tl2
1996-04-22 04:15:41 -07:00
1997-01-20 09:11:47 -08:00
and unify_fields env ty1 ty2 = (* Optimization *)
1996-04-22 04:15:41 -07:00
let ( fields1 , rest1 ) = flatten_fields ty1
and ( fields2 , rest2 ) = flatten_fields ty2 in
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
2004-05-28 03:32:16 -07:00
let l1 = ( repr ty1 ) . level and l2 = ( repr ty2 ) . level in
2002-04-18 00:27:47 -07:00
let va =
if miss1 = [] then rest2
else if miss2 = [] then rest1
2004-05-28 03:32:16 -07:00
else newty2 ( min l1 l2 ) Tvar
2002-04-18 00:27:47 -07:00
in
2002-09-08 19:58:21 -07:00
let d1 = rest1 . desc and d2 = rest2 . desc in
try
2004-05-28 03:32:16 -07:00
unify env ( build_fields l1 miss1 va ) rest2 ;
unify env rest1 ( build_fields l2 miss2 va ) ;
2002-09-08 19:58:21 -07:00
List . iter
( fun ( n , k1 , t1 , k2 , t2 ) ->
unify_kind k1 k2 ;
2010-09-26 23:24:35 -07:00
try unify env t1 t2 with Unify trace ->
2002-09-08 19:58:21 -07:00
raise ( Unify ( ( newty ( Tfield ( n , k1 , t1 , va ) ) ,
newty ( Tfield ( n , k2 , t2 , va ) ) ) :: trace ) ) )
pairs
with exn ->
2002-11-20 21:39:01 -08:00
log_type rest1 ; rest1 . desc <- d1 ;
log_type rest2 ; rest2 . desc <- d2 ;
2002-09-08 19:58:21 -07:00
raise exn
1997-05-11 14:35:00 -07:00
and unify_kind k1 k2 =
let k1 = field_kind_repr k1 in
let k2 = field_kind_repr k2 in
2002-10-15 18:26:15 -07:00
if k1 = = k2 then () else
1997-05-11 14:35:00 -07:00
match k1 , k2 with
2002-11-20 21:39:01 -08:00
( Fvar r , ( Fvar _ | Fpresent ) ) -> set_kind r k2
| ( Fpresent , Fvar r ) -> set_kind r k1
| ( Fpresent , Fpresent ) -> ()
| _ -> assert false
and unify_pairs env tpl =
List . iter ( fun ( t1 , t2 ) -> unify env t1 t2 ) tpl
1996-04-22 04:15:41 -07:00
1999-11-30 08:07:38 -08:00
and unify_row env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
2000-02-24 02:18:25 -08:00
let rm1 = row_more row1 and rm2 = row_more row2 in
1999-11-30 08:07:38 -08:00
if rm1 = = rm2 then () else
let r1 , r2 , pairs = merge_row_fields row1 . row_fields row2 . row_fields in
2006-09-20 04:14:37 -07:00
if r1 < > [] && r2 < > [] then begin
let ht = Hashtbl . create ( List . length r1 ) in
List . iter ( fun ( l , _ ) -> Hashtbl . add ht ( hash_variant l ) l ) r1 ;
List . iter
( fun ( l , _ ) ->
try raise ( Tags ( l , Hashtbl . find ht ( hash_variant l ) ) )
with Not_found -> () )
r2
end ;
2002-04-18 00:27:47 -07:00
let more =
if row1 . row_fixed then rm1 else
if row2 . row_fixed then rm2 else
newgenvar ()
2010-09-18 21:55:40 -07:00
in update_level ! env ( min rm1 . level rm2 . level ) more ;
2002-04-18 00:27:47 -07:00
let fixed = row1 . row_fixed | | row2 . row_fixed
1999-11-30 08:07:38 -08:00
and closed = row1 . row_closed | | row2 . row_closed in
let keep switch =
List . for_all
( fun ( _ , f1 , f2 ) ->
let f1 , f2 = switch f1 f2 in
row_field_repr f1 = Rabsent | | row_field_repr f2 < > Rabsent )
pairs
in
2000-02-24 02:18:25 -08:00
let empty fields =
List . for_all ( fun ( _ , f ) -> row_field_repr f = Rabsent ) fields in
2001-12-25 19:43:41 -08:00
(* Check whether we are going to build an empty type *)
if closed && ( empty r1 | | row2 . row_closed ) && ( empty r2 | | row1 . row_closed )
2001-09-27 00:34:39 -07:00
&& List . for_all
( fun ( _ , f1 , f2 ) ->
row_field_repr f1 = Rabsent | | row_field_repr f2 = Rabsent )
pairs
2002-06-18 03:47:33 -07:00
then raise ( Unify [ mkvariant [] true , mkvariant [] true ] ) ;
1999-11-30 08:07:38 -08:00
let name =
2000-02-24 02:18:25 -08:00
if row1 . row_name < > None && ( row1 . row_closed | | empty r2 ) &&
( not row2 . row_closed | | keep ( fun f1 f2 -> f1 , f2 ) && empty r1 )
then row1 . row_name
else if row2 . row_name < > None && ( row2 . row_closed | | empty r1 ) &&
( not row1 . row_closed | | keep ( fun f1 f2 -> f2 , f1 ) && empty r2 )
2000-02-24 19:33:54 -08:00
then row2 . row_name
2000-02-24 02:18:25 -08:00
else None
1999-11-30 08:07:38 -08:00
in
2008-01-11 08:13:18 -08:00
let row0 = { row_fields = [] ; row_more = more ; row_bound = () ;
2002-04-18 00:27:47 -07:00
row_closed = closed ; row_fixed = fixed ; row_name = name } in
let set_more row rest =
1999-11-30 08:07:38 -08:00
let rest =
2000-05-12 11:22:35 -07:00
if closed then
2001-03-02 16:14:35 -08:00
filter_row_fields row . row_closed rest
2000-05-12 11:22:35 -07:00
else rest in
2002-04-18 00:27:47 -07:00
if rest < > [] && ( row . row_closed | | row . row_fixed )
2002-06-18 03:47:33 -07:00
| | closed && row . row_fixed && not row . row_closed then begin
let t1 = mkvariant [] true and t2 = mkvariant rest false in
raise ( Unify [ if row = = row1 then ( t1 , t2 ) else ( t2 , t1 ) ] )
end ;
2002-04-18 00:27:47 -07:00
let rm = row_more row in
if row . row_fixed then
2005-08-18 20:50:12 -07:00
if row0 . row_more = = rm then () else
if rm . desc = Tvar then link_type rm row0 . row_more else
unify env rm row0 . row_more
2002-04-18 00:27:47 -07:00
else
let ty = newty2 generic_level ( Tvariant { row0 with row_fields = rest } ) in
2010-09-18 21:55:40 -07:00
update_level ! env rm . level ty ;
2002-11-20 21:39:01 -08:00
link_type rm ty
1999-11-30 08:07:38 -08:00
in
let md1 = rm1 . desc and md2 = rm2 . desc in
begin try
2002-04-18 00:27:47 -07:00
set_more row2 r1 ;
2007-02-16 03:18:36 -08:00
set_more row1 r2 ;
2002-04-18 00:27:47 -07:00
List . iter
( fun ( l , f1 , f2 ) ->
2010-05-20 18:26:16 -07:00
try unify_row_field env row1 . row_fixed row2 . row_fixed more l f1 f2
2004-04-27 00:37:30 -07:00
with Unify trace ->
raise ( Unify ( ( mkvariant [ l , f1 ] true ,
mkvariant [ l , f2 ] true ) :: trace ) ) )
2002-05-16 03:17:47 -07:00
pairs ;
1999-11-30 08:07:38 -08:00
with exn ->
2002-11-20 21:39:01 -08:00
log_type rm1 ; rm1 . desc <- md1 ; log_type rm2 ; rm2 . desc <- md2 ; raise exn
1999-11-30 08:07:38 -08:00
end
2010-05-20 18:26:16 -07:00
and unify_row_field env fixed1 fixed2 more l f1 f2 =
2001-09-25 02:54:18 -07:00
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
if f1 = = f2 then () else
match f1 , f2 with
2010-09-26 23:24:35 -07:00
Rpresent ( Some t1 ) , Rpresent ( Some t2 ) -> unify env t1 t2
2001-09-25 02:54:18 -07:00
| Rpresent None , Rpresent None -> ()
| Reither ( c1 , tl1 , m1 , e1 ) , Reither ( c2 , tl2 , m2 , e2 ) ->
if e1 = = e2 then () else
2002-09-01 20:41:14 -07:00
let redo =
2008-10-08 06:09:39 -07:00
( m1 | | m2 | |
2010-01-22 04:48:24 -08:00
! rigid_variants && ( List . length tl1 = 1 | | List . length tl2 = 1 ) ) &&
2002-11-20 21:39:01 -08:00
begin match tl1 @ tl2 with [] -> false
2001-09-25 02:54:18 -07:00
| t1 :: tl ->
if c1 | | c2 then raise ( Unify [] ) ;
2002-09-01 20:41:14 -07:00
List . iter ( unify env t1 ) tl ;
! e1 < > None | | ! e2 < > None
2002-11-20 21:39:01 -08:00
end in
2010-05-20 18:26:16 -07:00
if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else
2001-11-22 20:35:48 -08:00
let tl1 = List . map repr tl1 and tl2 = List . map repr tl2 in
let rec remq tl = function [] -> []
| ty :: tl' ->
if List . memq ty tl then remq tl tl' else ty :: remq tl tl'
2001-09-25 02:54:18 -07:00
in
2001-11-22 20:35:48 -08:00
let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
2010-05-20 18:26:16 -07:00
(* Is this handling of levels really principal? *)
2010-09-18 21:55:40 -07:00
List . iter ( update_level ! env ( repr more ) . level ) ( tl1' @ tl2' ) ;
2001-11-22 20:35:48 -08:00
let e = ref None in
2003-11-06 18:17:49 -08:00
let f1' = Reither ( c1 | | c2 , tl1' , m1 | | m2 , e )
and f2' = Reither ( c1 | | c2 , tl2' , m1 | | m2 , e ) in
set_row_field e1 f1' ; set_row_field e2 f2' ;
2002-11-20 21:39:01 -08:00
| Reither ( _ , _ , false , e1 ) , Rabsent -> set_row_field e1 f2
| Rabsent , Reither ( _ , _ , false , e2 ) -> set_row_field e2 f1
2002-04-18 00:27:47 -07:00
| Rabsent , Rabsent -> ()
| Reither ( false , tl , _ , e1 ) , Rpresent ( Some t2 ) when not fixed1 ->
2002-11-20 21:39:01 -08:00
set_row_field e1 f2 ;
2001-09-25 02:54:18 -07:00
( try List . iter ( fun t1 -> unify env t1 t2 ) tl
with exn -> e1 := None ; raise exn )
2002-04-18 00:27:47 -07:00
| Rpresent ( Some t1 ) , Reither ( false , tl , _ , e2 ) when not fixed2 ->
2002-11-20 21:39:01 -08:00
set_row_field e2 f1 ;
2001-09-25 02:54:18 -07:00
( try List . iter ( unify env t1 ) tl
with exn -> e2 := None ; raise exn )
2002-11-20 21:39:01 -08:00
| Reither ( true , [] , _ , e1 ) , Rpresent None when not fixed1 ->
set_row_field e1 f2
| Rpresent None , Reither ( true , [] , _ , e2 ) when not fixed2 ->
set_row_field e2 f1
2001-09-25 02:54:18 -07:00
| _ -> raise ( Unify [] )
2006-09-20 04:14:37 -07:00
2010-09-12 22:28:30 -07:00
1996-04-22 04:15:41 -07:00
let unify env ty1 ty2 =
1996-05-20 09:43:29 -07:00
try
2010-10-07 01:31:59 -07:00
TypeHash . clear unify_eq_set ;
2010-09-18 21:55:40 -07:00
unify env ty1 ty2
with Unify trace ->
raise ( Unify ( expand_trace ! env trace ) )
2010-10-07 00:12:50 -07:00
let unify_gadt plev ( env : Env . t ref ) ty1 ty2 =
2010-09-18 21:55:40 -07:00
try
2010-10-07 00:12:50 -07:00
pattern_level := Some plev ;
2010-09-18 21:55:40 -07:00
pattern_unification := true ;
2010-09-12 22:28:30 -07:00
unify env ty1 ty2 ;
2010-09-18 21:55:40 -07:00
pattern_unification := false ;
2010-10-07 00:12:50 -07:00
pattern_level := None ;
with
| Unify trace ->
raise ( Unify ( expand_trace ! env trace ) )
| e ->
pattern_unification := false ;
pattern_level := None ;
raise e
1995-05-04 03:15:53 -07:00
2010-09-12 22:28:30 -07:00
2002-04-18 00:27:47 -07:00
let unify_var env t1 t2 =
let t1 = repr t1 and t2 = repr t2 in
if t1 = = t2 then () else
match t1 . desc with
Tvar ->
begin try
2002-07-23 07:12:03 -07:00
occur env t1 t2 ;
update_level env t1 . level t2 ;
2002-11-20 21:39:01 -08:00
link_type t1 t2
2002-04-18 00:27:47 -07:00
with Unify trace ->
2002-08-05 16:41:09 -07:00
raise ( Unify ( expand_trace env ( ( t1 , t2 ) :: trace ) ) )
2002-04-18 00:27:47 -07:00
end
| _ ->
2010-09-18 21:55:40 -07:00
unify ( ref env ) t1 t2
2002-04-18 00:27:47 -07:00
let _ = unify' := unify_var
let unify_pairs env ty1 ty2 pairs =
univar_pairs := pairs ;
unify env ty1 ty2
let unify env ty1 ty2 =
univar_pairs := [] ;
2010-09-18 21:55:40 -07:00
unify ( ref env ) ty1 ty2
let unify_gadt env ty1 ty2 =
univar_pairs := [] ;
unify_gadt env ty1 ty2
2002-04-18 00:27:47 -07:00
1997-02-20 12:39:02 -08:00
1997-01-20 09:11:47 -08:00
(* * * * Special cases of unification * * * *)
1999-11-30 08:07:38 -08:00
(*
Unify [ t ] and [ l : ' a -> ' b ] . Return [ ' a ] and [ ' b ] .
2000-03-20 13:00:11 -08:00
In label mode , label mismatch is accepted when
1999-11-30 08:07:38 -08:00
( 1 ) the requested label is " "
( 2 ) the original label is not optional
* )
let rec filter_arrow env t l =
2006-09-20 04:14:37 -07:00
let t = expand_head_unif env t in
1996-04-22 04:15:41 -07:00
match t . desc with
Tvar ->
let t1 = newvar () and t2 = newvar () in
2001-04-19 01:34:21 -07:00
let t' = newty ( Tarrow ( l , t1 , t2 , Cok ) ) in
1997-01-23 04:46:46 -08:00
update_level env t . level t' ;
2002-11-20 21:39:01 -08:00
link_type t t' ;
1995-05-04 03:15:53 -07:00
( t1 , t2 )
2001-04-19 01:34:21 -07:00
| Tarrow ( l' , t1 , t2 , _ )
1999-11-30 08:07:38 -08:00
when l = l' | | ! Clflags . classic && l = " " && not ( is_optional l' ) ->
1995-05-04 03:15:53 -07:00
( t1 , t2 )
1996-04-22 04:15:41 -07:00
| _ ->
1996-05-20 09:43:29 -07:00
raise ( Unify [] )
1996-04-22 04:15:41 -07:00
1997-01-20 09:11:47 -08:00
(* Used by [filter_method]. *)
1997-05-11 14:35:00 -07:00
let rec filter_method_field env name priv ty =
1996-04-22 04:15:41 -07:00
let ty = repr ty in
match ty . desc with
Tvar ->
1998-06-24 12:22:26 -07:00
let level = ty . level in
let ty1 = newvar2 level and ty2 = newvar2 level in
let ty' = newty2 level ( Tfield ( name ,
begin match priv with
Private -> Fvar ( ref None )
| Public -> Fpresent
end ,
ty1 , ty2 ) )
1997-05-11 14:35:00 -07:00
in
2002-11-20 21:39:01 -08:00
link_type ty ty' ;
1996-04-22 04:15:41 -07:00
ty1
1997-05-11 14:35:00 -07:00
| Tfield ( n , kind , ty1 , ty2 ) ->
let kind = field_kind_repr kind in
if ( n = name ) && ( kind < > Fabsent ) then begin
if priv = Public then
unify_kind kind Fpresent ;
1996-04-22 04:15:41 -07:00
ty1
1997-05-11 14:35:00 -07:00
end else
filter_method_field env name priv ty2
1996-04-22 04:15:41 -07:00
| _ ->
1996-05-20 09:43:29 -07:00
raise ( Unify [] )
1996-04-22 04:15:41 -07:00
1997-01-20 09:11:47 -08:00
(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
1997-05-11 14:35:00 -07:00
let rec filter_method env name priv ty =
2006-09-20 04:14:37 -07:00
let ty = expand_head_unif env ty in
1996-04-22 04:15:41 -07:00
match ty . desc with
Tvar ->
1997-01-20 09:11:47 -08:00
let ty1 = newvar () in
1996-04-22 04:15:41 -07:00
let ty' = newobj ty1 in
1997-01-23 04:46:46 -08:00
update_level env ty . level ty' ;
2002-11-20 21:39:01 -08:00
link_type ty ty' ;
1997-05-11 14:35:00 -07:00
filter_method_field env name priv ty1
1996-04-22 04:15:41 -07:00
| Tobject ( f , _ ) ->
1997-05-11 14:35:00 -07:00
filter_method_field env name priv f
1995-05-04 03:15:53 -07:00
| _ ->
1996-05-20 09:43:29 -07:00
raise ( Unify [] )
1995-05-04 03:15:53 -07:00
1998-11-12 06:53:46 -08:00
let check_filter_method env name priv ty =
1999-02-24 07:21:50 -08:00
ignore ( filter_method env name priv ty )
1998-11-12 06:53:46 -08:00
1998-06-24 12:22:26 -07:00
let filter_self_method env lab priv meths ty =
let ty' = filter_method env lab priv ty in
try
Meths . find lab ! meths
with Not_found ->
let pair = ( Ident . create lab , ty' ) in
meths := Meths . add lab pair ! meths ;
pair
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Matching between type schemes *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
1997-03-08 14:05:39 -08:00
(*
1999-09-09 08:32:11 -07:00
Update the level of [ ty ] . First check that the levels of generic
variables from the subject are not lowered .
1997-03-08 14:05:39 -08:00
* )
2006-09-20 04:14:37 -07:00
let moregen_occur env level ty =
1997-04-01 12:52:21 -08:00
let rec occur ty =
1996-10-25 06:40:04 -07:00
let ty = repr ty in
1997-04-01 12:52:21 -08:00
if ty . level > level then begin
1999-09-09 08:32:11 -07:00
if ty . desc = Tvar && ty . level > = generic_level - 1 then raise Occur ;
1997-03-08 14:05:39 -08:00
ty . level <- pivot_level - ty . level ;
1999-11-30 08:07:38 -08:00
match ty . desc with
Tvariant row when static_row row ->
iter_row occur row
| _ ->
iter_type_expr occur ty
1997-01-20 09:11:47 -08:00
end
1996-04-22 04:15:41 -07:00
in
1997-04-01 12:52:21 -08:00
begin try
occur ty ; unmark_type ty
with Occur ->
unmark_type ty ; raise ( Unify [] )
end ;
2002-04-18 00:27:47 -07:00
(* also check for free univars *)
2004-10-13 19:36:19 -07:00
occur_univar env ty ;
1997-04-01 12:52:21 -08:00
update_level env level ty
1995-11-16 05:27:53 -08:00
2008-02-29 06:21:22 -08:00
let may_instantiate inst_nongen t1 =
if inst_nongen then t1 . level < > generic_level - 1
else t1 . level = generic_level
1998-06-24 12:22:26 -07:00
let rec moregen inst_nongen type_pairs env t1 t2 =
if t1 = = t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
if t1 = = t2 then () else
1997-04-01 12:52:21 -08:00
1998-06-24 12:22:26 -07:00
try
1997-04-01 12:52:21 -08:00
match ( t1 . desc , t2 . desc ) with
2002-04-18 00:27:47 -07:00
( Tunivar , Tunivar ) ->
2002-07-23 07:12:03 -07:00
unify_univar t1 t2 ! univar_pairs
2008-02-29 06:21:22 -08:00
| ( Tvar , _ ) when may_instantiate inst_nongen t1 ->
1997-03-08 14:05:39 -08:00
moregen_occur env t1 . level t2 ;
2001-03-02 12:52:21 -08:00
occur env t1 t2 ;
2002-11-20 21:39:01 -08:00
link_type t1 t2
1997-04-01 12:52:21 -08:00
| ( Tconstr ( p1 , [] , _ ) , Tconstr ( p2 , [] , _ ) ) when Path . same p1 p2 ->
1997-03-08 14:05:39 -08:00
()
1997-04-01 12:52:21 -08:00
| _ ->
2006-09-20 04:14:37 -07:00
let t1' = expand_head_unif env t1 in
let t2' = expand_head_unif env t2 in
1997-04-01 12:52:21 -08:00
(* Expansion may have changed the representative of the types... *)
let t1' = repr t1' and t2' = repr t2' in
if t1' = = t2' then () else
1998-07-03 10:40:39 -07:00
begin try
TypePairs . find type_pairs ( t1' , t2' )
with Not_found ->
TypePairs . add type_pairs ( t1' , t2' ) () ;
1997-04-01 12:52:21 -08:00
match ( t1' . desc , t2' . desc ) with
2009-03-01 22:41:07 -08:00
( Tvar , _ ) when may_instantiate inst_nongen t1' ->
1997-04-01 12:52:21 -08:00
moregen_occur env t1' . level t2 ;
2002-11-20 21:39:01 -08:00
link_type t1' t2
2001-04-19 01:34:21 -07:00
| ( Tarrow ( l1 , t1 , u1 , _ ) , Tarrow ( l2 , t2 , u2 , _ ) ) when l1 = l2
2000-12-28 05:07:42 -08:00
| | ! Clflags . classic && not ( is_optional l1 | | is_optional l2 ) ->
1998-06-24 12:22:26 -07:00
moregen inst_nongen type_pairs env t1 t2 ;
moregen inst_nongen type_pairs env u1 u2
1997-04-01 12:52:21 -08:00
| ( Ttuple tl1 , Ttuple tl2 ) ->
1998-06-24 12:22:26 -07:00
moregen_list inst_nongen type_pairs env tl1 tl2
1997-04-01 12:52:21 -08:00
| ( Tconstr ( p1 , tl1 , _ ) , Tconstr ( p2 , tl2 , _ ) )
when Path . same p1 p2 ->
1998-06-24 12:22:26 -07:00
moregen_list inst_nongen type_pairs env tl1 tl2
2009-10-26 03:53:16 -07:00
| Tpackage ( p1 , n1 , tl1 ) , Tpackage ( p2 , n2 , tl2 ) when Path . same p1 p2 && n1 = n2 ->
moregen_list inst_nongen type_pairs env tl1 tl2
1999-11-30 08:07:38 -08:00
| ( Tvariant row1 , Tvariant row2 ) ->
moregen_row inst_nongen type_pairs env row1 row2
1997-04-01 12:52:21 -08:00
| ( Tobject ( fi1 , nm1 ) , Tobject ( fi2 , nm2 ) ) ->
1998-06-24 12:22:26 -07:00
moregen_fields inst_nongen type_pairs env fi1 fi2
1997-04-01 12:52:21 -08:00
| ( Tfield _ , Tfield _ ) -> (* Actually unused *)
1998-06-24 12:22:26 -07:00
moregen_fields inst_nongen type_pairs env t1' t2'
1997-04-01 12:52:21 -08:00
| ( Tnil , Tnil ) ->
()
2002-07-23 07:12:03 -07:00
| ( Tpoly ( t1 , [] ) , Tpoly ( t2 , [] ) ) ->
moregen inst_nongen type_pairs env t1 t2
| ( Tpoly ( t1 , tl1 ) , Tpoly ( t2 , tl2 ) ) ->
2004-10-13 17:54:20 -07:00
enter_poly env univar_pairs t1 tl1 t2 tl2
2004-10-13 03:05:26 -07:00
( moregen inst_nongen type_pairs env )
1997-04-01 12:52:21 -08:00
| ( _ , _ ) ->
raise ( Unify [] )
end
1998-06-24 12:22:26 -07:00
with Unify trace ->
raise ( Unify ( ( t1 , t2 ) :: trace ) )
1995-05-04 03:15:53 -07:00
1998-06-24 12:22:26 -07:00
and moregen_list inst_nongen type_pairs env tl1 tl2 =
if List . length tl1 < > List . length tl2 then
raise ( Unify [] ) ;
List . iter2 ( moregen inst_nongen type_pairs env ) tl1 tl2
1997-05-11 14:35:00 -07:00
1998-06-24 12:22:26 -07:00
and moregen_fields inst_nongen type_pairs env ty1 ty2 =
let ( fields1 , rest1 ) = flatten_fields ty1
and ( fields2 , rest2 ) = flatten_fields ty2 in
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
if miss1 < > [] then raise ( Unify [] ) ;
moregen inst_nongen type_pairs env rest1
1998-10-10 10:57:27 -07:00
( build_fields ( repr ty2 ) . level miss2 rest2 ) ;
1998-06-24 12:22:26 -07:00
List . iter
( fun ( n , k1 , t1 , k2 , t2 ) ->
moregen_kind k1 k2 ;
try moregen inst_nongen type_pairs env t1 t2 with Unify trace ->
raise ( Unify ( ( newty ( Tfield ( n , k1 , t1 , rest2 ) ) ,
newty ( Tfield ( n , k2 , t2 , rest2 ) ) ) :: trace ) ) )
pairs
and moregen_kind k1 k2 =
let k1 = field_kind_repr k1 in
let k2 = field_kind_repr k2 in
2002-10-15 18:26:15 -07:00
if k1 = = k2 then () else
1998-06-24 12:22:26 -07:00
match k1 , k2 with
2002-11-20 21:39:01 -08:00
( Fvar r , ( Fvar _ | Fpresent ) ) -> set_kind r k2
1998-06-24 12:22:26 -07:00
| ( Fpresent , Fpresent ) -> ()
| _ -> raise ( Unify [] )
1996-04-22 04:15:41 -07:00
1999-11-30 08:07:38 -08:00
and moregen_row inst_nongen type_pairs env row1 row2 =
let row1 = row_repr row1 and row2 = row_repr row2 in
2008-02-29 06:21:22 -08:00
let rm1 = repr row1 . row_more and rm2 = repr row2 . row_more in
if rm1 = = rm2 then () else
let may_inst = rm1 . desc = Tvar && may_instantiate inst_nongen rm1 in
1999-11-30 08:07:38 -08:00
let r1 , r2 , pairs = merge_row_fields row1 . row_fields row2 . row_fields in
let r1 , r2 =
if row2 . row_closed then
2008-02-29 06:21:22 -08:00
filter_row_fields may_inst r1 , filter_row_fields false r2
1999-11-30 08:07:38 -08:00
else r1 , r2
in
2006-09-20 04:14:37 -07:00
if r1 < > [] | | row1 . row_closed && ( not row2 . row_closed | | r2 < > [] )
1999-11-30 08:07:38 -08:00
then raise ( Unify [] ) ;
2008-02-29 06:21:22 -08:00
begin match rm1 . desc , rm2 . desc with
Tunivar , Tunivar ->
unify_univar rm1 rm2 ! univar_pairs
| Tunivar , _ | _ , Tunivar ->
raise ( Unify [] )
| _ when static_row row1 -> ()
| _ when may_inst ->
if not ( static_row row2 ) then moregen_occur env rm1 . level rm2 ;
let ext =
if r2 = [] then rm2 else
let row_ext = { row2 with row_fields = r2 } in
iter_row ( moregen_occur env rm1 . level ) row_ext ;
newty2 rm1 . level ( Tvariant row_ext )
in
link_type rm1 ext
| Tconstr _ , Tconstr _ ->
moregen inst_nongen type_pairs env rm1 rm2
| _ -> raise ( Unify [] )
end ;
1999-11-30 08:07:38 -08:00
List . iter
( fun ( l , f1 , f2 ) ->
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
if f1 = = f2 then () else
match f1 , f2 with
Rpresent ( Some t1 ) , Rpresent ( Some t2 ) ->
moregen inst_nongen type_pairs env t1 t2
| Rpresent None , Rpresent None -> ()
2008-02-29 06:21:22 -08:00
| Reither ( false , tl1 , _ , e1 ) , Rpresent ( Some t2 ) when may_inst ->
2002-11-20 21:39:01 -08:00
set_row_field e1 f2 ;
1999-11-30 08:07:38 -08:00
List . iter ( fun t1 -> moregen inst_nongen type_pairs env t1 t2 ) tl1
2001-11-23 06:28:21 -08:00
| Reither ( c1 , tl1 , _ , e1 ) , Reither ( c2 , tl2 , m2 , e2 ) ->
2002-09-01 20:41:14 -07:00
if e1 != e2 then begin
if c1 && not c2 then raise ( Unify [] ) ;
2002-11-20 21:39:01 -08:00
set_row_field e1 ( Reither ( c2 , [] , m2 , e2 ) ) ;
2002-09-01 20:41:14 -07:00
if List . length tl1 = List . length tl2 then
List . iter2 ( moregen inst_nongen type_pairs env ) tl1 tl2
else match tl2 with
t2 :: _ ->
List . iter ( fun t1 -> moregen inst_nongen type_pairs env t1 t2 )
tl1
| [] ->
if tl1 < > [] then raise ( Unify [] )
1999-11-30 08:07:38 -08:00
end
2008-02-29 06:21:22 -08:00
| Reither ( true , [] , _ , e1 ) , Rpresent None when may_inst ->
2002-11-20 21:39:01 -08:00
set_row_field e1 f2
2008-02-29 06:21:22 -08:00
| Reither ( _ , _ , _ , e1 ) , Rabsent when may_inst ->
2002-11-20 21:39:01 -08:00
set_row_field e1 f2
1999-11-30 08:07:38 -08:00
| Rabsent , Rabsent -> ()
| _ -> raise ( Unify [] ) )
pairs
2002-07-07 22:59:51 -07:00
(* Must empty univar_pairs first *)
let moregen inst_nongen type_pairs env patt subj =
univar_pairs := [] ;
moregen inst_nongen type_pairs env patt subj
1998-06-24 12:22:26 -07:00
(*
Non - generic variable can be instanciated only if [ inst_nongen ] is
true . So , [ inst_nongen ] should be set to false if the subject might
contain non - generic variables ( and we do not want them to be
instanciated ) .
Usually , the subject is given by the user , and the pattern
is unimportant . So , no need to propagate abbreviations .
* )
let moregeneral env inst_nongen pat_sch subj_sch =
1997-03-24 12:12:00 -08:00
let old_level = ! current_level in
current_level := generic_level - 1 ;
1997-04-01 12:52:21 -08:00
(*
Generic variables are first duplicated with [ instance ] . So ,
their levels are lowered to [ generic_level - 1 ] . The subject is
1998-06-24 12:22:26 -07:00
then copied with [ duplicate_type ] . That way , its levels won't be
1997-04-01 12:52:21 -08:00
changed .
* )
1998-06-24 12:22:26 -07:00
let subj = duplicate_type ( instance subj_sch ) in
1997-03-24 12:12:00 -08:00
current_level := generic_level ;
1997-04-01 12:52:21 -08:00
(* Duplicate generic variables *)
let patt = instance pat_sch in
1998-06-24 12:22:26 -07:00
let res =
1998-07-03 10:40:39 -07:00
try moregen inst_nongen ( TypePairs . create 13 ) env patt subj ; true with
1998-06-24 12:22:26 -07:00
Unify _ -> false
in
1997-04-01 12:52:21 -08:00
current_level := old_level ;
res
1995-05-04 03:15:53 -07:00
1997-01-21 05:38:42 -08:00
2003-06-28 03:46:32 -07:00
(* Alternative approach: "rigidify" a type scheme,
and check validity after unification * )
(* Simpler, no? *)
let rec rigidify_rec vars ty =
let ty = repr ty in
if ty . level > = lowest_level then begin
ty . level <- pivot_level - ty . level ;
2003-08-09 04:47:57 -07:00
match ty . desc with
2003-06-28 03:46:32 -07:00
| Tvar ->
if not ( List . memq ty ! vars ) then vars := ty :: ! vars
| Tvariant row ->
let row = row_repr row in
let more = repr row . row_more in
2003-08-09 04:47:57 -07:00
if more . desc = Tvar && not row . row_fixed then begin
2003-06-28 03:46:32 -07:00
let more' = newty2 more . level Tvar in
let row' = { row with row_fixed = true ; row_fields = [] ; row_more = more' }
in link_type more ( newty2 ty . level ( Tvariant row' ) )
2003-08-09 04:47:57 -07:00
end ;
iter_row ( rigidify_rec vars ) row ;
(* only consider the row variable if the variant is not static *)
if not ( static_row row ) then rigidify_rec vars ( row_more row )
| _ ->
iter_type_expr ( rigidify_rec vars ) ty
2003-06-28 03:46:32 -07:00
end
let rigidify ty =
let vars = ref [] in
rigidify_rec vars ty ;
unmark_type ty ;
! vars
2003-07-08 03:01:10 -07:00
let all_distinct_vars env vars =
2003-06-28 03:46:32 -07:00
let tyl = ref [] in
List . for_all
( fun ty ->
2003-07-08 03:01:10 -07:00
let ty = expand_head env ty in
2003-06-28 03:46:32 -07:00
if List . memq ty ! tyl then false else
( tyl := ty :: ! tyl ; ty . desc = Tvar ) )
vars
2003-06-30 01:04:42 -07:00
let matches env ty ty' =
let snap = snapshot () in
let vars = rigidify ty in
2003-08-09 05:09:11 -07:00
cleanup_abbrev () ;
2003-06-30 01:04:42 -07:00
let ok =
2003-07-08 03:01:10 -07:00
try unify env ty ty' ; all_distinct_vars env vars
2003-06-30 01:04:42 -07:00
with Unify _ -> false
in
backtrack snap ;
ok
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* Equivalence between parameterized types *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
2008-10-08 06:09:39 -07:00
let expand_head_rigid env ty =
let old = ! rigid_variants in
rigid_variants := true ;
let ty' = expand_head_unif env ty in
rigid_variants := old ; ty'
2003-04-02 18:15:38 -08:00
let normalize_subst subst =
if List . exists
( function { desc = Tlink _ } , _ | _ , { desc = Tlink _ } -> true | _ -> false )
! subst
then subst := List . map ( fun ( t1 , t2 ) -> repr t1 , repr t2 ) ! subst
1997-01-21 05:38:42 -08:00
1998-06-24 12:22:26 -07:00
let rec eqtype rename type_pairs subst env t1 t2 =
if t1 = = t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
if t1 = = t2 then () else
1997-03-09 08:52:49 -08:00
1998-06-24 12:22:26 -07:00
try
1997-04-12 05:39:20 -07:00
match ( t1 . desc , t2 . desc ) with
1998-06-24 12:22:26 -07:00
( Tvar , Tvar ) when rename ->
1997-04-12 05:39:20 -07:00
begin try
2003-04-02 18:15:38 -08:00
normalize_subst subst ;
1998-06-24 12:22:26 -07:00
if List . assq t1 ! subst != t2 then raise ( Unify [] )
1997-04-12 05:39:20 -07:00
with Not_found ->
2010-08-02 07:37:22 -07:00
if List . exists ( fun ( _ , t ) -> t = = t2 ) ! subst then raise ( Unify [] ) ;
1998-06-24 12:22:26 -07:00
subst := ( t1 , t2 ) :: ! subst
1997-04-12 05:39:20 -07:00
end
| ( Tconstr ( p1 , [] , _ ) , Tconstr ( p2 , [] , _ ) ) when Path . same p1 p2 ->
1998-06-24 12:22:26 -07:00
()
1997-04-12 05:39:20 -07:00
| _ ->
2008-10-08 06:09:39 -07:00
let t1' = expand_head_rigid env t1 in
let t2' = expand_head_rigid env t2 in
1997-04-12 05:39:20 -07:00
(* Expansion may have changed the representative of the types... *)
1998-06-24 12:22:26 -07:00
let t1' = repr t1' and t2' = repr t2' in
if t1' = = t2' then () else
1998-07-03 10:40:39 -07:00
begin try
TypePairs . find type_pairs ( t1' , t2' )
with Not_found ->
TypePairs . add type_pairs ( t1' , t2' ) () ;
1998-06-24 12:22:26 -07:00
match ( t1' . desc , t2' . desc ) with
1997-04-12 05:39:20 -07:00
( Tvar , Tvar ) when rename ->
begin try
2003-04-02 18:15:38 -08:00
normalize_subst subst ;
2000-08-09 18:46:48 -07:00
if List . assq t1' ! subst != t2' then raise ( Unify [] )
1997-04-12 05:39:20 -07:00
with Not_found ->
2010-08-02 07:37:22 -07:00
if List . exists ( fun ( _ , t ) -> t = = t2' ) ! subst then raise ( Unify [] ) ;
1998-06-24 12:22:26 -07:00
subst := ( t1' , t2' ) :: ! subst
1997-04-12 05:39:20 -07:00
end
2001-04-19 01:34:21 -07:00
| ( Tarrow ( l1 , t1 , u1 , _ ) , Tarrow ( l2 , t2 , u2 , _ ) ) when l1 = l2
2000-12-28 05:07:42 -08:00
| | ! Clflags . classic && not ( is_optional l1 | | is_optional l2 ) ->
1998-06-24 12:22:26 -07:00
eqtype rename type_pairs subst env t1 t2 ;
eqtype rename type_pairs subst env u1 u2 ;
1997-04-12 05:39:20 -07:00
| ( Ttuple tl1 , Ttuple tl2 ) ->
1998-06-24 12:22:26 -07:00
eqtype_list rename type_pairs subst env tl1 tl2
1997-04-12 05:39:20 -07:00
| ( Tconstr ( p1 , tl1 , _ ) , Tconstr ( p2 , tl2 , _ ) )
when Path . same p1 p2 ->
1998-06-24 12:22:26 -07:00
eqtype_list rename type_pairs subst env tl1 tl2
2009-10-26 03:53:16 -07:00
| Tpackage ( p1 , n1 , tl1 ) , Tpackage ( p2 , n2 , tl2 ) when Path . same p1 p2 && n1 = n2 ->
eqtype_list rename type_pairs subst env tl1 tl2
1999-11-30 08:07:38 -08:00
| ( Tvariant row1 , Tvariant row2 ) ->
eqtype_row rename type_pairs subst env row1 row2
1997-04-12 05:39:20 -07:00
| ( Tobject ( fi1 , nm1 ) , Tobject ( fi2 , nm2 ) ) ->
1998-06-24 12:22:26 -07:00
eqtype_fields rename type_pairs subst env fi1 fi2
1997-04-12 05:39:20 -07:00
| ( Tfield _ , Tfield _ ) -> (* Actually unused *)
1998-06-24 12:22:26 -07:00
eqtype_fields rename type_pairs subst env t1' t2'
1997-04-12 05:39:20 -07:00
| ( Tnil , Tnil ) ->
1998-06-24 12:22:26 -07:00
()
2002-07-23 07:12:03 -07:00
| ( Tpoly ( t1 , [] ) , Tpoly ( t2 , [] ) ) ->
eqtype rename type_pairs subst env t1 t2
| ( Tpoly ( t1 , tl1 ) , Tpoly ( t2 , tl2 ) ) ->
2004-10-13 17:54:20 -07:00
enter_poly env univar_pairs t1 tl1 t2 tl2
2004-10-13 03:05:26 -07:00
( eqtype rename type_pairs subst env )
2002-07-23 07:12:03 -07:00
| ( Tunivar , Tunivar ) ->
2007-02-18 16:49:16 -08:00
unify_univar t1' t2' ! univar_pairs
1997-04-12 05:39:20 -07:00
| ( _ , _ ) ->
1998-06-24 12:22:26 -07:00
raise ( Unify [] )
1997-04-12 05:39:20 -07:00
end
1998-06-24 12:22:26 -07:00
with Unify trace ->
raise ( Unify ( ( t1 , t2 ) :: trace ) )
1997-03-09 08:52:49 -08:00
1998-06-24 12:22:26 -07:00
and eqtype_list rename type_pairs subst env tl1 tl2 =
if List . length tl1 < > List . length tl2 then
raise ( Unify [] ) ;
List . iter2 ( eqtype rename type_pairs subst env ) tl1 tl2
1997-03-09 08:52:49 -08:00
1998-06-24 12:22:26 -07:00
and eqtype_fields rename type_pairs subst env ty1 ty2 =
2005-03-22 19:08:37 -08:00
let ( fields2 , rest2 ) = flatten_fields ty2 in
(* Try expansion, needed when called from Includecore.type_manifest *)
2008-10-08 06:09:39 -07:00
match expand_head_rigid env rest2 with
2005-03-22 19:08:37 -08:00
{ desc = Tobject ( ty2 , _ ) } -> eqtype_fields rename type_pairs subst env ty1 ty2
2008-10-08 06:09:39 -07:00
| _ ->
2005-03-22 19:08:37 -08:00
let ( fields1 , rest1 ) = flatten_fields ty1 in
1998-06-24 12:22:26 -07:00
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
eqtype rename type_pairs subst env rest1 rest2 ;
2010-09-30 00:46:10 -07:00
let miss1 = List . filter ( function ( _ , Fvar _ , _ ) -> false | _ -> true ) miss1 in (* GAH: should probably remove this *)
let miss2 = List . filter ( function ( _ , Fvar _ , _ ) -> false | _ -> true ) miss2 in
1998-06-24 12:22:26 -07:00
if ( miss1 < > [] ) | | ( miss2 < > [] ) then raise ( Unify [] ) ;
List . iter
( function ( n , k1 , t1 , k2 , t2 ) ->
eqtype_kind k1 k2 ;
try eqtype rename type_pairs subst env t1 t2 with Unify trace ->
raise ( Unify ( ( newty ( Tfield ( n , k1 , t1 , rest2 ) ) ,
newty ( Tfield ( n , k2 , t2 , rest2 ) ) ) :: trace ) ) )
pairs
and eqtype_kind k1 k2 =
let k1 = field_kind_repr k1 in
let k2 = field_kind_repr k2 in
match k1 , k2 with
( Fvar _ , Fvar _ )
| ( Fpresent , Fpresent ) -> ()
| _ -> raise ( Unify [] )
1999-11-30 08:07:38 -08:00
and eqtype_row rename type_pairs subst env row1 row2 =
2005-03-22 19:08:37 -08:00
(* Try expansion, needed when called from Includecore.type_manifest *)
2008-10-08 06:09:39 -07:00
match expand_head_rigid env ( row_more row2 ) with
2005-03-22 19:08:37 -08:00
{ desc = Tvariant row2 } -> eqtype_row rename type_pairs subst env row1 row2
2008-10-08 06:09:39 -07:00
| _ ->
1999-11-30 08:07:38 -08:00
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1 , r2 , pairs = merge_row_fields row1 . row_fields row2 . row_fields in
if row1 . row_closed < > row2 . row_closed
| | not row1 . row_closed && ( r1 < > [] | | r2 < > [] )
| | filter_row_fields false ( r1 @ r2 ) < > []
then raise ( Unify [] ) ;
2000-04-18 20:14:02 -07:00
if not ( static_row row1 ) then
eqtype rename type_pairs subst env row1 . row_more row2 . row_more ;
1999-11-30 08:07:38 -08:00
List . iter
( fun ( _ , f1 , f2 ) ->
match row_field_repr f1 , row_field_repr f2 with
Rpresent ( Some t1 ) , Rpresent ( Some t2 ) ->
eqtype rename type_pairs subst env t1 t2
2001-08-23 16:21:30 -07:00
| Reither ( true , [] , _ , _ ) , Reither ( true , [] , _ , _ ) ->
()
| Reither ( false , t1 :: tl1 , _ , _ ) , Reither ( false , t2 :: tl2 , _ , _ ) ->
eqtype rename type_pairs subst env t1 t2 ;
if List . length tl1 = List . length tl2 then
(* if same length allow different types ( meaning? ) *)
List . iter2 ( eqtype rename type_pairs subst env ) tl1 tl2
else begin
(* otherwise everything must be equal *)
List . iter ( eqtype rename type_pairs subst env t1 ) tl2 ;
List . iter ( fun t1 -> eqtype rename type_pairs subst env t1 t2 ) tl1
end
1999-11-30 08:07:38 -08:00
| Rpresent None , Rpresent None -> ()
| Rabsent , Rabsent -> ()
| _ -> raise ( Unify [] ) )
pairs
2006-09-20 04:14:37 -07:00
1998-06-24 12:22:26 -07:00
(* Two modes: with or without renaming of variables *)
let equal env rename tyl1 tyl2 =
1998-07-03 10:40:39 -07:00
try
2002-04-18 00:27:47 -07:00
univar_pairs := [] ;
1998-07-03 10:40:39 -07:00
eqtype_list rename ( TypePairs . create 11 ) ( ref [] ) env tyl1 tyl2 ; true
with
1998-06-24 12:22:26 -07:00
Unify _ -> false
2006-09-20 04:14:37 -07:00
(* Must empty univar_pairs first *)
2002-07-07 22:59:51 -07:00
let eqtype rename type_pairs subst env t1 t2 =
univar_pairs := [] ;
eqtype rename type_pairs subst env t1 t2
1998-06-24 12:22:26 -07:00
(* * * * * * * * * * * * * * * * * * * * * * * * *)
(* Class type matching *)
(* * * * * * * * * * * * * * * * * * * * * * * * *)
type class_match_failure =
CM_Virtual_class
| CM_Parameter_arity_mismatch of int * int
| CM_Type_parameter_mismatch of ( type_expr * type_expr ) list
| CM_Class_type_mismatch of class_type * class_type
| CM_Parameter_mismatch of ( type_expr * type_expr ) list
| CM_Val_type_mismatch of string * ( type_expr * type_expr ) list
| CM_Meth_type_mismatch of string * ( type_expr * type_expr ) list
| CM_Non_mutable_value of string
2006-04-04 19:28:13 -07:00
| CM_Non_concrete_value of string
1998-06-24 12:22:26 -07:00
| CM_Missing_value of string
| CM_Missing_method of string
| CM_Hide_public of string
2006-04-04 19:28:13 -07:00
| CM_Hide_virtual of string * string
1998-06-24 12:22:26 -07:00
| CM_Public_method of string
| CM_Private_method of string
| CM_Virtual_method of string
exception Failure of class_match_failure list
let rec moregen_clty trace type_pairs env cty1 cty2 =
try
match cty1 , cty2 with
Tcty_constr ( _ , _ , cty1 ) , _ ->
moregen_clty true type_pairs env cty1 cty2
| _ , Tcty_constr ( _ , _ , cty2 ) ->
moregen_clty true type_pairs env cty1 cty2
1999-11-30 08:07:38 -08:00
| Tcty_fun ( l1 , ty1 , cty1' ) , Tcty_fun ( l2 , ty2 , cty2' ) when l1 = l2 ->
1998-06-24 12:22:26 -07:00
begin try moregen true type_pairs env ty1 ty2 with Unify trace ->
raise ( Failure [ CM_Parameter_mismatch ( expand_trace env trace ) ] )
end ;
moregen_clty false type_pairs env cty1' cty2'
| Tcty_signature sign1 , Tcty_signature sign2 ->
let ty1 = object_fields ( repr sign1 . cty_self ) in
let ty2 = object_fields ( repr sign2 . cty_self ) in
let ( fields1 , rest1 ) = flatten_fields ty1
and ( fields2 , rest2 ) = flatten_fields ty2 in
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
List . iter
( fun ( lab , k1 , t1 , k2 , t2 ) ->
begin try moregen true type_pairs env t1 t2 with Unify trace ->
raise ( Failure [ CM_Meth_type_mismatch
( lab , expand_trace env trace ) ] )
end )
pairs ;
Vars . iter
2006-04-04 19:28:13 -07:00
( fun lab ( mut , v , ty ) ->
let ( mut' , v' , ty' ) = Vars . find lab sign1 . cty_vars in
1999-09-09 08:32:11 -07:00
try moregen true type_pairs env ty' ty with Unify trace ->
1998-06-24 12:22:26 -07:00
raise ( Failure [ CM_Val_type_mismatch
( lab , expand_trace env trace ) ] ) )
sign2 . cty_vars
| _ ->
raise ( Failure [] )
with
2010-08-02 07:37:22 -07:00
Failure error when trace | | error = [] ->
1998-06-24 12:22:26 -07:00
raise ( Failure ( CM_Class_type_mismatch ( cty1 , cty2 ) :: error ) )
2010-08-02 07:37:22 -07:00
let match_class_types ? ( trace = true ) env pat_sch subj_sch =
1998-07-03 10:40:39 -07:00
let type_pairs = TypePairs . create 53 in
1998-06-24 12:22:26 -07:00
let old_level = ! current_level in
current_level := generic_level - 1 ;
(*
Generic variables are first duplicated with [ instance ] . So ,
their levels are lowered to [ generic_level - 1 ] . The subject is
then copied with [ duplicate_type ] . That way , its levels won't be
changed .
* )
let ( _ , subj_inst ) = instance_class [] subj_sch in
let subj = duplicate_class_type subj_inst in
current_level := generic_level ;
(* Duplicate generic variables *)
let ( _ , patt ) = instance_class [] pat_sch in
let res =
let sign1 = signature_of_class_type patt in
let sign2 = signature_of_class_type subj in
let t1 = repr sign1 . cty_self in
let t2 = repr sign2 . cty_self in
1998-07-03 10:40:39 -07:00
TypePairs . add type_pairs ( t1 , t2 ) () ;
1998-06-24 12:22:26 -07:00
let ( fields1 , rest1 ) = flatten_fields ( object_fields t1 )
and ( fields2 , rest2 ) = flatten_fields ( object_fields t2 ) in
1997-02-20 12:39:02 -08:00
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
1998-06-24 12:22:26 -07:00
let error =
List . fold_right
( fun ( lab , k , _ ) err ->
let err =
let k = field_kind_repr k in
begin match k with
2002-11-20 21:39:01 -08:00
Fvar r -> set_kind r Fabsent ; err
2002-10-15 18:26:15 -07:00
| _ -> CM_Hide_public lab :: err
1998-06-24 12:22:26 -07:00
end
in
if Concr . mem lab sign1 . cty_concr then err
2006-04-04 19:28:13 -07:00
else CM_Hide_virtual ( " method " , lab ) :: err )
1998-06-24 12:22:26 -07:00
miss1 []
in
let missing_method = List . map ( fun ( m , _ , _ ) -> m ) miss2 in
let error =
( List . map ( fun m -> CM_Missing_method m ) missing_method ) @ error
in
(* Always succeeds *)
moregen true type_pairs env rest1 rest2 ;
let error =
List . fold_right
( fun ( lab , k1 , t1 , k2 , t2 ) err ->
try moregen_kind k1 k2 ; err with
Unify _ -> CM_Public_method lab :: err )
pairs error
in
let error =
Vars . fold
2006-04-04 19:28:13 -07:00
( fun lab ( mut , vr , ty ) err ->
1998-06-24 12:22:26 -07:00
try
2006-04-04 19:28:13 -07:00
let ( mut' , vr' , ty' ) = Vars . find lab sign1 . cty_vars in
1998-06-24 12:22:26 -07:00
if mut = Mutable && mut' < > Mutable then
CM_Non_mutable_value lab :: err
2006-04-04 19:28:13 -07:00
else if vr = Concrete && vr' < > Concrete then
CM_Non_concrete_value lab :: err
1998-06-24 12:22:26 -07:00
else
err
with Not_found ->
CM_Missing_value lab :: err )
sign2 . cty_vars error
in
2006-04-04 19:28:13 -07:00
let error =
Vars . fold
( fun lab ( _ , vr , _ ) err ->
if vr = Virtual && not ( Vars . mem lab sign2 . cty_vars ) then
CM_Hide_virtual ( " instance variable " , lab ) :: err
else err )
sign1 . cty_vars error
in
1998-06-24 12:22:26 -07:00
let error =
List . fold_right
( fun e l ->
if List . mem e missing_method then l else CM_Virtual_method e :: l )
( Concr . elements ( Concr . diff sign2 . cty_concr sign1 . cty_concr ) )
error
in
match error with
[] ->
begin try
2010-08-02 07:37:22 -07:00
moregen_clty trace type_pairs env patt subj ;
1998-06-24 12:22:26 -07:00
[]
with
Failure r -> r
end
| error ->
CM_Class_type_mismatch ( patt , subj ) :: error
in
current_level := old_level ;
res
let rec equal_clty trace type_pairs subst env cty1 cty2 =
try
match cty1 , cty2 with
Tcty_constr ( _ , _ , cty1 ) , Tcty_constr ( _ , _ , cty2 ) ->
equal_clty true type_pairs subst env cty1 cty2
| Tcty_constr ( _ , _ , cty1 ) , _ ->
equal_clty true type_pairs subst env cty1 cty2
| _ , Tcty_constr ( _ , _ , cty2 ) ->
equal_clty true type_pairs subst env cty1 cty2
1999-11-30 08:07:38 -08:00
| Tcty_fun ( l1 , ty1 , cty1' ) , Tcty_fun ( l2 , ty2 , cty2' ) when l1 = l2 ->
1998-06-24 12:22:26 -07:00
begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace ->
raise ( Failure [ CM_Parameter_mismatch ( expand_trace env trace ) ] )
end ;
equal_clty false type_pairs subst env cty1' cty2'
| Tcty_signature sign1 , Tcty_signature sign2 ->
let ty1 = object_fields ( repr sign1 . cty_self ) in
let ty2 = object_fields ( repr sign2 . cty_self ) in
let ( fields1 , rest1 ) = flatten_fields ty1
and ( fields2 , rest2 ) = flatten_fields ty2 in
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
List . iter
( fun ( lab , k1 , t1 , k2 , t2 ) ->
begin try eqtype true type_pairs subst env t1 t2 with
Unify trace ->
raise ( Failure [ CM_Meth_type_mismatch
( lab , expand_trace env trace ) ] )
end )
pairs ;
Vars . iter
2006-04-04 19:28:13 -07:00
( fun lab ( _ , _ , ty ) ->
let ( _ , _ , ty' ) = Vars . find lab sign1 . cty_vars in
2010-08-02 07:37:22 -07:00
try eqtype true type_pairs subst env ty' ty with Unify trace ->
1998-06-24 12:22:26 -07:00
raise ( Failure [ CM_Val_type_mismatch
( lab , expand_trace env trace ) ] ) )
sign2 . cty_vars
| _ ->
1999-11-03 10:32:21 -08:00
raise
( Failure ( if trace then []
else [ CM_Class_type_mismatch ( cty1 , cty2 ) ] ) )
1998-06-24 12:22:26 -07:00
with
Failure error when trace ->
raise ( Failure ( CM_Class_type_mismatch ( cty1 , cty2 ) :: error ) )
1997-04-12 05:39:20 -07:00
1998-06-24 12:22:26 -07:00
let match_class_declarations env patt_params patt_type subj_params subj_type =
1998-07-03 10:40:39 -07:00
let type_pairs = TypePairs . create 53 in
1998-06-24 12:22:26 -07:00
let subst = ref [] in
let sign1 = signature_of_class_type patt_type in
let sign2 = signature_of_class_type subj_type in
let t1 = repr sign1 . cty_self in
let t2 = repr sign2 . cty_self in
1998-07-03 10:40:39 -07:00
TypePairs . add type_pairs ( t1 , t2 ) () ;
1998-06-24 12:22:26 -07:00
let ( fields1 , rest1 ) = flatten_fields ( object_fields t1 )
and ( fields2 , rest2 ) = flatten_fields ( object_fields t2 ) in
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
let error =
List . fold_right
( fun ( lab , k , _ ) err ->
let err =
let k = field_kind_repr k in
begin match k with
Fvar r -> err
| _ -> CM_Hide_public lab :: err
end
in
if Concr . mem lab sign1 . cty_concr then err
2006-04-04 19:28:13 -07:00
else CM_Hide_virtual ( " method " , lab ) :: err )
1998-06-24 12:22:26 -07:00
miss1 []
in
let missing_method = List . map ( fun ( m , _ , _ ) -> m ) miss2 in
let error =
( List . map ( fun m -> CM_Missing_method m ) missing_method ) @ error
in
(* Always succeeds *)
eqtype true type_pairs subst env rest1 rest2 ;
let error =
List . fold_right
( fun ( lab , k1 , t1 , k2 , t2 ) err ->
let k1 = field_kind_repr k1 in
let k2 = field_kind_repr k2 in
match k1 , k2 with
( Fvar _ , Fvar _ )
| ( Fpresent , Fpresent ) -> err
| ( Fvar _ , Fpresent ) -> CM_Private_method lab :: err
1998-11-30 05:06:53 -08:00
| ( Fpresent , Fvar _ ) -> CM_Public_method lab :: err
1998-06-24 12:22:26 -07:00
| _ -> assert false )
pairs error
in
let error =
Vars . fold
2006-04-04 19:28:13 -07:00
( fun lab ( mut , vr , ty ) err ->
1998-06-24 12:22:26 -07:00
try
2006-04-04 19:28:13 -07:00
let ( mut' , vr' , ty' ) = Vars . find lab sign1 . cty_vars in
1998-06-24 12:22:26 -07:00
if mut = Mutable && mut' < > Mutable then
CM_Non_mutable_value lab :: err
2006-04-04 19:28:13 -07:00
else if vr = Concrete && vr' < > Concrete then
CM_Non_concrete_value lab :: err
1998-06-24 12:22:26 -07:00
else
err
with Not_found ->
CM_Missing_value lab :: err )
sign2 . cty_vars error
1995-05-04 03:15:53 -07:00
in
2006-04-04 19:28:13 -07:00
let error =
Vars . fold
( fun lab ( _ , vr , _ ) err ->
if vr = Virtual && not ( Vars . mem lab sign2 . cty_vars ) then
CM_Hide_virtual ( " instance variable " , lab ) :: err
else err )
sign1 . cty_vars error
in
1998-06-24 12:22:26 -07:00
let error =
List . fold_right
( fun e l ->
if List . mem e missing_method then l else CM_Virtual_method e :: l )
( Concr . elements ( Concr . diff sign2 . cty_concr sign1 . cty_concr ) )
error
in
match error with
[] ->
begin try
let lp = List . length patt_params in
let ls = List . length subj_params in
if lp < > ls then
raise ( Failure [ CM_Parameter_arity_mismatch ( lp , ls ) ] ) ;
List . iter2 ( fun p s ->
try eqtype true type_pairs subst env p s with Unify trace ->
raise ( Failure [ CM_Type_parameter_mismatch
( expand_trace env trace ) ] ) )
patt_params subj_params ;
2010-08-02 07:37:22 -07:00
(* old code: equal_clty false type_pairs subst env patt_type subj_type; *)
equal_clty false type_pairs subst env
( Tcty_signature sign1 ) ( Tcty_signature sign2 ) ;
(* Use moregeneral for class parameters, need to recheck everything to
keeps relationships ( PR # 4824 ) * )
let clty_params = List . fold_right ( fun ty cty -> Tcty_fun ( " * " , ty , cty ) ) in
match_class_types ~ trace : false env
( clty_params patt_params patt_type ) ( clty_params subj_params subj_type )
1998-06-24 12:22:26 -07:00
with
Failure r -> r
end
| error ->
error
1995-05-04 03:15:53 -07:00
1997-01-21 05:38:42 -08:00
1997-01-20 09:11:47 -08:00
(* * * * * * * * * * * * * * *)
(* Subtyping *)
(* * * * * * * * * * * * * * *)
1997-01-21 05:38:42 -08:00
(* * * * Build a subtype of a given type. * * * *)
1996-04-22 04:15:41 -07:00
2001-06-08 00:52:30 -07:00
(* build_subtype:
[ visited ] traces traversed object and variant types
[ loops ] is a mapping from variables to variables , to reproduce
positive loops in a class type
[ posi ] true if the current variance is positive
2002-06-04 00:37:19 -07:00
[ level ] number of expansions / enlargement allowed on this branch * )
1995-05-04 03:15:53 -07:00
2002-06-12 02:52:08 -07:00
let warn = ref false (* whether double coercion might do better *)
2002-05-29 23:24:45 -07:00
let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n
let pred_enlarge n = if n mod 2 = 1 then pred n else n
2002-06-04 00:37:19 -07:00
type change = Unchanged | Equiv | Changed
2002-05-29 23:24:45 -07:00
let collect l = List . fold_left ( fun c1 ( _ , c2 ) -> max c1 c2 ) Unchanged l
let rec filter_visited = function
[] -> []
2002-06-04 00:37:19 -07:00
| { desc = Tobject _ | Tvariant _ } :: _ as l -> l
| _ :: l -> filter_visited l
2002-05-29 23:24:45 -07:00
2002-06-12 02:52:08 -07:00
let memq_warn t visited =
if List . memq t visited then ( warn := true ; true ) else false
2003-11-25 01:20:45 -08:00
let rec lid_of_path sharp = function
Path . Pident id ->
Longident . Lident ( sharp ^ Ident . name id )
| Path . Pdot ( p1 , s , _ ) ->
Longident . Ldot ( lid_of_path " " p1 , sharp ^ s )
| Path . Papply ( p1 , p2 ) ->
Longident . Lapply ( lid_of_path sharp p1 , lid_of_path " " p2 )
let find_cltype_for_path env p =
let path , cl_abbr = Env . lookup_type ( lid_of_path " # " p ) env in
match cl_abbr . type_manifest with
Some ty ->
begin match ( repr ty ) . desc with
Tobject ( _ , { contents = Some ( p' , _ ) } ) when Path . same p p' -> cl_abbr , ty
| _ -> raise Not_found
end
| None -> assert false
2005-03-22 19:08:37 -08:00
let has_constr_row' env t =
has_constr_row ( expand_abbrev env t )
2002-06-04 00:37:19 -07:00
let rec build_subtype env visited loops posi level t =
1997-01-20 09:11:47 -08:00
let t = repr t in
1996-04-22 04:15:41 -07:00
match t . desc with
2000-09-06 03:21:07 -07:00
Tvar ->
if posi then
try
2002-06-12 02:52:08 -07:00
let t' = List . assq t loops in
warn := true ;
2003-04-02 18:15:38 -08:00
( t' , Equiv )
2000-09-06 03:21:07 -07:00
with Not_found ->
2002-05-29 23:24:45 -07:00
( t , Unchanged )
2000-09-06 03:21:07 -07:00
else
2002-05-29 23:24:45 -07:00
( t , Unchanged )
2001-04-19 01:34:21 -07:00
| Tarrow ( l , t1 , t2 , _ ) ->
2002-06-12 02:52:08 -07:00
if memq_warn t visited then ( t , Unchanged ) else
2002-06-09 19:38:31 -07:00
let visited = t :: visited in
2002-06-04 00:37:19 -07:00
let ( t1' , c1 ) = build_subtype env visited loops ( not posi ) level t1 in
let ( t2' , c2 ) = build_subtype env visited loops posi level t2 in
2002-05-29 23:24:45 -07:00
let c = max c1 c2 in
if c > Unchanged then ( newty ( Tarrow ( l , t1' , t2' , Cok ) ) , c )
else ( t , Unchanged )
1996-04-22 04:15:41 -07:00
| Ttuple tlist ->
2002-06-12 02:52:08 -07:00
if memq_warn t visited then ( t , Unchanged ) else
2002-06-09 19:38:31 -07:00
let visited = t :: visited in
2001-06-08 00:52:30 -07:00
let tlist' =
2002-06-04 00:37:19 -07:00
List . map ( build_subtype env visited loops posi level ) tlist
1996-04-22 04:15:41 -07:00
in
2002-05-29 23:24:45 -07:00
let c = collect tlist' in
if c > Unchanged then ( newty ( Ttuple ( List . map fst tlist' ) ) , c )
else ( t , Unchanged )
2005-03-22 19:08:37 -08:00
| Tconstr ( p , tl , abbrev )
2006-09-20 04:14:37 -07:00
when level > 0 && generic_abbrev env p && safe_abbrev env t
&& not ( has_constr_row' env t ) ->
2000-06-23 01:08:34 -07:00
let t' = repr ( expand_abbrev env t ) in
2002-06-04 00:37:19 -07:00
let level' = pred_expand level in
2001-06-08 00:52:30 -07:00
begin try match t' . desc with
2002-05-29 23:24:45 -07:00
Tobject _ when posi && not ( opened_object t' ) ->
2003-11-25 01:20:45 -08:00
let cl_abbr , body = find_cltype_for_path env p in
2001-06-08 00:52:30 -07:00
let ty =
2008-07-18 19:13:09 -07:00
subst env ! current_level Public abbrev None
cl_abbr . type_params tl body in
2001-06-08 00:52:30 -07:00
let ty = repr ty in
2002-05-29 23:24:45 -07:00
let ty1 , tl1 =
2001-06-08 00:52:30 -07:00
match ty . desc with
2002-05-29 23:24:45 -07:00
Tobject ( ty1 , { contents = Some ( p' , tl1 ) } ) when Path . same p p' ->
ty1 , tl1
2001-06-08 08:24:34 -07:00
| _ -> raise Not_found
in
2008-10-08 06:09:39 -07:00
(* Fix PR4505: do not set ty to Tvar when it appears in tl1,
as this occurence might break the occur check .
XXX not clear whether this correct anyway .. . * )
if List . exists ( deep_occur ty ) tl1 then raise Not_found ;
2001-06-08 00:52:30 -07:00
ty . desc <- Tvar ;
let t'' = newvar () in
2002-06-04 00:37:19 -07:00
let loops = ( ty , t'' ) :: loops in
(* May discard [visited] as level is going down *)
2002-05-29 23:24:45 -07:00
let ( ty1' , c ) =
2002-06-04 00:37:19 -07:00
build_subtype env [ t' ] loops posi ( pred_enlarge level' ) ty1 in
2001-06-08 00:52:30 -07:00
assert ( t'' . desc = Tvar ) ;
2002-05-29 23:24:45 -07:00
let nm =
2002-06-04 00:37:19 -07:00
if c > Equiv | | deep_occur ty ty1' then None else Some ( p , tl1 ) in
2002-05-29 23:24:45 -07:00
t'' . desc <- Tobject ( ty1' , ref nm ) ;
2002-04-18 00:27:47 -07:00
( try unify_var env ty t with Unify _ -> assert false ) ;
2002-05-29 23:24:45 -07:00
( t'' , Changed )
2001-06-08 00:52:30 -07:00
| _ -> raise Not_found
2002-05-29 23:24:45 -07:00
with Not_found ->
2002-07-23 07:12:03 -07:00
let ( t'' , c ) = build_subtype env visited loops posi level' t' in
2002-05-29 23:24:45 -07:00
if c > Unchanged then ( t'' , c )
else ( t , Unchanged )
2001-06-08 00:52:30 -07:00
end
1996-04-22 04:15:41 -07:00
| Tconstr ( p , tl , abbrev ) ->
2002-06-02 02:06:51 -07:00
(* Must check recursion on constructors, since we do not always
expand them * )
2002-06-12 02:52:08 -07:00
if memq_warn t visited then ( t , Unchanged ) else
2002-06-02 02:06:51 -07:00
let visited = t :: visited in
2001-09-28 15:55:27 -07:00
begin try
let decl = Env . find_type p env in
2006-09-20 04:14:37 -07:00
if level = 0 && generic_abbrev env p && safe_abbrev env t
&& not ( has_constr_row' env t )
2005-03-22 19:08:37 -08:00
then warn := true ;
2001-09-28 15:55:27 -07:00
let tl' =
List . map2
2003-05-21 02:04:54 -07:00
( fun ( co , cn , _ ) t ->
2001-09-28 15:55:27 -07:00
if cn then
2002-05-29 23:24:45 -07:00
if co then ( t , Unchanged )
2002-06-04 00:37:19 -07:00
else build_subtype env visited loops ( not posi ) level t
2001-09-28 15:55:27 -07:00
else
2002-06-04 00:37:19 -07:00
if co then build_subtype env visited loops posi level t
2002-05-29 23:24:45 -07:00
else ( newvar () , Changed ) )
2001-09-28 15:55:27 -07:00
decl . type_variance tl
in
2002-05-29 23:24:45 -07:00
let c = collect tl' in
if c > Unchanged then ( newconstr p ( List . map fst tl' ) , c )
else ( t , Unchanged )
2001-09-28 15:55:27 -07:00
with Not_found ->
2002-05-29 23:24:45 -07:00
( t , Unchanged )
2001-09-28 15:55:27 -07:00
end
1999-11-30 08:07:38 -08:00
| Tvariant row ->
let row = row_repr row in
2002-06-12 02:52:08 -07:00
if memq_warn t visited | | not ( static_row row ) then ( t , Unchanged ) else
2002-06-04 00:37:19 -07:00
let level' = pred_enlarge level in
let visited =
t :: if level' < level then [] else filter_visited visited in
2002-05-29 23:24:45 -07:00
let fields = filter_row_fields false row . row_fields in
1999-11-30 08:07:38 -08:00
let fields =
List . map
2000-09-06 03:21:07 -07:00
( fun ( l , f as orig ) -> match row_field_repr f with
1999-11-30 08:07:38 -08:00
Rpresent None ->
2005-06-12 18:11:02 -07:00
if posi then
2002-05-29 23:24:45 -07:00
( l , Reither ( true , [] , false , ref None ) ) , Unchanged
2000-09-06 03:21:07 -07:00
else
2002-05-29 23:24:45 -07:00
orig , Unchanged
1999-11-30 08:07:38 -08:00
| Rpresent ( Some t ) ->
2002-06-04 00:37:19 -07:00
let ( t' , c ) = build_subtype env visited loops posi level' t in
2008-01-11 08:13:18 -08:00
let f =
if posi && level > 0
then Reither ( false , [ t' ] , false , ref None )
else Rpresent ( Some t' )
in ( l , f ) , c
1999-11-30 08:07:38 -08:00
| _ -> assert false )
2002-05-29 23:24:45 -07:00
fields
1999-11-30 08:07:38 -08:00
in
2002-05-29 23:24:45 -07:00
let c = collect fields in
1999-11-30 08:07:38 -08:00
let row =
2002-01-03 18:02:50 -08:00
{ row_fields = List . map fst fields ; row_more = newvar () ;
2008-01-11 08:13:18 -08:00
row_bound = () ; row_closed = posi ; row_fixed = false ;
2002-05-29 23:24:45 -07:00
row_name = if c > Unchanged then None else row . row_name }
1999-11-30 08:07:38 -08:00
in
2002-05-29 23:24:45 -07:00
( newty ( Tvariant row ) , Changed )
1996-04-22 04:15:41 -07:00
| Tobject ( t1 , _ ) ->
2002-06-12 02:52:08 -07:00
if memq_warn t visited | | opened_object t1 then ( t , Unchanged ) else
2002-06-04 00:37:19 -07:00
let level' = pred_enlarge level in
let visited =
t :: if level' < level then [] else filter_visited visited in
let ( t1' , c ) = build_subtype env visited loops posi level' t1 in
2002-05-29 23:24:45 -07:00
if c > Unchanged then ( newty ( Tobject ( t1' , ref None ) ) , c )
else ( t , Unchanged )
1997-05-11 14:35:00 -07:00
| Tfield ( s , _ , t1 , t2 ) (* Always present *) ->
2002-06-04 00:37:19 -07:00
let ( t1' , c1 ) = build_subtype env visited loops posi level t1 in
let ( t2' , c2 ) = build_subtype env visited loops posi level t2 in
2002-05-29 23:24:45 -07:00
let c = max c1 c2 in
if c > Unchanged then ( newty ( Tfield ( s , Fpresent , t1' , t2' ) ) , c )
else ( t , Unchanged )
1996-04-22 04:15:41 -07:00
| Tnil ->
2002-05-29 23:24:45 -07:00
if posi then
2000-09-06 03:21:07 -07:00
let v = newvar () in
2002-05-29 23:24:45 -07:00
( v , Changed )
2002-06-12 02:52:08 -07:00
else begin
warn := true ;
2002-05-29 23:24:45 -07:00
( t , Unchanged )
2002-06-12 02:52:08 -07:00
end
2000-09-06 03:21:07 -07:00
| Tsubst _ | Tlink _ ->
1999-11-30 08:07:38 -08:00
assert false
2002-04-18 00:27:47 -07:00
| Tpoly ( t1 , tl ) ->
2002-06-04 00:37:19 -07:00
let ( t1' , c ) = build_subtype env visited loops posi level t1 in
2002-05-29 23:24:45 -07:00
if c > Unchanged then ( newty ( Tpoly ( t1' , tl ) ) , c )
else ( t , Unchanged )
2009-10-26 03:53:16 -07:00
| Tunivar | Tpackage _ ->
2002-05-29 23:24:45 -07:00
( t , Unchanged )
1995-05-04 03:15:53 -07:00
2002-05-29 23:24:45 -07:00
let enlarge_type env ty =
warn := false ;
2002-06-04 00:37:19 -07:00
(* [level = 4] allows 2 expansions involving objects/variants *)
2002-05-29 23:24:45 -07:00
let ( ty' , _ ) = build_subtype env [] [] true 4 ty in
( ty' , ! warn )
1996-04-22 04:15:41 -07:00
1997-01-21 05:38:42 -08:00
(* * * * Check whether a type is a subtype of another type. * * * *)
1997-01-20 09:11:47 -08:00
1997-01-21 09:43:53 -08:00
(*
1997-01-23 04:46:46 -08:00
During the traversal , a trace of visited types is maintained . It
is printed in case of error .
1997-01-21 09:43:53 -08:00
Constraints ( pairs of types that must be equals ) are accumulated
rather than being enforced straight . Indeed , the result would
otherwise depend on the order in which these constraints are
enforced .
A function enforcing these constraints is returned . That way , type
variables can be bound to their actual values before this function
1997-01-23 04:46:46 -08:00
is called ( see Typecore ) .
Only well - defined abbreviations are expanded ( hence the tests
[ generic_abbrev .. . ] ) .
1997-01-21 09:43:53 -08:00
* )
1998-07-03 10:40:39 -07:00
let subtypes = TypePairs . create 17
1996-04-22 04:15:41 -07:00
1997-01-20 09:11:47 -08:00
let subtype_error env trace =
raise ( Subtype ( expand_trace env ( List . rev trace ) , [] ) )
1996-10-26 12:39:26 -07:00
2007-11-30 04:37:45 -08:00
let private_abbrev env path =
try
let decl = Env . find_type path env in
decl . type_private = Private && decl . type_manifest < > None
with Not_found -> false
1998-06-24 12:22:26 -07:00
let rec subtype_rec env trace t1 t2 cstrs =
1997-01-20 09:11:47 -08:00
let t1 = repr t1 in
let t2 = repr t2 in
2005-08-16 22:38:23 -07:00
if t1 = = t2 then cstrs else
2006-09-20 04:14:37 -07:00
1998-07-03 10:40:39 -07:00
begin try
TypePairs . find subtypes ( t1 , t2 ) ;
1998-06-24 12:22:26 -07:00
cstrs
1998-07-03 10:40:39 -07:00
with Not_found ->
TypePairs . add subtypes ( t1 , t2 ) () ;
1996-04-22 04:15:41 -07:00
match ( t1 . desc , t2 . desc ) with
1997-01-20 09:11:47 -08:00
( Tvar , _ ) | ( _ , Tvar ) ->
2002-04-18 00:27:47 -07:00
( trace , t1 , t2 , ! univar_pairs ) :: cstrs
2001-04-19 01:34:21 -07:00
| ( Tarrow ( l1 , t1 , u1 , _ ) , Tarrow ( l2 , t2 , u2 , _ ) ) when l1 = l2
2000-12-28 05:07:42 -08:00
| | ! Clflags . classic && not ( is_optional l1 | | is_optional l2 ) ->
1998-06-24 12:22:26 -07:00
let cstrs = subtype_rec env ( ( t2 , t1 ) :: trace ) t2 t1 cstrs in
subtype_rec env ( ( u1 , u2 ) :: trace ) u1 u2 cstrs
1996-04-22 04:15:41 -07:00
| ( Ttuple tl1 , Ttuple tl2 ) ->
1998-06-24 12:22:26 -07:00
subtype_list env trace tl1 tl2 cstrs
1998-07-03 10:40:39 -07:00
| ( Tconstr ( p1 , [] , _ ) , Tconstr ( p2 , [] , _ ) ) when Path . same p1 p2 ->
cstrs
2006-09-20 04:14:37 -07:00
| ( Tconstr ( p1 , tl1 , abbrev1 ) , _ )
when generic_abbrev env p1 && safe_abbrev env t1 ->
1998-06-24 12:22:26 -07:00
subtype_rec env trace ( expand_abbrev env t1 ) t2 cstrs
2006-09-20 04:14:37 -07:00
| ( _ , Tconstr ( p2 , tl2 , abbrev2 ) )
when generic_abbrev env p2 && safe_abbrev env t2 ->
1998-06-24 12:22:26 -07:00
subtype_rec env trace t1 ( expand_abbrev env t2 ) cstrs
2000-09-06 03:21:07 -07:00
| ( Tconstr ( p1 , tl1 , _ ) , Tconstr ( p2 , tl2 , _ ) ) when Path . same p1 p2 ->
2001-09-28 15:55:27 -07:00
begin try
let decl = Env . find_type p1 env in
List . fold_left2
2003-05-21 02:04:54 -07:00
( fun cstrs ( co , cn , _ ) ( t1 , t2 ) ->
2001-09-28 15:55:27 -07:00
if co then
if cn then
( trace , newty2 t1 . level ( Ttuple [ t1 ] ) ,
2006-09-20 04:14:37 -07:00
newty2 t2 . level ( Ttuple [ t2 ] ) , ! univar_pairs ) :: cstrs
2001-09-28 15:55:27 -07:00
else subtype_rec env ( ( t1 , t2 ) :: trace ) t1 t2 cstrs
else
if cn then subtype_rec env ( ( t2 , t1 ) :: trace ) t2 t1 cstrs
else cstrs )
cstrs decl . type_variance ( List . combine tl1 tl2 )
with Not_found ->
2002-04-18 00:27:47 -07:00
( trace , t1 , t2 , ! univar_pairs ) :: cstrs
2001-09-28 15:55:27 -07:00
end
2007-11-30 04:37:45 -08:00
| ( Tconstr ( p1 , tl1 , _ ) , _ ) when private_abbrev env p1 ->
subtype_rec env trace ( expand_abbrev_opt env t1 ) t2 cstrs
1997-01-23 04:46:46 -08:00
| ( Tobject ( f1 , _ ) , Tobject ( f2 , _ ) )
2005-08-16 22:38:23 -07:00
when ( object_row f1 ) . desc = Tvar && ( object_row f2 ) . desc = Tvar ->
1997-01-23 04:46:46 -08:00
(* Same row variable implies same object. *)
2002-04-18 00:27:47 -07:00
( trace , t1 , t2 , ! univar_pairs ) :: cstrs
1996-04-22 04:15:41 -07:00
| ( Tobject ( f1 , _ ) , Tobject ( f2 , _ ) ) ->
1998-06-24 12:22:26 -07:00
subtype_fields env trace f1 f2 cstrs
1999-11-30 08:07:38 -08:00
| ( Tvariant row1 , Tvariant row2 ) ->
begin try
2005-08-18 20:50:12 -07:00
subtype_row env trace row1 row2 cstrs
1999-11-30 08:07:38 -08:00
with Exit ->
2002-04-18 00:27:47 -07:00
( trace , t1 , t2 , ! univar_pairs ) :: cstrs
1999-11-30 08:07:38 -08:00
end
2002-04-18 00:27:47 -07:00
| ( Tpoly ( u1 , [] ) , Tpoly ( u2 , [] ) ) ->
2002-07-23 07:12:03 -07:00
subtype_rec env trace u1 u2 cstrs
2007-11-30 04:37:45 -08:00
| ( Tpoly ( u1 , tl1 ) , Tpoly ( u2 , [] ) ) ->
let _ , u1' = instance_poly false tl1 u1 in
subtype_rec env trace u1' u2 cstrs
2004-10-13 17:54:20 -07:00
| ( Tpoly ( u1 , tl1 ) , Tpoly ( u2 , tl2 ) ) ->
begin try
enter_poly env univar_pairs u1 tl1 u2 tl2
( fun t1 t2 -> subtype_rec env trace t1 t2 cstrs )
with Unify _ ->
( trace , t1 , t2 , ! univar_pairs ) :: cstrs
end
1996-04-22 04:15:41 -07:00
| ( _ , _ ) ->
2002-04-18 00:27:47 -07:00
( trace , t1 , t2 , ! univar_pairs ) :: cstrs
1997-01-20 09:11:47 -08:00
end
1996-04-22 04:15:41 -07:00
1998-06-24 12:22:26 -07:00
and subtype_list env trace tl1 tl2 cstrs =
1996-05-31 05:27:03 -07:00
if List . length tl1 < > List . length tl2 then
1997-01-20 09:11:47 -08:00
subtype_error env trace ;
List . fold_left2
1998-06-24 12:22:26 -07:00
( fun cstrs t1 t2 -> subtype_rec env ( ( t1 , t2 ) :: trace ) t1 t2 cstrs )
cstrs tl1 tl2
1996-04-22 04:15:41 -07:00
1998-06-24 12:22:26 -07:00
and subtype_fields env trace ty1 ty2 cstrs =
2005-08-18 20:50:12 -07:00
(* Assume that either rest1 or rest2 is not Tvar *)
1996-04-22 04:15:41 -07:00
let ( fields1 , rest1 ) = flatten_fields ty1 in
let ( fields2 , rest2 ) = flatten_fields ty2 in
let ( pairs , miss1 , miss2 ) = associate_fields fields1 fields2 in
2005-08-16 22:38:23 -07:00
let cstrs =
if rest2 . desc = Tnil then cstrs else
if miss1 = [] then
subtype_rec env ( ( rest1 , rest2 ) :: trace ) rest1 rest2 cstrs
else
( trace , build_fields ( repr ty1 ) . level miss1 rest1 , rest2 ,
! univar_pairs ) :: cstrs
in
let cstrs =
if miss2 = [] then cstrs else
( trace , rest1 , build_fields ( repr ty2 ) . level miss2 ( newvar () ) ,
! univar_pairs ) :: cstrs
in
List . fold_left
( fun cstrs ( _ , k1 , t1 , k2 , t2 ) ->
(* Theses fields are always present *)
subtype_rec env ( ( t1 , t2 ) :: trace ) t1 t2 cstrs )
cstrs pairs
1997-01-20 09:11:47 -08:00
2005-08-18 20:50:12 -07:00
and subtype_row env trace row1 row2 cstrs =
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1 , r2 , pairs =
merge_row_fields row1 . row_fields row2 . row_fields in
let more1 = repr row1 . row_more
and more2 = repr row2 . row_more in
match more1 . desc , more2 . desc with
Tconstr ( p1 , _ , _ ) , Tconstr ( p2 , _ , _ ) when Path . same p1 p2 ->
subtype_rec env ( ( more1 , more2 ) :: trace ) more1 more2 cstrs
| ( Tvar | Tconstr _ ) , ( Tvar | Tconstr _ )
when row1 . row_closed && r1 = [] ->
List . fold_left
( fun cstrs ( _ , f1 , f2 ) ->
match row_field_repr f1 , row_field_repr f2 with
( Rpresent None | Reither ( true , _ , _ , _ ) ) , Rpresent None ->
cstrs
| Rpresent ( Some t1 ) , Rpresent ( Some t2 ) ->
subtype_rec env ( ( t1 , t2 ) :: trace ) t1 t2 cstrs
| Reither ( false , t1 :: _ , _ , _ ) , Rpresent ( Some t2 ) ->
subtype_rec env ( ( t1 , t2 ) :: trace ) t1 t2 cstrs
| Rabsent , _ -> cstrs
| _ -> raise Exit )
cstrs pairs
| Tunivar , Tunivar
when row1 . row_closed = row2 . row_closed && r1 = [] && r2 = [] ->
let cstrs =
subtype_rec env ( ( more1 , more2 ) :: trace ) more1 more2 cstrs in
List . fold_left
( fun cstrs ( _ , f1 , f2 ) ->
match row_field_repr f1 , row_field_repr f2 with
Rpresent None , Rpresent None
| Reither ( true , [] , _ , _ ) , Reither ( true , [] , _ , _ )
| Rabsent , Rabsent ->
cstrs
| Rpresent ( Some t1 ) , Rpresent ( Some t2 )
| Reither ( false , [ t1 ] , _ , _ ) , Reither ( false , [ t2 ] , _ , _ ) ->
subtype_rec env ( ( t1 , t2 ) :: trace ) t1 t2 cstrs
| _ -> raise Exit )
cstrs pairs
| _ ->
raise Exit
1997-01-20 09:11:47 -08:00
let subtype env ty1 ty2 =
1998-07-03 10:40:39 -07:00
TypePairs . clear subtypes ;
2002-04-18 00:27:47 -07:00
univar_pairs := [] ;
1997-01-20 09:11:47 -08:00
(* Build constraint set. *)
1998-06-24 12:22:26 -07:00
let cstrs = subtype_rec env [ ( ty1 , ty2 ) ] ty1 ty2 [] in
2001-11-05 01:04:08 -08:00
TypePairs . clear subtypes ;
1997-01-20 09:11:47 -08:00
(* Enforce constraints. *)
function () ->
List . iter
2002-04-18 00:27:47 -07:00
( function ( trace0 , t1 , t2 , pairs ) ->
2010-09-18 21:55:40 -07:00
try unify_pairs ( ref env ) t1 t2 pairs with Unify trace ->
1997-01-20 09:11:47 -08:00
raise ( Subtype ( expand_trace env ( List . rev trace0 ) ,
List . tl ( List . tl trace ) ) ) )
2001-11-05 01:04:08 -08:00
( List . rev cstrs )
1997-01-21 05:38:42 -08:00
1997-03-09 08:52:49 -08:00
(* * * * * * * * * * * * * * * * * * *)
(* Miscellaneous *)
(* * * * * * * * * * * * * * * * * * *)
2002-05-29 23:24:45 -07:00
(* Utility for printing. The resulting type is not used in computation. *)
let rec unalias_object ty =
let ty = repr ty in
match ty . desc with
Tfield ( s , k , t1 , t2 ) ->
newty2 ty . level ( Tfield ( s , k , t1 , unalias_object t2 ) )
| Tvar | Tnil ->
newty2 ty . level ty . desc
| Tunivar ->
ty
2005-03-22 19:08:37 -08:00
| Tconstr _ ->
newty2 ty . level Tvar
2002-05-29 23:24:45 -07:00
| _ ->
assert false
1997-03-09 08:52:49 -08:00
let unalias ty =
let ty = repr ty in
match ty . desc with
2002-05-29 23:24:45 -07:00
Tvar | Tunivar ->
1997-03-09 08:52:49 -08:00
ty
2000-06-27 22:47:42 -07:00
| Tvariant row ->
let row = row_repr row in
let more = row . row_more in
newty2 ty . level
( Tvariant { row with row_more = newty2 more . level more . desc } )
2002-05-29 23:24:45 -07:00
| Tobject ( ty , nm ) ->
newty2 ty . level ( Tobject ( unalias_object ty , nm ) )
1997-03-09 08:52:49 -08:00
| _ ->
1998-07-03 10:40:39 -07:00
newty2 ty . level ty . desc
1997-03-09 08:52:49 -08:00
(* Return the arity ( as for curried functions ) of the given type. *)
let rec arity ty =
match ( repr ty ) . desc with
2001-04-19 01:34:21 -07:00
Tarrow ( _ , t1 , t2 , _ ) -> 1 + arity t2
1997-03-09 08:52:49 -08:00
| _ -> 0
1997-06-29 06:16:47 -07:00
(* Check whether an abbreviation expands to itself. *)
2003-06-19 08:53:53 -07:00
let cyclic_abbrev env id ty =
let rec check_cycle seen ty =
let ty = repr ty in
match ty . desc with
Tconstr ( p , tl , abbrev ) ->
2003-09-25 01:05:38 -07:00
p = Path . Pident id | | List . memq ty seen | |
begin try
2010-04-26 01:55:20 -07:00
check_cycle ( ty :: seen ) ( expand_abbrev_opt env ty )
2006-09-20 04:14:37 -07:00
with
Cannot_expand -> false
| Unify _ -> true
2003-06-19 08:53:53 -07:00
end
| _ ->
1997-06-29 06:16:47 -07:00
false
2003-09-25 01:05:38 -07:00
in check_cycle [] ty
2000-05-24 19:08:23 -07:00
(* Normalize a type before printing, saving... *)
2009-05-20 04:52:42 -07:00
(* Cannot use mark_type because deep_occur uses it too *)
let rec normalize_type_rec env visited ty =
2000-02-24 02:18:25 -08:00
let ty = repr ty in
2009-05-20 04:52:42 -07:00
if not ( TypeSet . mem ty ! visited ) then begin
visited := TypeSet . add ty ! visited ;
2000-05-10 19:22:54 -07:00
begin match ty . desc with
| Tvariant row ->
2000-02-24 02:18:25 -08:00
let row = row_repr row in
2000-03-08 23:39:05 -08:00
let fields = List . map
2008-10-08 06:09:39 -07:00
( fun ( l , f0 ) ->
let f = row_field_repr f0 in l ,
2001-03-02 16:14:35 -08:00
match f with Reither ( b , ty :: ( _ :: _ as tyl ) , m , e ) ->
2000-03-08 23:39:05 -08:00
let tyl' =
2000-03-14 23:55:24 -08:00
List . fold_left
2000-03-08 23:39:05 -08:00
( fun tyl ty ->
if List . exists ( fun ty' -> equal env false [ ty ] [ ty' ] ) tyl
then tyl else ty :: tyl )
[ ty ] tyl
in
2008-10-08 06:09:39 -07:00
if f != f0 | | List . length tyl' < List . length tyl then
Reither ( b , List . rev tyl' , m , e )
2000-03-14 23:55:24 -08:00
else f
| _ -> f )
2002-04-14 19:11:32 -07:00
row . row_fields in
let fields =
List . sort ( fun ( p , _ ) ( q , _ ) -> compare p q )
2008-01-11 08:13:18 -08:00
( List . filter ( fun ( _ , fi ) -> fi < > Rabsent ) fields ) in
2002-11-20 21:39:01 -08:00
log_type ty ;
2008-01-11 08:13:18 -08:00
ty . desc <- Tvariant { row with row_fields = fields }
2002-04-14 19:11:32 -07:00
| Tobject ( fi , nm ) ->
2000-05-10 19:22:54 -07:00
begin match ! nm with
| None -> ()
| Some ( n , v :: l ) ->
2010-01-22 04:48:24 -08:00
if deep_occur ty ( newgenty ( Ttuple l ) ) then
(* The abbreviation may be hiding something, so remove it *)
set_name nm None
else let v' = repr v in
2000-05-10 19:22:54 -07:00
begin match v' . desc with
2002-11-20 21:39:01 -08:00
| Tvar | Tunivar ->
2002-11-20 22:22:02 -08:00
if v' != v then set_name nm ( Some ( n , v' :: l ) )
2009-05-20 04:52:42 -07:00
| Tnil ->
2010-01-22 04:48:24 -08:00
log_type ty ; ty . desc <- Tconstr ( n , l , ref Mnil )
2002-11-20 22:22:02 -08:00
| _ -> set_name nm None
2000-05-10 19:22:54 -07:00
end
| _ ->
fatal_error " Ctype.normalize_type_rec "
2002-04-14 19:11:32 -07:00
end ;
let fi = repr fi in
if fi . level < lowest_level then () else
let fields , row = flatten_fields fi in
let fi' = build_fields fi . level fields row in
2002-11-20 21:39:01 -08:00
log_type ty ; fi . desc <- fi' . desc
2000-02-24 02:18:25 -08:00
| _ -> ()
end ;
2009-05-20 04:52:42 -07:00
iter_type_expr ( normalize_type_rec env visited ) ty
2000-02-24 02:18:25 -08:00
end
2000-02-24 09:41:18 -08:00
let normalize_type env ty =
2009-05-20 04:52:42 -07:00
normalize_type_rec env ( ref TypeSet . empty ) ty
2006-09-20 04:14:37 -07:00
1997-03-09 08:52:49 -08:00
1997-01-21 05:38:42 -08:00
(* * * * * * * * * * * * * * * * * * * * * * * * *)
(* Remove dependencies *)
(* * * * * * * * * * * * * * * * * * * * * * * * *)
1996-04-22 04:15:41 -07:00
1997-03-09 08:52:49 -08:00
(*
Variables are left unchanged . Other type nodes are duplicated , with
levels set to generic level .
2009-05-19 01:17:02 -07:00
We cannot use Tsubst here , because unification may be called by
expand_abbrev .
1997-03-09 08:52:49 -08:00
* )
2009-05-19 01:17:02 -07:00
let nondep_hash = TypeHash . create 47
let nondep_variants = TypeHash . create 17
let clear_hash () =
TypeHash . clear nondep_hash ; TypeHash . clear nondep_variants
1996-04-22 04:15:41 -07:00
let rec nondep_type_rec env id ty =
1999-11-30 08:07:38 -08:00
match ty . desc with
2002-04-18 00:27:47 -07:00
Tvar | Tunivar -> ty
2009-05-19 01:17:02 -07:00
| Tlink ty -> nondep_type_rec env id ty
| _ -> try TypeHash . find nondep_hash ty
with Not_found ->
1999-11-30 08:07:38 -08:00
let ty' = newgenvar () in (* Stub *)
2009-05-19 01:17:02 -07:00
TypeHash . add nondep_hash ty ty' ;
1996-04-22 04:15:41 -07:00
ty' . desc <-
2009-05-19 01:17:02 -07:00
begin match ty . desc with
1996-04-22 04:15:41 -07:00
| Tconstr ( p , tl , abbrev ) ->
if Path . isfree id p then
begin try
1997-03-09 08:52:49 -08:00
Tlink ( nondep_type_rec env id
2009-05-19 01:17:02 -07:00
( expand_abbrev env ( newty2 ty . level ty . desc ) ) )
1997-03-09 08:52:49 -08:00
(*
The [ Tlink ] is important . The expanded type may be a
variable , or may not be completely copied yet
( recursive type ) , so one cannot just take its
description .
* )
2009-05-19 01:17:02 -07:00
with Cannot_expand | Unify _ ->
1996-04-22 04:15:41 -07:00
raise Not_found
end
else
1997-01-21 09:43:53 -08:00
Tconstr ( p , List . map ( nondep_type_rec env id ) tl , ref Mnil )
2010-04-30 04:59:50 -07:00
| Tpackage ( p , _ , _ ) when Path . isfree id p ->
raise Not_found
1996-04-22 04:15:41 -07:00
| Tobject ( t1 , name ) ->
Tobject ( nondep_type_rec env id t1 ,
ref ( match ! name with
None -> None
| Some ( p , tl ) ->
if Path . isfree id p then None
else Some ( p , List . map ( nondep_type_rec env id ) tl ) ) )
1999-11-30 08:07:38 -08:00
| Tvariant row ->
let row = row_repr row in
let more = repr row . row_more in
2009-05-19 01:17:02 -07:00
(* We must keep sharing according to the row variable *)
begin try
let ty2 = TypeHash . find nondep_variants more in
(* This variant type has been already copied *)
TypeHash . add nondep_hash ty ty2 ;
Tlink ty2
with Not_found ->
(* Register new type first for recursion *)
TypeHash . add nondep_variants more ty' ;
let static = static_row row in
let more' = if static then newgenvar () else more in
(* Return a new copy *)
let row =
copy_row ( nondep_type_rec env id ) true row true more' in
match row . row_name with
Some ( p , tl ) when Path . isfree id p ->
Tvariant { row with row_name = None }
| _ -> Tvariant row
1997-05-11 14:35:00 -07:00
end
2009-05-19 01:17:02 -07:00
| _ -> copy_type_desc ( nondep_type_rec env id ) ty . desc
1997-03-09 08:52:49 -08:00
end ;
ty'
1996-04-22 04:15:41 -07:00
let nondep_type env id ty =
1997-03-09 08:52:49 -08:00
try
let ty' = nondep_type_rec env id ty in
2009-05-19 01:17:02 -07:00
clear_hash () ;
1997-03-09 08:52:49 -08:00
ty'
with Not_found ->
2009-05-19 01:17:02 -07:00
clear_hash () ;
1997-03-09 08:52:49 -08:00
raise Not_found
2010-08-02 07:37:22 -07:00
let unroll_abbrev id tl ty =
let ty = repr ty and path = Path . Pident id in
if ( ty . desc = Tvar ) | | ( List . exists ( deep_occur ty ) tl )
| | is_object_type path then
ty
else
let ty' = newty2 ty . level ty . desc in
link_type ty ( newty2 ty . level ( Tconstr ( path , tl , ref Mnil ) ) ) ;
ty'
1997-03-09 10:42:51 -08:00
(* Preserve sharing inside type declarations. *)
1997-03-09 08:52:49 -08:00
let nondep_type_decl env mid id is_covariant decl =
try
let params = List . map ( nondep_type_rec env mid ) decl . type_params in
2010-01-20 08:26:46 -08:00
let tk =
try match decl . type_kind with
Type_abstract ->
Type_abstract
| Type_variant cstrs ->
Type_variant
( List . map
2010-09-12 22:28:30 -07:00
( 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? *)
2010-01-20 08:26:46 -08:00
cstrs )
| Type_record ( lbls , rep ) ->
Type_record
( List . map
( fun ( c , mut , t ) -> ( c , mut , nondep_type_rec env mid t ) )
lbls ,
rep )
with Not_found when is_covariant -> Type_abstract
and tm =
try match decl . type_manifest with
None -> None
| Some ty ->
Some ( unroll_abbrev id params ( nondep_type_rec env mid ty ) )
with Not_found when is_covariant ->
None
1997-03-09 08:52:49 -08:00
in
2009-05-19 01:17:02 -07:00
clear_hash () ;
2010-01-20 08:26:46 -08:00
let priv =
match tm with
| Some ty when Btype . has_constr_row ty -> Private
| _ -> decl . type_private
in
{ type_params = params ;
type_arity = decl . type_arity ;
type_kind = tk ;
type_manifest = tm ;
type_private = priv ;
type_variance = decl . type_variance ;
2010-10-07 00:12:50 -07:00
type_newtype = false ;
2010-01-20 08:26:46 -08:00
}
1997-03-09 08:52:49 -08:00
with Not_found ->
2009-05-19 01:17:02 -07:00
clear_hash () ;
1997-03-09 08:52:49 -08:00
raise Not_found
1996-04-22 04:15:41 -07:00
1997-03-09 10:42:51 -08:00
(* Preserve sharing inside class types. *)
1998-06-24 12:22:26 -07:00
let nondep_class_signature env id sign =
{ cty_self = nondep_type_rec env id sign . cty_self ;
cty_vars =
2006-04-04 19:28:13 -07:00
Vars . map ( function ( m , v , t ) -> ( m , v , nondep_type_rec env id t ) )
1998-06-24 12:22:26 -07:00
sign . cty_vars ;
2004-05-18 06:28:00 -07:00
cty_concr = sign . cty_concr ;
cty_inher =
List . map ( fun ( p , tl ) -> ( p , List . map ( nondep_type_rec env id ) tl ) )
sign . cty_inher }
1998-06-24 12:22:26 -07:00
let rec nondep_class_type env id =
function
Tcty_constr ( p , _ , cty ) when Path . isfree id p ->
nondep_class_type env id cty
| Tcty_constr ( p , tyl , cty ) ->
Tcty_constr ( p , List . map ( nondep_type_rec env id ) tyl ,
nondep_class_type env id cty )
| Tcty_signature sign ->
Tcty_signature ( nondep_class_signature env id sign )
1999-11-30 08:07:38 -08:00
| Tcty_fun ( l , ty , cty ) ->
Tcty_fun ( l , nondep_type_rec env id ty , nondep_class_type env id cty )
1998-06-24 12:22:26 -07:00
let nondep_class_declaration env id decl =
assert ( not ( Path . isfree id decl . cty_path ) ) ;
let decl =
{ cty_params = List . map ( nondep_type_rec env id ) decl . cty_params ;
2004-12-09 04:40:53 -08:00
cty_variance = decl . cty_variance ;
1998-06-24 12:22:26 -07:00
cty_type = nondep_class_type env id decl . cty_type ;
cty_path = decl . cty_path ;
cty_new =
begin match decl . cty_new with
None -> None
| Some ty -> Some ( nondep_type_rec env id ty )
end }
in
2009-05-19 01:17:02 -07:00
clear_hash () ;
1998-06-24 12:22:26 -07:00
decl
let nondep_cltype_declaration env id decl =
assert ( not ( Path . isfree id decl . clty_path ) ) ;
let decl =
{ clty_params = List . map ( nondep_type_rec env id ) decl . clty_params ;
2004-12-09 04:40:53 -08:00
clty_variance = decl . clty_variance ;
1998-06-24 12:22:26 -07:00
clty_type = nondep_class_type env id decl . clty_type ;
clty_path = decl . clty_path }
in
2009-05-19 01:17:02 -07:00
clear_hash () ;
1998-06-24 12:22:26 -07:00
decl
2002-10-07 23:55:58 -07:00
(* collapse conjonctive types in class parameters *)
let rec collapse_conj env visited ty =
let ty = repr ty in
if List . memq ty visited then () else
let visited = ty :: visited in
match ty . desc with
Tvariant row ->
let row = row_repr row in
List . iter
( fun ( l , fi ) ->
match row_field_repr fi with
Reither ( c , t1 :: ( _ :: _ as tl ) , m , e ) ->
List . iter ( unify env t1 ) tl ;
2002-11-20 21:39:01 -08:00
set_row_field e ( Reither ( c , [ t1 ] , m , ref None ) )
2002-10-07 23:55:58 -07:00
| _ ->
() )
row . row_fields ;
iter_row ( collapse_conj env visited ) row
| _ ->
iter_type_expr ( collapse_conj env visited ) ty
let collapse_conj_params env params =
List . iter ( collapse_conj env [] ) params