+5

.depend

reviewed

··· 538 538 typing/ident.cmi \ 539 539 typing/errortrace.cmi \ 540 540 typing/env.cmi \ 541 541 + typing/btype.cmi \ 541 542 parsing/asttypes.cmi 542 543 typing/datarepr.cmo : \ 543 544 typing/types.cmi \ ··· 1722 1723 utils/misc.cmi \ 1723 1724 parsing/longident.cmi \ 1724 1725 parsing/location.cmi \ 1726 1726 + utils/local_store.cmi \ 1725 1727 utils/identifiable.cmi \ 1726 1728 typing/ident.cmi \ 1727 1729 utils/config.cmi \ ··· 1735 1737 utils/misc.cmx \ 1736 1738 parsing/longident.cmx \ 1737 1739 parsing/location.cmx \ 1740 1740 + utils/local_store.cmx \ 1738 1741 utils/identifiable.cmx \ 1739 1742 typing/ident.cmx \ 1740 1743 utils/config.cmx \ ··· 6435 6438 parsing/location.cmi \ 6436 6439 typing/env.cmi 6437 6440 toplevel/byte/topmain.cmo : \ 6441 6441 + typing/types.cmi \ 6438 6442 toplevel/byte/trace.cmi \ 6439 6443 toplevel/byte/toploop.cmi \ 6440 6444 toplevel/byte/topeval.cmi \ ··· 6452 6456 utils/clflags.cmi \ 6453 6457 toplevel/byte/topmain.cmi 6454 6458 toplevel/byte/topmain.cmx : \ 6459 6459 + typing/types.cmx \ 6455 6460 toplevel/byte/trace.cmx \ 6456 6461 toplevel/byte/toploop.cmi \ 6457 6462 toplevel/byte/topeval.cmx \

+20

Changes

reviewed

··· 10 10 11 11 ### Other libraries: 12 12 13 13 + - #10192: Add support for Unix domain sockets on Windows and use them 14 14 + to emulate Unix.socketpair (only available on Windows 1803+) 15 15 + (Antonin Décimo, review by David Allsopp) 16 16 + 13 17 ### Tools: 14 18 15 19 ### Manual and documentation: ··· 31 35 32 36 - #10434: Pun labelled arguments with type constraint in function applications. 33 37 (Greta Yorsh, review by Nicolas Chataing and Nicolás Ojeda Bär) 38 38 + 39 39 + - #10470: Remove unused `cstr_normal` field from the `constructor_description` 40 40 + type 41 41 + (Nicolas Chataing, review by Gabriel Scherer) 34 42 35 43 ### Build system: 36 44 ··· 302 310 documentation comments 303 311 (Florian Angeletti, report by Hendrik Tews, review by Gabriel Scherer) 304 312 313 313 + - #10206: Split labels and polymorphic variants tutorials 314 314 + Splits the labels and polymorphic variants tutorial into two. Moves the GADTs 315 315 + tutorial from the Language Extensions chapter to the tutorials. 316 316 + (John Whitington, review by Florian Angeletti and Xavier Leroy) 317 317 + 305 318 - #10247: Add initial tranche of examples to reference manual. 306 319 Adds some eighty examples to the reference manual, principally to the 307 320 expressions and patterns sections. ··· 437 450 438 451 - #10327: Add a subdirectories variable and a copy action to ocamltest 439 452 (Sébastien Hinderer, review by David Allsopp) 453 453 + 454 454 + * #10337: Normalize type_expr nodes on access 455 455 + One should now use accessors such as get_desc and get_level to access fields 456 456 + of type_expr, rather than calling manually Btype.repr (which is now hidden 457 457 + in Types.Transient_expr). 458 458 + (Jacques Garrigue and Takafumi Saikawa, 459 459 + review by Florian Angeletti and Gabriel Radanne) 440 460 441 461 - #10358: Use a hash table for the load path. 442 462 (Leo White, review by Gabriel Scherer)

+28

configure

reviewed

··· 15170 15170 test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" 15171 15171 15172 15172 fi 15173 15173 + 15174 15174 + ac_fn_c_check_func "$LINENO" "socketpair" "ac_cv_func_socketpair" 15175 15175 + if test "x$ac_cv_func_socketpair" = xyes; then : 15176 15176 + $as_echo "#define HAS_SOCKETPAIR 1" >>confdefs.h 15177 15177 + 15178 15178 + fi 15173 15179 ;; #( 15174 15180 *-*-haiku) : 15175 15181 cclibs="$cclibs -lnetwork" ··· 15395 15401 15396 15402 fi 15397 15403 15404 15404 + 15405 15405 + ## Unix domain sockets support on Windows 15406 15406 + 15407 15407 + case $host in #( 15408 15408 + *-*-mingw32|*-pc-windows) : 15409 15409 + for ac_header in afunix.h 15410 15410 + do : 15411 15411 + ac_fn_c_check_header_compile "$LINENO" "afunix.h" "ac_cv_header_afunix_h" "#include <winsock2.h> 15412 15412 + " 15413 15413 + if test "x$ac_cv_header_afunix_h" = xyes; then : 15414 15414 + cat >>confdefs.h <<_ACEOF 15415 15415 + #define HAVE_AFUNIX_H 1 15416 15416 + _ACEOF 15417 15417 + $as_echo "#define HAS_AFUNIX_H 1" >>confdefs.h 15418 15418 + 15419 15419 + fi 15420 15420 + 15421 15421 + done 15422 15422 + ;; #( 15423 15423 + *) : 15424 15424 + ;; 15425 15425 + esac 15398 15426 15399 15427 ## IPv6 support 15400 15428

+9 -1

configure.ac

reviewed

··· 1405 1405 AS_CASE([$host], 1406 1406 [*-*-mingw32|*-pc-windows], 1407 1407 [cclibs="$cclibs -lws2_32" 1408 1408 - AC_SEARCH_LIBS([socket], [ws2_32])], 1408 1408 + AC_SEARCH_LIBS([socket], [ws2_32]) 1409 1409 + AC_CHECK_FUNC([socketpair], [AC_DEFINE([HAS_SOCKETPAIR])])], 1409 1410 [*-*-haiku], 1410 1411 [cclibs="$cclibs -lnetwork" 1411 1412 AC_SEARCH_LIBS([socket], [network])], ··· 1433 1434 [#include <sys/socket.h>])]) 1434 1435 1435 1436 AC_CHECK_FUNC([inet_aton], [AC_DEFINE([HAS_INET_ATON])]) 1437 1437 + 1438 1438 + ## Unix domain sockets support on Windows 1439 1439 + 1440 1440 + AS_CASE([$host], 1441 1441 + [*-*-mingw32|*-pc-windows], 1442 1442 + [AC_CHECK_HEADERS([afunix.h], [AC_DEFINE([HAS_AFUNIX_H])], [], 1443 1443 + [#include <winsock2.h>])]) 1436 1444 1437 1445 ## IPv6 support 1438 1446

-2

debugger/.depend

reviewed

··· 72 72 debugger_lexer.cmi \ 73 73 debugger_config.cmi \ 74 74 debugcom.cmi \ 75 75 - ../typing/ctype.cmi \ 76 75 checkpoints.cmi \ 77 76 breakpoints.cmi \ 78 77 command_line.cmi ··· 110 109 debugger_lexer.cmx \ 111 110 debugger_config.cmx \ 112 111 debugcom.cmx \ 113 113 - ../typing/ctype.cmx \ 114 112 checkpoints.cmx \ 115 113 breakpoints.cmx \ 116 114 command_line.cmi

+1 -1

debugger/command_line.ml

reviewed

··· 623 623 in 624 624 begin try 625 625 let (v, ty) = Eval.expression !selected_event env expr in 626 626 - match (Ctype.repr ty).desc with 626 626 + match get_desc ty with 627 627 | Tarrow _ -> 628 628 add_breakpoint_after_pc (Remote_value.closure_code v) 629 629 | _ ->

+2 -2

debugger/eval.ml

reviewed

··· 112 112 end 113 113 | E_item(arg, n) -> 114 114 let (v, ty) = expression event env arg in 115 115 - begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with 115 115 + begin match get_desc (Ctype.expand_head_opt env ty) with 116 116 Ttuple ty_list -> 117 117 if n < 1 || n > List.length ty_list 118 118 then raise(Error(Tuple_index(ty, List.length ty_list, n))) ··· 142 142 end 143 143 | E_field(arg, lbl) -> 144 144 let (v, ty) = expression event env arg in 145 145 - begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with 145 145 + begin match get_desc (Ctype.expand_head_opt env ty) with 146 146 Tconstr(path, _, _) -> 147 147 let tydesc = Env.find_type path env in 148 148 begin match tydesc.type_kind with

+1 -1

driver/main_args.ml

reviewed

··· 691 691 692 692 let mk_match_context_rows f = 693 693 "-match-context-rows", Arg.Int f, 694 694 - let[@manual.ref "s:comp-options"] chapter, section = 9, 2 in 694 694 + let[@manual.ref "s:comp-options"] chapter, section = 11, 2 in 695 695 Printf.sprintf 696 696 "<n> (advanced, see manual section %d.%d.)" chapter section 697 697 ;;

+4 -4

lambda/translmod.ml

reviewed

··· 242 242 [] -> [] 243 243 | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem -> 244 244 let init_v = 245 245 - match Ctype.expand_head env ty with 246 246 - {desc = Tarrow(_,_,_,_)} -> 245 245 + match get_desc (Ctype.expand_head env ty) with 246 246 + Tarrow(_,_,_,_) -> 247 247 const_int 0 (* camlinternalMod.Function *) 248 248 - | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> 248 248 + | Tconstr(p, _, _) when Path.same p Predef.path_lazy_t -> 249 249 const_int 1 (* camlinternalMod.Lazy *) 250 250 | _ -> 251 251 let not_a_function = ··· 1693 1693 1694 1694 let report_error loc = function 1695 1695 | Circular_dependency cycle -> 1696 1696 - let[@manual.ref "s:recursive-modules"] chapter, section = 8, 2 in 1696 1696 + let[@manual.ref "s:recursive-modules"] chapter, section = 10, 2 in 1697 1697 Location.errorf ~loc ~sub:(List.map explanation_submsg cycle) 1698 1698 "Cannot safely evaluate the definition of the following cycle@ \ 1699 1699 of recursively-defined modules:@ %a.@ \

+2

manual/src/allfiles.etex

reviewed

··· 45 45 \input{moduleexamples.tex} 46 46 \input{objectexamples.tex} 47 47 \input{lablexamples.tex} 48 48 + \input{polyvariant.tex} 48 49 \input{polymorphism.tex} 50 50 + \input{gadtexamples.tex} 49 51 \input{advexamples.tex} 50 52 51 53 \part{The OCaml language}

+1 -1

manual/src/library/libunix.etex

reviewed

··· 90 90 \entree{"getpwnam", "getpwuid"}{always raise "Not_found"} 91 91 \entree{"getgrnam", "getgrgid"}{always raise "Not_found"} 92 92 \entree{type "socket_domain"}{"PF_INET" is fully supported; 93 93 - "PF_INET6" is fully supported (since 4.01.0); "PF_UNIX" is not supported } 93 93 + "PF_INET6" is fully supported (since 4.01.0); "PF_UNIX" is supported since 4.14.0, but only works on Windows 10 1803 and later.} 94 94 \entree{"establish_server"}{not implemented; use threads} 95 95 \entree{terminal functions ("tc*")}{not implemented} 96 96 \entree{"setsid"}{not implemented}

+8 -299

manual/src/refman/extensions/gadts.etex

reviewed

··· 1 1 + Generalized algebraic datatypes, or GADTs, extend usual sum types in 2 2 + two ways: constraints on type parameters may change depending on the 3 3 + value constructor, and some type variables may be existentially 4 4 + quantified. They are described in chapter \ref{c:gadts-tutorial}. 5 5 + 1 6 (Introduced in OCaml 4.00) 2 7 3 8 \begin{syntax} ··· 10 15 | [variance] '_' 11 16 \end{syntax} 12 17 13 13 - Generalized algebraic datatypes, or GADTs, extend usual sum types in 14 14 - two ways: constraints on type parameters may change depending on the 15 15 - value constructor, and some type variables may be existentially 16 16 - quantified. 17 17 - Adding constraints is done by giving an explicit return type 18 18 - (the rightmost @typexpr@ in the above syntax), where type parameters 19 19 - are instantiated. 20 20 - This return type must use the same type constructor as the type being 21 21 - defined, and have the same number of parameters. 22 22 - Variables are made existential when they appear inside a constructor's 23 23 - argument, but not in its return type. 24 24 - 25 25 - Since the use of a return type often eliminates the need to name type 26 26 - parameters in the left-hand side of a type definition, one can replace 27 27 - them with anonymous types @"_"@ in that case. 28 28 - 29 29 - The constraints associated to each constructor can be recovered 30 30 - through pattern-matching. 31 31 - Namely, if the type of the scrutinee of a pattern-matching contains 32 32 - a locally abstract type, this type can be refined according to the 33 33 - constructor used. 34 34 - These extra constraints are only valid inside the corresponding branch 35 35 - of the pattern-matching. 36 36 - If a constructor has some existential variables, fresh locally 37 37 - abstract types are generated, and they must not escape the 38 38 - scope of this branch. 39 39 - 40 40 - \lparagraph{p:gadts-recfun}{Recursive functions} 41 41 - 42 42 - Here is a concrete example: 43 43 - \begin{caml_example*}{verbatim} 44 44 - type _ term = 45 45 - | Int : int -> int term 46 46 - | Add : (int -> int -> int) term 47 47 - | App : ('b -> 'a) term * 'b term -> 'a term 48 48 - 49 49 - let rec eval : type a. a term -> a = function 50 50 - | Int n -> n (* a = int *) 51 51 - | Add -> (fun x y -> x+y) (* a = int -> int -> int *) 52 52 - | App(f,x) -> (eval f) (eval x) 53 53 - (* eval called at types (b->a) and b for fresh b *) 54 54 - \end{caml_example*} 55 55 - \begin{caml_example}{verbatim} 56 56 - let two = eval (App (App (Add, Int 1), Int 1)) 57 57 - \end{caml_example} 58 58 - It is important to remark that the function "eval" is using the 59 59 - polymorphic syntax for locally abstract types. When defining a recursive 60 60 - function that manipulates a GADT, explicit polymorphic recursion should 61 61 - generally be used. For instance, the following definition fails with a 62 62 - type error: 63 63 - \begin{caml_example}{verbatim}[error] 64 64 - let rec eval (type a) : a term -> a = function 65 65 - | Int n -> n 66 66 - | Add -> (fun x y -> x+y) 67 67 - | App(f,x) -> (eval f) (eval x) 68 68 - \end{caml_example} 69 69 - In absence of an explicit polymorphic annotation, a monomorphic type 70 70 - is inferred for the recursive function. If a recursive call occurs 71 71 - inside the function definition at a type that involves an existential 72 72 - GADT type variable, this variable flows to the type of the recursive 73 73 - function, and thus escapes its scope. In the above example, this happens 74 74 - in the branch "App(f,x)" when "eval" is called with "f" as an argument. 75 75 - In this branch, the type of "f" is "($App_ 'b-> a)". The prefix "$" in 76 76 - "$App_ 'b" denotes an existential type named by the compiler 77 77 - (see~\ref{p:existential-names}). Since the type of "eval" is 78 78 - "'a term -> 'a", the call "eval f" makes the existential type "$App_'b" 79 79 - flow to the type variable "'a" and escape its scope. This triggers the 80 80 - above error. 81 81 - 82 82 - \lparagraph{p:gadts-type-inference}{Type inference} 83 83 - 84 84 - Type inference for GADTs is notoriously hard. 85 85 - This is due to the fact some types may become ambiguous when escaping 86 86 - from a branch. 87 87 - For instance, in the "Int" case above, "n" could have either type "int" 88 88 - or "a", and they are not equivalent outside of that branch. 89 89 - As a first approximation, type inference will always work if a 90 90 - pattern-matching is annotated with types containing no free type 91 91 - variables (both on the scrutinee and the return type). 92 92 - This is the case in the above example, thanks to the type annotation 93 93 - containing only locally abstract types. 94 94 - 95 95 - In practice, type inference is a bit more clever than that: type 96 96 - annotations do not need to be immediately on the pattern-matching, and 97 97 - the types do not have to be always closed. 98 98 - As a result, it is usually enough to only annotate functions, as in 99 99 - the example above. Type annotations are 100 100 - propagated in two ways: for the scrutinee, they follow the flow of 101 101 - type inference, in a way similar to polymorphic methods; for the 102 102 - return type, they follow the structure of the program, they are split 103 103 - on functions, propagated to all branches of a pattern matching, 104 104 - and go through tuples, records, and sum types. 105 105 - Moreover, the notion of ambiguity used is stronger: a type is only 106 106 - seen as ambiguous if it was mixed with incompatible types (equated by 107 107 - constraints), without type annotations between them. 108 108 - For instance, the following program types correctly. 109 109 - \begin{caml_example}{verbatim} 110 110 - let rec sum : type a. a term -> _ = fun x -> 111 111 - let y = 112 112 - match x with 113 113 - | Int n -> n 114 114 - | Add -> 0 115 115 - | App(f,x) -> sum f + sum x 116 116 - in y + 1 117 117 - \end{caml_example} 118 118 - Here the return type "int" is never mixed with "a", so it is seen as 119 119 - non-ambiguous, and can be inferred. 120 120 - When using such partial type annotations we strongly suggest 121 121 - specifying the "-principal" mode, to check that inference is 122 122 - principal. 18 18 + Refutation cases. (Introduced in OCaml 4.03) 123 19 124 124 - The exhaustiveness check is aware of GADT constraints, and can 125 125 - automatically infer that some cases cannot happen. 126 126 - For instance, the following pattern matching is correctly seen as 127 127 - exhaustive (the "Add" case cannot happen). 128 128 - \begin{caml_example*}{verbatim} 129 129 - let get_int : int term -> int = function 130 130 - | Int n -> n 131 131 - | App(_,_) -> 0 132 132 - \end{caml_example*} 133 133 - 134 134 - 135 135 - \lparagraph{p:gadt-refutation-cases}{Refutation cases} (Introduced in OCaml 4.03) 136 136 - 137 137 - Usually, the exhaustiveness check only tries to check whether the 138 138 - cases omitted from the pattern matching are typable or not. 139 139 - However, you can force it to try harder by adding {\em refutation cases}: 140 20 \begin{syntax} 141 21 matching-case: 142 22 pattern ['when' expr] '->' expr 143 23 | pattern '->' '.' 144 24 \end{syntax} 145 145 - In presence of a refutation case, the exhaustiveness check will first 146 146 - compute the intersection of the pattern with the complement of the 147 147 - cases preceding it. It then checks whether the resulting patterns can 148 148 - really match any concrete values by trying to type-check them. 149 149 - Wild cards in the generated patterns are handled in a special way: if 150 150 - their type is a variant type with only GADT constructors, then the 151 151 - pattern is split into the different constructors, in order to check whether 152 152 - any of them is possible (this splitting is not done for arguments of these 153 153 - constructors, to avoid non-termination). We also split tuples and 154 154 - variant types with only one case, since they may contain GADTs inside. 155 155 - For instance, the following code is deemed exhaustive: 156 25 157 157 - \begin{caml_example*}{verbatim} 158 158 - type _ t = 159 159 - | Int : int t 160 160 - | Bool : bool t 161 161 - 162 162 - let deep : (char t * int) option -> char = function 163 163 - | None -> 'c' 164 164 - | _ -> . 165 165 - \end{caml_example*} 166 166 - 167 167 - Namely, the inferred remaining case is "Some _", which is split into 168 168 - "Some (Int, _)" and "Some (Bool, _)", which are both untypable because 169 169 - "deep" expects a non-existing "char t" as the first element of the tuple. 170 170 - Note that the refutation case could be omitted here, because it is 171 171 - automatically added when there is only one case in the pattern 172 172 - matching. 173 173 - 174 174 - Another addition is that the redundancy check is now aware of GADTs: a 175 175 - case will be detected as redundant if it could be replaced by a 176 176 - refutation case using the same pattern. 177 177 - 178 178 - \lparagraph{p:gadts-advexamples}{Advanced examples} 179 179 - The "term" type we have defined above is an {\em indexed} type, where 180 180 - a type parameter reflects a property of the value contents. 181 181 - Another use of GADTs is {\em singleton} types, where a GADT value 182 182 - represents exactly one type. This value can be used as runtime 183 183 - representation for this type, and a function receiving it can have a 184 184 - polytypic behavior. 185 185 - 186 186 - Here is an example of a polymorphic function that takes the 187 187 - runtime representation of some type "t" and a value of the same type, 188 188 - then pretty-prints the value as a string: 189 189 - \begin{caml_example*}{verbatim} 190 190 - type _ typ = 191 191 - | Int : int typ 192 192 - | String : string typ 193 193 - | Pair : 'a typ * 'b typ -> ('a * 'b) typ 194 194 - 195 195 - let rec to_string: type t. t typ -> t -> string = 196 196 - fun t x -> 197 197 - match t with 198 198 - | Int -> Int.to_string x 199 199 - | String -> Printf.sprintf "%S" x 200 200 - | Pair(t1,t2) -> 201 201 - let (x1, x2) = x in 202 202 - Printf.sprintf "(%s,%s)" (to_string t1 x1) (to_string t2 x2) 203 203 - \end{caml_example*} 204 204 - 205 205 - Another frequent application of GADTs is equality witnesses. 206 206 - \begin{caml_example*}{verbatim} 207 207 - type (_,_) eq = Eq : ('a,'a) eq 208 208 - 209 209 - let cast : type a b. (a,b) eq -> a -> b = fun Eq x -> x 210 210 - \end{caml_example*} 211 211 - Here type "eq" has only one constructor, and by matching on it one 212 212 - adds a local constraint allowing the conversion between "a" and "b". 213 213 - By building such equality witnesses, one can make equal types which 214 214 - are syntactically different. 215 215 - 216 216 - Here is an example using both singleton types and equality witnesses 217 217 - to implement dynamic types. 218 218 - \begin{caml_example*}{verbatim} 219 219 - let rec eq_type : type a b. a typ -> b typ -> (a,b) eq option = 220 220 - fun a b -> 221 221 - match a, b with 222 222 - | Int, Int -> Some Eq 223 223 - | String, String -> Some Eq 224 224 - | Pair(a1,a2), Pair(b1,b2) -> 225 225 - begin match eq_type a1 b1, eq_type a2 b2 with 226 226 - | Some Eq, Some Eq -> Some Eq 227 227 - | _ -> None 228 228 - end 229 229 - | _ -> None 230 230 - 231 231 - type dyn = Dyn : 'a typ * 'a -> dyn 232 232 - 233 233 - let get_dyn : type a. a typ -> dyn -> a option = 234 234 - fun a (Dyn(b,x)) -> 235 235 - match eq_type a b with 236 236 - | None -> None 237 237 - | Some Eq -> Some x 238 238 - \end{caml_example*} 239 239 - 240 240 - \lparagraph{p:existential-names}{Existential type names in error messages}% 241 241 - (Updated in OCaml 4.03.0) 242 242 - 243 243 - The typing of pattern matching in presence of GADT can generate many 244 244 - existential types. When necessary, error messages refer to these 245 245 - existential types using compiler-generated names. Currently, the 246 246 - compiler generates these names according to the following nomenclature: 247 247 - \begin{itemize} 248 248 - \item First, types whose name starts with a "$" are existentials. 249 249 - \item "$Constr_'a" denotes an existential type introduced for the type 250 250 - variable "'a" of the GADT constructor "Constr": 251 251 - \begin{caml_example}{verbatim}[error] 252 252 - type any = Any : 'name -> any 253 253 - let escape (Any x) = x 254 254 - \end{caml_example} 255 255 - \item "$Constr" denotes an existential type introduced for an anonymous %$ 256 256 - type variable in the GADT constructor "Constr": 257 257 - \begin{caml_example}{verbatim}[error] 258 258 - type any = Any : _ -> any 259 259 - let escape (Any x) = x 260 260 - \end{caml_example} 261 261 - \item "$'a" if the existential variable was unified with the type %$ 262 262 - variable "'a" during typing: 263 263 - \begin{caml_example}{verbatim}[error] 264 264 - type ('arg,'result,'aux) fn = 265 265 - | Fun: ('a ->'b) -> ('a,'b,unit) fn 266 266 - | Mem1: ('a ->'b) * 'a * 'b -> ('a, 'b, 'a * 'b) fn 267 267 - let apply: ('arg,'result, _ ) fn -> 'arg -> 'result = fun f x -> 268 268 - match f with 269 269 - | Fun f -> f x 270 270 - | Mem1 (f,y,fy) -> if x = y then fy else f x 271 271 - \end{caml_example} 272 272 - \item "$n" (n a number) is an internally generated existential %$ 273 273 - which could not be named using one of the previous schemes. 274 274 - \end{itemize} 275 275 - 276 276 - As shown by the last item, the current behavior is imperfect 277 277 - and may be improved in future versions. 278 278 - 279 279 - \lparagraph{p:explicit-existential-name}{Explicit naming of 280 280 - existentials} (Introduced in OCaml 4.13.0) 281 281 - 282 282 - As explained above, pattern-matching on a GADT constructor may 283 283 - introduce existential types. The following syntax allows to name them 284 284 - explicitly. 26 26 + Explicit naming of existentials. (Introduced in OCaml 4.13.0) 285 27 286 28 \begin{syntax} 287 29 pattern: 288 30 ... 289 31 | constr '(' "type" {{typeconstr-name}} ')' '(' pattern ')' 290 32 ; 291 291 - \end{syntax} 292 292 - 293 293 - For instance, the following code names the type of the argument of f 294 294 - and uses this name. 295 295 - 296 296 - \begin{caml_example*}{verbatim} 297 297 - type _ closure = Closure : ('a -> 'b) * 'a -> 'b closure 298 298 - let eval = fun (Closure (type a) (f, x : (a -> _) * _)) -> f (x : a) 299 299 - \end{caml_example*} 300 300 - All existential type variables of the constructor must by introduced by 301 301 - the ("type" ...) construct and bound by a type annotation on the 302 302 - outside of the constructor argument. 303 303 - 304 304 - \lparagraph{p:gadt-equation-nonlocal-abstract}{Equations on non-local abstract types} (Introduced in OCaml 305 305 - 4.04) 306 306 - 307 307 - GADT pattern-matching may also add type equations to non-local 308 308 - abstract types. The behaviour is the same as with local abstract 309 309 - types. Reusing the above "eq" type, one can write: 310 310 - \begin{caml_example*}{verbatim} 311 311 - module M : sig type t val x : t val e : (t,int) eq end = struct 312 312 - type t = int 313 313 - let x = 33 314 314 - let e = Eq 315 315 - end 316 316 - 317 317 - let x : int = let Eq = M.e in M.x 318 318 - \end{caml_example*} 319 319 - 320 320 - Of course, not all abstract types can be refined, as this would 321 321 - contradict the exhaustiveness check. Namely, builtin types (those 322 322 - defined by the compiler itself, such as "int" or "array"), and 323 323 - abstract types defined by the local module, are non-instantiable, and 324 324 - as such cause a type error rather than introduce an equation. 33 33 + \end{syntax}

+2 -2

manual/src/tutorials/Makefile

reviewed

··· 11 11 TRANSF = $(SET_LD_PATH) $(OCAMLRUN) $(TOOLS)/transf 12 12 13 13 14 14 - FILES = coreexamples.tex lablexamples.tex objectexamples.tex \ 15 15 - moduleexamples.tex advexamples.tex polymorphism.tex 14 14 + FILES = coreexamples.tex lablexamples.tex polyvariant.tex objectexamples.tex \ 15 15 + gadtexamples.tex moduleexamples.tex advexamples.tex polymorphism.tex 16 16 17 17 18 18 etex-files: $(FILES)

+2 -2

manual/src/tutorials/coreexamples.etex

reviewed

··· 6 6 is assumed, but no prior exposure to functional languages is required. The 7 7 present chapter introduces the core language. Chapter~\ref{c:moduleexamples} 8 8 deals with the module system, chapter~\ref{c:objectexamples} with the 9 9 - object-oriented features, chapter~\ref{c:labl-examples} with extensions to the 10 10 - core language (labeled arguments and polymorphic variants), 9 9 + object-oriented features, chapter~\ref{c:labl-examples} with labeled 10 10 + arguments, chapter~\ref{c:poly-variant} with polymorphic variants, 11 11 chapter~\ref{c:polymorphism} with the limitations of polymorphism, and 12 12 chapter~\ref{c:advexamples} gives some advanced examples. 13 13

+304

manual/src/tutorials/gadtexamples.etex

reviewed

··· 1 1 + \chapter{Generalized algebraic datatypes} \label{c:gadts-tutorial} 2 2 + %HEVEA\cutname{gadts-tutorial.html} 3 3 + 4 4 + Generalized algebraic datatypes, or GADTs, extend usual sum types in 5 5 + two ways: constraints on type parameters may change depending on the 6 6 + value constructor, and some type variables may be existentially 7 7 + quantified. 8 8 + Adding constraints is done by giving an explicit return type, where type 9 9 + parameters are instantiated: 10 10 + 11 11 + \begin{caml_example*}{verbatim} 12 12 + type _ term = 13 13 + | Int : int -> int term 14 14 + | Add : (int -> int -> int) term 15 15 + | App : ('b -> 'a) term * 'b term -> 'a term 16 16 + \end{caml_example*} 17 17 + 18 18 + This return type must use the same type constructor as the type being 19 19 + defined, and have the same number of parameters. 20 20 + Variables are made existential when they appear inside a constructor's 21 21 + argument, but not in its return type. 22 22 + Since the use of a return type often eliminates the need to name type 23 23 + parameters in the left-hand side of a type definition, one can replace 24 24 + them with anonymous types "_" in that case. 25 25 + 26 26 + The constraints associated to each constructor can be recovered 27 27 + through pattern-matching. 28 28 + Namely, if the type of the scrutinee of a pattern-matching contains 29 29 + a locally abstract type, this type can be refined according to the 30 30 + constructor used. 31 31 + These extra constraints are only valid inside the corresponding branch 32 32 + of the pattern-matching. 33 33 + If a constructor has some existential variables, fresh locally 34 34 + abstract types are generated, and they must not escape the 35 35 + scope of this branch. 36 36 + 37 37 + \section{s:gadts-recfun}{Recursive functions} 38 38 + 39 39 + We write an "eval" function: 40 40 + 41 41 + \begin{caml_example*}{verbatim} 42 42 + let rec eval : type a. a term -> a = function 43 43 + | Int n -> n (* a = int *) 44 44 + | Add -> (fun x y -> x+y) (* a = int -> int -> int *) 45 45 + | App(f,x) -> (eval f) (eval x) 46 46 + (* eval called at types (b->a) and b for fresh b *) 47 47 + \end{caml_example*} 48 48 + 49 49 + And use it: 50 50 + 51 51 + \begin{caml_example}{verbatim} 52 52 + let two = eval (App (App (Add, Int 1), Int 1)) 53 53 + \end{caml_example} 54 54 + It is important to remark that the function "eval" is using the 55 55 + polymorphic syntax for locally abstract types. When defining a recursive 56 56 + function that manipulates a GADT, explicit polymorphic recursion should 57 57 + generally be used. For instance, the following definition fails with a 58 58 + type error: 59 59 + \begin{caml_example}{verbatim}[error] 60 60 + let rec eval (type a) : a term -> a = function 61 61 + | Int n -> n 62 62 + | Add -> (fun x y -> x+y) 63 63 + | App(f,x) -> (eval f) (eval x) 64 64 + \end{caml_example} 65 65 + In absence of an explicit polymorphic annotation, a monomorphic type 66 66 + is inferred for the recursive function. If a recursive call occurs 67 67 + inside the function definition at a type that involves an existential 68 68 + GADT type variable, this variable flows to the type of the recursive 69 69 + function, and thus escapes its scope. In the above example, this happens 70 70 + in the branch "App(f,x)" when "eval" is called with "f" as an argument. 71 71 + In this branch, the type of "f" is "($App_ 'b-> a)". The prefix "$" in 72 72 + "$App_ 'b" denotes an existential type named by the compiler 73 73 + (see~\ref{s:existential-names}). Since the type of "eval" is 74 74 + "'a term -> 'a", the call "eval f" makes the existential type "$App_'b" 75 75 + flow to the type variable "'a" and escape its scope. This triggers the 76 76 + above error. 77 77 + 78 78 + \section{s:gadts-type-inference}{Type inference} 79 79 + 80 80 + Type inference for GADTs is notoriously hard. 81 81 + This is due to the fact some types may become ambiguous when escaping 82 82 + from a branch. 83 83 + For instance, in the "Int" case above, "n" could have either type "int" 84 84 + or "a", and they are not equivalent outside of that branch. 85 85 + As a first approximation, type inference will always work if a 86 86 + pattern-matching is annotated with types containing no free type 87 87 + variables (both on the scrutinee and the return type). 88 88 + This is the case in the above example, thanks to the type annotation 89 89 + containing only locally abstract types. 90 90 + 91 91 + In practice, type inference is a bit more clever than that: type 92 92 + annotations do not need to be immediately on the pattern-matching, and 93 93 + the types do not have to be always closed. 94 94 + As a result, it is usually enough to only annotate functions, as in 95 95 + the example above. Type annotations are 96 96 + propagated in two ways: for the scrutinee, they follow the flow of 97 97 + type inference, in a way similar to polymorphic methods; for the 98 98 + return type, they follow the structure of the program, they are split 99 99 + on functions, propagated to all branches of a pattern matching, 100 100 + and go through tuples, records, and sum types. 101 101 + Moreover, the notion of ambiguity used is stronger: a type is only 102 102 + seen as ambiguous if it was mixed with incompatible types (equated by 103 103 + constraints), without type annotations between them. 104 104 + For instance, the following program types correctly. 105 105 + \begin{caml_example}{verbatim} 106 106 + let rec sum : type a. a term -> _ = fun x -> 107 107 + let y = 108 108 + match x with 109 109 + | Int n -> n 110 110 + | Add -> 0 111 111 + | App(f,x) -> sum f + sum x 112 112 + in y + 1 113 113 + \end{caml_example} 114 114 + Here the return type "int" is never mixed with "a", so it is seen as 115 115 + non-ambiguous, and can be inferred. 116 116 + When using such partial type annotations we strongly suggest 117 117 + specifying the "-principal" mode, to check that inference is 118 118 + principal. 119 119 + 120 120 + The exhaustiveness check is aware of GADT constraints, and can 121 121 + automatically infer that some cases cannot happen. 122 122 + For instance, the following pattern matching is correctly seen as 123 123 + exhaustive (the "Add" case cannot happen). 124 124 + \begin{caml_example*}{verbatim} 125 125 + let get_int : int term -> int = function 126 126 + | Int n -> n 127 127 + | App(_,_) -> 0 128 128 + \end{caml_example*} 129 129 + 130 130 + 131 131 + \section{s:gadt-refutation-cases}{Refutation cases} 132 132 + 133 133 + Usually, the exhaustiveness check only tries to check whether the 134 134 + cases omitted from the pattern matching are typable or not. 135 135 + However, you can force it to try harder by adding {\em refutation cases}, 136 136 + written as a full stop. 137 137 + In the presence of a refutation case, the exhaustiveness check will first 138 138 + compute the intersection of the pattern with the complement of the 139 139 + cases preceding it. It then checks whether the resulting patterns can 140 140 + really match any concrete values by trying to type-check them. 141 141 + Wild cards in the generated patterns are handled in a special way: if 142 142 + their type is a variant type with only GADT constructors, then the 143 143 + pattern is split into the different constructors, in order to check whether 144 144 + any of them is possible (this splitting is not done for arguments of these 145 145 + constructors, to avoid non-termination). We also split tuples and 146 146 + variant types with only one case, since they may contain GADTs inside. 147 147 + For instance, the following code is deemed exhaustive: 148 148 + 149 149 + \begin{caml_example*}{verbatim} 150 150 + type _ t = 151 151 + | Int : int t 152 152 + | Bool : bool t 153 153 + 154 154 + let deep : (char t * int) option -> char = function 155 155 + | None -> 'c' 156 156 + | _ -> . 157 157 + \end{caml_example*} 158 158 + 159 159 + Namely, the inferred remaining case is "Some _", which is split into 160 160 + "Some (Int, _)" and "Some (Bool, _)", which are both untypable because 161 161 + "deep" expects a non-existing "char t" as the first element of the tuple. 162 162 + Note that the refutation case could be omitted here, because it is 163 163 + automatically added when there is only one case in the pattern 164 164 + matching. 165 165 + 166 166 + Another addition is that the redundancy check is now aware of GADTs: a 167 167 + case will be detected as redundant if it could be replaced by a 168 168 + refutation case using the same pattern. 169 169 + 170 170 + \section{s:gadts-advexamples}{Advanced examples} 171 171 + The "term" type we have defined above is an {\em indexed} type, where 172 172 + a type parameter reflects a property of the value contents. 173 173 + Another use of GADTs is {\em singleton} types, where a GADT value 174 174 + represents exactly one type. This value can be used as runtime 175 175 + representation for this type, and a function receiving it can have a 176 176 + polytypic behavior. 177 177 + 178 178 + Here is an example of a polymorphic function that takes the 179 179 + runtime representation of some type "t" and a value of the same type, 180 180 + then pretty-prints the value as a string: 181 181 + \begin{caml_example*}{verbatim} 182 182 + type _ typ = 183 183 + | Int : int typ 184 184 + | String : string typ 185 185 + | Pair : 'a typ * 'b typ -> ('a * 'b) typ 186 186 + 187 187 + let rec to_string: type t. t typ -> t -> string = 188 188 + fun t x -> 189 189 + match t with 190 190 + | Int -> Int.to_string x 191 191 + | String -> Printf.sprintf "%S" x 192 192 + | Pair(t1,t2) -> 193 193 + let (x1, x2) = x in 194 194 + Printf.sprintf "(%s,%s)" (to_string t1 x1) (to_string t2 x2) 195 195 + \end{caml_example*} 196 196 + 197 197 + Another frequent application of GADTs is equality witnesses. 198 198 + \begin{caml_example*}{verbatim} 199 199 + type (_,_) eq = Eq : ('a,'a) eq 200 200 + 201 201 + let cast : type a b. (a,b) eq -> a -> b = fun Eq x -> x 202 202 + \end{caml_example*} 203 203 + Here type "eq" has only one constructor, and by matching on it one 204 204 + adds a local constraint allowing the conversion between "a" and "b". 205 205 + By building such equality witnesses, one can make equal types which 206 206 + are syntactically different. 207 207 + 208 208 + Here is an example using both singleton types and equality witnesses 209 209 + to implement dynamic types. 210 210 + \begin{caml_example*}{verbatim} 211 211 + let rec eq_type : type a b. a typ -> b typ -> (a,b) eq option = 212 212 + fun a b -> 213 213 + match a, b with 214 214 + | Int, Int -> Some Eq 215 215 + | String, String -> Some Eq 216 216 + | Pair(a1,a2), Pair(b1,b2) -> 217 217 + begin match eq_type a1 b1, eq_type a2 b2 with 218 218 + | Some Eq, Some Eq -> Some Eq 219 219 + | _ -> None 220 220 + end 221 221 + | _ -> None 222 222 + 223 223 + type dyn = Dyn : 'a typ * 'a -> dyn 224 224 + 225 225 + let get_dyn : type a. a typ -> dyn -> a option = 226 226 + fun a (Dyn(b,x)) -> 227 227 + match eq_type a b with 228 228 + | None -> None 229 229 + | Some Eq -> Some x 230 230 + \end{caml_example*} 231 231 + 232 232 + \section{s:existential-names}{Existential type names in error messages} 233 233 + 234 234 + The typing of pattern matching in presence of GADT can generate many 235 235 + existential types. When necessary, error messages refer to these 236 236 + existential types using compiler-generated names. Currently, the 237 237 + compiler generates these names according to the following nomenclature: 238 238 + \begin{itemize} 239 239 + \item First, types whose name starts with a "$" are existentials. 240 240 + \item "$Constr_'a" denotes an existential type introduced for the type 241 241 + variable "'a" of the GADT constructor "Constr": 242 242 + \begin{caml_example}{verbatim}[error] 243 243 + type any = Any : 'name -> any 244 244 + let escape (Any x) = x 245 245 + \end{caml_example} 246 246 + \item "$Constr" denotes an existential type introduced for an anonymous %$ 247 247 + type variable in the GADT constructor "Constr": 248 248 + \begin{caml_example}{verbatim}[error] 249 249 + type any = Any : _ -> any 250 250 + let escape (Any x) = x 251 251 + \end{caml_example} 252 252 + \item "$'a" if the existential variable was unified with the type %$ 253 253 + variable "'a" during typing: 254 254 + \begin{caml_example}{verbatim}[error] 255 255 + type ('arg,'result,'aux) fn = 256 256 + | Fun: ('a ->'b) -> ('a,'b,unit) fn 257 257 + | Mem1: ('a ->'b) * 'a * 'b -> ('a, 'b, 'a * 'b) fn 258 258 + let apply: ('arg,'result, _ ) fn -> 'arg -> 'result = fun f x -> 259 259 + match f with 260 260 + | Fun f -> f x 261 261 + | Mem1 (f,y,fy) -> if x = y then fy else f x 262 262 + \end{caml_example} 263 263 + \item "$n" (n a number) is an internally generated existential %$ 264 264 + which could not be named using one of the previous schemes. 265 265 + \end{itemize} 266 266 + 267 267 + As shown by the last item, the current behavior is imperfect 268 268 + and may be improved in future versions. 269 269 + 270 270 + \section{s:explicit-existential-name}{Explicit naming of existentials} 271 271 + 272 272 + As explained above, pattern-matching on a GADT constructor may introduce 273 273 + existential types. Syntax has been introduced which allows them to be named 274 274 + explicitly. For instance, the following code names the type of the argument of 275 275 + "f" and uses this name. 276 276 + 277 277 + \begin{caml_example*}{verbatim} 278 278 + type _ closure = Closure : ('a -> 'b) * 'a -> 'b closure 279 279 + let eval = fun (Closure (type a) (f, x : (a -> _) * _)) -> f (x : a) 280 280 + \end{caml_example*} 281 281 + All existential type variables of the constructor must by introduced by 282 282 + the ("type" ...) construct and bound by a type annotation on the 283 283 + outside of the constructor argument. 284 284 + 285 285 + \section{s:gadt-equation-nonlocal-abstract}{Equations on non-local abstract types} 286 286 + 287 287 + GADT pattern-matching may also add type equations to non-local 288 288 + abstract types. The behaviour is the same as with local abstract 289 289 + types. Reusing the above "eq" type, one can write: 290 290 + \begin{caml_example*}{verbatim} 291 291 + module M : sig type t val x : t val e : (t,int) eq end = struct 292 292 + type t = int 293 293 + let x = 33 294 294 + let e = Eq 295 295 + end 296 296 + 297 297 + let x : int = let Eq = M.e in M.x 298 298 + \end{caml_example*} 299 299 + 300 300 + Of course, not all abstract types can be refined, as this would 301 301 + contradict the exhaustiveness check. Namely, builtin types (those 302 302 + defined by the compiler itself, such as "int" or "array"), and 303 303 + abstract types defined by the local module, are non-instantiable, and 304 304 + as such cause a type error rather than introduce an equation.

+5 -194

manual/src/tutorials/lablexamples.etex

reviewed

··· 1 1 - \chapter{Labels and variants} \label{c:labl-examples} 1 1 + \chapter{Labeled arguments} \label{c:labl-examples} 2 2 %HEVEA\cutname{lablexamples.html} 3 3 {\it (Chapter written by Jacques Garrigue)} 4 4 - 5 5 - \bigskip 6 6 - 7 7 - \noindent This chapter gives an overview of the new features in 8 8 - OCaml 3: labels, and polymorphic variants. 9 9 - 10 10 - \section{s:labels}{Labels} 11 4 12 5 If you have a look at modules ending in "Labels" in the standard 13 6 library, you will see that function types have annotations you did not ··· 42 35 cannot use a reserved keyword (like "in" or "to") as label. 43 36 44 37 Formal parameters and arguments are matched according to their 45 45 - respective labels\footnote{This corresponds to the commuting label mode 46 46 - of Objective Caml 3.00 through 3.02, with some additional flexibility 47 47 - on total applications. The so-called classic mode ("-nolabels" 48 48 - options) is now deprecated for normal use.}, the absence of label 38 38 + respective labels, the absence of label 49 39 being interpreted as the empty label. 50 40 % 51 41 This allows commuting arguments in applications. One can also ··· 69 59 hline ~x:3 ~y:2 ~x:5;; 70 60 \end{caml_example} 71 61 72 72 - \subsection{ss:optional-arguments}{Optional arguments} 62 62 + \section{s:optional-arguments}{Optional arguments} 73 63 74 64 An interesting feature of labeled arguments is that they can be made 75 65 optional. For optional parameters, the question mark "?" replaces the ··· 133 123 test2 ?x:None;; 134 124 \end{caml_example} 135 125 136 136 - \subsection{ss:label-inference}{Labels and type inference} 126 126 + \section{s:label-inference}{Labels and type inference} 137 127 138 128 While they provide an increased comfort for writing function 139 129 applications, labels and optional arguments have the pitfall that they ··· 199 189 parameters shall produce side-effects, these are delayed until the 200 190 received function is really applied to an argument. 201 191 202 202 - \subsection{ss:label-suggestions}{Suggestions for labeling} 192 192 + \section{s:label-suggestions}{Suggestions for labeling} 203 193 204 194 Like for names, choosing labels for functions is not an easy task. A 205 195 good labeling is a labeling which ··· 278 268 \begin{caml_eval} 279 269 #label false;; 280 270 \end{caml_eval} 281 281 - 282 282 - 283 283 - \section{s:polymorphic-variants}{Polymorphic variants} 284 284 - 285 285 - Variants as presented in section~\ref{s:tut-recvariants} are a 286 286 - powerful tool to build data structures and algorithms. However they 287 287 - sometimes lack flexibility when used in modular programming. This is 288 288 - due to the fact that every constructor is assigned to a unique type 289 289 - when defined and used. Even if the same name appears in the definition 290 290 - of multiple types, the constructor itself belongs to only one type. 291 291 - Therefore, one cannot decide that a given constructor belongs to 292 292 - multiple types, or consider a value of some type to belong to some 293 293 - other type with more constructors. 294 294 - 295 295 - With polymorphic variants, this original assumption is removed. That 296 296 - is, a variant tag does not belong to any type in particular, the type 297 297 - system will just check that it is an admissible value according to its 298 298 - use. You need not define a type before using a variant tag. A variant 299 299 - type will be inferred independently for each of its uses. 300 300 - 301 301 - \subsection*{ss:polyvariant:basic-use}{Basic use} 302 302 - 303 303 - In programs, polymorphic variants work like usual ones. You just have 304 304 - to prefix their names with a backquote character "`". 305 305 - \begin{caml_example}{toplevel} 306 306 - [`On; `Off];; 307 307 - `Number 1;; 308 308 - let f = function `On -> 1 | `Off -> 0 | `Number n -> n;; 309 309 - List.map f [`On; `Off];; 310 310 - \end{caml_example} 311 311 - "[>`Off|`On] list" means that to match this list, you should at 312 312 - least be able to match "`Off" and "`On", without argument. 313 313 - "[<`On|`Off|`Number of int]" means that "f" may be applied to "`Off", 314 314 - "`On" (both without argument), or "`Number" $n$ where 315 315 - $n$ is an integer. 316 316 - The ">" and "<" inside the variant types show that they may still be 317 317 - refined, either by defining more tags or by allowing less. As such, they 318 318 - contain an implicit type variable. Because each of the variant types 319 319 - appears only once in the whole type, their implicit type variables are 320 320 - not shown. 321 321 - 322 322 - The above variant types were polymorphic, allowing further refinement. 323 323 - When writing type annotations, one will most often describe fixed 324 324 - variant types, that is types that cannot be refined. This is 325 325 - also the case for type abbreviations. Such types do not contain "<" or 326 326 - ">", but just an enumeration of the tags and their associated types, 327 327 - just like in a normal datatype definition. 328 328 - \begin{caml_example}{toplevel} 329 329 - type 'a vlist = [`Nil | `Cons of 'a * 'a vlist];; 330 330 - let rec map f : 'a vlist -> 'b vlist = function 331 331 - | `Nil -> `Nil 332 332 - | `Cons(a, l) -> `Cons(f a, map f l) 333 333 - ;; 334 334 - \end{caml_example} 335 335 - 336 336 - \subsection*{ss:polyvariant-advanced}{Advanced use} 337 337 - 338 338 - Type-checking polymorphic variants is a subtle thing, and some 339 339 - expressions may result in more complex type information. 340 340 - 341 341 - \begin{caml_example}{toplevel} 342 342 - let f = function `A -> `C | `B -> `D | x -> x;; 343 343 - f `E;; 344 344 - \end{caml_example} 345 345 - Here we are seeing two phenomena. First, since this matching is open 346 346 - (the last case catches any tag), we obtain the type "[> `A | `B]" 347 347 - rather than "[< `A | `B]" in a closed matching. Then, since "x" is 348 348 - returned as is, input and return types are identical. The notation "as 349 349 - 'a" denotes such type sharing. If we apply "f" to yet another tag 350 350 - "`E", it gets added to the list. 351 351 - 352 352 - \begin{caml_example}{toplevel} 353 353 - let f1 = function `A x -> x = 1 | `B -> true | `C -> false 354 354 - let f2 = function `A x -> x = "a" | `B -> true ;; 355 355 - let f x = f1 x && f2 x;; 356 356 - \end{caml_example} 357 357 - Here "f1" and "f2" both accept the variant tags "`A" and "`B", but the 358 358 - argument of "`A" is "int" for "f1" and "string" for "f2". In "f"'s 359 359 - type "`C", only accepted by "f1", disappears, but both argument types 360 360 - appear for "`A" as "int & string". This means that if we 361 361 - pass the variant tag "`A" to "f", its argument should be {\em both} 362 362 - "int" and "string". Since there is no such value, "f" cannot be 363 363 - applied to "`A", and "`B" is the only accepted input. 364 364 - 365 365 - Even if a value has a fixed variant type, one can still give it a 366 366 - larger type through coercions. Coercions are normally written with 367 367 - both the source type and the destination type, but in simple cases the 368 368 - source type may be omitted. 369 369 - \begin{caml_example}{toplevel} 370 370 - type 'a wlist = [`Nil | `Cons of 'a * 'a wlist | `Snoc of 'a wlist * 'a];; 371 371 - let wlist_of_vlist l = (l : 'a vlist :> 'a wlist);; 372 372 - let open_vlist l = (l : 'a vlist :> [> 'a vlist]);; 373 373 - fun x -> (x :> [`A|`B|`C]);; 374 374 - \end{caml_example} 375 375 - 376 376 - You may also selectively coerce values through pattern matching. 377 377 - \begin{caml_example}{toplevel} 378 378 - let split_cases = function 379 379 - | `Nil | `Cons _ as x -> `A x 380 380 - | `Snoc _ as x -> `B x 381 381 - ;; 382 382 - \end{caml_example} 383 383 - When an or-pattern composed of variant tags is wrapped inside an 384 384 - alias-pattern, the alias is given a type containing only the tags 385 385 - enumerated in the or-pattern. This allows for many useful idioms, like 386 386 - incremental definition of functions. 387 387 - 388 388 - \begin{caml_example}{toplevel} 389 389 - let num x = `Num x 390 390 - let eval1 eval (`Num x) = x 391 391 - let rec eval x = eval1 eval x ;; 392 392 - let plus x y = `Plus(x,y) 393 393 - let eval2 eval = function 394 394 - | `Plus(x,y) -> eval x + eval y 395 395 - | `Num _ as x -> eval1 eval x 396 396 - let rec eval x = eval2 eval x ;; 397 397 - \end{caml_example} 398 398 - 399 399 - To make this even more comfortable, you may use type definitions as 400 400 - abbreviations for or-patterns. That is, if you have defined "type 401 401 - myvariant = [`Tag1 of int | `Tag2 of bool]", then the pattern "#myvariant" is 402 402 - equivalent to writing "(`Tag1(_ : int) | `Tag2(_ : bool))". 403 403 - \begin{caml_eval} 404 404 - type myvariant = [`Tag1 of int | `Tag2 of bool];; 405 405 - \end{caml_eval} 406 406 - 407 407 - Such abbreviations may be used alone, 408 408 - \begin{caml_example}{toplevel} 409 409 - let f = function 410 410 - | #myvariant -> "myvariant" 411 411 - | `Tag3 -> "Tag3";; 412 412 - \end{caml_example} 413 413 - or combined with with aliases. 414 414 - \begin{caml_example}{toplevel} 415 415 - let g1 = function `Tag1 _ -> "Tag1" | `Tag2 _ -> "Tag2";; 416 416 - let g = function 417 417 - | #myvariant as x -> g1 x 418 418 - | `Tag3 -> "Tag3";; 419 419 - \end{caml_example} 420 420 - 421 421 - \subsection{ss:polyvariant-weaknesses}{Weaknesses of polymorphic variants} 422 422 - 423 423 - After seeing the power of polymorphic variants, one may wonder why 424 424 - they were added to core language variants, rather than replacing them. 425 425 - 426 426 - The answer is twofold. One first aspect is that while being pretty 427 427 - efficient, the lack of static type information allows for less 428 428 - optimizations, and makes polymorphic variants slightly heavier than 429 429 - core language ones. However noticeable differences would only 430 430 - appear on huge data structures. 431 431 - 432 432 - More important is the fact that polymorphic variants, while being 433 433 - type-safe, result in a weaker type discipline. That is, core language 434 434 - variants do actually much more than ensuring type-safety, they also 435 435 - check that you use only declared constructors, that all constructors 436 436 - present in a data-structure are compatible, and they enforce typing 437 437 - constraints to their parameters. 438 438 - 439 439 - For this reason, you must be more careful about making types explicit 440 440 - when you use polymorphic variants. When you write a library, this is 441 441 - easy since you can describe exact types in interfaces, but for simple 442 442 - programs you are probably better off with core language variants. 443 443 - 444 444 - Beware also that some idioms make trivial errors very hard to find. 445 445 - For instance, the following code is probably wrong but the compiler 446 446 - has no way to see it. 447 447 - \begin{caml_example}{toplevel} 448 448 - type abc = [`A | `B | `C] ;; 449 449 - let f = function 450 450 - | `As -> "A" 451 451 - | #abc -> "other" ;; 452 452 - let f : abc -> string = f ;; 453 453 - \end{caml_example} 454 454 - You can avoid such risks by annotating the definition itself. 455 455 - \begin{caml_example}{toplevel}[error] 456 456 - let f : abc -> string = function 457 457 - | `As -> "A" 458 458 - | #abc -> "other" ;; 459 459 - \end{caml_example}

+179

manual/src/tutorials/polyvariant.etex

reviewed

··· 1 1 + \chapter{Polymorphic variants} \label{c:poly-variant} 2 2 + %HEVEA\cutname{polyvariant.html} 3 3 + {\it (Chapter written by Jacques Garrigue)} 4 4 + 5 5 + Variants as presented in section~\ref{s:tut-recvariants} are a 6 6 + powerful tool to build data structures and algorithms. However they 7 7 + sometimes lack flexibility when used in modular programming. This is 8 8 + due to the fact that every constructor is assigned to a unique type 9 9 + when defined and used. Even if the same name appears in the definition 10 10 + of multiple types, the constructor itself belongs to only one type. 11 11 + Therefore, one cannot decide that a given constructor belongs to 12 12 + multiple types, or consider a value of some type to belong to some 13 13 + other type with more constructors. 14 14 + 15 15 + With polymorphic variants, this original assumption is removed. That 16 16 + is, a variant tag does not belong to any type in particular, the type 17 17 + system will just check that it is an admissible value according to its 18 18 + use. You need not define a type before using a variant tag. A variant 19 19 + type will be inferred independently for each of its uses. 20 20 + 21 21 + \section{s:polyvariant:basic-use}{Basic use} 22 22 + 23 23 + In programs, polymorphic variants work like usual ones. You just have 24 24 + to prefix their names with a backquote character "`". 25 25 + \begin{caml_example}{toplevel} 26 26 + [`On; `Off];; 27 27 + `Number 1;; 28 28 + let f = function `On -> 1 | `Off -> 0 | `Number n -> n;; 29 29 + List.map f [`On; `Off];; 30 30 + \end{caml_example} 31 31 + "[>`Off|`On] list" means that to match this list, you should at 32 32 + least be able to match "`Off" and "`On", without argument. 33 33 + "[<`On|`Off|`Number of int]" means that "f" may be applied to "`Off", 34 34 + "`On" (both without argument), or "`Number" $n$ where 35 35 + $n$ is an integer. 36 36 + The ">" and "<" inside the variant types show that they may still be 37 37 + refined, either by defining more tags or by allowing less. As such, they 38 38 + contain an implicit type variable. Because each of the variant types 39 39 + appears only once in the whole type, their implicit type variables are 40 40 + not shown. 41 41 + 42 42 + The above variant types were polymorphic, allowing further refinement. 43 43 + When writing type annotations, one will most often describe fixed 44 44 + variant types, that is types that cannot be refined. This is 45 45 + also the case for type abbreviations. Such types do not contain "<" or 46 46 + ">", but just an enumeration of the tags and their associated types, 47 47 + just like in a normal datatype definition. 48 48 + \begin{caml_example}{toplevel} 49 49 + type 'a vlist = [`Nil | `Cons of 'a * 'a vlist];; 50 50 + let rec map f : 'a vlist -> 'b vlist = function 51 51 + | `Nil -> `Nil 52 52 + | `Cons(a, l) -> `Cons(f a, map f l) 53 53 + ;; 54 54 + \end{caml_example} 55 55 + 56 56 + \section{s:polyvariant-advanced}{Advanced use} 57 57 + 58 58 + Type-checking polymorphic variants is a subtle thing, and some 59 59 + expressions may result in more complex type information. 60 60 + 61 61 + \begin{caml_example}{toplevel} 62 62 + let f = function `A -> `C | `B -> `D | x -> x;; 63 63 + f `E;; 64 64 + \end{caml_example} 65 65 + Here we are seeing two phenomena. First, since this matching is open 66 66 + (the last case catches any tag), we obtain the type "[> `A | `B]" 67 67 + rather than "[< `A | `B]" in a closed matching. Then, since "x" is 68 68 + returned as is, input and return types are identical. The notation "as 69 69 + 'a" denotes such type sharing. If we apply "f" to yet another tag 70 70 + "`E", it gets added to the list. 71 71 + 72 72 + \begin{caml_example}{toplevel} 73 73 + let f1 = function `A x -> x = 1 | `B -> true | `C -> false 74 74 + let f2 = function `A x -> x = "a" | `B -> true ;; 75 75 + let f x = f1 x && f2 x;; 76 76 + \end{caml_example} 77 77 + Here "f1" and "f2" both accept the variant tags "`A" and "`B", but the 78 78 + argument of "`A" is "int" for "f1" and "string" for "f2". In "f"'s 79 79 + type "`C", only accepted by "f1", disappears, but both argument types 80 80 + appear for "`A" as "int & string". This means that if we 81 81 + pass the variant tag "`A" to "f", its argument should be {\em both} 82 82 + "int" and "string". Since there is no such value, "f" cannot be 83 83 + applied to "`A", and "`B" is the only accepted input. 84 84 + 85 85 + Even if a value has a fixed variant type, one can still give it a 86 86 + larger type through coercions. Coercions are normally written with 87 87 + both the source type and the destination type, but in simple cases the 88 88 + source type may be omitted. 89 89 + \begin{caml_example}{toplevel} 90 90 + type 'a wlist = [`Nil | `Cons of 'a * 'a wlist | `Snoc of 'a wlist * 'a];; 91 91 + let wlist_of_vlist l = (l : 'a vlist :> 'a wlist);; 92 92 + let open_vlist l = (l : 'a vlist :> [> 'a vlist]);; 93 93 + fun x -> (x :> [`A|`B|`C]);; 94 94 + \end{caml_example} 95 95 + 96 96 + You may also selectively coerce values through pattern matching. 97 97 + \begin{caml_example}{toplevel} 98 98 + let split_cases = function 99 99 + | `Nil | `Cons _ as x -> `A x 100 100 + | `Snoc _ as x -> `B x 101 101 + ;; 102 102 + \end{caml_example} 103 103 + When an or-pattern composed of variant tags is wrapped inside an 104 104 + alias-pattern, the alias is given a type containing only the tags 105 105 + enumerated in the or-pattern. This allows for many useful idioms, like 106 106 + incremental definition of functions. 107 107 + 108 108 + \begin{caml_example}{toplevel} 109 109 + let num x = `Num x 110 110 + let eval1 eval (`Num x) = x 111 111 + let rec eval x = eval1 eval x ;; 112 112 + let plus x y = `Plus(x,y) 113 113 + let eval2 eval = function 114 114 + | `Plus(x,y) -> eval x + eval y 115 115 + | `Num _ as x -> eval1 eval x 116 116 + let rec eval x = eval2 eval x ;; 117 117 + \end{caml_example} 118 118 + 119 119 + To make this even more comfortable, you may use type definitions as 120 120 + abbreviations for or-patterns. That is, if you have defined "type 121 121 + myvariant = [`Tag1 of int | `Tag2 of bool]", then the pattern "#myvariant" is 122 122 + equivalent to writing "(`Tag1(_ : int) | `Tag2(_ : bool))". 123 123 + \begin{caml_eval} 124 124 + type myvariant = [`Tag1 of int | `Tag2 of bool];; 125 125 + \end{caml_eval} 126 126 + 127 127 + Such abbreviations may be used alone, 128 128 + \begin{caml_example}{toplevel} 129 129 + let f = function 130 130 + | #myvariant -> "myvariant" 131 131 + | `Tag3 -> "Tag3";; 132 132 + \end{caml_example} 133 133 + or combined with with aliases. 134 134 + \begin{caml_example}{toplevel} 135 135 + let g1 = function `Tag1 _ -> "Tag1" | `Tag2 _ -> "Tag2";; 136 136 + let g = function 137 137 + | #myvariant as x -> g1 x 138 138 + | `Tag3 -> "Tag3";; 139 139 + \end{caml_example} 140 140 + 141 141 + \section{s:polyvariant-weaknesses}{Weaknesses of polymorphic variants} 142 142 + 143 143 + After seeing the power of polymorphic variants, one may wonder why 144 144 + they were added to core language variants, rather than replacing them. 145 145 + 146 146 + The answer is twofold. One first aspect is that while being pretty 147 147 + efficient, the lack of static type information allows for less 148 148 + optimizations, and makes polymorphic variants slightly heavier than 149 149 + core language ones. However noticeable differences would only 150 150 + appear on huge data structures. 151 151 + 152 152 + More important is the fact that polymorphic variants, while being 153 153 + type-safe, result in a weaker type discipline. That is, core language 154 154 + variants do actually much more than ensuring type-safety, they also 155 155 + check that you use only declared constructors, that all constructors 156 156 + present in a data-structure are compatible, and they enforce typing 157 157 + constraints to their parameters. 158 158 + 159 159 + For this reason, you must be more careful about making types explicit 160 160 + when you use polymorphic variants. When you write a library, this is 161 161 + easy since you can describe exact types in interfaces, but for simple 162 162 + programs you are probably better off with core language variants. 163 163 + 164 164 + Beware also that some idioms make trivial errors very hard to find. 165 165 + For instance, the following code is probably wrong but the compiler 166 166 + has no way to see it. 167 167 + \begin{caml_example}{toplevel} 168 168 + type abc = [`A | `B | `C] ;; 169 169 + let f = function 170 170 + | `As -> "A" 171 171 + | #abc -> "other" ;; 172 172 + let f : abc -> string = f ;; 173 173 + \end{caml_example} 174 174 + You can avoid such risks by annotating the definition itself. 175 175 + \begin{caml_example}{toplevel}[error] 176 176 + let f : abc -> string = function 177 177 + | `As -> "A" 178 178 + | #abc -> "other" ;; 179 179 + \end{caml_example}

+3 -3

ocamldoc/odoc_ast.ml

reviewed

··· 258 258 259 259 | Typedtree.Tpat_construct (_, cons_desc, _, _) when 260 260 (* we give a name to the parameter only if it is unit *) 261 261 - (match cons_desc.cstr_res.desc with 261 261 + (match get_desc cons_desc.cstr_res with 262 262 Tconstr (p, _, _) -> 263 263 Path.same p Predef.path_unit 264 264 | _ -> ··· 585 585 with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label)) 586 586 in 587 587 let real_type = 588 588 - match met_type.Types.desc with 588 588 + match get_desc met_type with 589 589 Tarrow (_, _, t, _) -> 590 590 t 591 591 | _ -> ··· 627 627 with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name)) 628 628 in 629 629 let real_type = 630 630 - match exp.exp_type.desc with 630 630 + match get_desc exp.exp_type with 631 631 Tarrow (_, _, t,_) -> 632 632 t 633 633 | _ ->

+23 -18

ocamldoc/odoc_env.ml

reviewed

··· 169 169 if List.memq t !deja_vu then () else begin 170 170 deja_vu := t :: !deja_vu; 171 171 Btype.iter_type_expr iter t; 172 172 - match t.Types.desc with 173 173 - | Types.Tconstr (p, [_], _) when Path.same p Predef.path_option -> 172 172 + let open Types in 173 173 + match get_desc t with 174 174 + | Tconstr (p, [_], _) when Path.same p Predef.path_option -> 174 175 () 175 175 - | Types.Tconstr (p, l, a) -> 176 176 + | Tconstr (p, l, a) -> 176 177 let new_p = 177 178 Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in 178 178 - Btype.set_type_desc t (Types.Tconstr (new_p, l, a)) 179 179 - | Types.Tpackage (p, fl) -> 179 179 + set_type_desc t (Tconstr (new_p, l, a)) 180 180 + | Tpackage (p, fl) -> 180 181 let new_p = 181 181 - Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in 182 182 - Btype.set_type_desc t (Types.Tpackage (new_p, fl)) 183 183 - | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) -> 182 182 + Odoc_name.to_path 183 183 + (full_module_type_name env (Odoc_name.from_path p)) in 184 184 + set_type_desc t (Tpackage (new_p, fl)) 185 185 + | Tobject (_, ({contents=Some(p,tyl)} as r)) -> 184 186 let new_p = 185 187 Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in 186 188 r := Some (new_p, tyl) 187 187 - | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) -> 189 189 + | Tvariant ({row_name=Some(p, tyl)} as row) -> 188 190 let new_p = 189 191 Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in 190 190 - Btype.set_type_desc t 191 191 - (Types.Tvariant {row with Types.row_name=Some(new_p, tyl)}) 192 192 + set_type_desc t (Tvariant {row with row_name=Some(new_p, tyl)}) 192 193 | _ -> 193 194 () 194 195 end ··· 202 203 let open Types in 203 204 match t with 204 205 Mty_ident p -> 205 205 - let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in 206 206 + let new_p = 207 207 + Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) 208 208 + in 206 209 Mty_ident new_p 207 210 | Mty_alias _ 208 211 | Mty_signature _ -> ··· 215 218 216 219 let subst_class_type env t = 217 220 let rec iter t = 221 221 + let open Types in 218 222 match t with 219 219 - Types.Cty_constr (p,texp_list,ct) -> 220 220 - let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in 223 223 + Cty_constr (p,texp_list,ct) -> 224 224 + let new_p = 225 225 + Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in 221 226 let new_texp_list = List.map (subst_type env) texp_list in 222 227 let new_ct = iter ct in 223 223 - Types.Cty_constr (new_p, new_texp_list, new_ct) 224 224 - | Types.Cty_signature _ -> 228 228 + Cty_constr (new_p, new_texp_list, new_ct) 229 229 + | Cty_signature _ -> 225 230 (* we don't handle vals and methods *) 226 231 t 227 227 - | Types.Cty_arrow (l, texp, ct) -> 232 232 + | Cty_arrow (l, texp, ct) -> 228 233 let new_texp = subst_type env texp in 229 234 let new_ct = iter ct in 230 230 - Types.Cty_arrow (l, new_texp, new_ct) 235 235 + Cty_arrow (l, new_texp, new_ct) 231 236 in 232 237 iter t

+22 -17

ocamldoc/odoc_misc.ml

reviewed

··· 492 492 let label_name = Btype.label_name 493 493 494 494 let remove_option typ = 495 495 - let rec iter t = 495 495 + let open Types in 496 496 + let rec trim t = 496 497 match t with 497 497 - | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc 498 498 - | Types.Tconstr _ 499 499 - | Types.Tvar _ 500 500 - | Types.Tunivar _ 501 501 - | Types.Tpoly _ 502 502 - | Types.Tarrow _ 503 503 - | Types.Ttuple _ 504 504 - | Types.Tobject _ 505 505 - | Types.Tfield _ 506 506 - | Types.Tnil 507 507 - | Types.Tvariant _ 508 508 - | Types.Tpackage _ -> t 509 509 - | Types.Tlink t2 -> iter t2.Types.desc 510 510 - | Types.Tsubst _ -> assert false 498 498 + | Tconstr(path, [ty], _) 499 499 + when Path.same path Predef.path_option -> get_desc ty 500 500 + | Tconstr _ 501 501 + | Tvar _ 502 502 + | Tunivar _ 503 503 + | Tpoly _ 504 504 + | Tarrow _ 505 505 + | Ttuple _ 506 506 + | Tobject _ 507 507 + | Tfield _ 508 508 + | Tnil 509 509 + | Tvariant _ 510 510 + | Tpackage _ -> t 511 511 + | Tlink t2 -> trim (get_desc t2) 512 512 + | Tsubst _ -> assert false 511 513 in 512 512 - Types.Private_type_expr.create (iter typ.Types.desc) 513 513 - ~level:typ.Types.level ~scope:typ.Types.scope ~id:typ.Types.id 514 514 + Transient_expr.type_expr 515 515 + (Transient_expr.create (trim (get_desc typ)) 516 516 + ~level:(get_level typ) 517 517 + ~scope:(get_scope typ) 518 518 + ~id:(get_id typ))

+16 -12

ocamldoc/odoc_print.ml

reviewed

··· 81 81 from the signatures. Used when we don't want to print a too long class type.*) 82 82 let simpl_class_type t = 83 83 let rec iter t = 84 84 + let open Types in 84 85 match t with 85 85 - Types.Cty_constr _ -> t 86 86 - | Types.Cty_signature cs -> 86 86 + Cty_constr _ -> t 87 87 + | Cty_signature cs -> 87 88 (* we delete vals and methods in order to not print them when 88 89 displaying the type *) 89 90 let tself = 90 90 - let t = cs.Types.csig_self in 91 91 - let t' = Types.Private_type_expr.create Types.Tnil 91 91 + let t = cs.csig_self in 92 92 + let t' = Transient_expr.create Tnil 92 93 ~level:0 ~scope:Btype.lowest_level ~id:0 in 93 93 - let desc = Types.Tobject (t', ref None) in 94 94 - Types.Private_type_expr.create desc 95 95 - ~level:t.Types.level ~scope:t.Types.scope ~id:t.Types.id 94 94 + let desc = 95 95 + Tobject (Transient_expr.type_expr t', ref None) in 96 96 + Transient_expr.create desc 97 97 + ~level:(get_level t) 98 98 + ~scope:(get_scope t) 99 99 + ~id:(get_id t) 96 100 in 97 97 - Types.Cty_signature { Types.csig_self = tself; 98 98 - csig_vars = Types.Vars.empty ; 99 99 - csig_concr = Types.Concr.empty ; 101 101 + Cty_signature { csig_self = Transient_expr.type_expr tself; 102 102 + csig_vars = Vars.empty ; 103 103 + csig_concr = Concr.empty ; 100 104 csig_inher = [] 101 105 } 102 102 - | Types.Cty_arrow (l, texp, ct) -> 106 106 + | Cty_arrow (l, texp, ct) -> 103 107 let new_ct = iter ct in 104 104 - Types.Cty_arrow (l, texp, new_ct) 108 108 + Cty_arrow (l, texp, new_ct) 105 109 in 106 110 iter t 107 111

+1 -1

ocamldoc/odoc_sig.ml

reviewed

··· 341 341 342 342 343 343 let manifest_structure env name_comment_list type_expr = 344 344 - match type_expr.desc with 344 344 + match get_desc type_expr with 345 345 | Tobject (fields, _) -> 346 346 let f (field_name, _, type_expr) = 347 347 let comment_opt =

+2 -2

ocamldoc/odoc_str.ml

reviewed

··· 30 30 else 31 31 "" 32 32 let rec is_arrow_type t = 33 33 - match t.Types.desc with 33 33 + match Types.get_desc t with 34 34 Types.Tarrow _ -> true 35 35 | Types.Tlink t2 -> is_arrow_type t2 36 36 | Types.Ttuple _ ··· 43 43 let buf = Buffer.create 256 in 44 44 let fmt = Format.formatter_of_buffer buf in 45 45 let rec need_parent t = 46 46 - match t.Types.desc with 46 46 + match Types.get_desc t with 47 47 Types.Tarrow _ | Types.Ttuple _ -> true 48 48 | Types.Tlink t2 -> need_parent t2 49 49 | Types.Tconstr _

+3 -3

ocamldoc/odoc_value.ml

reviewed

··· 72 72 [parameter_list_from_arrows t = [ a ; b ]] if t = a -> b -> c.*) 73 73 let parameter_list_from_arrows typ = 74 74 let rec iter t = 75 75 - match t.Types.desc with 75 75 + match Types.get_desc t with 76 76 Types.Tarrow (l, t1, t2, _) -> 77 77 (l, t1) :: (iter t2) 78 78 | Types.Tlink texp ··· 102 102 Printtyp.mark_loops typ; 103 103 let liste_param = parameter_list_from_arrows typ in 104 104 let rec iter (label, t) = 105 105 - match t.Types.desc with 105 105 + match Types.get_desc t with 106 106 | Types.Ttuple l -> 107 107 let open Asttypes in 108 108 if label = Nolabel then ··· 129 129 (** Return true if the value is a function, i.e. has a functional type.*) 130 130 let is_function v = 131 131 let rec f t = 132 132 - match t.Types.desc with 132 132 + match Types.get_desc t with 133 133 Types.Tarrow _ -> 134 134 true 135 135 | Types.Tlink t ->

-6

otherlibs/unix/socketaddr.c

reviewed

··· 55 55 socklen_param_type * adr_len /*out*/) 56 56 { 57 57 switch(Tag_val(mladr)) { 58 58 - #ifndef _WIN32 59 58 case 0: /* ADDR_UNIX */ 60 59 { value path; 61 60 mlsize_t len; ··· 75 74 + len; 76 75 break; 77 76 } 78 78 - #endif 79 77 case 1: /* ADDR_INET */ 80 78 #ifdef HAS_IPV6 81 79 if (caml_string_length(Field(mladr, 0)) == 16) { ··· 114 112 socklen_param_type adr_len, int close_on_error) 115 113 { 116 114 value res; 117 117 - #ifndef _WIN32 118 115 if (adr_len < offsetof(struct sockaddr, sa_data)) { 119 116 // Only possible for an unnamed AF_UNIX socket, in 120 117 // which case sa_family might be uninitialized. 121 118 return alloc_unix_sockaddr(caml_alloc_string(0)); 122 119 } 123 123 - #endif 124 120 125 121 switch(adr->s_gen.sa_family) { 126 126 - #ifndef _WIN32 127 122 case AF_UNIX: 128 123 { /* Based on recommendation in section BUGS of Linux unix(7). See 129 124 http://man7.org/linux/man-pages/man7/unix.7.html. */ ··· 147 142 ); 148 143 break; 149 144 } 150 150 - #endif 151 145 case AF_INET: 152 146 { value a = alloc_inet_addr(&adr->s_inet.sin_addr); 153 147 Begin_root (a);

+21 -3

otherlibs/unix/socketaddr.h

reviewed

··· 17 17 #define CAML_SOCKETADDR_H 18 18 19 19 #include "caml/misc.h" 20 20 - #ifndef _WIN32 20 20 + 21 21 + #ifdef _WIN32 22 22 + 23 23 + /* Code duplication with runtime/debugger.c is inevitable, because 24 24 + * pulling winsock2.h creates many naming conflicts. */ 25 25 + #include <winsock2.h> 26 26 + #ifdef HAS_AFUNIX_H 27 27 + #include <afunix.h> 28 28 + #else 29 29 + #define UNIX_PATH_MAX 108 30 30 + 31 31 + struct sockaddr_un { 32 32 + ADDRESS_FAMILY sun_family; 33 33 + char sun_path[UNIX_PATH_MAX]; 34 34 + }; 35 35 + 36 36 + #define SIO_AF_UNIX_GETPEERPID _WSAIOR(IOC_VENDOR, 256) 37 37 + 38 38 + #endif 39 39 + 40 40 + #else 21 41 #include <sys/types.h> 22 42 #include <sys/socket.h> 23 43 #include <sys/un.h> ··· 27 47 28 48 union sock_addr_union { 29 49 struct sockaddr s_gen; 30 30 - #ifndef _WIN32 31 50 struct sockaddr_un s_unix; 32 32 - #endif 33 51 struct sockaddr_in s_inet; 34 52 #ifdef HAS_IPV6 35 53 struct sockaddr_in6 s_inet6;

+2 -1

otherlibs/unix/unix.mli

reviewed

··· 1399 1399 (** The type of socket domains. Not all platforms support 1400 1400 IPv6 sockets (type [PF_INET6]). 1401 1401 1402 1402 - On Windows: [PF_UNIX] not implemented. *) 1402 1402 + On Windows: [PF_UNIX] supported since 4.14.0 on Windows 10 1803 1403 1403 + and later. *) 1403 1404 1404 1405 type socket_type = 1405 1406 SOCK_STREAM (** Stream socket *)

+2 -1

otherlibs/unix/unixLabels.mli

reviewed

··· 1403 1403 (** The type of socket domains. Not all platforms support 1404 1404 IPv6 sockets (type [PF_INET6]). 1405 1405 1406 1406 - On Windows: [PF_UNIX] not implemented. *) 1406 1406 + On Windows: [PF_UNIX] supported since 4.14.0 on Windows 10 1803 1407 1407 + and later. *) 1407 1408 1408 1409 type socket_type = Unix.socket_type = 1409 1410 SOCK_STREAM (** Stream socket *)

+1 -1

otherlibs/win32unix/Makefile

reviewed

··· 24 24 link.c listen.c lockf.c lseek.c nonblock.c \ 25 25 mmap.c open.c pipe.c read.c readlink.c rename.c \ 26 26 realpath.c select.c sendrecv.c \ 27 27 - shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \ 27 27 + shutdown.c sleep.c socket.c socketpair.c sockopt.c startup.c stat.c \ 28 28 symlink.c system.c times.c truncate.c unixsupport.c windir.c winwait.c \ 29 29 write.c winlist.c winworker.c windbug.c utimes.c 30 30

+1 -4

otherlibs/win32unix/accept.c

reviewed

··· 38 38 win32_maperr(err); 39 39 uerror("accept", Nothing); 40 40 } 41 41 - /* This is a best effort, not guaranteed to work, so don't fail on error */ 42 42 - SetHandleInformation((HANDLE) snew, 43 43 - HANDLE_FLAG_INHERIT, 44 44 - unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT); 41 41 + win_set_cloexec((HANDLE) snew, cloexec); 45 42 Begin_roots2 (fd, adr) 46 43 fd = win_alloc_socket(snew); 47 44 adr = alloc_sockaddr(&addr, addr_len, snew);

+4 -15

otherlibs/win32unix/close_on.c

reviewed

··· 17 17 #include "unixsupport.h" 18 18 #include <windows.h> 19 19 20 20 - int win_set_inherit(value fd, BOOL inherit) 21 21 - { 22 22 - /* According to the MSDN, SetHandleInformation may not work 23 23 - for console handles on WinNT4 and earlier versions. */ 24 24 - if (! SetHandleInformation(Handle_val(fd), 25 25 - HANDLE_FLAG_INHERIT, 26 26 - inherit ? HANDLE_FLAG_INHERIT : 0)) { 27 27 - win32_maperr(GetLastError()); 28 28 - return -1; 29 29 - } 30 30 - return 0; 31 31 - } 32 32 - 33 20 CAMLprim value win_set_close_on_exec(value fd) 34 21 { 35 35 - if (win_set_inherit(fd, FALSE) == -1) uerror("set_close_on_exec", Nothing); 22 22 + if (win_set_inherit(Handle_val(fd), FALSE) == -1) 23 23 + uerror("set_close_on_exec", Nothing); 36 24 return Val_unit; 37 25 } 38 26 39 27 CAMLprim value win_clear_close_on_exec(value fd) 40 28 { 41 41 - if (win_set_inherit(fd, TRUE) == -1) uerror("clear_close_on_exec", Nothing); 29 29 + if (win_set_inherit(Handle_val(fd), TRUE) == -1) 30 30 + uerror("clear_close_on_exec", Nothing); 42 31 return Val_unit; 43 32 }

+1 -4

otherlibs/win32unix/socket.c

reviewed

··· 35 35 win32_maperr(WSAGetLastError()); 36 36 uerror("socket", Nothing); 37 37 } 38 38 - /* This is a best effort, not guaranteed to work, so don't fail on error */ 39 39 - SetHandleInformation((HANDLE) s, 40 40 - HANDLE_FLAG_INHERIT, 41 41 - unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT); 38 38 + win_set_cloexec((HANDLE) s, cloexec); 42 39 return win_alloc_socket(s); 43 40 }

+201

otherlibs/win32unix/socketpair.c

reviewed

··· 1 1 + /**************************************************************************/ 2 2 + /* */ 3 3 + /* OCaml */ 4 4 + /* */ 5 5 + /* Antonin Decimo, Tarides */ 6 6 + /* */ 7 7 + /* Copyright 2021 Tarides */ 8 8 + /* */ 9 9 + /* All rights reserved. This file is distributed under the terms of */ 10 10 + /* the GNU Lesser General Public License version 2.1, with the */ 11 11 + /* special exception on linking described in the file LICENSE. */ 12 12 + /* */ 13 13 + /**************************************************************************/ 14 14 + 15 15 + #include <caml/mlvalues.h> 16 16 + #include <caml/memory.h> 17 17 + #include <caml/alloc.h> 18 18 + #include <caml/misc.h> 19 19 + #include <caml/signals.h> 20 20 + #include "unixsupport.h" 21 21 + #include <errno.h> 22 22 + 23 23 + #ifdef HAS_SOCKETS 24 24 + 25 25 + #include "socketaddr.h" 26 26 + #include <ws2tcpip.h> 27 27 + 28 28 + extern int socket_domain_table[]; /* from socket.c */ 29 29 + extern int socket_type_table[]; /* from socket.c */ 30 30 + 31 31 + #ifdef HAS_SOCKETPAIR 32 32 + 33 33 + #error "Windows has defined sockepair! win32unix should be updated." 34 34 + 35 35 + #else 36 36 + 37 37 + static int socketpair(int domain, int type, int protocol, 38 38 + SOCKET socket_vector[2]) 39 39 + { 40 40 + wchar_t dirname[MAX_PATH + 1], path[MAX_PATH + 1]; 41 41 + union sock_addr_union addr; 42 42 + socklen_param_type socklen; 43 43 + 44 44 + /* POSIX states that in case of error, the contents of socket_vector 45 45 + shall be unmodified. */ 46 46 + SOCKET listener = INVALID_SOCKET, 47 47 + server = INVALID_SOCKET, 48 48 + client = INVALID_SOCKET; 49 49 + 50 50 + fd_set writefds, exceptfds; 51 51 + u_long non_block, peerid = 0UL; 52 52 + 53 53 + DWORD drc; 54 54 + int rc; 55 55 + 56 56 + if (GetTempPath(MAX_PATH + 1, dirname) == 0) { 57 57 + win32_maperr(GetLastError()); 58 58 + goto fail; 59 59 + } 60 60 + 61 61 + if (GetTempFileName(dirname, L"osp", 0U, path) == 0) { 62 62 + win32_maperr(GetLastError()); 63 63 + goto fail; 64 64 + } 65 65 + 66 66 + addr.s_unix.sun_family = PF_UNIX; 67 67 + socklen = sizeof(addr.s_unix); 68 68 + 69 69 + /* sun_path needs to be set in UTF-8 */ 70 70 + rc = WideCharToMultiByte(CP_UTF8, 0, path, -1, addr.s_unix.sun_path, 71 71 + UNIX_PATH_MAX, NULL, NULL); 72 72 + if (rc == 0) { 73 73 + win32_maperr(GetLastError()); 74 74 + goto fail_path; 75 75 + } 76 76 + 77 77 + listener = socket(domain, type, protocol); 78 78 + if (listener == INVALID_SOCKET) 79 79 + goto fail_wsa; 80 80 + 81 81 + /* The documentation requires removing the file before binding the socket. */ 82 82 + if (DeleteFile(path) == 0) { 83 83 + drc = GetLastError(); 84 84 + if (drc != ERROR_FILE_NOT_FOUND) { 85 85 + win32_maperr(drc); 86 86 + goto fail_sockets; 87 87 + } 88 88 + } 89 89 + 90 90 + rc = bind(listener, (struct sockaddr *) &addr, socklen); 91 91 + if (rc == SOCKET_ERROR) 92 92 + goto fail_wsa; 93 93 + 94 94 + rc = listen(listener, 1); 95 95 + if (rc == SOCKET_ERROR) 96 96 + goto fail_wsa; 97 97 + 98 98 + client = socket(domain, type, protocol); 99 99 + if (client == INVALID_SOCKET) 100 100 + goto fail_wsa; 101 101 + 102 102 + non_block = 1UL; 103 103 + if (ioctlsocket(client, FIONBIO, &non_block) == SOCKET_ERROR) 104 104 + goto fail_wsa; 105 105 + 106 106 + rc = connect(client, (struct sockaddr *) &addr, socklen); 107 107 + if (rc != SOCKET_ERROR || WSAGetLastError() != WSAEWOULDBLOCK) 108 108 + goto fail_wsa; 109 109 + 110 110 + server = accept(listener, NULL, NULL); 111 111 + if (server == INVALID_SOCKET) 112 112 + goto fail_wsa; 113 113 + 114 114 + rc = closesocket(listener); 115 115 + listener = INVALID_SOCKET; 116 116 + if (rc == SOCKET_ERROR) 117 117 + goto fail_wsa; 118 118 + 119 119 + FD_ZERO(&writefds); 120 120 + FD_SET(client, &writefds); 121 121 + FD_ZERO(&exceptfds); 122 122 + FD_SET(client, &exceptfds); 123 123 + 124 124 + rc = select(0 /* ignored */, 125 125 + NULL, &writefds, &exceptfds, 126 126 + NULL /* blocking */); 127 127 + if (rc == SOCKET_ERROR 128 128 + || FD_ISSET(client, &exceptfds) 129 129 + || !FD_ISSET(client, &writefds)) { 130 130 + /* We're not interested in the socket error status */ 131 131 + goto fail_wsa; 132 132 + } 133 133 + 134 134 + non_block = 0UL; 135 135 + if (ioctlsocket(client, FIONBIO, &non_block) == SOCKET_ERROR) 136 136 + goto fail_wsa; 137 137 + 138 138 + if (DeleteFile(path) == 0) { 139 139 + win32_maperr(GetLastError()); 140 140 + goto fail_sockets; 141 141 + } 142 142 + 143 143 + rc = WSAIoctl(client, SIO_AF_UNIX_GETPEERPID, 144 144 + NULL, 0U, 145 145 + &peerid, sizeof(peerid), &drc /* Windows bug: always 0 */, 146 146 + NULL, NULL); 147 147 + if (rc == SOCKET_ERROR || peerid != GetCurrentProcessId()) 148 148 + goto fail_wsa; 149 149 + 150 150 + socket_vector[0] = client; 151 151 + socket_vector[1] = server; 152 152 + return 0; 153 153 + 154 154 + fail_wsa: 155 155 + win32_maperr(WSAGetLastError()); 156 156 + 157 157 + fail_path: 158 158 + DeleteFile(path); 159 159 + 160 160 + fail_sockets: 161 161 + if(listener != INVALID_SOCKET) 162 162 + closesocket(listener); 163 163 + if(client != INVALID_SOCKET) 164 164 + closesocket(client); 165 165 + if(server != INVALID_SOCKET) 166 166 + closesocket(server); 167 167 + 168 168 + fail: 169 169 + return SOCKET_ERROR; 170 170 + } 171 171 + 172 172 + CAMLprim value unix_socketpair(value cloexec, value domain, value type, 173 173 + value protocol) 174 174 + { 175 175 + CAMLparam4(cloexec, domain, type, protocol); 176 176 + CAMLlocal1(result); 177 177 + SOCKET sv[2]; 178 178 + int rc; 179 179 + 180 180 + caml_enter_blocking_section(); 181 181 + rc = socketpair(socket_domain_table[Int_val(domain)], 182 182 + socket_type_table[Int_val(type)], 183 183 + Int_val(protocol), 184 184 + sv); 185 185 + caml_leave_blocking_section(); 186 186 + 187 187 + if (rc == SOCKET_ERROR) 188 188 + uerror("socketpair", Nothing); 189 189 + 190 190 + win_set_cloexec((HANDLE) sv[0], cloexec); 191 191 + win_set_cloexec((HANDLE) sv[1], cloexec); 192 192 + 193 193 + result = caml_alloc_tuple(2); 194 194 + Store_field(result, 0, win_alloc_socket(sv[0])); 195 195 + Store_field(result, 1, win_alloc_socket(sv[1])); 196 196 + CAMLreturn(result); 197 197 + } 198 198 + 199 199 + #endif /* HAS_SOCKETPAIR */ 200 200 + 201 201 + #endif /* HAS_SOCKETS */

+4 -2

otherlibs/win32unix/unix.ml

reviewed

··· 696 696 external socket : 697 697 ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr 698 698 = "unix_socket" 699 699 - let socketpair ?cloexec:_ _dom _ty _proto = 700 700 - invalid_arg "Unix.socketpair not implemented" 699 699 + external socketpair : 700 700 + ?cloexec: bool -> socket_domain -> socket_type -> int -> 701 701 + file_descr * file_descr 702 702 + = "unix_socketpair" 701 703 external accept : 702 704 ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept" 703 705 external bind : file_descr -> sockaddr -> unit = "unix_bind"

+13

otherlibs/win32unix/unixsupport.c

reviewed

··· 331 331 else 332 332 return unix_cloexec_default; 333 333 } 334 334 + 335 335 + int win_set_inherit(HANDLE fd, BOOL inherit) 336 336 + { 337 337 + /* According to the MSDN, SetHandleInformation may not work 338 338 + for console handles on WinNT4 and earlier versions. */ 339 339 + if (! SetHandleInformation(fd, 340 340 + HANDLE_FLAG_INHERIT, 341 341 + inherit ? HANDLE_FLAG_INHERIT : 0)) { 342 342 + win32_maperr(GetLastError()); 343 343 + return -1; 344 344 + } 345 345 + return 0; 346 346 + }

+4

otherlibs/win32unix/unixsupport.h

reviewed

··· 74 74 75 75 extern int unix_cloexec_default; 76 76 extern int unix_cloexec_p(value cloexec); 77 77 + extern int win_set_inherit(HANDLE fd, BOOL inherit); 78 78 + /* This is a best effort, not guaranteed to work, so don't fail on error */ 79 79 + #define win_set_cloexec(fd, cloexec) \ 80 80 + win_set_inherit((fd), ! unix_cloexec_p((cloexec))) 77 81 78 82 /* Information stored in flags_fd, describing more precisely the socket 79 83 * and its status. The whole flags_fd is initialized to 0.

+9

runtime/caml/s.h.in

reviewed

··· 78 78 79 79 /* Define HAS_SOCKETS if you have BSD sockets. */ 80 80 81 81 + #undef HAS_SOCKETPAIR 82 82 + 83 83 + /* Define HAS_SOCKETPAIR if you have the socketpair function. Only 84 84 + relevant on Windows. */ 85 85 + 81 86 #undef HAS_SOCKLEN_T 82 87 83 88 /* Define HAS_SOCKLEN_T if the type socklen_t is defined in 84 89 /usr/include/sys/socket.h. */ 90 90 + 91 91 + #undef HAS_AFUNIX_H 92 92 + 93 93 + /* Define HAS_AFUNIX_H if you have <afunix.h>. */ 85 94 86 95 #undef HAS_INET_ATON 87 96

+12 -8

runtime/debugger.c

reviewed

··· 70 70 #define ATOM ATOM_WS 71 71 #include <winsock2.h> 72 72 #undef ATOM 73 73 + /* Code duplication with otherlibs/unix/socketaddr.h is inevitable 74 74 + * because pulling winsock2.h creates many naming conflicts. */ 75 75 + #ifdef HAS_AFUNIX_H 76 76 + #include <afunix.h> 77 77 + #else 78 78 + struct sockaddr_un { 79 79 + ADDRESS_FAMILY sun_family; 80 80 + char sun_path[108]; 81 81 + }; 82 82 + #endif /* HAS_AFUNIX_H */ 73 83 #include <process.h> 74 74 - #endif 84 84 + #endif /* _WIN32 */ 75 85 76 86 #include "caml/fail.h" 77 87 #include "caml/fix_code.h" ··· 85 95 static int sock_domain; /* Socket domain for the debugger */ 86 96 static union { /* Socket address for the debugger */ 87 97 struct sockaddr s_gen; 88 88 - #ifndef _WIN32 89 98 struct sockaddr_un s_unix; 90 90 - #endif 91 99 struct sockaddr_in s_inet; 92 100 } sock_addr; 93 101 static int sock_addr_len; /* Length of sock_addr */ ··· 170 178 { 171 179 char * address; 172 180 char_os * a; 173 173 - size_t a_len; 174 181 char * port, * p; 175 182 struct hostent * host; 176 183 value flags; ··· 207 214 if (*p == ':') { *p = 0; port = p+1; break; } 208 215 } 209 216 if (port == NULL) { 210 210 - #ifndef _WIN32 217 217 + size_t a_len; 211 218 /* Unix domain */ 212 219 sock_domain = PF_UNIX; 213 220 sock_addr.s_unix.sun_family = AF_UNIX; ··· 224 231 sock_addr_len = 225 232 ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix)) 226 233 + a_len; 227 227 - #else 228 228 - caml_fatal_error("unix sockets not supported"); 229 229 - #endif 230 234 } else { 231 235 /* Internet domain */ 232 236 sock_domain = PF_INET;

+4 -4

testsuite/tests/basic-modules/recursive_module_evaluation_errors.ml

reviewed

··· 13 13 ^^^^^^^^^^^^^^^^^^^^^^ 14 14 Error: Cannot safely evaluate the definition of the following cycle 15 15 of recursively-defined modules: B -> E -> D -> C -> B. 16 16 - There are no safe modules in this cycle (see manual section 8.2). 16 16 + There are no safe modules in this cycle (see manual section 10.2). 17 17 Line 2, characters 10-20: 18 18 2 | and B:sig val x: int end = struct let x = E.y end 19 19 ^^^^^^^^^^ ··· 42 42 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 43 43 Error: Cannot safely evaluate the definition of the following cycle 44 44 of recursively-defined modules: A -> B -> A. 45 45 - There are no safe modules in this cycle (see manual section 8.2). 45 45 + There are no safe modules in this cycle (see manual section 10.2). 46 46 Line 2, characters 28-29: 47 47 2 | module rec A: sig type t += A end = struct type t += A = B.A end 48 48 ^ ··· 70 70 7 | end 71 71 Error: Cannot safely evaluate the definition of the following cycle 72 72 of recursively-defined modules: A -> B -> A. 73 73 - There are no safe modules in this cycle (see manual section 8.2). 73 73 + There are no safe modules in this cycle (see manual section 10.2). 74 74 Line 2, characters 2-41: 75 75 2 | module F: functor(X:sig end) -> sig end 76 76 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ··· 100 100 8 | end 101 101 Error: Cannot safely evaluate the definition of the following cycle 102 102 of recursively-defined modules: A -> B -> A. 103 103 - There are no safe modules in this cycle (see manual section 8.2). 103 103 + There are no safe modules in this cycle (see manual section 10.2). 104 104 Line 3, characters 4-17: 105 105 3 | module M: X.t 106 106 ^^^^^^^^^^^^^

+8

testsuite/tests/lib-unix/win-socketpair/has-afunix.sh

reviewed

··· 1 1 + #!/bin/sh 2 2 + 3 3 + # Test if the OS runtime has afunix enabled. 4 4 + 5 5 + if sc query afunix > /dev/null; then 6 6 + exit "${TEST_PASS}"; 7 7 + fi 8 8 + exit "${TEST_SKIP}"

+32

testsuite/tests/lib-unix/win-socketpair/test.ml

reviewed

··· 1 1 + (* TEST 2 2 + 3 3 + * libwin32unix 4 4 + script = "sh ${test_source_directory}/has-afunix.sh" 5 5 + ** hassysthreads 6 6 + include systhreads 7 7 + *** script 8 8 + **** bytecode 9 9 + output = "${test_build_directory}/program-output" 10 10 + stdout = "${output}" 11 11 + **** native 12 12 + output = "${test_build_directory}/program-output" 13 13 + stdout = "${output}" 14 14 + 15 15 + *) 16 16 + 17 17 + let peer id fd = 18 18 + let msg = Bytes.of_string (Printf.sprintf "%d" id) in 19 19 + ignore (Unix.write fd msg 0 (Bytes.length msg)); 20 20 + ignore (Unix.read fd msg 0 (Bytes.length msg)); 21 21 + let expected = Bytes.of_string (Printf.sprintf "%d" (if id = 0 then 1 else 0)) in 22 22 + if msg = expected then 23 23 + Printf.printf "Ok\n%!" 24 24 + else 25 25 + Printf.printf "%d: %s\n%!" id (Bytes.to_string msg); 26 26 + flush_all () 27 27 + 28 28 + let () = 29 29 + let fd0, fd1 = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 30 30 + let t0, t1 = Thread.create (peer 0) fd0, Thread.create (peer 1) fd1 in 31 31 + Thread.join t0; Thread.join t1; 32 32 + Unix.close fd0; Unix.close fd1

+2

testsuite/tests/lib-unix/win-socketpair/test.reference

reviewed

··· 1 1 + Ok 2 2 + Ok

+3 -3

testsuite/tests/typing-gadts/omega07.ml

reviewed

··· 904 904 (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun> 905 905 val _1 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam = 906 906 App (Shift (Var Suc), Var Zero) 907 907 - val _2 : ((zero, int, (suc, int -> int, '_weak2) rcons) rcons, int) lam = 907 907 + val _2 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam = 908 908 App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)) 909 909 - val _3 : ((zero, int, (suc, int -> int, '_weak3) rcons) rcons, int) lam = 909 909 + val _3 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam = 910 910 App (Shift (Var Suc), 911 911 App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))) 912 912 val add : ··· 921 921 App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)) 922 922 val ex3 : 923 923 ((zero, int, 924 924 - (suc, int -> int, (add, int -> int -> int, '_weak4) rcons) rcons) 924 924 + (suc, int -> int, (add, int -> int -> int, '_weak2) rcons) rcons) 925 925 rcons, int) 926 926 lam = 927 927 App

+9

testsuite/tests/typing-gadts/test.ml

reviewed

··· 628 628 in M.z 629 629 ;; (* fails because of aliasing... *) 630 630 [%%expect{| 631 631 + Lines 2-4, characters 2-10: 632 632 + 2 | ..match x with Int -> 633 633 + 3 | let module M = struct type b = a let z = (y : b) end 634 634 + 4 | in M.z 635 635 + Warning 18 [not-principal]: 636 636 + The return type of this pattern-matching is ambiguous. 637 637 + Please add a type annotation, as the choice of `a' is not principal. 638 638 + val f : 'a t -> 'a -> 'a = <fun> 639 639 + |}, Principal{| 631 640 Line 3, characters 46-47: 632 641 3 | let module M = struct type b = a let z = (y : b) end 633 642 ^

+1 -2

testsuite/tests/typing-misc/constraints.ml

reviewed

··· 7 7 Line 1, characters 0-32: 8 8 1 | type 'a t = [`A of 'a t t] as 'a;; (* fails *) 9 9 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 10 10 - Error: The definition of t contains a cycle: 11 11 - 'a t t as 'a 10 10 + Error: The type abbreviation t is cyclic 12 11 |}, Principal{| 13 12 Line 1, characters 0-32: 14 13 1 | type 'a t = [`A of 'a t t] as 'a;; (* fails *)

-14

testsuite/tests/typing-objects/Exemples.ml

reviewed

··· 589 589 but an expression was expected of type 590 590 #comparable as 'a = < cmp : 'a -> int; .. > 591 591 Type int_comparable = < cmp : int_comparable -> int; x : int > 592 592 - is not compatible with type 593 593 - int_comparable3 = 594 594 - < cmp : int_comparable -> int; setx : int -> unit; x : int > 595 595 - The first object type has no method setx 596 596 - |}, Principal{| 597 597 - Line 1, characters 25-27: 598 598 - 1 | (new sorted_list ())#add c3;; 599 599 - ^^ 600 600 - Error: This expression has type 601 601 - int_comparable3 = 602 602 - < cmp : int_comparable -> int; setx : int -> unit; x : int > 603 603 - but an expression was expected of type 604 604 - #comparable as 'a = < cmp : 'a -> int; .. > 605 605 - Type int_comparable = < cmp : int_comparable -> int; x : int > 606 592 is not compatible with type 'a = < cmp : 'a -> int; .. > 607 593 The first object type has no method setx 608 594 |}];; (* Error; strange message with -principal *)

+13 -13

testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml

reviewed

··· 28 28 2 | | ((Val x, _) | (_, Val x)) when x < 0 -> () 29 29 ^^^^^^^^^^^^^^^^^^^^^^^^^ 30 30 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 31 31 - variable x may match different arguments. (See manual section 9.5) 31 31 + variable x may match different arguments. (See manual section 11.5) 32 32 val ambiguous_typical_example : expr * expr -> unit = <fun> 33 33 |}] 34 34 ··· 95 95 2 | | (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x 96 96 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 97 97 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 98 98 - variable y may match different arguments. (See manual section 9.5) 98 98 + variable y may match different arguments. (See manual section 11.5) 99 99 val ambiguous__y : [> `B of 'a * bool option * bool option ] -> unit = <fun> 100 100 |}] 101 101 ··· 126 126 2 | | (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> () 127 127 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 128 128 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 129 129 - variable y may match different arguments. (See manual section 9.5) 129 129 + variable y may match different arguments. (See manual section 11.5) 130 130 val ambiguous__x_y : [> `B of 'a * 'a option * 'a option ] -> unit = <fun> 131 131 |}] 132 132 ··· 139 139 2 | | (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> () 140 140 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 141 141 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 142 142 - variables y,z may match different arguments. (See manual section 9.5) 142 142 + variables y,z may match different arguments. (See manual section 11.5) 143 143 val ambiguous__x_y_z : [> `B of 'a * 'a option * 'a option ] -> unit = <fun> 144 144 |}] 145 145 ··· 170 170 2 | | `A (`B (Some x, _) | `B (_, Some x)) when x -> () 171 171 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 172 172 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 173 173 - variable x may match different arguments. (See manual section 9.5) 173 173 + variable x may match different arguments. (See manual section 11.5) 174 174 val ambiguous__in_depth : 175 175 [> `A of [> `B of bool option * bool option ] ] -> unit = <fun> 176 176 |}] ··· 201 201 2 | ....`A ((`B (Some x, _) | `B (_, Some x)), 202 202 3 | (`C (Some y, Some _, _) | `C (Some y, _, Some _)))................. 203 203 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 204 204 - variable x may match different arguments. (See manual section 9.5) 204 204 + variable x may match different arguments. (See manual section 11.5) 205 205 val ambiguous__first_orpat : 206 206 [> `A of 207 207 [> `B of 'a option * 'a option ] * ··· 219 219 2 | ....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)), 220 220 3 | (`C (Some y, _) | `C (_, Some y)))................. 221 221 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 222 222 - variable y may match different arguments. (See manual section 9.5) 222 222 + variable y may match different arguments. (See manual section 11.5) 223 223 val ambiguous__second_orpat : 224 224 [> `A of 225 225 [> `B of 'a option * 'b option * 'c option ] * ··· 312 312 2 | ..X (Z x,Y (y,0)) 313 313 3 | | X (Z y,Y (x,_)) 314 314 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 315 315 - variables x,y may match different arguments. (See manual section 9.5) 315 315 + variables x,y may match different arguments. (See manual section 11.5) 316 316 val ambiguous__amoi : amoi -> int = <fun> 317 317 |}] 318 318 ··· 332 332 2 | ....(module M:S),_,(1,_) 333 333 3 | | _,(module M:S),(_,1)................... 334 334 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 335 335 - variable M may match different arguments. (See manual section 9.5) 335 335 + variable M may match different arguments. (See manual section 11.5) 336 336 val ambiguous__module_variable : 337 337 (module S) * (module S) * (int * int) -> bool -> int = <fun> 338 338 |}] ··· 379 379 2 | | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1 380 380 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 381 381 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 382 382 - variables x,y may match different arguments. (See manual section 9.5) 382 382 + variables x,y may match different arguments. (See manual section 11.5) 383 383 val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t2 -> int = 384 384 <fun> 385 385 |}, Principal{| ··· 408 408 2 | | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1 409 409 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 410 410 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 411 411 - variables x,y may match different arguments. (See manual section 9.5) 411 411 + variables x,y may match different arguments. (See manual section 11.5) 412 412 val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t2 -> int = 413 413 <fun> 414 414 |}] ··· 467 467 3 | | ((Val y, _) | (_, Val y)) when y < 0 -> () 468 468 ^^^^^^^^^^^^^^^^^^^^^^^^^ 469 469 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 470 470 - variable y may match different arguments. (See manual section 9.5) 470 470 + variable y may match different arguments. (See manual section 11.5) 471 471 val guarded_ambiguity : expr * expr -> unit = <fun> 472 472 |}] 473 473 ··· 496 496 4 | | ((Val x, _) | (_, Val x)) when pred x -> () 497 497 ^^^^^^^^^^^^^^^^^^^^^^^^^ 498 498 Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; 499 499 - variable x may match different arguments. (See manual section 9.5) 499 499 + variable x may match different arguments. (See manual section 11.5) 500 500 val cmp : (a -> bool) -> a alg -> a alg -> unit = <fun> 501 501 |}] 502 502

+6 -6

testsuite/tests/warnings/w52.ml

reviewed

··· 10 10 ^^^^^ 11 11 Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of 12 12 this constructor's arguments. They are only for information 13 13 - and may change in future versions. (See manual section 9.5) 13 13 + and may change in future versions. (See manual section 11.5) 14 14 |}];; 15 15 16 16 let () = try () with Match_failure ("Any",_,_) -> ();; ··· 20 20 ^^^^^^^^^^^ 21 21 Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of 22 22 this constructor's arguments. They are only for information 23 23 - and may change in future versions. (See manual section 9.5) 23 23 + and may change in future versions. (See manual section 11.5) 24 24 |}];; 25 25 26 26 let () = try () with Match_failure (_,0,_) -> ();; ··· 30 30 ^^^^^^^ 31 31 Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of 32 32 this constructor's arguments. They are only for information 33 33 - and may change in future versions. (See manual section 9.5) 33 33 + and may change in future versions. (See manual section 11.5) 34 34 |}];; 35 35 36 36 type t = ··· 55 55 ^^^^^^^^^^ 56 56 Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of 57 57 this constructor's arguments. They are only for information 58 58 - and may change in future versions. (See manual section 9.5) 58 58 + and may change in future versions. (See manual section 11.5) 59 59 val f : t -> unit = <fun> 60 60 |}];; 61 61 ··· 68 68 ^^ 69 69 Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of 70 70 this constructor's arguments. They are only for information 71 71 - and may change in future versions. (See manual section 9.5) 71 71 + and may change in future versions. (See manual section 11.5) 72 72 val g : t -> unit = <fun> 73 73 |}];; 74 74 ··· 95 95 ^^^^^^^^^^^^^^^^^^^^^^^^^^^ 96 96 Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of 97 97 this constructor's arguments. They are only for information 98 98 - and may change in future versions. (See manual section 9.5) 98 98 + and may change in future versions. (See manual section 11.5) 99 99 val j : t -> unit = <fun> 100 100 |}];;

+3 -2

toplevel/byte/topmain.ml

reviewed

··· 39 39 if Obj.is_block clos 40 40 && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) 41 41 && (match 42 42 - Ctype.(repr (expand_head !Topcommon.toplevel_env desc.val_type)) 43 43 - with {desc=Tarrow _} -> true | _ -> false) 42 42 + Types.get_desc 43 43 + (Ctype.expand_head !Topcommon.toplevel_env desc.val_type) 44 44 + with Tarrow _ -> true | _ -> false) 44 45 then begin 45 46 match is_traced clos with 46 47 | Some opath ->

+2 -2

toplevel/byte/trace.ml

reviewed

··· 66 66 (* If a function returns a functional value, wrap it into a trace code *) 67 67 68 68 let rec instrument_result env name ppf clos_typ = 69 69 - match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with 69 69 + match get_desc (Ctype.expand_head env clos_typ) with 70 70 | Tarrow(l, t1, t2, _) -> 71 71 let starred_name = 72 72 match name with ··· 109 109 let _ = Dummy 110 110 111 111 let instrument_closure env name ppf clos_typ = 112 112 - match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with 112 112 + match get_desc (Ctype.expand_head env clos_typ) with 113 113 | Tarrow(l, t1, t2, _) -> 114 114 let trace_res = instrument_result env name ppf t2 in 115 115 (fun actual_code closure arg ->

+7 -7

toplevel/genprintval.ml

reviewed

··· 203 203 Oide_ident name 204 204 | Pdot(p, _s) -> 205 205 if 206 206 - match (find (Lident (Out_name.print name)) env).desc with 206 206 + match get_desc (find (Lident (Out_name.print name)) env) with 207 207 | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' 208 208 | _ -> false 209 209 | exception Not_found -> false ··· 215 215 let tree_of_constr = 216 216 tree_of_qualified 217 217 (fun lid env -> 218 218 - (Env.find_constructor_by_name lid env).cstr_res) 218 218 + (Env.find_constructor_by_name lid env).cstr_res) 219 219 220 220 and tree_of_label = 221 221 tree_of_qualified 222 222 (fun lid env -> 223 223 - (Env.find_label_by_name lid env).lbl_res) 223 223 + (Env.find_label_by_name lid env).lbl_res) 224 224 225 225 (* An abstract type *) 226 226 ··· 260 260 try 261 261 find_printer depth env ty obj 262 262 with Not_found -> 263 263 - match (Ctype.repr ty).desc with 263 263 + match get_desc ty with 264 264 | Tvar _ | Tunivar _ -> 265 265 Oval_stuff "<poly>" 266 266 | Tarrow _ -> ··· 397 397 let type_params = 398 398 match cd_res with 399 399 Some t -> 400 400 - begin match (Ctype.repr t).desc with 400 400 + begin match get_desc t with 401 401 Tconstr (_,params,_) -> 402 402 params 403 403 | _ -> assert false end ··· 559 559 if not (EVP.same_value slot (EVP.eval_address addr)) 560 560 then raise Not_found; 561 561 let type_params = 562 562 - match (Ctype.repr cstr.cstr_res).desc with 562 562 + match get_desc cstr.cstr_res with 563 563 Tconstr (_,params,_) -> 564 564 params 565 565 | _ -> assert false ··· 592 592 then printer 593 593 else find remainder 594 594 | (_name, Generic (path, fn)) :: remainder -> 595 595 - begin match (Ctype.expand_head env ty).desc with 595 595 + begin match get_desc (Ctype.expand_head env ty) with 596 596 | Tconstr (p, args, _) when Path.same p path -> 597 597 begin try apply_generic_printer path (fn depth) args 598 598 with exn -> (fun _obj -> out_exn path exn) end

+6 -5

toplevel/topdirs.ml

reviewed

··· 175 175 176 176 let filter_arrow ty = 177 177 let ty = Ctype.expand_head !toplevel_env ty in 178 178 - match ty.desc with 178 178 + match get_desc ty with 179 179 | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> Some (l, r) 180 180 | _ -> None 181 181 ··· 189 189 let extract_target_type ty = fst (extract_last_arrow ty) 190 190 let extract_target_parameters ty = 191 191 let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in 192 192 - match ty.desc with 192 192 + match get_desc ty with 193 193 | Tconstr (path, (_ :: _ as args), _) 194 194 - when Ctype.all_distinct_vars !toplevel_env args -> Some (path, args) 194 194 + when Ctype.all_distinct_vars !toplevel_env args -> 195 195 + Some (path, args) 195 196 | _ -> None 196 197 197 198 type 'a printer_type_new = Format.formatter -> 'a -> unit ··· 454 455 if is_exception_constructor env desc.cstr_res then 455 456 raise Not_found; 456 457 let path = 457 457 - match Ctype.repr desc.cstr_res with 458 458 - | {desc=Tconstr(path, _, _)} -> path 458 458 + match get_desc desc.cstr_res with 459 459 + | Tconstr(path, _, _) -> path 459 460 | _ -> raise Not_found 460 461 in 461 462 let type_decl = Env.find_type path env in

+103 -230

typing/btype.ml

reviewed

··· 22 22 23 23 (**** Sets, maps and hashtables of types ****) 24 24 25 25 - module TypeSet = Set.Make(TypeOps) 26 26 - module TypeMap = Map.Make (TypeOps) 27 27 - module TypeHash = Hashtbl.Make(TypeOps) 25 25 + let wrap_repr f ty = f (Transient_expr.repr ty) 26 26 + let wrap_type_expr f tty = f (Transient_expr.type_expr tty) 27 27 + 28 28 + module TransientTypeSet = Set.Make(TransientTypeOps) 29 29 + module TypeSet = struct 30 30 + include TransientTypeSet 31 31 + let add = wrap_repr add 32 32 + let mem = wrap_repr mem 33 33 + let singleton = wrap_repr singleton 34 34 + let exists p = TransientTypeSet.exists (wrap_type_expr p) 35 35 + let elements set = 36 36 + List.map Transient_expr.type_expr (TransientTypeSet.elements set) 37 37 + end 38 38 + module TransientTypeMap = Map.Make(TransientTypeOps) 39 39 + module TypeMap = struct 40 40 + include TransientTypeMap 41 41 + let add ty = wrap_repr add ty 42 42 + let find ty = wrap_repr find ty 43 43 + let singleton ty = wrap_repr singleton ty 44 44 + let fold f = TransientTypeMap.fold (wrap_type_expr f) 45 45 + end 46 46 + module TransientTypeHash = Hashtbl.Make(TransientTypeOps) 47 47 + module TypeHash = struct 48 48 + include TransientTypeHash 49 49 + let add hash = wrap_repr (add hash) 50 50 + let find hash = wrap_repr (find hash) 51 51 + let iter f = TransientTypeHash.iter (wrap_type_expr f) 52 52 + end 53 53 + module TransientTypePairs = 54 54 + Hashtbl.Make (struct 55 55 + type t = transient_expr * transient_expr 56 56 + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') 57 57 + let hash (t, t') = t.id + 93 * t'.id 58 58 + end) 59 59 + module TypePairs = struct 60 60 + include TransientTypePairs 61 61 + open Transient_expr 62 62 + let wrap_repr f (t1, t2) = f (repr t1, repr t2) 63 63 + let wrap_type_expr f (tt1, tt2) = f (type_expr tt1, type_expr tt2) 64 64 + let add hash = wrap_repr (add hash) 65 65 + let find hash = wrap_repr (find hash) 66 66 + let mem hash = wrap_repr (mem hash) 67 67 + let iter f = TransientTypePairs.iter (wrap_type_expr f) 68 68 + end 28 69 29 70 (**** Forward declarations ****) 30 71 ··· 42 83 43 84 (**** Some type creators ****) 44 85 45 45 - let new_id = s_ref (-1) 86 86 + let newgenty desc = newty2 ~level:generic_level desc 87 87 + let newgenvar ?name () = newgenty (Tvar name) 88 88 + let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) 46 89 47 47 - let newty2 level desc = 48 48 - incr new_id; 49 49 - Private_type_expr.create desc ~level ~scope:lowest_level ~id:!new_id 50 50 - let newgenty desc = newty2 generic_level desc 51 51 - let newgenvar ?name () = newgenty (Tvar name) 52 90 (* 53 91 let newmarkedvar level = 54 92 incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } ··· 59 97 60 98 (**** Check some types ****) 61 99 62 62 - let is_Tvar = function {desc=Tvar _} -> true | _ -> false 63 63 - let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false 64 64 - let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false 100 100 + let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false 101 101 + let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false 102 102 + let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false 65 103 66 104 let dummy_method = "*dummy method*" 67 105 68 68 - (**** Definitions for backtracking ****) 69 69 - 70 70 - type change = 71 71 - Ctype of type_expr * type_desc 72 72 - | Ccompress of type_expr * type_desc * type_desc 73 73 - | Clevel of type_expr * int 74 74 - | Cscope of type_expr * int 75 75 - | Cname of 76 76 - (Path.t * type_expr list) option ref * (Path.t * type_expr list) option 77 77 - | Crow of row_field option ref * row_field option 78 78 - | Ckind of field_kind option ref * field_kind option 79 79 - | Ccommu of commutable ref * commutable 80 80 - | Cuniv of type_expr option ref * type_expr option 81 81 - 82 82 - type changes = 83 83 - Change of change * changes ref 84 84 - | Unchanged 85 85 - | Invalid 86 86 - 87 87 - let trail = s_table ref Unchanged 88 88 - 89 89 - let log_change ch = 90 90 - let r' = ref Unchanged in 91 91 - !trail := Change (ch, r'); 92 92 - trail := r' 93 93 - 94 106 (**** Representative of a type ****) 95 107 96 96 - let rec field_kind_repr = 97 97 - function 98 98 - Fvar {contents = Some kind} -> field_kind_repr kind 99 99 - | kind -> kind 100 100 - 101 101 - let rec repr_link compress (t : type_expr) d : type_expr -> type_expr = 102 102 - function 103 103 - {desc = Tlink t' as d'} -> 104 104 - repr_link true t d' t' 105 105 - | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> 106 106 - repr_link true t d' t' 107 107 - | t' -> 108 108 - if compress then begin 109 109 - log_change (Ccompress (t, t.desc, d)); Private_type_expr.set_desc t d 110 110 - end; 111 111 - t' 112 112 - 113 113 - let repr (t : type_expr) = 114 114 - match t.desc with 115 115 - Tlink t' as d -> 116 116 - repr_link false t d t' 117 117 - | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> 118 118 - repr_link false t d t' 119 119 - | _ -> t 120 120 - 121 108 let rec commu_repr = function 122 109 Clink r when !r <> Cunknown -> commu_repr !r 123 110 | c -> c ··· 139 126 | l'::ll -> rev_concat (l'@l) ll 140 127 141 128 let rec row_repr_aux ll row = 142 142 - match (repr row.row_more).desc with 129 129 + match get_desc row.row_more with 143 130 | Tvariant row' -> 144 131 let f = row.row_fields in 145 132 row_repr_aux (if f = [] then ll else f::ll) row' ··· 154 141 | (tag',f) :: fields -> 155 142 if tag = tag' then row_field_repr f else find fields 156 143 | [] -> 157 157 - match repr row.row_more with 158 158 - | {desc=Tvariant row'} -> row_field tag row' 144 144 + match get_desc row.row_more with 145 145 + | Tvariant row' -> row_field tag row' 159 146 | _ -> Rabsent 160 147 in find row.row_fields 161 148 162 149 let rec row_more row = 163 163 - match repr row.row_more with 164 164 - | {desc=Tvariant row'} -> row_more row' 165 165 - | ty -> ty 150 150 + match get_desc row.row_more with 151 151 + | Tvariant row' -> row_more row' 152 152 + | _ -> row.row_more 166 153 167 154 let merge_fixed_explanation fixed1 fixed2 = 168 155 match fixed1, fixed2 with ··· 178 165 match row.row_fixed with 179 166 | Some _ as x -> x 180 167 | None -> 181 181 - let more = repr row.row_more in 182 182 - match more.desc with 168 168 + match get_desc row.row_more with 183 169 | Tvar _ | Tnil -> None 184 184 - | Tunivar _ -> Some (Univar more) 170 170 + | Tunivar _ -> Some (Univar row.row_more) 185 171 | Tconstr (p,_,_) -> Some (Reified p) 186 172 | _ -> assert false 187 173 ··· 210 196 if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu 211 197 212 198 let proxy ty = 213 213 - let ty0 = repr ty in 214 214 - match ty0.desc with 199 199 + match get_desc ty with 215 200 | Tvariant row when not (static_row row) -> 216 201 row_more row 217 202 | Tobject (ty, _) -> 218 203 let rec proxy_obj ty = 219 219 - match ty.desc with 220 220 - Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty 204 204 + match get_desc ty with 205 205 + Tfield (_, _, _, ty) -> proxy_obj ty 221 206 | Tvar _ | Tunivar _ | Tconstr _ -> ty 222 222 - | Tnil -> ty0 207 207 + | Tnil -> ty 223 208 | _ -> assert false 224 209 in proxy_obj ty 225 225 - | _ -> ty0 210 210 + | _ -> ty 226 211 227 212 (**** Utilities for fixed row private types ****) 228 213 229 214 let row_of_type t = 230 230 - match (repr t).desc with 215 215 + match get_desc t with 231 216 Tobject(t,_) -> 232 217 let rec get_row t = 233 233 - let t = repr t in 234 234 - match t.desc with 218 218 + match get_desc t with 235 219 Tfield(_,_,_,t) -> get_row t 236 220 | _ -> t 237 221 in get_row t ··· 248 232 if l < 4 then false else String.sub s (l-4) 4 = "#row" 249 233 250 234 let is_constr_row ~allow_ident t = 251 251 - match t.desc with 235 235 + match get_desc t with 252 236 Tconstr (Path.Pident id, _, _) when allow_ident -> 253 237 is_row_name (Ident.name id) 254 238 | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s ··· 260 244 match decl.type_manifest with 261 245 None -> () 262 246 | Some ty -> 263 263 - let ty = repr ty in 264 264 - match ty.desc with 247 247 + match get_desc ty with 265 248 Tvariant row when static_row row -> 266 249 let row = {(row_repr row) with 267 250 row_name = Some (path, decl.type_params)} in 268 268 - Private_type_expr.set_desc ty (Tvariant row) 251 251 + set_type_desc ty (Tvariant row) 269 252 | _ -> () 270 253 271 254 ··· 284 267 init 285 268 row.row_fields 286 269 in 287 287 - match (repr row.row_more).desc with 270 270 + match get_desc row.row_more with 288 271 Tvariant row -> fold_row f result row 289 272 | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> 290 273 begin match ··· 298 281 let iter_row f row = 299 282 fold_row (fun () v -> f v) () row 300 283 301 301 - let rec fold_type_expr f init ty = 302 302 - match ty.desc with 284 284 + let fold_type_expr f init ty = 285 285 + match get_desc ty with 303 286 Tvar _ -> init 304 287 | Tarrow (_, ty1, ty2, _) -> 305 305 - let result = f init ty1 in 306 306 - f result ty2 288 288 + let result = f init ty1 in 289 289 + f result ty2 307 290 | Ttuple l -> List.fold_left f init l 308 291 | Tconstr (_, l, _) -> List.fold_left f init l 309 309 - | Tobject(ty, {contents = Some (_, p)}) 310 310 - -> 311 311 - let result = f init ty in 312 312 - List.fold_left f result p 292 292 + | Tobject(ty, {contents = Some (_, p)}) -> 293 293 + let result = f init ty in 294 294 + List.fold_left f result p 313 295 | Tobject (ty, _) -> f init ty 314 296 | Tvariant row -> 315 315 - let result = fold_row f init row in 316 316 - f result (row_more row) 297 297 + let result = fold_row f init row in 298 298 + f result (row_more row) 317 299 | Tfield (_, _, ty1, ty2) -> 318 318 - let result = f init ty1 in 319 319 - f result ty2 300 300 + let result = f init ty1 in 301 301 + f result ty2 320 302 | Tnil -> init 321 321 - | Tlink ty -> fold_type_expr f init ty 303 303 + | Tlink _ 322 304 | Tsubst _ -> assert false 323 305 | Tunivar _ -> init 324 306 | Tpoly (ty, tyl) -> ··· 440 422 iter_type_expr_kind (it.it_type_expr it) kind 441 423 and it_do_type_expr it ty = 442 424 iter_type_expr (it.it_type_expr it) ty; 443 443 - match ty.desc with 425 425 + match get_desc ty with 444 426 Tconstr (p, _, _) 445 427 | Tobject (_, {contents=Some (p, _)}) 446 428 | Tpackage (p, _) -> ··· 498 480 | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) 499 481 Tfield (p, field_kind_repr k, f ty1, f ty2) 500 482 | Tnil -> Tnil 501 501 - | Tlink ty -> copy_type_desc f ty.desc 483 483 + | Tlink ty -> copy_type_desc f (get_desc ty) 502 484 | Tsubst _ -> assert false 503 485 | Tunivar _ as ty -> ty (* always keep the name *) 504 486 | Tpoly (ty, tyl) -> ··· 511 493 module For_copy : sig 512 494 type copy_scope 513 495 514 514 - val save_desc: copy_scope -> type_expr -> type_desc -> unit 496 496 + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit 515 497 516 498 val dup_kind: copy_scope -> field_kind option ref -> unit 517 499 518 500 val with_scope: (copy_scope -> 'a) -> 'a 519 501 end = struct 520 502 type copy_scope = { 521 521 - mutable saved_desc : (type_expr * type_desc) list; 503 503 + mutable saved_desc : (transient_expr * type_desc) list; 522 504 (* Save association of generic nodes with their description. *) 523 505 524 506 mutable saved_kinds: field_kind option ref list; ··· 528 510 (* new kind variables *) 529 511 } 530 512 531 531 - let save_desc copy_scope ty desc = 532 532 - copy_scope.saved_desc <- (ty, desc) :: copy_scope.saved_desc 513 513 + let redirect_desc copy_scope ty desc = 514 514 + let ty = Transient_expr.repr ty in 515 515 + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; 516 516 + Transient_expr.set_desc ty desc 533 517 534 518 let dup_kind copy_scope r = 535 519 assert (Option.is_none !r); ··· 542 526 543 527 (* Restore type descriptions. *) 544 528 let cleanup { saved_desc; saved_kinds; _ } = 545 545 - List.iter (fun (ty, desc) -> Private_type_expr.set_desc ty desc) saved_desc; 529 529 + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc; 546 530 List.iter (fun r -> r := None) saved_kinds 547 531 548 532 let with_scope f = ··· 551 535 cleanup scope; 552 536 res 553 537 end 554 554 - 555 538 556 539 (*******************************************) 557 540 (* Memorization of abbreviation expansion *) ··· 625 608 List.for_all (fun mem -> check_abbrev_rec !mem) !memo 626 609 *) 627 610 611 611 + (* Re-export backtrack *) 612 612 + 613 613 + let snapshot = snapshot 614 614 + let backtrack = backtrack ~cleanup_abbrev 615 615 + 628 616 (**********************************) 629 617 (* Utilities for labels *) 630 618 (**********************************) ··· 651 639 652 640 let extract_label l ls = extract_label_aux [] l ls 653 641 654 654 - 655 642 (**********************************) 656 656 - (* Utilities for backtracking *) 643 643 + (* Utilities for level-marking *) 657 644 (**********************************) 658 645 659 659 - let undo_change = function 660 660 - Ctype (ty, desc) -> Private_type_expr.set_desc ty desc 661 661 - | Ccompress (ty, desc, _) -> Private_type_expr.set_desc ty desc 662 662 - | Clevel (ty, level) -> Private_type_expr.set_level ty level 663 663 - | Cscope (ty, scope) -> Private_type_expr.set_scope ty scope 664 664 - | Cname (r, v) -> r := v 665 665 - | Crow (r, v) -> r := v 666 666 - | Ckind (r, v) -> r := v 667 667 - | Ccommu (r, v) -> r := v 668 668 - | Cuniv (r, v) -> r := v 669 669 - 670 670 - type snapshot = changes ref * int 671 671 - let last_snapshot = s_ref 0 672 672 - 673 673 - let log_type ty = 674 674 - if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) 675 675 - let link_type ty ty' = 676 676 - log_type ty; 677 677 - let desc = ty.desc in 678 678 - Private_type_expr.set_desc ty (Tlink ty'); 679 679 - (* Name is a user-supplied name for this unification variable (obtained 680 680 - * through a type annotation for instance). *) 681 681 - match desc, ty'.desc with 682 682 - Tvar name, Tvar name' -> 683 683 - begin match name, name' with 684 684 - | Some _, None -> log_type ty'; Private_type_expr.set_desc ty' (Tvar name) 685 685 - | None, Some _ -> () 686 686 - | Some _, Some _ -> 687 687 - if ty.level < ty'.level then 688 688 - (log_type ty'; Private_type_expr.set_desc ty' (Tvar name)) 689 689 - | None, None -> () 690 690 - end 691 691 - | _ -> () 692 692 - (* ; assert (check_memorized_abbrevs ()) *) 693 693 - (* ; check_expans [] ty' *) 694 694 - (* TODO: consider eliminating set_type_desc, replacing it with link types *) 695 695 - let set_type_desc ty td = 696 696 - if td != ty.desc then begin 697 697 - log_type ty; 698 698 - Private_type_expr.set_desc ty td 699 699 - end 700 700 - (* TODO: separate set_level into two specific functions: *) 701 701 - (* set_lower_level and set_generic_level *) 702 702 - let set_level ty level = 703 703 - if level <> ty.level then begin 704 704 - if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); 705 705 - Private_type_expr.set_level ty level 706 706 - end 707 707 - (* TODO: introduce a guard and rename it to set_higher_scope? *) 708 708 - let set_scope ty scope = 709 709 - if scope <> ty.scope then begin 710 710 - if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); 711 711 - Private_type_expr.set_scope ty scope 712 712 - end 713 713 - let set_univar rty ty = 714 714 - log_change (Cuniv (rty, !rty)); rty := Some ty 715 715 - let set_name nm v = 716 716 - log_change (Cname (nm, !nm)); nm := v 717 717 - let set_row_field e v = 718 718 - log_change (Crow (e, !e)); e := Some v 719 719 - let set_kind rk k = 720 720 - log_change (Ckind (rk, !rk)); rk := Some k 721 721 - let set_commu rc c = 722 722 - log_change (Ccommu (rc, !rc)); rc := c 723 723 - 724 724 - let snapshot () = 725 725 - let old = !last_snapshot in 726 726 - last_snapshot := !new_id; 727 727 - (!trail, old) 728 728 - 729 729 - let rec rev_log accu = function 730 730 - Unchanged -> accu 731 731 - | Invalid -> assert false 732 732 - | Change (ch, next) -> 733 733 - let d = !next in 734 734 - next := Invalid; 735 735 - rev_log (ch::accu) d 736 736 - 737 737 - let backtrack (changes, old) = 738 738 - match !changes with 739 739 - Unchanged -> last_snapshot := old 740 740 - | Invalid -> failwith "Btype.backtrack" 741 741 - | Change _ as change -> 742 742 - cleanup_abbrev (); 743 743 - let backlog = rev_log [] change in 744 744 - List.iter undo_change backlog; 745 745 - changes := Unchanged; 746 746 - last_snapshot := old; 747 747 - trail := changes 748 748 - 749 749 - let rec rev_compress_log log r = 750 750 - match !r with 751 751 - Unchanged | Invalid -> 752 752 - log 753 753 - | Change (Ccompress _, next) -> 754 754 - rev_compress_log (r::log) next 755 755 - | Change (_, next) -> 756 756 - rev_compress_log log next 757 757 - 758 758 - let undo_compress (changes, _old) = 759 759 - match !changes with 760 760 - Unchanged 761 761 - | Invalid -> () 762 762 - | Change _ -> 763 763 - let log = rev_compress_log [] changes in 764 764 - List.iter 765 765 - (fun r -> match !r with 766 766 - Change (Ccompress (ty, desc, d), next) when ty.desc == d -> 767 767 - Private_type_expr.set_desc ty desc; r := !next 768 768 - | _ -> ()) 769 769 - log 770 770 - 771 771 - (* Mark a type. *) 772 772 - 773 773 - let not_marked_node ty = ty.level >= lowest_level 646 646 + let not_marked_node ty = get_level ty >= lowest_level 774 647 (* type nodes with negative levels are "marked" *) 775 648 776 776 - let flip_mark_node ty = Private_type_expr.set_level ty (pivot_level - ty.level) 777 777 - let logged_mark_node ty = set_level ty (pivot_level - ty.level) 649 649 + let flip_mark_node ty = 650 650 + let ty = Transient_expr.repr ty in 651 651 + Transient_expr.set_level ty (pivot_level - ty.level) 652 652 + let logged_mark_node ty = 653 653 + set_level ty (pivot_level - get_level ty) 778 654 779 655 let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true) 780 656 let try_logged_mark_node ty = not_marked_node ty && (logged_mark_node ty; true) 781 657 782 658 let rec mark_type ty = 783 783 - let ty = repr ty in 784 659 if not_marked_node ty then begin 785 660 flip_mark_node ty; 786 661 iter_type_expr mark_type ty ··· 791 666 792 667 let type_iterators = 793 668 let it_type_expr it ty = 794 794 - let ty = repr ty in 795 669 if try_mark_node ty then it.it_do_type_expr it ty 796 670 in 797 671 {type_iterators with it_type_expr} ··· 799 673 800 674 (* Remove marks from a type. *) 801 675 let rec unmark_type ty = 802 802 - let ty = repr ty in 803 803 - if ty.level < lowest_level then begin 676 676 + if get_level ty < lowest_level then begin 804 677 (* flip back the marked level *) 805 678 flip_mark_node ty; 806 679 iter_type_expr unmark_type ty

+50 -53

typing/btype.mli

reviewed

··· 20 20 21 21 (**** Sets, maps and hashtables of types ****) 22 22 23 23 - module TypeSet : Set.S with type elt = type_expr 24 24 - module TypeMap : Map.S with type key = type_expr 25 25 - module TypeHash : Hashtbl.S with type key = type_expr 23 23 + module TypeSet : sig 24 24 + include Set.S with type elt = transient_expr 25 25 + val add: type_expr -> t -> t 26 26 + val mem: type_expr -> t -> bool 27 27 + val singleton: type_expr -> t 28 28 + val exists: (type_expr -> bool) -> t -> bool 29 29 + val elements: t -> type_expr list 30 30 + end 31 31 + module TransientTypeMap : Map.S with type key = transient_expr 32 32 + module TypeMap : sig 33 33 + include Map.S with type key = transient_expr 34 34 + and type 'a t = 'a TransientTypeMap.t 35 35 + val add: type_expr -> 'a -> 'a t -> 'a t 36 36 + val find: type_expr -> 'a t -> 'a 37 37 + val singleton: type_expr -> 'a -> 'a t 38 38 + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 39 39 + end 40 40 + module TypeHash : sig 41 41 + include Hashtbl.S with type key = transient_expr 42 42 + val add: 'a t -> type_expr -> 'a -> unit 43 43 + val find: 'a t -> type_expr -> 'a 44 44 + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit 45 45 + end 46 46 + module TypePairs : sig 47 47 + include Hashtbl.S with type key = transient_expr * transient_expr 48 48 + val add: 'a t -> type_expr * type_expr -> 'a -> unit 49 49 + val find: 'a t -> type_expr * type_expr -> 'a 50 50 + val mem: 'a t -> type_expr * type_expr -> bool 51 51 + val iter: (type_expr * type_expr -> 'a -> unit) -> 'a t -> unit 52 52 + end 26 53 27 54 (**** Levels ****) 28 55 29 56 val generic_level: int 30 57 31 31 - val newty2: int -> type_desc -> type_expr 32 32 - (* Create a type *) 33 58 val newgenty: type_desc -> type_expr 34 59 (* Create a generic type *) 35 60 val newgenvar: ?name:string -> unit -> type_expr 36 61 (* Return a fresh generic variable *) 62 62 + val newgenstub: scope:int -> type_expr 63 63 + (* Return a fresh generic node, to be instantiated 64 64 + by [Transient_expr.set_stub_desc] *) 37 65 38 66 (* Use Tsubst instead 39 67 val newmarkedvar: int -> type_expr ··· 48 76 val is_Tunivar: type_expr -> bool 49 77 val is_Tconstr: type_expr -> bool 50 78 val dummy_method: label 51 51 - 52 52 - val repr: type_expr -> type_expr 53 53 - (* Return the canonical representative of a type. *) 54 54 - 55 55 - val field_kind_repr: field_kind -> field_kind 56 56 - (* Return the canonical representative of an object field 57 57 - kind. *) 58 79 59 80 val commu_repr: commutable -> commutable 60 81 (* Return the canonical representative of a commutation lock *) ··· 113 134 val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a 114 135 val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit 115 136 (* Iteration on types in an abbreviation list *) 137 137 + val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit) 138 138 + 139 139 + val iter_type_expr_cstr_args: (type_expr -> unit) -> 140 140 + (constructor_arguments -> unit) 141 141 + val map_type_expr_cstr_args: (type_expr -> type_expr) -> 142 142 + (constructor_arguments -> constructor_arguments) 143 143 + 116 144 117 145 type type_iterators = 118 146 { it_signature: type_iterators -> signature -> unit; ··· 154 182 While it is possible to circumvent that discipline in various 155 183 ways, you should NOT do that. *) 156 184 157 157 - val save_desc: copy_scope -> type_expr -> type_desc -> unit 158 158 - (* Save a type description *) 185 185 + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit 186 186 + (* Temporarily change a type description *) 159 187 160 188 val dup_kind: copy_scope -> field_kind option ref -> unit 161 189 (* Save a None field_kind, and make it point to a fresh Fvar *) ··· 217 245 abbrev_memo ref -> Path.t -> unit 218 246 (* Remove an abbreviation from the cache *) 219 247 248 248 + (**** Backtracking ****) 249 249 + 250 250 + val snapshot: unit -> snapshot 251 251 + val backtrack: snapshot -> unit 252 252 + (* Backtrack to a given snapshot. Only possible if you have 253 253 + not already backtracked to a previous snapshot. 254 254 + Calls [cleanup_abbrev] internally *) 255 255 + 220 256 (**** Utilities for labels ****) 221 257 222 258 val is_optional : arg_label -> bool ··· 233 269 whether (label, value) was at the head of the list, 234 270 list without the extracted (label, value) *) 235 271 236 236 - (**** Utilities for backtracking ****) 237 237 - 238 238 - type snapshot 239 239 - (* A snapshot for backtracking *) 240 240 - val snapshot: unit -> snapshot 241 241 - (* Make a snapshot for later backtracking. Costs nothing *) 242 242 - val backtrack: snapshot -> unit 243 243 - (* Backtrack to a given snapshot. Only possible if you have 244 244 - not already backtracked to a previous snapshot. 245 245 - Calls [cleanup_abbrev] internally *) 246 246 - val undo_compress: snapshot -> unit 247 247 - (* Backtrack only path compression. Only meaningful if you have 248 248 - not already backtracked to a previous snapshot. 249 249 - Does not call [cleanup_abbrev] *) 250 250 - 251 251 - (* Functions to use when modifying a type (only Ctype?) *) 252 252 - val link_type: type_expr -> type_expr -> unit 253 253 - (* Set the desc field of [t1] to [Tlink t2], logging the old 254 254 - value if there is an active snapshot *) 255 255 - val set_type_desc: type_expr -> type_desc -> unit 256 256 - (* Set directly the desc field, without sharing *) 257 257 - val set_level: type_expr -> int -> unit 258 258 - val set_scope: type_expr -> int -> unit 259 259 - val set_name: 260 260 - (Path.t * type_expr list) option ref -> 261 261 - (Path.t * type_expr list) option -> unit 262 262 - val set_row_field: row_field option ref -> row_field -> unit 263 263 - val set_univar: type_expr option ref -> type_expr -> unit 264 264 - val set_kind: field_kind option ref -> field_kind -> unit 265 265 - val set_commu: commutable ref -> commutable -> unit 266 266 - (* Set references, logging the old value *) 267 267 - 268 272 (**** Forward declarations ****) 269 273 val print_raw: (Format.formatter -> type_expr -> unit) ref 270 270 - 271 271 - val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit) 272 272 - 273 273 - val iter_type_expr_cstr_args: (type_expr -> unit) -> 274 274 - (constructor_arguments -> unit) 275 275 - val map_type_expr_cstr_args: (type_expr -> type_expr) -> 276 276 - (constructor_arguments -> constructor_arguments)

+473 -523

typing/ctype.ml

reviewed

··· 231 231 232 232 (* Re-export generic type creators *) 233 233 234 234 - let newty2 = Btype.newty2 235 235 - let newty desc = newty2 !current_level desc 234 234 + let newty desc = newty2 ~level:!current_level desc 236 235 237 237 - let newvar ?name () = newty2 !current_level (Tvar name) 238 238 - let newvar2 ?name level = newty2 level (Tvar name) 239 239 - let new_global_var ?name () = newty2 !global_level (Tvar name) 236 236 + let newvar ?name () = newty2 ~level:!current_level (Tvar name) 237 237 + let newvar2 ?name level = newty2 ~level:level (Tvar name) 238 238 + let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) 239 239 + let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) 240 240 241 241 let newobj fields = newty (Tobject (fields, ref None)) 242 242 243 243 let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) 244 244 245 245 let none = newty (Ttuple []) (* Clearly ill-formed type *) 246 246 - 247 247 - (**** Representative of a type ****) 248 248 - 249 249 - (* Re-export repr *) 250 250 - let repr = repr 251 251 - 252 252 - (**** Type maps ****) 253 253 - 254 254 - module TypePairs = 255 255 - Hashtbl.Make (struct 256 256 - type t = type_expr * type_expr 257 257 - let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') 258 258 - let hash (t, t') = t.id + 93 * t'.id 259 259 - end) 260 260 - 261 246 262 247 (**** unification mode ****) 263 248 ··· 317 302 (**** Object field manipulation. ****) 318 303 319 304 let object_fields ty = 320 320 - match (repr ty).desc with 305 305 + match get_desc ty with 321 306 Tobject (fields, _) -> fields 322 307 | _ -> assert false 323 308 324 309 let flatten_fields ty = 325 310 let rec flatten l ty = 326 326 - let ty = repr ty in 327 327 - match ty.desc with 311 311 + match get_desc ty with 328 312 Tfield(s, k, ty1, ty2) -> 329 313 flatten ((s, k, ty1)::l) ty2 330 314 | _ -> ··· 335 319 336 320 let build_fields level = 337 321 List.fold_right 338 338 - (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2))) 322 322 + (fun (s, k, ty1) ty2 -> newty2 ~level (Tfield(s, k, ty1, ty2))) 339 323 340 324 let associate_fields fields1 fields2 = 341 325 let rec associate p s s' = ··· 354 338 associate [] [] [] (fields1, fields2) 355 339 356 340 let rec has_dummy_method ty = 357 357 - match repr ty with 358 358 - {desc = Tfield (m, _, _, ty2)} -> 341 341 + match get_desc ty with 342 342 + Tfield (m, _, _, ty2) -> 359 343 m = dummy_method || has_dummy_method ty2 360 344 | _ -> false 361 345 ··· 367 351 368 352 (* +++ The abbreviation should eventually be expanded *) 369 353 let rec object_row ty = 370 370 - let ty = repr ty in 371 371 - match ty.desc with 354 354 + match get_desc ty with 372 355 Tobject (t, _) -> object_row t 373 356 | Tfield(_, _, _, t) -> object_row t 374 357 | _ -> ty 375 358 376 359 let opened_object ty = 377 377 - match (object_row ty).desc with 360 360 + match get_desc (object_row ty) with 378 361 | Tvar _ | Tunivar _ | Tconstr _ -> true 379 362 | _ -> false 380 363 381 364 let concrete_object ty = 382 382 - match (object_row ty).desc with 365 365 + match get_desc (object_row ty) with 383 366 | Tvar _ -> false 384 367 | _ -> true 385 368 ··· 387 370 388 371 let close_object ty = 389 372 let rec close ty = 390 390 - let ty = repr ty in 391 391 - match ty.desc with 373 373 + match get_desc ty with 392 374 Tvar _ -> 393 393 - link_type ty (newty2 ty.level Tnil); true 375 375 + link_type ty (newty2 ~level:(get_level ty) Tnil); true 394 376 | Tfield(lab, _, _, _) when lab = dummy_method -> 395 377 false 396 378 | Tfield(_, _, _, ty') -> close ty' 397 379 | _ -> assert false 398 380 in 399 399 - match (repr ty).desc with 381 381 + match get_desc ty with 400 382 Tobject (ty, _) -> close ty 401 383 | _ -> assert false 402 384 ··· 404 386 405 387 let row_variable ty = 406 388 let rec find ty = 407 407 - let ty = repr ty in 408 408 - match ty.desc with 389 389 + match get_desc ty with 409 390 Tfield (_, _, _, ty) -> find ty 410 391 | Tvar _ -> ty 411 392 | _ -> assert false 412 393 in 413 413 - match (repr ty).desc with 394 394 + match get_desc ty with 414 395 Tobject (fi, _) -> find fi 415 396 | _ -> assert false 416 397 ··· 418 399 (* +++ Bientot obsolete *) 419 400 420 401 let set_object_name id rv params ty = 421 421 - match (repr ty).desc with 402 402 + match get_desc ty with 422 403 Tobject (_fi, nm) -> 423 404 set_name nm (Some (Path.Pident id, rv::params)) 424 405 | _ -> 425 406 assert false 426 407 427 408 let remove_object_name ty = 428 428 - match (repr ty).desc with 409 409 + match get_desc ty with 429 410 Tobject (_, nm) -> set_name nm None 430 411 | Tconstr (_, _, _) -> () 431 412 | _ -> fatal_error "Ctype.remove_object_name" ··· 433 414 (**** Hiding of private methods ****) 434 415 435 416 let hide_private_methods ty = 436 436 - match (repr ty).desc with 417 417 + match get_desc ty with 437 418 Tobject (fi, nm) -> 438 419 nm := None; 439 420 let (fl, _) = flatten_fields fi in ··· 459 440 | Cty_arrow (_, _, cty) -> signature_of_class_type cty 460 441 461 442 let self_type cty = 462 462 - repr (signature_of_class_type cty).csig_self 443 443 + (signature_of_class_type cty).csig_self 463 444 464 445 let rec class_type_arity = 465 446 function ··· 530 511 and only returns a [variable list]. 531 512 *) 532 513 let rec free_vars_rec real ty = 533 533 - let ty = repr ty in 534 514 if try_mark_node ty then 535 535 - match ty.desc, !really_closed with 515 515 + match get_desc ty, !really_closed with 536 516 Tvar _, _ -> 537 517 free_variables := (ty, real) :: !free_variables 538 518 | Tconstr (path, tl, _), Some env -> 539 519 begin try 540 520 let (_, body, _) = Env.find_type_expansion path env in 541 541 - if (repr body).level <> generic_level then 521 521 + if get_level body <> generic_level then 542 522 free_variables := (ty, real) :: !free_variables 543 523 with Not_found -> () 544 524 end; ··· 636 616 exception CCFailure of closed_class_failure 637 617 638 618 let closed_class params sign = 639 639 - let ty = object_fields (repr sign.csig_self) in 619 619 + let ty = object_fields sign.csig_self in 640 620 let (fields, rest) = flatten_fields ty in 641 621 List.iter mark_type params; 642 622 mark_type rest; ··· 644 624 (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) 645 625 fields; 646 626 try 647 647 - ignore (try_mark_node (repr sign.csig_self)); 627 627 + ignore (try_mark_node sign.csig_self); 648 628 List.iter 649 629 (fun (lab, kind, ty) -> 650 630 if field_kind_repr kind = Fpresent then 651 631 try closed_type ty with Non_closed (ty0, real) -> 652 632 raise (CCFailure (CC_Method (ty0, real, lab, ty)))) 653 633 fields; 654 654 - mark_type_params (repr sign.csig_self); 634 634 + mark_type_params sign.csig_self; 655 635 List.iter unmark_type params; 656 636 unmark_class_signature sign; 657 637 None 658 638 with CCFailure reason -> 659 659 - mark_type_params (repr sign.csig_self); 639 639 + mark_type_params sign.csig_self; 660 640 List.iter unmark_type params; 661 641 unmark_class_signature sign; 662 642 Some reason ··· 688 668 preserved. Does it worth duplicating this code ? 689 669 *) 690 670 let rec generalize ty = 691 691 - let ty = repr ty in 692 692 - if (ty.level > !current_level) && (ty.level <> generic_level) then begin 671 671 + let level = get_level ty in 672 672 + if (level > !current_level) && (level <> generic_level) then begin 693 673 set_level ty generic_level; 694 674 (* recur into abbrev for the speed *) 695 695 - begin match ty.desc with 675 675 + begin match get_desc ty with 696 676 Tconstr (_, _, abbrev) -> 697 677 iter_abbrev generalize !abbrev 698 678 | _ -> () ··· 707 687 (* Generalize the structure and lower the variables *) 708 688 709 689 let rec generalize_structure ty = 710 710 - let ty = repr ty in 711 711 - if ty.level <> generic_level then begin 712 712 - if is_Tvar ty && ty.level > !current_level then 690 690 + let level = get_level ty in 691 691 + if level <> generic_level then begin 692 692 + if is_Tvar ty && level > !current_level then 713 693 set_level ty !current_level 714 694 else if 715 715 - ty.level > !current_level && 716 716 - match ty.desc with 695 695 + level > !current_level && 696 696 + match get_desc ty with 717 697 Tconstr (p, _, abbrev) -> 718 698 not (is_object_type p) && (abbrev := Mnil; true) 719 699 | _ -> true ··· 730 710 (* Generalize the spine of a function, if the level >= !current_level *) 731 711 732 712 let rec generalize_spine ty = 733 733 - let ty = repr ty in 734 734 - if ty.level < !current_level || ty.level = generic_level then () else 735 735 - match ty.desc with 713 713 + let level = get_level ty in 714 714 + if level < !current_level || level = generic_level then () else 715 715 + match get_desc ty with 736 716 Tarrow (_, ty1, ty2, _) -> 737 717 set_level ty generic_level; 738 718 generalize_spine ty1; ··· 777 757 | _ -> p 778 758 779 759 let rec check_scope_escape env level ty = 780 780 - let ty = repr ty in 781 781 - let orig_level = ty.level in 760 760 + let orig_level = get_level ty in 782 761 if try_logged_mark_node ty then begin 783 783 - if level < ty.scope then 762 762 + if level < get_scope ty then 784 763 raise_scope_escape_exn ty; 785 785 - begin match ty.desc with 764 764 + begin match get_desc ty with 786 765 | Tconstr (p, _, _) when level < Path.scope p -> 787 766 begin match !forward_try_expand_safe env ty with 788 767 | ty' -> ··· 794 773 let p' = normalize_package_path env p in 795 774 if Path.same p p' then raise_escape_exn (Module_type p); 796 775 check_scope_escape env level 797 797 - (Btype.newty2 orig_level (Tpackage (p', fl))) 776 776 + (newty2 ~level:orig_level (Tpackage (p', fl))) 798 777 | _ -> 799 799 - iter_type_expr (check_scope_escape env level) ty 778 778 + iter_type_expr (check_scope_escape env level) ty 800 779 end; 801 780 end 802 781 ··· 808 787 raise (Escape { e with context = Some ty }) 809 788 810 789 let rec update_scope scope ty = 811 811 - let ty = repr ty in 812 812 - if ty.scope < scope then begin 813 813 - if ty.level < scope then raise_scope_escape_exn ty; 790 790 + if get_scope ty < scope then begin 791 791 + if get_level ty < scope then raise_scope_escape_exn ty; 814 792 set_scope ty scope; 815 793 (* Only recurse in principal mode as this is not necessary for soundness *) 816 794 if !Clflags.principal then iter_type_expr (update_scope scope) ty ··· 830 808 *) 831 809 832 810 let rec update_level env level expand ty = 833 833 - let ty = repr ty in 834 834 - if ty.level > level then begin 835 835 - if level < ty.scope then raise_scope_escape_exn ty; 836 836 - match ty.desc with 811 811 + if get_level ty > level then begin 812 812 + if level < get_scope ty then raise_scope_escape_exn ty; 813 813 + match get_desc ty with 837 814 Tconstr(p, _tl, _abbrev) when level < Path.scope p -> 838 815 (* Try first to replace an abbreviation by its expansion. *) 839 816 begin try 840 840 - link_type ty (!forward_try_expand_safe env ty); 841 841 - update_level env level expand ty 817 817 + let ty' = !forward_try_expand_safe env ty in 818 818 + link_type ty ty'; 819 819 + update_level env level expand ty' 842 820 with Cannot_expand -> 843 821 raise_escape_exn (Constructor p) 844 822 end ··· 849 827 let needs_expand = 850 828 expand || 851 829 List.exists2 852 852 - (fun var ty -> var = Variance.null && (repr ty).level > level) 830 830 + (fun var ty -> var = Variance.null && get_level ty > level) 853 831 variance tl 854 832 in 855 833 begin try 856 834 if not needs_expand then raise Cannot_expand; 857 857 - link_type ty (!forward_try_expand_safe env ty); 858 858 - update_level env level expand ty 835 835 + let ty' = !forward_try_expand_safe env ty in 836 836 + link_type ty ty'; 837 837 + update_level env level expand ty' 859 838 with Cannot_expand -> 860 839 set_level ty level; 861 840 iter_type_expr (update_level env level expand) ty ··· 865 844 if Path.same p p' then raise_escape_exn (Module_type p); 866 845 set_type_desc ty (Tpackage (p', fl)); 867 846 update_level env level expand ty 868 868 - | Tobject(_, ({contents=Some(p, _tl)} as nm)) 847 847 + | Tobject (_, ({contents=Some(p, _tl)} as nm)) 869 848 when level < Path.scope p -> 870 849 set_name nm None; 871 850 update_level env level expand ty ··· 878 857 end; 879 858 set_level ty level; 880 859 iter_type_expr (update_level env level expand) ty 881 881 - | Tfield(lab, _, ty1, _) 882 882 - when lab = dummy_method && (repr ty1).level > level -> 860 860 + | Tfield (lab, _, ty1, _) 861 861 + when lab = dummy_method && get_level ty1 > level -> 883 862 raise_escape_exn Self 884 863 | _ -> 885 864 set_level ty level; ··· 890 869 (* First try without expanding, then expand everything, 891 870 to avoid combinatorial blow-up *) 892 871 let update_level env level ty = 893 893 - let ty = repr ty in 894 894 - if ty.level > level then begin 872 872 + if get_level ty > level then begin 895 873 let snap = snapshot () in 896 874 try 897 875 update_level env level false ty ··· 908 886 (* Lower level of type variables inside contravariant branches *) 909 887 910 888 let rec lower_contravariant env var_level visited contra ty = 911 911 - let ty = repr ty in 912 889 let must_visit = 913 913 - ty.level > var_level && 914 914 - match Hashtbl.find visited ty.id with 890 890 + get_level ty > var_level && 891 891 + match Hashtbl.find visited (get_id ty) with 915 892 | done_contra -> contra && not done_contra 916 893 | exception Not_found -> true 917 894 in 918 895 if must_visit then begin 919 919 - Hashtbl.add visited ty.id contra; 896 896 + Hashtbl.add visited (get_id ty) contra; 920 897 let lower_rec = lower_contravariant env var_level visited in 921 921 - match ty.desc with 898 898 + match get_desc ty with 922 899 Tvar _ -> if contra then set_level ty var_level 923 900 | Tconstr (_, [], _) -> () 924 901 | Tconstr (path, tyl, _abbrev) -> ··· 983 960 984 961 (* Only generalize the type ty0 in ty *) 985 962 let limited_generalize ty0 ty = 986 986 - let ty0 = repr ty0 in 987 987 - 988 963 let graph = Hashtbl.create 17 in 989 964 let idx = ref lowest_level in 990 965 let roots = ref [] in 991 966 992 967 let rec inverse pty ty = 993 993 - let ty = repr ty in 994 994 - if (ty.level > !current_level) || (ty.level = generic_level) then begin 968 968 + let level = get_level ty in 969 969 + if (level > !current_level) || (level = generic_level) then begin 995 970 decr idx; 996 971 Hashtbl.add graph !idx (ty, ref pty); 997 997 - if (ty.level = generic_level) || (ty == ty0) then 972 972 + if (level = generic_level) || eq_type ty ty0 then 998 973 roots := ty :: !roots; 999 974 set_level ty !idx; 1000 975 iter_type_expr (inverse [ty]) ty 1001 1001 - end else if ty.level < lowest_level then begin 1002 1002 - let (_, parents) = Hashtbl.find graph ty.level in 976 976 + end else if level < lowest_level then begin 977 977 + let (_, parents) = Hashtbl.find graph level in 1003 978 parents := pty @ !parents 1004 979 end 1005 980 1006 981 and generalize_parents ty = 1007 1007 - let idx = ty.level in 982 982 + let idx = get_level ty in 1008 983 if idx <> generic_level then begin 1009 984 set_level ty generic_level; 1010 985 List.iter generalize_parents !(snd (Hashtbl.find graph idx)); 1011 986 (* Special case for rows: must generalize the row variable *) 1012 1012 - match ty.desc with 987 987 + match get_desc ty with 1013 988 Tvariant row -> 1014 989 let more = row_more row in 1015 1015 - let lv = more.level in 990 990 + let lv = get_level more in 1016 991 if (lv < lowest_level || lv > !current_level) 1017 992 && lv <> generic_level then set_level more generic_level 1018 993 | _ -> () ··· 1020 995 in 1021 996 1022 997 inverse [] ty; 1023 1023 - if ty0.level < lowest_level then 998 998 + if get_level ty0 < lowest_level then 1024 999 iter_type_expr (inverse []) ty0; 1025 1000 List.iter generalize_parents !roots; 1026 1001 Hashtbl.iter 1027 1002 (fun _ (ty, _) -> 1028 1028 - if ty.level <> generic_level then set_level ty !current_level) 1003 1003 + if get_level ty <> generic_level then set_level ty !current_level) 1029 1004 graph 1030 1005 1031 1006 ··· 1037 1012 mutable inv_parents : inv_type_expr list } 1038 1013 1039 1014 let rec inv_type hash pty ty = 1040 1040 - let ty = repr ty in 1041 1015 try 1042 1016 let inv = TypeHash.find hash ty in 1043 1017 inv.inv_parents <- pty @ inv.inv_parents ··· 1051 1025 inv_type inverted [] ty; 1052 1026 let node_univars = TypeHash.create 17 in 1053 1027 let rec add_univar univ inv = 1054 1054 - match inv.inv_type.desc with 1055 1055 - Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () 1028 1028 + match get_desc inv.inv_type with 1029 1029 + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id tl) -> () 1056 1030 | _ -> 1057 1031 try 1058 1032 let univs = TypeHash.find node_univars inv.inv_type in ··· 1072 1046 1073 1047 let fully_generic ty = 1074 1048 let rec aux ty = 1075 1075 - let ty = repr ty in 1076 1049 if not_marked_node ty then 1077 1077 - if ty.level = generic_level then 1050 1050 + if get_level ty = generic_level then 1078 1051 (flip_mark_node ty; iter_type_expr aux ty) 1079 1052 else raise Exit 1080 1053 in ··· 1116 1089 before we call type_pat *) 1117 1090 let rec copy ?partial ?keep_names scope ty = 1118 1091 let copy = copy ?partial ?keep_names scope in 1119 1119 - let ty = repr ty in 1120 1120 - match ty.desc with 1092 1092 + match get_desc ty with 1121 1093 Tsubst (ty, _) -> ty 1122 1122 - | _ -> 1123 1123 - if ty.level <> generic_level && partial = None then ty else 1094 1094 + | desc -> 1095 1095 + let level = get_level ty in 1096 1096 + if level <> generic_level && partial = None then ty else 1124 1097 (* We only forget types that are non generic and do not contain 1125 1098 free univars *) 1126 1099 let forget = 1127 1127 - if ty.level = generic_level then generic_level else 1100 1100 + if level = generic_level then generic_level else 1128 1101 match partial with 1129 1102 None -> assert false 1130 1103 | Some (free_univars, keep) -> 1131 1104 if TypeSet.is_empty (free_univars ty) then 1132 1132 - if keep then ty.level else !current_level 1105 1105 + if keep then level else !current_level 1133 1106 else generic_level 1134 1107 in 1135 1135 - if forget <> generic_level then newty2 forget (Tvar None) else 1136 1136 - let desc = ty.desc in 1137 1137 - For_copy.save_desc scope ty desc; 1138 1138 - let t = newvar() in (* Stub *) 1139 1139 - set_scope t ty.scope; 1140 1140 - Private_type_expr.set_desc ty (Tsubst (t, None)); 1141 1141 - Private_type_expr.set_desc t 1142 1142 - begin match desc with 1108 1108 + if forget <> generic_level then newty2 ~level:forget (Tvar None) else 1109 1109 + let t = newstub ~scope:(get_scope ty) in 1110 1110 + For_copy.redirect_desc scope ty (Tsubst (t, None)); 1111 1111 + let desc' = 1112 1112 + match desc with 1143 1113 | Tconstr (p, tl, _) -> 1144 1114 let abbrevs = proper_abbrevs p tl !abbreviations in 1145 1115 begin match find_repr p !abbrevs with 1146 1146 - Some ty when repr ty != t -> 1116 1116 + Some ty when not (eq_type ty t) -> 1147 1117 Tlink ty 1148 1118 | _ -> 1149 1119 (* ··· 1162 1132 end 1163 1133 | Tvariant row0 -> 1164 1134 let row = row_repr row0 in 1165 1165 - let more = repr row.row_more in 1135 1135 + let more = row.row_more in 1136 1136 + let mored = get_desc more in 1166 1137 (* We must substitute in a subtle way *) 1167 1138 (* Tsubst takes a tuple containing the row var and the variant *) 1168 1168 - begin match more.desc with 1139 1139 + begin match mored with 1169 1140 Tsubst (_, Some ty2) -> 1170 1141 (* This variant type has been already copied *) 1171 1171 - Private_type_expr.set_desc ty (Tsubst (ty2, None)); 1172 1172 - (* avoid Tlink in the new type *) 1142 1142 + (* Change the stub to avoid Tlink in the new type *) 1143 1143 + For_copy.redirect_desc scope ty (Tsubst (ty2, None)); 1173 1144 Tlink ty2 1174 1145 | _ -> 1175 1146 (* If the row variable is not generic, we must keep it *) 1176 1176 - let keep = more.level <> generic_level && partial = None in 1147 1147 + let keep = get_level more <> generic_level && partial = None in 1177 1148 let more' = 1178 1178 - match more.desc with 1149 1149 + match mored with 1179 1150 Tsubst (ty, None) -> ty 1180 1151 (* TODO: is this case possible? 1181 1152 possibly an interaction with (copy more) below? *) 1182 1153 | Tconstr _ | Tnil -> 1183 1183 - For_copy.save_desc scope more more.desc; 1184 1154 copy more 1185 1155 | Tvar _ | Tunivar _ -> 1186 1186 - For_copy.save_desc scope more more.desc; 1187 1187 - if keep then more else newty more.desc 1156 1156 + if keep then more else newty mored 1188 1157 | _ -> assert false 1189 1158 in 1190 1159 let row = 1191 1191 - match repr more' with (* PR#6163 *) 1192 1192 - {desc=Tconstr (x,_,_)} when not (is_fixed row) -> 1160 1160 + match get_desc more' with (* PR#6163 *) 1161 1161 + Tconstr (x,_,_) when not (is_fixed row) -> 1193 1162 {row with row_fixed = Some (Reified x)} 1194 1163 | _ -> row 1195 1164 in ··· 1198 1167 match partial with 1199 1168 Some (free_univars, false) -> 1200 1169 let more' = 1201 1201 - if more.id <> more'.id then 1170 1170 + if not (eq_type more more') then 1202 1171 more' (* we've already made a copy *) 1203 1172 else 1204 1173 newvar () ··· 1219 1188 | _ -> (more', row) 1220 1189 in 1221 1190 (* Register new type first for recursion *) 1222 1222 - Private_type_expr.set_desc 1223 1223 - more (Tsubst (more', Some t)); 1191 1191 + For_copy.redirect_desc scope more 1192 1192 + (Tsubst(more', Some t)); 1224 1193 (* Return a new copy *) 1225 1194 Tvariant (copy_row copy true row keep more') 1226 1195 end ··· 1235 1204 | Tobject (ty1, _) when partial <> None -> 1236 1205 Tobject (copy ty1, ref None) 1237 1206 | _ -> copy_type_desc ?keep_names copy desc 1238 1238 - end; 1207 1207 + in 1208 1208 + Transient_expr.set_stub_desc t desc'; 1239 1209 t 1240 1210 1241 1211 (**** Variants of instantiations ****) ··· 1296 1266 type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); 1297 1267 } 1298 1268 1299 1299 - let existential_name cstr ty = match repr ty with 1300 1300 - | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name 1269 1269 + let existential_name cstr ty = 1270 1270 + match get_desc ty with 1271 1271 + | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name 1301 1272 | _ -> "$" ^ cstr.cstr_name 1302 1273 1303 1274 let instance_constructor ?in_pattern cstr = ··· 1408 1379 | a :: l1 -> a :: diff_list l1 l2 1409 1380 1410 1381 let conflicts free bound = 1411 1411 - let bound = List.map repr bound in 1412 1412 - TypeSet.exists (fun t -> List.memq (repr t) bound) free 1382 1382 + let bound = List.map get_id bound in 1383 1383 + TypeSet.exists (fun t -> List.memq (get_id t) bound) free 1413 1384 1414 1385 let delayed_copy = ref [] 1415 1386 (* copying to do later *) 1416 1387 1417 1388 (* Copy without sharing until there are no free univars left *) 1418 1389 (* all free univars must be included in [visited] *) 1419 1419 - let rec copy_sep cleanup_scope fixed free bound visited ty = 1420 1420 - let ty = repr ty in 1390 1390 + let rec copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share 1391 1391 + (visited : (int * (type_expr * type_expr list)) list) (ty : type_expr) = 1421 1392 let univars = free ty in 1422 1422 - if TypeSet.is_empty univars then 1423 1423 - if ty.level <> generic_level then ty else 1424 1424 - let t = newvar () in 1393 1393 + if is_Tvar ty || may_share && TypeSet.is_empty univars then 1394 1394 + if get_level ty <> generic_level then ty else 1395 1395 + let t = newstub ~scope:(get_scope ty) in 1425 1396 delayed_copy := 1426 1426 - lazy (Private_type_expr.set_desc t (Tlink (copy cleanup_scope ty))) 1397 1397 + lazy (Transient_expr.set_stub_desc t (Tlink (copy cleanup_scope ty))) 1427 1398 :: !delayed_copy; 1428 1399 t 1429 1400 else try 1430 1430 - let t, bound_t = List.assq ty visited in 1401 1401 + let t, bound_t = List.assq (get_id ty) visited in 1431 1402 let dl = if is_Tunivar ty then [] else diff_list bound bound_t in 1432 1403 if dl <> [] && conflicts univars dl then raise Not_found; 1433 1404 t 1434 1405 with Not_found -> begin 1435 1435 - let t = newvar() in (* Stub *) 1406 1406 + let t = newstub ~scope:(get_scope ty) in 1407 1407 + let desc = get_desc ty in 1436 1408 let visited = 1437 1437 - match ty.desc with 1409 1409 + match desc with 1438 1410 Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> 1439 1439 - (ty,(t,bound)) :: visited 1411 1411 + (get_id ty, (t, bound)) :: visited 1440 1412 | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ -> 1441 1413 visited 1442 1414 | Tlink _ | Tsubst _ -> 1443 1415 assert false 1444 1416 in 1445 1445 - let copy_rec = copy_sep cleanup_scope fixed free bound visited in 1446 1446 - Private_type_expr.set_desc t 1447 1447 - begin match ty.desc with 1417 1417 + let copy_rec = copy_sep ~cleanup_scope ~fixed ~free ~bound visited in 1418 1418 + let desc' = 1419 1419 + match desc with 1448 1420 | Tvariant row0 -> 1449 1421 let row = row_repr row0 in 1450 1450 - let more = repr row.row_more in 1422 1422 + let more = row.row_more in 1451 1423 (* We shall really check the level on the row variable *) 1452 1452 - let keep = is_Tvar more && more.level <> generic_level in 1453 1453 - let more' = copy_rec more in 1424 1424 + let keep = is_Tvar more && get_level more <> generic_level in 1425 1425 + let more' = copy_rec ~may_share:false more in 1454 1426 let fixed' = fixed && (is_Tvar more || is_Tunivar more) in 1455 1455 - let row = copy_row copy_rec fixed' row keep more' in 1427 1427 + let row = 1428 1428 + copy_row (copy_rec ~may_share:true) fixed' row keep more' in 1456 1429 Tvariant row 1457 1430 | Tpoly (t1, tl) -> 1458 1458 - let tl = List.map repr tl in 1459 1459 - let tl' = List.map (fun t -> newty t.desc) tl in 1431 1431 + let tl' = List.map (fun t -> newty (get_desc t)) tl in 1460 1432 let bound = tl @ bound in 1461 1433 let visited = 1462 1462 - List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in 1463 1463 - Tpoly (copy_sep cleanup_scope fixed free bound visited t1, tl') 1464 1464 - | _ -> copy_type_desc copy_rec ty.desc 1465 1465 - end; 1434 1434 + List.map2 (fun ty t -> get_id ty, (t, bound)) tl tl' @ visited in 1435 1435 + let body = 1436 1436 + copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share:true 1437 1437 + visited t1 in 1438 1438 + Tpoly (body, tl') 1439 1439 + | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) 1440 1440 + Tfield (p, field_kind_repr k, copy_rec ~may_share:true ty1, 1441 1441 + copy_rec ~may_share:false ty2) 1442 1442 + | _ -> copy_type_desc (copy_rec ~may_share:true) desc 1443 1443 + in 1444 1444 + Transient_expr.set_stub_desc t desc'; 1466 1445 t 1467 1446 end 1468 1447 1469 1448 let instance_poly' cleanup_scope ~keep_names fixed univars sch = 1470 1449 (* In order to compute univars below, [sch] should not contain [Tsubst] *) 1471 1471 - let univars = List.map repr univars in 1472 1450 let copy_var ty = 1473 1473 - match ty.desc with 1451 1451 + match get_desc ty with 1474 1452 Tunivar name -> if keep_names then newty (Tvar name) else newvar () 1475 1453 | _ -> assert false 1476 1454 in 1477 1455 let vars = List.map copy_var univars in 1478 1478 - let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in 1456 1456 + let pairs = List.map2 (fun u v -> get_id u, (v, [])) univars vars in 1479 1457 delayed_copy := []; 1480 1480 - let ty = copy_sep cleanup_scope fixed (compute_univars sch) [] pairs sch in 1458 1458 + let ty = 1459 1459 + copy_sep ~cleanup_scope ~fixed ~free:(compute_univars sch) ~bound:[] 1460 1460 + ~may_share:true pairs sch in 1481 1461 List.iter Lazy.force !delayed_copy; 1482 1462 delayed_copy := []; 1483 1463 vars, ty ··· 1490 1470 let instance_label fixed lbl = 1491 1471 For_copy.with_scope (fun scope -> 1492 1472 let vars, ty_arg = 1493 1493 - match repr lbl.lbl_arg with 1494 1494 - {desc = Tpoly (ty, tl)} -> 1473 1473 + match get_desc lbl.lbl_arg with 1474 1474 + Tpoly (ty, tl) -> 1495 1475 instance_poly' scope ~keep_names:false fixed tl ty 1496 1476 | _ -> 1497 1477 [], copy scope lbl.lbl_arg ··· 1507 1487 let unify_var' = (* Forward declaration *) 1508 1488 ref (fun _env _ty1 _ty2 -> assert false) 1509 1489 1510 1510 - let subst env level priv abbrev ty params args body = 1490 1490 + let subst env level priv abbrev oty params args body = 1511 1491 if List.length params <> List.length args then raise Cannot_subst; 1512 1492 let old_level = !current_level in 1513 1493 current_level := level; 1514 1494 let body0 = newvar () in (* Stub *) 1515 1495 let undo_abbrev = 1516 1516 - match ty with 1496 1496 + match oty with 1517 1497 | None -> fun () -> () (* No abbreviation added *) 1518 1518 - | Some ({desc = Tconstr (path, tl, _)} as ty) -> 1519 1519 - let abbrev = proper_abbrevs path tl abbrev in 1520 1520 - memorize_abbrev abbrev priv path ty body0; 1521 1521 - fun () -> forget_abbrev abbrev path 1522 1522 - | _ -> 1523 1523 - assert false 1498 1498 + | Some ty -> 1499 1499 + match get_desc ty with 1500 1500 + Tconstr (path, tl, _) -> 1501 1501 + let abbrev = proper_abbrevs path tl abbrev in 1502 1502 + memorize_abbrev abbrev priv path ty body0; 1503 1503 + fun () -> forget_abbrev abbrev path 1504 1504 + | _ -> assert false 1524 1505 in 1525 1506 abbreviations := abbrev; 1526 1507 let (params', body') = instance_parameterized_type params body in ··· 1589 1570 *) 1590 1571 let expand_abbrev_gen kind find_type_expansion env ty = 1591 1572 check_abbrev_env env; 1592 1592 - match ty with 1593 1593 - {desc = Tconstr (path, args, abbrev); level = level; scope} -> 1573 1573 + match get_desc ty with 1574 1574 + Tconstr (path, args, abbrev) -> 1575 1575 + let level = get_level ty in 1576 1576 + let scope = get_scope ty in 1594 1577 let lookup_abbrev = proper_abbrevs path args abbrev in 1595 1578 begin match find_expans kind path !lookup_abbrev with 1596 1579 Some ty' -> ··· 1613 1596 typing error *) 1614 1597 () 1615 1598 end; 1616 1616 - let ty' = repr ty' in 1617 1617 - (* assert (ty != ty'); *) (* PR#7324 *) 1618 1599 ty' 1619 1600 | None -> 1620 1601 match find_type_expansion path env with ··· 1622 1603 (* another way to expand is to normalize the path itself *) 1623 1604 let path' = Env.normalize_type_path None env path in 1624 1605 if Path.same path path' then raise Cannot_expand 1625 1625 - else newty2 level (Tconstr (path', args, abbrev)) 1606 1606 + else newty2 ~level (Tconstr (path', args, abbrev)) 1626 1607 | (params, body, lv) -> 1627 1608 (* prerr_endline 1628 1609 ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) ··· 1634 1615 (* For gadts, remember type as non exportable *) 1635 1616 (* The ambiguous level registered for ty' should be the highest *) 1636 1617 (* if !trace_gadt_instances then begin *) 1637 1637 - let scope = Int.max lv ty.scope in 1618 1618 + let scope = Int.max lv (get_scope ty) in 1638 1619 update_scope scope ty; 1639 1620 update_scope scope ty'; 1640 1621 ty' ··· 1649 1630 (* Expand once the head of a type *) 1650 1631 let expand_head_once env ty = 1651 1632 try 1652 1652 - expand_abbrev env (repr ty) 1633 1633 + expand_abbrev env ty 1653 1634 with Cannot_expand | Escape _ -> assert false 1654 1635 1655 1636 (* Check whether a type can be expanded *) ··· 1668 1649 Raise Cannot_expand if the type cannot be expanded. 1669 1650 May raise Escape, if a recursion was hidden in the type. *) 1670 1651 let try_expand_once env ty = 1671 1671 - let ty = repr ty in 1672 1672 - match ty.desc with 1673 1673 - Tconstr _ -> repr (expand_abbrev env ty) 1652 1652 + match get_desc ty with 1653 1653 + Tconstr _ -> expand_abbrev env ty 1674 1654 | _ -> raise Cannot_expand 1675 1655 1676 1656 (* This one only raises Cannot_expand *) ··· 1681 1661 Btype.backtrack snap; cleanup_abbrev (); raise Cannot_expand 1682 1662 1683 1663 (* Fully expand the head of a type. *) 1684 1684 - let rec try_expand_head try_once env ty = 1664 1664 + let rec try_expand_head 1665 1665 + (try_once : Env.t -> type_expr -> type_expr) env ty = 1685 1666 let ty' = try_once env ty in 1686 1667 try try_expand_head try_once env ty' 1687 1668 with Cannot_expand -> ty' ··· 1691 1672 try 1692 1673 try_expand_head try_expand_once env ty 1693 1674 with 1694 1694 - | Cannot_expand -> repr ty 1675 1675 + | Cannot_expand -> ty 1695 1676 | Escape e -> raise_for Unify (Escape e) 1696 1677 1697 1678 (* Safe version of expand_head, never fails *) 1698 1679 let expand_head env ty = 1699 1699 - try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty 1680 1680 + try try_expand_head try_expand_safe env ty 1681 1681 + with Cannot_expand -> ty 1700 1682 1701 1683 let _ = forward_try_expand_safe := try_expand_safe 1702 1684 ··· 1712 1694 | May_have_typedecl 1713 1695 1714 1696 let rec extract_concrete_typedecl env ty = 1715 1715 - let ty = repr ty in 1716 1716 - match ty.desc with 1717 1717 - | Tconstr (p, _, _) -> 1697 1697 + match get_desc ty with 1698 1698 + Tconstr (p, _, _) -> 1718 1699 let decl = Env.find_type p env in 1719 1700 if decl.type_kind <> Type_abstract then Typedecl(p, p, decl) 1720 1701 else begin ··· 1750 1731 false 1751 1732 1752 1733 let try_expand_once_opt env ty = 1753 1753 - let ty = repr ty in 1754 1754 - match ty.desc with 1755 1755 - Tconstr _ -> repr (expand_abbrev_opt env ty) 1734 1734 + match get_desc ty with 1735 1735 + Tconstr _ -> expand_abbrev_opt env ty 1756 1736 | _ -> raise Cannot_expand 1757 1737 1758 1738 let try_expand_safe_opt env ty = ··· 1762 1742 Btype.backtrack snap; raise Cannot_expand 1763 1743 1764 1744 let expand_head_opt env ty = 1765 1765 - try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> repr ty 1745 1745 + try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> ty 1766 1746 1767 1747 (* Recursively expand the head of a type. 1768 1748 Also expand #-types. ··· 1772 1752 let full_expand ~may_forget_scope env ty = 1773 1753 let ty = 1774 1754 if may_forget_scope then 1775 1775 - let ty = repr ty in 1776 1755 try expand_head_unif env ty with Unify_trace _ -> 1777 1756 (* #10277: forget scopes when printing trace *) 1778 1757 begin_def (); 1779 1779 - init_def ty.level; 1758 1758 + init_def (get_level ty); 1780 1759 let ty = 1781 1760 (* The same as [expand_head], except in the failing case we return the 1782 1761 *original* type, not [correct_levels ty].*) 1783 1762 try try_expand_head try_expand_safe env (correct_levels ty) with 1784 1784 - | Cannot_expand -> repr ty 1763 1763 + | Cannot_expand -> ty 1785 1764 in 1786 1765 end_def (); 1787 1766 ty 1788 1767 else expand_head env ty 1789 1768 in 1790 1790 - let ty = repr ty in 1791 1791 - match ty.desc with 1792 1792 - Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> 1793 1793 - newty2 ty.level (Tobject (fi, ref None)) 1769 1769 + match get_desc ty with 1770 1770 + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> 1771 1771 + newty2 ~level:(get_level ty) (Tobject (fi, ref None)) 1794 1772 | _ -> 1795 1773 ty 1796 1774 ··· 1802 1780 let generic_abbrev env path = 1803 1781 try 1804 1782 let (_, body, _) = Env.find_type_expansion path env in 1805 1805 - (repr body).level = generic_level 1783 1783 + get_level body = generic_level 1806 1784 with 1807 1785 Not_found -> 1808 1786 false ··· 1813 1791 {type_kind = Type_abstract; 1814 1792 type_private = Private; 1815 1793 type_manifest = Some body} -> 1816 1816 - (repr body).level = generic_level 1794 1794 + get_level body = generic_level 1817 1795 | _ -> false 1818 1796 with Not_found -> false 1819 1797 ··· 1831 1809 1832 1810 exception Occur 1833 1811 1834 1834 - let rec occur_rec env allow_recursive visited ty0 = function 1835 1835 - | {desc=Tlink ty} -> 1836 1836 - occur_rec env allow_recursive visited ty0 ty 1837 1837 - | ty -> 1838 1838 - if ty == ty0 then raise Occur; 1839 1839 - match ty.desc with 1812 1812 + let rec occur_rec env allow_recursive visited ty0 ty = 1813 1813 + if eq_type ty ty0 then raise Occur; 1814 1814 + match get_desc ty with 1840 1815 Tconstr(p, _tl, _abbrev) -> 1841 1816 if allow_recursive && is_contractive env p then () else 1842 1817 begin try ··· 1893 1868 1894 1869 let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = 1895 1870 (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) 1896 1896 - let ty = repr ty in 1897 1897 - if not (List.memq ty visited) then begin 1898 1898 - match ty.desc with 1871 1871 + if not (List.memq (get_id ty) visited) then begin 1872 1872 + match get_desc ty with 1899 1873 Tconstr(p', args, _abbrev) -> 1900 1874 if Path.same p p' then raise Occur; 1901 1875 if allow_rec && not strict && is_contractive env p' then () else 1902 1902 - let visited = ty :: visited in 1876 1876 + let visited = get_id ty :: visited in 1903 1877 begin try 1904 1878 (* try expanding, since [p] could be hidden *) 1905 1879 local_non_recursive_abbrev ~allow_rec strict visited env p ··· 1911 1885 in 1912 1886 List.iter2 1913 1887 (fun tv ty -> 1914 1914 - let strict = strict || not (is_Tvar (repr tv)) in 1888 1888 + let strict = strict || not (is_Tvar tv) in 1915 1889 local_non_recursive_abbrev ~allow_rec strict visited env p ty) 1916 1890 params args 1917 1891 end ··· 1919 1893 () 1920 1894 | _ -> 1921 1895 if strict || not allow_rec then (* PR#7374 *) 1922 1922 - let visited = ty :: visited in 1896 1896 + let visited = get_id ty :: visited in 1923 1897 iter_type_expr 1924 1898 (local_non_recursive_abbrev ~allow_rec true visited env p) ty 1925 1899 end ··· 1945 1919 (cl1, cl2) :: rem -> 1946 1920 let find_univ t cl = 1947 1921 try 1948 1948 - let (_, r) = List.find (fun (t',_) -> t == repr t') cl in 1922 1922 + let (_, r) = List.find (fun (t',_) -> eq_type t t') cl in 1949 1923 Some r 1950 1924 with Not_found -> None 1951 1925 in 1952 1926 begin match find_univ t1 cl1, find_univ t2 cl2 with 1953 1953 - Some {contents=Some t'2}, Some _ when t2 == repr t'2 -> 1927 1927 + Some {contents=Some t'2}, Some _ when eq_type t2 t'2 -> 1954 1928 () 1955 1929 | Some({contents=None} as r1), Some({contents=None} as r2) -> 1956 1930 set_univar r1 t2; set_univar r2 t1 ··· 1973 1947 let occur_univar ?(inj_only=false) env ty = 1974 1948 let visited = ref TypeMap.empty in 1975 1949 let rec occur_rec bound ty = 1976 1976 - let ty = repr ty in 1977 1950 if not_marked_node ty then 1978 1951 if TypeSet.is_empty bound then 1979 1952 (flip_mark_node ty; occur_desc bound ty) ··· 1987 1960 visited := TypeMap.add ty bound !visited; 1988 1961 occur_desc bound ty 1989 1962 and occur_desc bound ty = 1990 1990 - match ty.desc with 1963 1963 + match get_desc ty with 1991 1964 Tunivar _ -> 1992 1965 if not (TypeSet.mem ty bound) then 1993 1966 raise_escape_exn (Univ ty) 1994 1967 | Tpoly (ty, tyl) -> 1995 1995 - let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in 1968 1968 + let bound = List.fold_right TypeSet.add tyl bound in 1996 1969 occur_rec bound ty 1997 1970 | Tconstr (_, [], _) -> () 1998 1971 | Tconstr (p, tl, _) -> ··· 2032 2005 2033 2006 (* Grouping univars by families according to their binders *) 2034 2007 let add_univars = 2035 2035 - List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s) 2008 2008 + List.fold_left (fun s (t,_) -> TypeSet.add t s) 2036 2009 2037 2010 let get_univar_family univar_pairs univars = 2038 2011 if univars = [] then TypeSet.empty else 2039 2012 let insert s = function 2040 2013 cl1, (_::_ as cl2) -> 2041 2041 - if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then 2014 2014 + if List.exists (fun (t1,_) -> TypeSet.mem t1 s) cl1 then 2042 2015 add_univars s cl2 2043 2016 else s 2044 2017 | _ -> s ··· 2051 2024 let family = get_univar_family univar_pairs vl in 2052 2025 let visited = ref TypeSet.empty in 2053 2026 let rec occur t = 2054 2054 - let t = repr t in 2055 2027 if TypeSet.mem t !visited then () else begin 2056 2028 visited := TypeSet.add t !visited; 2057 2057 - match t.desc with 2029 2029 + match get_desc t with 2058 2030 Tpoly (t, tl) -> 2059 2059 - if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () 2031 2031 + if List.exists (fun t -> TypeSet.mem t family) tl then () 2060 2032 else occur t 2061 2033 | Tunivar _ -> if TypeSet.mem t family then raise_escape_exn (Univ t) 2062 2034 | Tconstr (_, [], _) -> () ··· 2083 2055 List.fold_left (fun s (cl,_) -> add_univars s cl) 2084 2056 TypeSet.empty old_univars 2085 2057 in 2086 2086 - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in 2087 2058 if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then 2088 2059 univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))); 2089 2060 if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then ··· 2105 2076 2106 2077 let polyfy env ty vars = 2107 2078 let subst_univar scope ty = 2108 2108 - let ty = repr ty in 2109 2109 - match ty.desc with 2110 2110 - | Tvar name when ty.level = generic_level -> 2111 2111 - For_copy.save_desc scope ty ty.desc; 2079 2079 + match get_desc ty with 2080 2080 + | Tvar name when get_level ty = generic_level -> 2112 2081 let t = newty (Tunivar name) in 2113 2113 - Private_type_expr.set_desc ty (Tsubst (t, None)); 2082 2082 + For_copy.redirect_desc scope ty (Tsubst (t, None)); 2114 2083 Some t 2115 2084 | _ -> None 2116 2085 in ··· 2120 2089 For_copy.with_scope (fun scope -> 2121 2090 let vars' = List.filter_map (subst_univar scope) vars in 2122 2091 let ty = copy scope ty in 2123 2123 - let ty = newty2 ty.level (Tpoly(repr ty, vars')) in 2092 2092 + let ty = newty2 ~level:(get_level ty) (Tpoly(ty, vars')) in 2124 2093 let complete = List.length vars = List.length vars' in 2125 2094 ty, complete 2126 2095 ) ··· 2139 2108 2140 2109 let rec has_cached_expansion p abbrev = 2141 2110 match abbrev with 2142 2142 - Mnil -> false 2143 2143 - | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem 2144 2144 - | Mlink rem -> has_cached_expansion p !rem 2111 2111 + Mnil -> false 2112 2112 + | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem 2113 2113 + | Mlink rem -> has_cached_expansion p !rem 2145 2114 2146 2115 (**** Transform error trace ****) 2147 2116 (* +++ Move it to some other place ? *) ··· 2149 2118 but still might be nice. *) 2150 2119 2151 2120 let expand_type env ty = 2152 2152 - { ty = repr ty; 2121 2121 + { ty = ty; 2153 2122 expanded = full_expand ~may_forget_scope:true env ty } 2154 2123 2155 2124 let expand_any_trace map env trace = ··· 2190 2159 (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) 2191 2160 let deep_occur t0 ty = 2192 2161 let rec occur_rec ty = 2193 2193 - let ty = repr ty in 2194 2194 - if ty.level >= t0.level && try_mark_node ty then begin 2195 2195 - if ty == t0 then raise Occur; 2162 2162 + if get_level ty >= get_level t0 && try_mark_node ty then begin 2163 2163 + if eq_type ty t0 then raise Occur; 2196 2164 iter_type_expr occur_rec ty 2197 2165 end 2198 2166 in ··· 2221 2189 Env.enter_type (get_new_abstract_name name) decl !env 2222 2190 ~scope:fresh_constr_scope in 2223 2191 let path = Path.Pident id in 2224 2224 - let t = newty2 lev (Tconstr (path,[],ref Mnil)) in 2192 2192 + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in 2225 2193 env := new_env; 2226 2194 path, t 2227 2195 in 2228 2196 let visited = ref TypeSet.empty in 2229 2197 let rec iterator ty = 2230 2230 - let ty = repr ty in 2231 2198 if TypeSet.mem ty !visited then () else begin 2232 2199 visited := TypeSet.add ty !visited; 2233 2233 - match ty.desc with 2200 2200 + match get_desc ty with 2234 2201 Tvar o -> 2235 2235 - let path, t = create_fresh_constr ty.level o in 2202 2202 + let level = get_level ty in 2203 2203 + let path, t = create_fresh_constr level o in 2236 2204 link_type ty t; 2237 2237 - if ty.level < fresh_constr_scope then 2205 2205 + if level < fresh_constr_scope then 2238 2206 raise_for Unify (Escape (escape (Constructor path))) 2239 2207 | Tvariant r -> 2240 2208 let r = row_repr r in 2241 2209 if not (static_row r) then begin 2242 2210 if is_fixed r then iterator (row_more r) else 2243 2211 let m = r.row_more in 2244 2244 - match m.desc with 2212 2212 + match get_desc m with 2245 2213 Tvar o -> 2246 2246 - let path, t = create_fresh_constr m.level o in 2214 2214 + let level = get_level m in 2215 2215 + let path, t = create_fresh_constr level o in 2247 2216 let row = 2248 2217 let row_fixed = Some (Reified path) in 2249 2218 {r with row_fields=[]; row_fixed; row_more = t} in 2250 2250 - link_type m (newty2 m.level (Tvariant row)); 2251 2251 - if m.level < fresh_constr_scope then 2219 2219 + link_type m (newty2 ~level (Tvariant row)); 2220 2220 + if level < fresh_constr_scope then 2252 2221 raise_for Unify (Escape (escape (Constructor path))) 2253 2222 | _ -> assert false 2254 2223 end; ··· 2293 2262 2294 2263 (* Check for datatypes carefully; see PR#6348 *) 2295 2264 let rec expands_to_datatype env ty = 2296 2296 - let ty = repr ty in 2297 2297 - match ty.desc with 2265 2265 + match get_desc ty with 2298 2266 Tconstr (p, _, _) -> 2299 2267 begin try 2300 2268 is_datatype (Env.find_type p env) || ··· 2317 2285 *) 2318 2286 2319 2287 let rec mcomp type_pairs env t1 t2 = 2320 2320 - if t1 == t2 then () else 2321 2321 - let t1 = repr t1 in 2322 2322 - let t2 = repr t2 in 2323 2323 - if t1 == t2 then () else 2324 2324 - match (t1.desc, t2.desc) with 2288 2288 + if eq_type t1 t2 then () else 2289 2289 + match (get_desc t1, get_desc t2) with 2325 2290 | (Tvar _, _) 2326 2291 | (_, Tvar _) -> 2327 2292 () ··· 2331 2296 let t1' = expand_head_opt env t1 in 2332 2297 let t2' = expand_head_opt env t2 in 2333 2298 (* Expansion may have changed the representative of the types... *) 2334 2334 - let t1' = repr t1' and t2' = repr t2' in 2335 2335 - if t1' == t2' then () else 2299 2299 + if eq_type t1' t2' then () else 2336 2300 begin try TypePairs.find type_pairs (t1', t2') 2337 2301 with Not_found -> 2338 2302 TypePairs.add type_pairs (t1', t2') (); 2339 2339 - match (t1'.desc, t2'.desc) with 2303 2303 + match (get_desc t1', get_desc t2') with 2340 2304 | (Tvar _, _) 2341 2305 | (_, Tvar _) -> 2342 2306 () ··· 2399 2363 let has_present = 2400 2364 List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in 2401 2365 mcomp type_pairs env rest1 rest2; 2402 2402 - if has_present miss1 && (object_row ty2).desc = Tnil 2403 2403 - || has_present miss2 && (object_row ty1).desc = Tnil then raise Incompatible; 2366 2366 + if has_present miss1 && get_desc (object_row ty2) = Tnil 2367 2367 + || has_present miss2 && get_desc (object_row ty1) = Tnil 2368 2368 + then raise Incompatible; 2404 2369 List.iter 2405 2370 (function (_n, k1, t1, k2, t2) -> 2406 2371 mcomp_kind k1 k2; ··· 2524 2489 let find_lowest_level ty = 2525 2490 let lowest = ref generic_level in 2526 2491 let rec find ty = 2527 2527 - let ty = repr ty in 2528 2492 if not_marked_node ty then begin 2529 2529 - if ty.level < !lowest then lowest := ty.level; 2493 2493 + let level = get_level ty in 2494 2494 + if level < !lowest then lowest := level; 2530 2495 flip_mark_node ty; 2531 2496 iter_type_expr find ty 2532 2497 end ··· 2554 2519 let unify_eq_set = TypePairs.create 11 2555 2520 2556 2521 let order_type_pair t1 t2 = 2557 2557 - if t1.id <= t2.id then (t1, t2) else (t2, t1) 2522 2522 + if get_id t1 <= get_id t2 then (t1, t2) else (t2, t1) 2558 2523 2559 2524 let add_type_equality t1 t2 = 2560 2525 TypePairs.add unify_eq_set (order_type_pair t1 t2) () ··· 2643 2608 let rigid_variants = ref false 2644 2609 2645 2610 let unify_eq t1 t2 = 2646 2646 - t1 == t2 || 2611 2611 + eq_type t1 t2 || 2647 2612 match !umode with 2648 2613 | Expression -> false 2649 2614 | Pattern -> ··· 2657 2622 | () -> 2658 2623 begin 2659 2624 try 2660 2660 - update_level env t1.level t2; 2661 2661 - update_scope t1.scope t2 2625 2625 + update_level env (get_level t1) t2; 2626 2626 + update_scope (get_scope t1) t2; 2662 2627 with Escape e -> 2663 2628 raise_for Unify (Escape e) 2664 2629 end; ··· 2671 2636 let record_equation t1 t2 = 2672 2637 match !equations_generation with 2673 2638 | Forbidden -> assert false 2674 2674 - | Allowed { equated_types } -> TypePairs.add equated_types (t1, t2) () 2639 2639 + | Allowed { equated_types } -> 2640 2640 + TypePairs.add equated_types (t1, t2) () 2675 2641 2676 2642 (* Called from unify3 *) 2677 2643 let unify3_var env t1' t2 t2' = ··· 2712 2678 2713 2679 let rec unify (env:Env.t ref) t1 t2 = 2714 2680 (* First step: special cases (optimizations) *) 2715 2715 - if t1 == t2 then () else 2716 2716 - let t1 = repr t1 in 2717 2717 - let t2 = repr t2 in 2718 2681 if unify_eq t1 t2 then () else 2719 2682 let reset_tracing = check_trace_gadt_instances !env in 2720 2683 2721 2684 try 2722 2685 type_changed := true; 2723 2723 - begin match (t1.desc, t2.desc) with 2686 2686 + begin match (get_desc t1, get_desc t2) with 2724 2687 (Tvar _, Tconstr _) when deep_occur t1 t2 -> 2725 2688 unify2 env t1 t2 2726 2689 | (Tconstr _, Tvar _) when deep_occur t2 t1 -> ··· 2731 2694 if unify1_var !env t2 t1 then () else unify2 env t1 t2 2732 2695 | (Tunivar _, Tunivar _) -> 2733 2696 unify_univar_for Unify t1 t2 !univar_pairs; 2734 2734 - update_level_for Unify !env t1.level t2; 2735 2735 - update_scope_for Unify t1.scope t2; 2697 2697 + update_level_for Unify !env (get_level t1) t2; 2698 2698 + update_scope_for Unify (get_scope t1) t2; 2736 2699 link_type t1 t2 2737 2700 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) 2738 2701 when Path.same p1 p2 (* && actual_mode !env = Old *) ··· 2741 2704 when any of the types has a cached expansion. *) 2742 2705 && not (has_cached_expansion p1 !a1 2743 2706 || has_cached_expansion p2 !a2) -> 2744 2744 - update_level_for Unify !env t1.level t2; 2745 2745 - update_scope_for Unify t1.scope t2; 2707 2707 + update_level_for Unify !env (get_level t1) t2; 2708 2708 + update_scope_for Unify (get_scope t1) t2; 2746 2709 link_type t1 t2 2747 2710 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) 2748 2711 when Env.has_local_constraints !env ··· 2771 2734 ignore (expand_head_unif !env t2); 2772 2735 let t1' = expand_head_unif !env t1 in 2773 2736 let t2' = expand_head_unif !env t2 in 2774 2774 - let lv = Int.min t1'.level t2'.level in 2775 2775 - let scope = Int.max t1'.scope t2'.scope in 2737 2737 + let lv = Int.min (get_level t1') (get_level t2') in 2738 2738 + let scope = Int.max (get_scope t1') (get_scope t2') in 2776 2739 update_level_for Unify !env lv t2; 2777 2740 update_level_for Unify !env lv t1; 2778 2741 update_scope_for Unify scope t2; 2779 2742 update_scope_for Unify scope t1; 2780 2743 if unify_eq t1' t2' then () else 2781 2744 2782 2782 - let t1 = repr t1 and t2 = repr t2 in 2783 2745 let t1, t2 = 2784 2746 if !Clflags.principal 2785 2747 && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then 2786 2748 (* Expand abbreviations hiding a lower level *) 2787 2749 (* Should also do it for parameterized types, after unification... *) 2788 2788 - (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1), 2789 2789 - (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2) 2750 2750 + (match get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), 2751 2751 + (match get_desc t2 with Tconstr (_, [], _) -> t2' | _ -> t2) 2790 2752 else (t1, t2) 2791 2753 in 2792 2754 if unify_eq t1 t1' || not (unify_eq t2 t2') then ··· 2798 2760 and unify3 env t1 t1' t2 t2' = 2799 2761 (* Third step: truly unification *) 2800 2762 (* Assumes either [t1 == t1'] or [t2 != t2'] *) 2801 2801 - let d1 = t1'.desc and d2 = t2'.desc in 2802 2802 - let create_recursion = (t2 != t2') && (deep_occur t1' t2) in 2763 2763 + let tt1' = Transient_expr.repr t1' in 2764 2764 + let d1 = tt1'.desc and d2 = get_desc t2' in 2765 2765 + let create_recursion = 2766 2766 + (not (eq_type t2 t2')) && (deep_occur t1' t2) in 2803 2767 2804 2768 begin match (d1, d2) with (* handle vars and univars specially *) 2805 2769 (Tunivar _, Tunivar _) -> ··· 2896 2860 unify_fields env fi1 fi2; 2897 2861 (* Type [t2'] may have been instantiated by [unify_fields] *) 2898 2862 (* XXX One should do some kind of unification... *) 2899 2899 - begin match (repr t2').desc with 2863 2863 + begin match get_desc t2' with 2900 2864 Tobject (_, {contents = Some (_, va::_)}) when 2901 2901 - (match (repr va).desc with 2865 2865 + (match get_desc va with 2902 2866 Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () 2903 2867 | Tobject (_, nm2) -> set_name nm2 !nm1 2904 2868 | _ -> () ··· 2923 2887 Fvar r when f <> dummy_method -> 2924 2888 set_kind r Fabsent; 2925 2889 if d2 = Tnil then unify env rem t2' 2926 2926 - else unify env (newty2 rem.level Tnil) rem 2890 2890 + else unify env (newgenty Tnil) rem 2927 2891 | _ -> 2928 2892 if f = dummy_method then 2929 2893 raise_for Unify (Obj Self_cannot_be_closed) ··· 2941 2905 | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> 2942 2906 begin try 2943 2907 unify_package !env (unify_list env) 2944 2944 - t1.level p1 fl1 t2.level p2 fl2 2908 2908 + (get_level t1) p1 fl1 (get_level t2) p2 fl2 2945 2909 with Not_found -> 2946 2910 if !umode = Expression then raise_unexplained_for Unify; 2947 2911 List.iter (fun (_n, ty) -> reify env ty) (fl1 @ fl2); ··· 2956 2920 (* XXX Commentaires + changer "create_recursion" 2957 2921 ||| Comments + change "create_recursion" *) 2958 2922 if create_recursion then 2959 2959 - match t2.desc with 2923 2923 + match get_desc t2 with 2960 2924 Tconstr (p, tl, abbrev) -> 2961 2925 forget_abbrev abbrev p; 2962 2926 let t2'' = expand_head_unif !env t2 in 2963 2927 if not (closed_parameterized_type tl t2'') then 2964 2964 - link_type (repr t2) (repr t2') 2928 2928 + link_type t2 t2' 2965 2929 | _ -> 2966 2930 () (* t2 has already been expanded by update_level *) 2967 2931 with Unify_trace trace -> 2968 2968 - Private_type_expr.set_desc t1' d1; 2932 2932 + Transient_expr.set_desc tt1' d1; 2969 2933 raise_trace_for Unify trace 2970 2934 end 2971 2935 ··· 2977 2941 (* Build a fresh row variable for unification *) 2978 2942 and make_rowvar level use1 rest1 use2 rest2 = 2979 2943 let set_name ty name = 2980 2980 - match ty.desc with 2944 2944 + match get_desc ty with 2981 2945 Tvar None -> set_type_desc ty (Tvar name) 2982 2946 | _ -> () 2983 2947 in 2984 2948 let name = 2985 2985 - match rest1.desc, rest2.desc with 2949 2949 + match get_desc rest1, get_desc rest2 with 2986 2950 Tvar (Some _ as name1), Tvar (Some _ as name2) -> 2987 2987 - if rest1.level <= rest2.level then name1 else name2 2951 2951 + if get_level rest1 <= get_level rest2 then name1 else name2 2988 2952 | Tvar (Some _ as name), _ -> 2989 2953 if use2 then set_name rest2 name; name 2990 2954 | _, Tvar (Some _ as name) -> ··· 2992 2956 | _ -> None 2993 2957 in 2994 2958 if use1 then rest1 else 2995 2995 - if use2 then rest2 else newvar2 ?name level 2959 2959 + if use2 then rest2 else newty2 ~level (Tvar name) 2996 2960 2997 2961 and unify_fields env ty1 ty2 = (* Optimization *) 2998 2962 let (fields1, rest1) = flatten_fields ty1 2999 2963 and (fields2, rest2) = flatten_fields ty2 in 3000 2964 let (pairs, miss1, miss2) = associate_fields fields1 fields2 in 3001 3001 - let l1 = (repr ty1).level and l2 = (repr ty2).level in 2965 2965 + let l1 = get_level ty1 and l2 = get_level ty2 in 3002 2966 let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in 3003 3003 - let d1 = rest1.desc and d2 = rest2.desc in 2967 2967 + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in 2968 2968 + let d1 = tr1.desc and d2 = tr2.desc in 3004 2969 try 3005 2970 unify env (build_fields l1 miss1 va) rest2; 3006 2971 unify env rest1 (build_fields l2 miss2 va); ··· 3009 2974 unify_kind k1 k2; 3010 2975 try 3011 2976 if !trace_gadt_instances then begin 3012 3012 - update_level_for Unify !env va.level t1; 3013 3013 - update_scope_for Unify va.scope t1 2977 2977 + update_level_for Unify !env (get_level va) t1; 2978 2978 + update_scope_for Unify (get_scope va) t1 3014 2979 end; 3015 2980 unify env t1 t2 3016 2981 with Unify_trace trace -> ··· 3019 2984 ) 3020 2985 pairs 3021 2986 with exn -> 3022 3022 - set_type_desc rest1 d1; 3023 3023 - set_type_desc rest2 d2; 2987 2987 + Transient_expr.set_desc tr1 d1; 2988 2988 + Transient_expr.set_desc tr2 d2; 3024 2989 raise exn 3025 2990 3026 2991 and unify_kind k1 k2 = ··· 3049 3014 end; 3050 3015 let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in 3051 3016 let more = match fixed1, fixed2 with 3052 3052 - | Some _, Some _ -> if rm2.level < rm1.level then rm2 else rm1 3017 3017 + | Some _, Some _ -> if get_level rm2 < get_level rm1 then rm2 else rm1 3053 3018 | Some _, None -> rm1 3054 3019 | None, Some _ -> rm2 3055 3055 - | None, None -> newty2 (Int.min rm1.level rm2.level) (Tvar None) 3020 3020 + | None, None -> 3021 3021 + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) 3056 3022 in 3057 3023 let fixed = merge_fixed_explanation fixed1 fixed2 3058 3024 and closed = row1.row_closed || row2.row_closed in ··· 3105 3071 let rm = row_more row in 3106 3072 (*if !trace_gadt_instances && rm.desc = Tnil then () else*) 3107 3073 if !trace_gadt_instances then 3108 3108 - update_level_for Unify !env rm.level (newgenty (Tvariant row)); 3074 3074 + update_level_for Unify !env (get_level rm) (newgenty (Tvariant row)); 3109 3075 if row_fixed row then 3110 3110 - if more == rm then () else 3076 3076 + if eq_type more rm then () else 3111 3077 if is_Tvar rm then link_type rm more else unify env rm more 3112 3078 else 3113 3079 let ty = newgenty (Tvariant {row0 with row_fields = rest}) in 3114 3114 - update_level_for Unify !env rm.level ty; 3115 3115 - update_scope_for Unify rm.scope ty; 3080 3080 + update_level_for Unify !env (get_level rm) ty; 3081 3081 + update_scope_for Unify (get_scope rm) ty; 3116 3082 link_type rm ty 3117 3083 in 3118 3118 - let md1 = rm1.desc and md2 = rm2.desc in 3084 3084 + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in 3085 3085 + let md1 = tm1.desc and md2 = tm2.desc in 3119 3086 begin try 3120 3087 set_more row2 r1; 3121 3088 set_more row1 r2; ··· 3128 3095 pairs; 3129 3096 if static_row row1 then begin 3130 3097 let rm = row_more row1 in 3131 3131 - if is_Tvar rm then link_type rm (newty2 rm.level Tnil) 3098 3098 + if is_Tvar rm then link_type rm (newty2 ~level:(get_level rm) Tnil) 3132 3099 end 3133 3100 with exn -> 3134 3134 - set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn 3101 3101 + Transient_expr.set_desc tm1 md1; 3102 3102 + Transient_expr.set_desc tm2 md2; 3103 3103 + raise exn 3135 3104 end 3136 3105 3137 3106 and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = ··· 3169 3138 !e1 <> None || !e2 <> None 3170 3139 end in 3171 3140 if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else 3172 3172 - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in 3173 3173 - let rec remq tl = function [] -> [] 3174 3174 - | ty :: tl' -> 3175 3175 - if List.memq ty tl then remq tl tl' else ty :: remq tl tl' 3176 3176 - in 3141 3141 + let remq tl = 3142 3142 + List.filter (fun ty -> not (List.exists (eq_type ty) tl)) in 3177 3143 let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in 3178 3144 (* PR#6744 *) 3179 3145 let (tlu1,tl1') = List.partition (has_free_univars !env) tl1' ··· 3187 3153 occur_univar_for Unify !env tu 3188 3154 end; 3189 3155 (* Is this handling of levels really principal? *) 3190 3190 - List.iter (fun ty -> 3191 3191 - let rm = repr rm2 in 3192 3192 - update_level_for Unify !env rm.level ty; 3193 3193 - update_scope_for Unify rm.scope ty; 3194 3194 - ) tl1'; 3195 3195 - List.iter (fun ty -> 3196 3196 - let rm = repr rm1 in 3197 3197 - update_level_for Unify !env rm.level ty; 3198 3198 - update_scope_for Unify rm.scope ty; 3199 3199 - ) tl2'; 3156 3156 + let update_levels rm = 3157 3157 + List.iter 3158 3158 + (fun ty -> 3159 3159 + update_level_for Unify !env (get_level rm) ty; 3160 3160 + update_scope_for Unify (get_scope rm) ty) 3161 3161 + in 3162 3162 + update_levels rm2 tl1'; 3163 3163 + update_levels rm1 tl2'; 3200 3164 let e = ref None in 3201 3165 let f1' = Reither(c1 || c2, tl2', m1 || m2, e) 3202 3166 and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in ··· 3209 3173 | Reither(false, tl, _, e1), Rpresent(Some t2) -> 3210 3174 if_not_fixed first (fun () -> 3211 3175 set_row_field e1 f2; 3212 3212 - let rm = repr rm1 in 3213 3213 - update_level_for Unify !env rm.level t2; 3214 3214 - update_scope_for Unify rm.scope t2; 3176 3176 + update_level_for Unify !env (get_level rm1) t2; 3177 3177 + update_scope_for Unify (get_scope rm1) t2; 3215 3178 (try List.iter (fun t1 -> unify env t1 t2) tl 3216 3179 with exn -> e1 := None; raise exn) 3217 3180 ) 3218 3181 | Rpresent(Some t1), Reither(false, tl, _, e2) -> 3219 3182 if_not_fixed second (fun () -> 3220 3183 set_row_field e2 f1; 3221 3221 - let rm = repr rm2 in 3222 3222 - update_level_for Unify !env rm.level t1; 3223 3223 - update_scope_for Unify rm.scope t1; 3184 3184 + update_level_for Unify !env (get_level rm2) t1; 3185 3185 + update_scope_for Unify (get_scope rm2) t1; 3224 3186 (try List.iter (unify env t1) tl 3225 3187 with exn -> e2 := None; raise exn) 3226 3188 ) ··· 3258 3220 raise e 3259 3221 3260 3222 let unify_var env t1 t2 = 3261 3261 - let t1 = repr t1 and t2 = repr t2 in 3262 3262 - if t1 == t2 then () else 3263 3263 - match t1.desc, t2.desc with 3223 3223 + if eq_type t1 t2 then () else 3224 3224 + match get_desc t1, get_desc t2 with 3264 3225 Tvar _, Tconstr _ when deep_occur t1 t2 -> 3265 3226 unify (ref env) t1 t2 3266 3227 | Tvar _, _ -> 3267 3228 let reset_tracing = check_trace_gadt_instances env in 3268 3229 begin try 3269 3230 occur_for Unify env t1 t2; 3270 3270 - update_level_for Unify env t1.level t2; 3271 3271 - update_scope_for Unify t1.scope t2; 3231 3231 + update_level_for Unify env (get_level t1) t2; 3232 3232 + update_scope_for Unify (get_scope t1) t2; 3272 3233 link_type t1 t2; 3273 3234 reset_trace_gadt_instances reset_tracing; 3274 3235 with Unify_trace trace -> ··· 3320 3281 let filter_arrow env t l = 3321 3282 let function_type level = 3322 3283 let t1 = newvar2 level and t2 = newvar2 level in 3323 3323 - let t' = newty2 level (Tarrow (l, t1, t2, Cok)) in 3284 3284 + let t' = newty2 ~level (Tarrow (l, t1, t2, Cok)) in 3324 3285 t', t1, t2 3325 3286 in 3326 3287 let t = 3327 3288 try expand_head_trace env t 3328 3289 with Unify_trace trace -> 3329 3329 - let t', _, _ = function_type t.level in 3290 3290 + let t', _, _ = function_type (get_level t) in 3330 3291 raise (Filter_arrow_failed 3331 3292 (Unification_error 3332 3293 (expand_to_unification_error 3333 3294 env 3334 3295 (Diff { got = t'; expected = t } :: trace)))) 3335 3296 in 3336 3336 - match t.desc with 3297 3297 + match get_desc t with 3337 3298 | Tvar _ -> 3338 3338 - let t', t1, t2 = function_type t.level in 3299 3299 + let t', t1, t2 = function_type (get_level t) in 3339 3300 link_type t t'; 3340 3301 (t1, t2) 3341 3302 | Tarrow(l', t1, t2, _) -> ··· 3358 3319 let rec filter_method_field env name priv ty = 3359 3320 let method_type level = 3360 3321 let ty1 = newvar2 level and ty2 = newvar2 level in 3361 3361 - let ty' = newty2 level (Tfield (name, 3322 3322 + let ty' = newty2 ~level (Tfield (name, 3362 3323 begin match priv with 3363 3324 Private -> Fvar (ref None) 3364 3325 | Public -> Fpresent ··· 3370 3331 let ty = 3371 3332 try expand_head_trace env ty 3372 3333 with Unify_trace trace -> 3373 3373 - let ty', _ = method_type ty.level in 3334 3334 + let ty', _ = method_type (get_level ty) in 3374 3335 raise (Filter_method_failed 3375 3336 (Unification_error 3376 3337 (expand_to_unification_error 3377 3338 env 3378 3339 (Diff { got = ty; expected = ty' } :: trace)))) 3379 3340 in 3380 3380 - match ty.desc with 3341 3341 + match get_desc ty with 3381 3342 | Tvar _ -> 3382 3382 - let ty', ty1 = method_type ty.level in 3343 3343 + let ty', ty1 = method_type (get_level ty) in 3383 3344 link_type ty ty'; 3384 3345 ty1 3385 3346 | Tfield(n, kind, ty1, ty2) -> ··· 3406 3367 let ty = 3407 3368 try expand_head_trace env ty 3408 3369 with Unify_trace trace -> 3409 3409 - let ty', _ = object_type ~level:ty.level ~scope:ty.scope in 3370 3370 + let ty', _ = object_type ~level:(get_level ty) ~scope:(get_scope ty) in 3410 3371 raise (Filter_method_failed 3411 3372 (Unification_error 3412 3373 (expand_to_unification_error 3413 3374 env 3414 3375 (Diff { got = ty; expected = ty' } :: trace)))) 3415 3376 in 3416 3416 - match ty.desc with 3377 3377 + match get_desc ty with 3417 3378 | Tvar _ -> 3418 3418 - let ty', ty_meth = object_type ~level:ty.level ~scope:ty.scope in 3379 3379 + let ty', ty_meth = 3380 3380 + object_type ~level:(get_level ty) ~scope:(get_scope ty) in 3419 3381 link_type ty ty'; 3420 3382 ty_meth 3421 3383 | Tobject(f, _) -> ··· 3446 3408 *) 3447 3409 let moregen_occur env level ty = 3448 3410 let rec occur ty = 3449 3449 - let ty = repr ty in 3450 3450 - if ty.level <= level then () else 3451 3451 - if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur else 3411 3411 + let lv = get_level ty in 3412 3412 + if lv <= level then () else 3413 3413 + if is_Tvar ty && lv >= generic_level - 1 then raise Occur else 3452 3414 if try_mark_node ty then iter_type_expr occur ty 3453 3415 in 3454 3416 begin try ··· 3461 3423 update_level_for Moregen env level ty 3462 3424 3463 3425 let may_instantiate inst_nongen t1 = 3464 3464 - if inst_nongen then t1.level <> generic_level - 1 3465 3465 - else t1.level = generic_level 3426 3426 + let level = get_level t1 in 3427 3427 + if inst_nongen then level <> generic_level - 1 3428 3428 + else level = generic_level 3466 3429 3467 3430 let rec moregen inst_nongen type_pairs env t1 t2 = 3468 3468 - if t1 == t2 then () else 3469 3469 - let t1 = repr t1 in 3470 3470 - let t2 = repr t2 in 3471 3471 - if t1 == t2 then () else 3431 3431 + if eq_type t1 t2 then () else 3432 3432 + 3472 3433 try 3473 3473 - match (t1.desc, t2.desc) with 3474 3474 - | (Tvar _, _) when may_instantiate inst_nongen t1 -> 3475 3475 - moregen_occur env t1.level t2; 3476 3476 - update_scope_for Moregen t1.scope t2; 3434 3434 + match (get_desc t1, get_desc t2) with 3435 3435 + (Tvar _, _) when may_instantiate inst_nongen t1 -> 3436 3436 + moregen_occur env (get_level t1) t2; 3437 3437 + update_scope_for Moregen (get_scope t1) t2; 3477 3438 occur_for Moregen env t1 t2; 3478 3439 link_type t1 t2 3479 3440 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> ··· 3482 3443 let t1' = expand_head env t1 in 3483 3444 let t2' = expand_head env t2 in 3484 3445 (* Expansion may have changed the representative of the types... *) 3485 3485 - let t1' = repr t1' and t2' = repr t2' in 3486 3486 - if t1' == t2' then () else 3446 3446 + if eq_type t1' t2' then () else 3487 3447 begin try 3488 3448 TypePairs.find type_pairs (t1', t2') 3489 3449 with Not_found -> 3490 3450 TypePairs.add type_pairs (t1', t2') (); 3491 3491 - match (t1'.desc, t2'.desc) with 3451 3451 + match (get_desc t1', get_desc t2') with 3492 3452 (Tvar _, _) when may_instantiate inst_nongen t1' -> 3493 3493 - moregen_occur env t1'.level t2; 3494 3494 - update_scope_for Moregen t1'.scope t2; 3453 3453 + moregen_occur env (get_level t1') t2; 3454 3454 + update_scope_for Moregen (get_scope t1') t2; 3495 3455 link_type t1' t2 3496 3456 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 3497 3457 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> ··· 3505 3465 | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> 3506 3466 begin try 3507 3467 unify_package env (moregen_list inst_nongen type_pairs env) 3508 3508 - t1'.level p1 fl1 t2'.level p2 fl2 3468 3468 + (get_level t1') p1 fl1 (get_level t2') p2 fl2 3509 3469 with Not_found -> raise_unexplained_for Moregen 3510 3470 end 3511 3471 | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) ··· 3515 3475 | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> 3516 3476 moregen_fields inst_nongen type_pairs env fi1 fi2 3517 3477 | (Tfield _, Tfield _) -> (* Actually unused *) 3518 3518 - moregen_fields inst_nongen type_pairs env t1' t2' 3478 3478 + moregen_fields inst_nongen type_pairs env 3479 3479 + t1' t2' 3519 3480 | (Tnil, Tnil) -> 3520 3481 () 3521 3482 | (Tpoly (t1, []), Tpoly (t2, [])) -> ··· 3547 3508 | [] -> () 3548 3509 end; 3549 3510 moregen inst_nongen type_pairs env rest1 3550 3550 - (build_fields (repr ty2).level miss2 rest2); 3551 3551 - 3511 3511 + (build_fields (get_level ty2) miss2 rest2); 3552 3512 List.iter 3553 3513 (fun (name, k1, t1, k2, t2) -> 3554 3514 (* The below call should never throw [Public_method_to_private_method] *) ··· 3571 3531 3572 3532 and moregen_row inst_nongen type_pairs env row1 row2 = 3573 3533 let row1 = row_repr row1 and row2 = row_repr row2 in 3574 3574 - let rm1 = repr row1.row_more and rm2 = repr row2.row_more in 3575 3575 - if rm1 == rm2 then () else 3534 3534 + let rm1 = row1.row_more and rm2 = row2.row_more in 3535 3535 + if eq_type rm1 rm2 then () else 3576 3536 let may_inst = 3577 3577 - is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in 3537 3537 + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in 3578 3538 let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in 3579 3539 let r1, r2 = 3580 3540 if row2.row_closed then ··· 3590 3550 | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) 3591 3551 | _, [] -> () 3592 3552 end; 3593 3593 - let md1 = rm1.desc (* This lets us undo a following [link_type] *) in 3594 3594 - begin match rm1.desc, rm2.desc with 3553 3553 + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in 3554 3554 + begin match md1, get_desc rm2 with 3595 3555 Tunivar _, Tunivar _ -> 3596 3556 unify_univar_for Moregen rm1 rm2 !univar_pairs 3597 3557 | Tunivar _, _ | _, Tunivar _ -> ··· 3601 3561 let ext = 3602 3562 newgenty (Tvariant {row2 with row_fields = r2; row_name = None}) 3603 3563 in 3604 3604 - moregen_occur env rm1.level ext; 3605 3605 - update_scope_for Moregen rm1.scope ext; 3564 3564 + moregen_occur env (get_level rm1) ext; 3565 3565 + update_scope_for Moregen (get_scope rm1) ext; 3606 3566 (* This [link_type] has to be undone if the rest of the function fails *) 3607 3567 link_type rm1 ext 3608 3568 | Tconstr _, Tconstr _ -> ··· 3736 3696 (* Simpler, no? *) 3737 3697 3738 3698 let rec rigidify_rec vars ty = 3739 3739 - let ty = repr ty in 3740 3699 if try_mark_node ty then 3741 3741 - begin match ty.desc with 3700 3700 + begin match get_desc ty with 3742 3701 | Tvar _ -> 3743 3743 - if not (List.memq ty !vars) then vars := ty :: !vars 3702 3702 + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars 3744 3703 | Tvariant row -> 3745 3704 let row = row_repr row in 3746 3746 - let more = repr row.row_more in 3705 3705 + let more = row.row_more in 3747 3706 if is_Tvar more && not (row_fixed row) then begin 3748 3748 - let more' = newty2 more.level more.desc in 3707 3707 + let more' = newty2 ~level:(get_level more) (get_desc more) in 3749 3708 let row' = 3750 3709 {row with row_fixed=Some Rigid; row_fields=[]; row_more=more'} 3751 3751 - in link_type more (newty2 ty.level (Tvariant row')) 3710 3710 + in link_type more (newty2 ~level:(get_level ty) (Tvariant row')) 3752 3711 end; 3753 3712 iter_row (rigidify_rec vars) row; 3754 3713 (* only consider the row variable if the variant is not static *) 3755 3755 - if not (static_row row) then rigidify_rec vars (row_more row) 3714 3714 + if not (static_row row) then 3715 3715 + rigidify_rec vars (row_more row) 3756 3716 | _ -> 3757 3717 iter_type_expr (rigidify_rec vars) ty 3758 3718 end 3759 3719 3760 3720 let rigidify ty = 3761 3761 - let vars = ref [] in 3721 3721 + let vars = ref TypeSet.empty in 3762 3722 rigidify_rec vars ty; 3763 3723 unmark_type ty; 3764 3764 - !vars 3724 3724 + TypeSet.elements !vars 3765 3725 3766 3726 let all_distinct_vars env vars = 3767 3767 - let tyl = ref [] in 3727 3727 + let tys = ref TypeSet.empty in 3768 3728 List.for_all 3769 3729 (fun ty -> 3770 3730 let ty = expand_head env ty in 3771 3771 - if List.memq ty !tyl then false else 3772 3772 - (tyl := ty :: !tyl; is_Tvar ty)) 3731 3731 + if TypeSet.mem ty !tys then false else 3732 3732 + (tys := TypeSet.add ty !tys; is_Tvar ty)) 3773 3733 vars 3774 3734 3775 3735 let matches ~expand_error_trace env ty ty' = ··· 3807 3767 let ty' = expand_head env ty in 3808 3768 rigid_variants := old; ty' 3809 3769 3810 3810 - let normalize_subst subst = 3770 3770 + let eqtype_subst type_pairs subst t1 t2 = 3811 3771 if List.exists 3812 3812 - (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) 3772 3772 + (fun (t,t') -> 3773 3773 + let found1 = eq_type t1 t in 3774 3774 + let found2 = eq_type t2 t' in 3775 3775 + if found1 && found2 then true else 3776 3776 + if found1 || found2 then raise_unexplained_for Equality else false) 3813 3777 !subst 3814 3814 - then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst 3778 3778 + then () 3779 3779 + else begin 3780 3780 + subst := (t1, t2) :: !subst; 3781 3781 + TypePairs.add type_pairs (t1, t2) () 3782 3782 + end 3815 3783 3816 3784 let rec eqtype rename type_pairs subst env t1 t2 = 3817 3817 - if t1 == t2 then () else 3818 3818 - let t1 = repr t1 in 3819 3819 - let t2 = repr t2 in 3820 3820 - if t1 == t2 then () else 3785 3785 + if eq_type t1 t2 then () else 3821 3786 3822 3787 try 3823 3823 - match (t1.desc, t2.desc) with 3824 3824 - | (Tvar _, Tvar _) when rename -> 3825 3825 - begin try 3826 3826 - normalize_subst subst; 3827 3827 - if List.assq t1 !subst != t2 then raise_unexplained_for Equality 3828 3828 - with Not_found -> 3829 3829 - if List.exists (fun (_, t) -> t == t2) !subst then 3830 3830 - raise_unexplained_for Equality; 3831 3831 - subst := (t1, t2) :: !subst 3832 3832 - end 3788 3788 + match (get_desc t1, get_desc t2) with 3789 3789 + (Tvar _, Tvar _) when rename -> 3790 3790 + eqtype_subst type_pairs subst t1 t2 3833 3791 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> 3834 3792 () 3835 3793 | _ -> 3836 3794 let t1' = expand_head_rigid env t1 in 3837 3795 let t2' = expand_head_rigid env t2 in 3838 3796 (* Expansion may have changed the representative of the types... *) 3839 3839 - let t1' = repr t1' and t2' = repr t2' in 3840 3840 - if t1' == t2' then () else 3797 3797 + if eq_type t1' t2' then () else 3841 3798 begin try 3842 3799 TypePairs.find type_pairs (t1', t2') 3843 3800 with Not_found -> 3844 3801 TypePairs.add type_pairs (t1', t2') (); 3845 3845 - match (t1'.desc, t2'.desc) with 3846 3846 - | (Tvar _, Tvar _) when rename -> 3847 3847 - begin try 3848 3848 - normalize_subst subst; 3849 3849 - if List.assq t1' !subst != t2' then 3850 3850 - raise_unexplained_for Equality 3851 3851 - with Not_found -> 3852 3852 - if List.exists (fun (_, t) -> t == t2') !subst then 3853 3853 - raise_unexplained_for Equality; 3854 3854 - subst := (t1', t2') :: !subst 3855 3855 - end 3802 3802 + match (get_desc t1', get_desc t2') with 3803 3803 + (Tvar _, Tvar _) when rename -> 3804 3804 + eqtype_subst type_pairs subst t1' t2' 3856 3805 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 3857 3806 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> 3858 3807 eqtype rename type_pairs subst env t1 t2; ··· 3865 3814 | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> 3866 3815 begin try 3867 3816 unify_package env (eqtype_list rename type_pairs subst env) 3868 3868 - t1'.level p1 fl1 t2'.level p2 fl2 3817 3817 + (get_level t1') p1 fl1 (get_level t2') p2 fl2 3869 3818 with Not_found -> raise_unexplained_for Equality 3870 3819 end 3871 3820 | (Tnil, Tconstr _ ) -> ··· 3877 3826 | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> 3878 3827 eqtype_fields rename type_pairs subst env fi1 fi2 3879 3828 | (Tfield _, Tfield _) -> (* Actually unused *) 3880 3880 - eqtype_fields rename type_pairs subst env t1' t2' 3829 3829 + eqtype_fields rename type_pairs subst env 3830 3830 + t1' t2' 3881 3831 | (Tnil, Tnil) -> 3882 3832 () 3883 3833 | (Tpoly (t1, []), Tpoly (t2, [])) -> ··· 3903 3853 let (fields2, rest2) = flatten_fields ty2 in 3904 3854 (* First check if same row => already equal *) 3905 3855 let same_row = 3906 3906 - rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) || 3907 3907 - (rename && List.mem (rest1, rest2) !subst) 3856 3856 + eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) 3908 3857 in 3909 3858 if same_row then () else 3910 3859 (* Try expansion, needed when called from Includecore.type_manifest *) 3911 3911 - match expand_head_rigid env rest2 with 3912 3912 - {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 3860 3860 + match get_desc (expand_head_rigid env rest2) with 3861 3861 + Tobject(ty2,_) -> eqtype_fields rename type_pairs subst env ty1 ty2 3913 3862 | _ -> 3914 3863 let (pairs, miss1, miss2) = associate_fields fields1 fields2 in 3915 3864 eqtype rename type_pairs subst env rest1 rest2; ··· 3939 3888 3940 3889 and eqtype_row rename type_pairs subst env row1 row2 = 3941 3890 (* Try expansion, needed when called from Includecore.type_manifest *) 3942 3942 - match expand_head_rigid env (row_more row2) with 3943 3943 - {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 3891 3891 + match get_desc (expand_head_rigid env (row_more row2)) with 3892 3892 + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 3944 3893 | _ -> 3945 3894 let row1 = row_repr row1 and row2 = row_repr row2 in 3946 3895 let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in ··· 4036 3985 let subst = ref [] in 4037 3986 try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 4038 3987 with Equality_trace trace -> 4039 4039 - normalize_subst subst; 4040 3988 raise (Equality (expand_to_equality_error env trace !subst)) 4041 3989 4042 3990 let is_equal env rename tyl1 tyl2 = ··· 4091 4039 end; 4092 4040 moregen_clty false type_pairs env cty1' cty2' 4093 4041 | Cty_signature sign1, Cty_signature sign2 -> 4094 4094 - let ty1 = object_fields (repr sign1.csig_self) in 4095 4095 - let ty2 = object_fields (repr sign2.csig_self) in 4042 4042 + let ty1 = object_fields sign1.csig_self in 4043 4043 + let ty2 = object_fields sign2.csig_self in 4096 4044 let (fields1, _rest1) = flatten_fields ty1 4097 4045 and (fields2, _rest2) = flatten_fields ty2 in 4098 4046 let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in ··· 4137 4085 let res = 4138 4086 let sign1 = signature_of_class_type patt in 4139 4087 let sign2 = signature_of_class_type subj in 4140 4140 - let t1 = repr sign1.csig_self in 4141 4141 - let t2 = repr sign2.csig_self in 4088 4088 + let t1 = sign1.csig_self in 4089 4089 + let t2 = sign2.csig_self in 4142 4090 TypePairs.add type_pairs (t1, t2) (); 4143 4091 let (fields1, rest1) = flatten_fields (object_fields t1) 4144 4092 and (fields2, rest2) = flatten_fields (object_fields t2) in ··· 4232 4180 4233 4181 let equal_clsig trace type_pairs subst env sign1 sign2 = 4234 4182 try 4235 4235 - let ty1 = object_fields (repr sign1.csig_self) in 4236 4236 - let ty2 = object_fields (repr sign2.csig_self) in 4183 4183 + let ty1 = object_fields sign1.csig_self in 4184 4184 + let ty2 = object_fields sign2.csig_self in 4237 4185 let (fields1, _rest1) = flatten_fields ty1 4238 4186 and (fields2, _rest2) = flatten_fields ty2 in 4239 4187 let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in ··· 4241 4189 (fun (lab, _k1, t1, _k2, t2) -> 4242 4190 begin try eqtype true type_pairs subst env t1 t2 with 4243 4191 Equality_trace trace -> 4244 4244 - normalize_subst subst; 4245 4192 raise (Failure 4246 4193 [CM_Meth_type_mismatch 4247 4194 (lab, ··· 4255 4202 let (_, _, ty') = Vars.find lab sign1.csig_vars in 4256 4203 try eqtype true type_pairs subst env ty' ty 4257 4204 with Equality_trace trace -> 4258 4258 - normalize_subst subst; 4259 4205 raise (Failure 4260 4206 [CM_Val_type_mismatch 4261 4207 (lab, ··· 4273 4219 let subst = ref [] in 4274 4220 let sign1 = signature_of_class_type patt_type in 4275 4221 let sign2 = signature_of_class_type subj_type in 4276 4276 - let t1 = repr sign1.csig_self in 4277 4277 - let t2 = repr sign2.csig_self in 4222 4222 + let t1 = sign1.csig_self in 4223 4223 + let t2 = sign2.csig_self in 4278 4224 TypePairs.add type_pairs (t1, t2) (); 4279 4225 let (fields1, rest1) = flatten_fields (object_fields t1) 4280 4226 and (fields2, rest2) = flatten_fields (object_fields t2) in ··· 4351 4297 raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); 4352 4298 List.iter2 (fun p s -> 4353 4299 try eqtype true type_pairs subst env p s with Equality_trace trace -> 4354 4354 - normalize_subst subst; 4355 4300 raise (Failure 4356 4301 [CM_Type_parameter_mismatch 4357 4302 (env, expand_to_equality_error env trace !subst)])) ··· 4411 4356 let cl_abbr = Env.find_hash_type p env in 4412 4357 match cl_abbr.type_manifest with 4413 4358 Some ty -> 4414 4414 - begin match (repr ty).desc with 4359 4359 + begin match get_desc ty with 4415 4360 Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty 4416 4361 | _ -> raise Not_found 4417 4362 end ··· 4420 4365 let has_constr_row' env t = 4421 4366 has_constr_row (expand_abbrev env t) 4422 4367 4423 4423 - let rec build_subtype env visited loops posi level t = 4424 4424 - let t = repr t in 4425 4425 - match t.desc with 4368 4368 + let rec build_subtype env (visited : transient_expr list) 4369 4369 + (loops : (int * type_expr) list) posi level t = 4370 4370 + match get_desc t with 4426 4371 Tvar _ -> 4427 4372 if posi then 4428 4373 try 4429 4429 - let t' = List.assq t loops in 4374 4374 + let t' = List.assq (get_id t) loops in 4430 4375 warn := true; 4431 4376 (t', Equiv) 4432 4377 with Not_found -> ··· 4434 4379 else 4435 4380 (t, Unchanged) 4436 4381 | Tarrow(l, t1, t2, _) -> 4437 4437 - if memq_warn t visited then (t, Unchanged) else 4438 4438 - let visited = t :: visited in 4382 4382 + let tt = Transient_expr.repr t in 4383 4383 + if memq_warn tt visited then (t, Unchanged) else 4384 4384 + let visited = tt :: visited in 4439 4385 let (t1', c1) = build_subtype env visited loops (not posi) level t1 in 4440 4386 let (t2', c2) = build_subtype env visited loops posi level t2 in 4441 4387 let c = max_change c1 c2 in 4442 4388 if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c) 4443 4389 else (t, Unchanged) 4444 4390 | Ttuple tlist -> 4445 4445 - if memq_warn t visited then (t, Unchanged) else 4446 4446 - let visited = t :: visited in 4391 4391 + let tt = Transient_expr.repr t in 4392 4392 + if memq_warn tt visited then (t, Unchanged) else 4393 4393 + let visited = tt :: visited in 4447 4394 let tlist' = 4448 4395 List.map (build_subtype env visited loops posi level) tlist 4449 4396 in ··· 4453 4400 | Tconstr(p, tl, abbrev) 4454 4401 when level > 0 && generic_abbrev env p && safe_abbrev env t 4455 4402 && not (has_constr_row' env t) -> 4456 4456 - let t' = repr (expand_abbrev env t) in 4403 4403 + let t' = expand_abbrev env t in 4457 4404 let level' = pred_expand level in 4458 4458 - begin try match t'.desc with 4405 4405 + begin try match get_desc t' with 4459 4406 Tobject _ when posi && not (opened_object t') -> 4460 4407 let cl_abbr, body = find_cltype_for_path env p in 4461 4408 let ty = ··· 4463 4410 subst env !current_level Public abbrev None 4464 4411 cl_abbr.type_params tl body 4465 4412 with Cannot_subst -> assert false in 4466 4466 - let ty = repr ty in 4467 4413 let ty1, tl1 = 4468 4468 - match ty.desc with 4414 4414 + match get_desc ty with 4469 4415 Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> 4470 4416 ty1, tl1 4471 4417 | _ -> raise Not_found ··· 4476 4422 if List.exists (deep_occur ty) tl1 then raise Not_found; 4477 4423 set_type_desc ty (Tvar None); 4478 4424 let t'' = newvar () in 4479 4479 - let loops = (ty, t'') :: loops in 4425 4425 + let loops = (get_id ty, t'') :: loops in 4480 4426 (* May discard [visited] as level is going down *) 4481 4427 let (ty1', c) = 4482 4482 - build_subtype env [t'] loops posi (pred_enlarge level') ty1 in 4428 4428 + build_subtype env [Transient_expr.repr t'] 4429 4429 + loops posi (pred_enlarge level') ty1 in 4483 4430 assert (is_Tvar t''); 4484 4431 let nm = 4485 4432 if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in 4486 4433 set_type_desc t'' (Tobject (ty1', ref nm)); 4487 4434 (try unify_var env ty t with Unify _ -> assert false); 4488 4488 - (t'', Changed) 4435 4435 + ( t'', Changed) 4489 4436 | _ -> raise Not_found 4490 4437 with Not_found -> 4491 4491 - let (t'',c) = build_subtype env visited loops posi level' t' in 4438 4438 + let (t'',c) = 4439 4439 + build_subtype env visited loops posi level' t' in 4492 4440 if c > Unchanged then (t'',c) 4493 4441 else (t, Unchanged) 4494 4442 end 4495 4443 | Tconstr(p, tl, _abbrev) -> 4496 4444 (* Must check recursion on constructors, since we do not always 4497 4445 expand them *) 4498 4498 - if memq_warn t visited then (t, Unchanged) else 4499 4499 - let visited = t :: visited in 4446 4446 + let tt = Transient_expr.repr t in 4447 4447 + if memq_warn tt visited then (t, Unchanged) else 4448 4448 + let visited = tt :: visited in 4500 4449 begin try 4501 4450 let decl = Env.find_type p env in 4502 4451 if level = 0 && generic_abbrev env p && safe_abbrev env t ··· 4522 4471 end 4523 4472 | Tvariant row -> 4524 4473 let row = row_repr row in 4525 4525 - if memq_warn t visited || not (static_row row) then (t, Unchanged) else 4474 4474 + let tt = Transient_expr.repr t in 4475 4475 + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else 4526 4476 let level' = pred_enlarge level in 4527 4477 let visited = 4528 4528 - t :: if level' < level then [] else filter_visited visited in 4478 4478 + tt :: if level' < level then [] else filter_visited visited in 4529 4479 let fields = filter_row_fields false row.row_fields in 4530 4480 let fields = 4531 4481 List.map ··· 4553 4503 in 4554 4504 (newty (Tvariant row), Changed) 4555 4505 | Tobject (t1, _) -> 4556 4556 - if memq_warn t visited || opened_object t1 then (t, Unchanged) else 4506 4506 + let tt = Transient_expr.repr t in 4507 4507 + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else 4557 4508 let level' = pred_enlarge level in 4558 4509 let visited = 4559 4559 - t :: if level' < level then [] else filter_visited visited in 4510 4510 + tt :: if level' < level then [] else filter_visited visited in 4560 4511 let (t1', c) = build_subtype env visited loops posi level' t1 in 4561 4512 if c > Unchanged then (newty (Tobject (t1', ref None)), c) 4562 4513 else (t, Unchanged) ··· 4613 4564 ~unification_trace)) 4614 4565 4615 4566 let rec subtype_rec env trace t1 t2 cstrs = 4616 4616 - let t1 = repr t1 in 4617 4617 - let t2 = repr t2 in 4618 4618 - if t1 == t2 then cstrs else 4567 4567 + if eq_type t1 t2 then cstrs else 4619 4568 4620 4569 begin try 4621 4570 TypePairs.find subtypes (t1, t2); 4622 4571 cstrs 4623 4572 with Not_found -> 4624 4573 TypePairs.add subtypes (t1, t2) (); 4625 4625 - match (t1.desc, t2.desc) with 4574 4574 + match (get_desc t1, get_desc t2) with 4626 4575 (Tvar _, _) | (_, Tvar _) -> 4627 4576 (trace, t1, t2, !univar_pairs)::cstrs 4628 4577 | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 ··· 4657 4606 let (co, cn) = Variance.get_upper v in 4658 4607 if co then 4659 4608 if cn then 4660 4660 - (trace, newty2 t1.level (Ttuple[t1]), 4661 4661 - newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs 4609 4609 + (trace, newty2 ~level:(get_level t1) (Ttuple[t1]), 4610 4610 + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) 4611 4611 + :: cstrs 4662 4612 else 4663 4613 subtype_rec 4664 4614 env ··· 4709 4659 end 4710 4660 | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> 4711 4661 begin try 4712 4712 - let ntl1 = complete_type_list env fl2 t1.level (Mty_ident p1) fl1 4713 4713 - and ntl2 = complete_type_list env fl1 t2.level (Mty_ident p2) fl2 4662 4662 + let ntl1 = 4663 4663 + complete_type_list env fl2 (get_level t1) (Mty_ident p1) fl1 4664 4664 + and ntl2 = 4665 4665 + complete_type_list env fl1 (get_level t2) (Mty_ident p2) fl2 4714 4666 ~allow_absent:true in 4715 4667 let cstrs' = 4716 4668 List.map ··· 4752 4704 let (fields2, rest2) = flatten_fields ty2 in 4753 4705 let (pairs, miss1, miss2) = associate_fields fields1 fields2 in 4754 4706 let cstrs = 4755 4755 - if rest2.desc = Tnil then cstrs else 4707 4707 + if get_desc rest2 = Tnil then cstrs else 4756 4708 if miss1 = [] then 4757 4709 subtype_rec 4758 4710 env ··· 4760 4712 rest1 rest2 4761 4713 cstrs 4762 4714 else 4763 4763 - (trace, build_fields (repr ty1).level miss1 rest1, rest2, 4715 4715 + (trace, build_fields (get_level ty1) miss1 rest1, rest2, 4764 4716 !univar_pairs) :: cstrs 4765 4717 in 4766 4718 let cstrs = 4767 4719 if miss2 = [] then cstrs else 4768 4768 - (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()), 4720 4720 + (trace, rest1, build_fields (get_level ty2) miss2 (newvar ()), 4769 4721 !univar_pairs) :: cstrs 4770 4722 in 4771 4723 List.fold_left ··· 4784 4736 merge_row_fields row1.row_fields row2.row_fields in 4785 4737 let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in 4786 4738 let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in 4787 4787 - let more1 = repr row1.row_more 4788 4788 - and more2 = repr row2.row_more in 4789 4789 - match more1.desc, more2.desc with 4739 4739 + let more1 = row1.row_more 4740 4740 + and more2 = row2.row_more in 4741 4741 + match get_desc more1, get_desc more2 with 4790 4742 Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> 4791 4743 subtype_rec 4792 4744 env ··· 4865 4817 4866 4818 (* Utility for printing. The resulting type is not used in computation. *) 4867 4819 let rec unalias_object ty = 4868 4868 - let ty = repr ty in 4869 4869 - match ty.desc with 4820 4820 + let level = get_level ty in 4821 4821 + match get_desc ty with 4870 4822 Tfield (s, k, t1, t2) -> 4871 4871 - newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) 4872 4872 - | Tvar _ | Tnil -> 4873 4873 - newty2 ty.level ty.desc 4823 4823 + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) 4824 4824 + | Tvar _ | Tnil as desc -> 4825 4825 + newty2 ~level desc 4874 4826 | Tunivar _ -> 4875 4827 ty 4876 4828 | Tconstr _ -> 4877 4877 - newvar2 ty.level 4829 4829 + newvar2 level 4878 4830 | _ -> 4879 4831 assert false 4880 4832 4881 4833 let unalias ty = 4882 4882 - let ty = repr ty in 4883 4883 - match ty.desc with 4834 4834 + let level = get_level ty in 4835 4835 + match get_desc ty with 4884 4836 Tvar _ | Tunivar _ -> 4885 4837 ty 4886 4838 | Tvariant row -> 4887 4839 let row = row_repr row in 4888 4840 let more = row.row_more in 4889 4889 - newty2 ty.level 4890 4890 - (Tvariant {row with row_more = newty2 more.level more.desc}) 4841 4841 + newty2 ~level 4842 4842 + (Tvariant {row with 4843 4843 + row_more = newty2 ~level:(get_level more) (get_desc more)}) 4891 4844 | Tobject (ty, nm) -> 4892 4892 - newty2 ty.level (Tobject (unalias_object ty, nm)) 4893 4893 - | _ -> 4894 4894 - newty2 ty.level ty.desc 4845 4845 + newty2 ~level (Tobject (unalias_object ty, nm)) 4846 4846 + | desc -> 4847 4847 + newty2 ~level desc 4895 4848 4896 4849 (* Return the arity (as for curried functions) of the given type. *) 4897 4850 let rec arity ty = 4898 4898 - match (repr ty).desc with 4851 4851 + match get_desc ty with 4899 4852 Tarrow(_, _t1, t2, _) -> 1 + arity t2 4900 4853 | _ -> 0 4901 4854 ··· 4904 4857 let visited = ref TypeSet.empty 4905 4858 4906 4859 let rec closed_schema_rec env ty = 4907 4907 - let ty = repr ty in 4908 4860 if TypeSet.mem ty !visited then () else begin 4909 4861 visited := TypeSet.add ty !visited; 4910 4910 - match ty.desc with 4911 4911 - Tvar _ when ty.level <> generic_level -> 4862 4862 + match get_desc ty with 4863 4863 + Tvar _ when get_level ty <> generic_level -> 4912 4864 raise Non_closed0 4913 4865 | Tconstr _ -> 4914 4866 let old = !visited in 4915 4867 begin try iter_type_expr (closed_schema_rec env) ty 4916 4868 with Non_closed0 -> try 4917 4869 visited := old; 4918 4918 - closed_schema_rec env (try_expand_head try_expand_safe env ty) 4870 4870 + closed_schema_rec env 4871 4871 + (try_expand_head try_expand_safe env ty) 4919 4872 with Cannot_expand -> 4920 4873 raise Non_closed0 4921 4874 end ··· 4945 4898 (* Normalize a type before printing, saving... *) 4946 4899 (* Cannot use mark_type because deep_occur uses it too *) 4947 4900 let rec normalize_type_rec visited ty = 4948 4948 - let ty = repr ty in 4949 4901 if not (TypeSet.mem ty !visited) then begin 4950 4902 visited := TypeSet.add ty !visited; 4951 4903 let tm = row_of_type ty in 4952 4904 begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then 4953 4953 - match tm.desc with (* PR#7348 *) 4905 4905 + match get_desc tm with (* PR#7348 *) 4954 4906 Tconstr (Path.Pdot(m,i), tl, _abbrev) -> 4955 4907 let i' = String.sub i 0 (String.length i - 4) in 4956 4908 set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil)) 4957 4909 | _ -> assert false 4958 4958 - else match ty.desc with 4910 4910 + else match get_desc ty with 4959 4911 | Tvariant row -> 4960 4912 let row = row_repr row in 4961 4913 let fields = List.map ··· 4988 4940 if deep_occur ty (newgenty (Ttuple l)) then 4989 4941 (* The abbreviation may be hiding something, so remove it *) 4990 4942 set_name nm None 4991 4991 - else let v' = repr v in 4992 4992 - begin match v'.desc with 4993 4993 - | Tvar _ | Tunivar _ -> 4994 4994 - if v' != v then set_name nm (Some (n, v' :: l)) 4995 4995 - | Tnil -> 4996 4996 - set_type_desc ty (Tconstr (n, l, ref Mnil)) 4997 4997 - | _ -> set_name nm None 4943 4943 + else 4944 4944 + begin match get_desc v with 4945 4945 + | Tvar _ | Tunivar _ -> () 4946 4946 + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) 4947 4947 + | _ -> set_name nm None 4998 4948 end 4999 4949 | _ -> 5000 4950 fatal_error "Ctype.normalize_type_rec" 5001 4951 end; 5002 5002 - let fi = repr fi in 5003 5003 - if fi.level < lowest_level then () else 4952 4952 + let level = get_level fi in 4953 4953 + if level < lowest_level then () else 5004 4954 let fields, row = flatten_fields fi in 5005 5005 - let fi' = build_fields fi.level fields row in 5006 5006 - set_type_desc fi fi'.desc 4955 4955 + let fi' = build_fields level fields row in 4956 4956 + set_type_desc fi (get_desc fi') 5007 4957 | _ -> () 5008 4958 end; 5009 4959 iter_type_expr (normalize_type_rec visited) ty ··· 5035 4985 if expand_private then try_expand_safe_opt env t 5036 4986 else try_expand_safe env t 5037 4987 in 5038 5038 - match ty.desc with 4988 4988 + match get_desc ty with 5039 4989 Tvar _ | Tunivar _ -> ty 5040 5040 - | Tlink ty -> nondep_type_rec env ids ty 5041 4990 | _ -> try TypeHash.find nondep_hash ty 5042 4991 with Not_found -> 5043 5043 - let ty' = newgenvar () in (* Stub *) 4992 4992 + let ty' = newgenstub ~scope:(get_scope ty) in 5044 4993 TypeHash.add nondep_hash ty ty'; 5045 5045 - set_type_desc ty' 5046 5046 - begin match ty.desc with 5047 5047 - | Tconstr(p, tl, _abbrev) -> 4994 4994 + let desc = 4995 4995 + match get_desc ty with 4996 4996 + | Tconstr(p, tl, _abbrev) as desc -> 5048 4997 begin try 5049 4998 (* First, try keeping the same type constructor p *) 5050 4999 match Path.find_free_opt ids p with ··· 5055 5004 with (Nondep_cannot_erase _) as exn -> 5056 5005 (* If that doesn't work, try expanding abbrevs *) 5057 5006 try Tlink (nondep_type_rec ~expand_private env ids 5058 5058 - (try_expand env (newty2 ty.level ty.desc))) 5007 5007 + (try_expand env (newty2 ~level:(get_level ty) desc))) 5059 5008 (* 5060 5009 The [Tlink] is important. The expanded type may be a 5061 5010 variable, or may not be completely copied yet ··· 5081 5030 else Some (p, List.map (nondep_type_rec env ids) tl))) 5082 5031 | Tvariant row -> 5083 5032 let row = row_repr row in 5084 5084 - let more = repr row.row_more in 5033 5033 + let more = row.row_more in 5085 5034 (* We must keep sharing according to the row variable *) 5086 5035 begin try 5087 5036 let ty2 = TypeHash.find nondep_variants more in ··· 5103 5052 Tvariant {row with row_name = None} 5104 5053 | _ -> Tvariant row 5105 5054 end 5106 5106 - | _ -> copy_type_desc (nondep_type_rec env ids) ty.desc 5107 5107 - end; 5055 5055 + | desc -> copy_type_desc (nondep_type_rec env ids) desc 5056 5056 + in 5057 5057 + Transient_expr.set_stub_desc ty' desc; 5108 5058 ty' 5109 5059 5110 5060 let nondep_type env id ty = ··· 5173 5123 newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) 5174 5124 in 5175 5125 let ty' = nondep_type_rec env ids ty in 5176 5176 - match (repr ty').desc with 5126 5126 + match get_desc ty' with 5177 5127 Tconstr(p, tl, _) -> p, tl 5178 5128 | _ -> raise (Nondep_cannot_erase id) 5179 5129 end ··· 5260 5210 5261 5211 (* collapse conjunctive types in class parameters *) 5262 5212 let rec collapse_conj env visited ty = 5263 5263 - let ty = repr ty in 5264 5264 - if List.memq ty visited then () else 5265 5265 - let visited = ty :: visited in 5266 5266 - match ty.desc with 5213 5213 + let id = get_id ty in 5214 5214 + if List.memq id visited then () else 5215 5215 + let visited = id :: visited in 5216 5216 + match get_desc ty with 5267 5217 Tvariant row -> 5268 5218 let row = row_repr row in 5269 5219 List.iter ··· 5285 5235 let same_constr env t1 t2 = 5286 5236 let t1 = expand_head env t1 in 5287 5237 let t2 = expand_head env t2 in 5288 5288 - match t1.desc, t2.desc with 5238 5238 + match get_desc t1, get_desc t2 with 5289 5239 | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 5290 5240 | _ -> false 5291 5241 ··· 5301 5251 !Clflags.native_code && Sys.word_size = 64 5302 5252 5303 5253 let immediacy env typ = 5304 5304 - match (repr typ).desc with 5254 5254 + match get_desc typ with 5305 5255 | Tconstr(p, _args, _abbrev) -> 5306 5256 begin try 5307 5257 let type_decl = Env.find_type p env in

+1 -6

typing/ctype.mli

reviewed

··· 18 18 open Asttypes 19 19 open Types 20 20 21 21 - module TypePairs : Hashtbl.S with type key = type_expr * type_expr 22 22 - 23 21 exception Unify of Errortrace.unification_error 24 22 exception Equality of Errortrace.equality_error 25 23 exception Moregen of Errortrace.moregen_error ··· 67 65 val newconstr: Path.t -> type_expr list -> type_expr 68 66 val none: type_expr 69 67 (* A dummy type expression *) 70 70 - 71 71 - val repr: type_expr -> type_expr 72 72 - (* Return the canonical representative of a type. *) 73 68 74 69 val object_fields: type_expr -> type_expr 75 70 val flatten_fields: ··· 225 220 (* Unify the two types given. Raise [Unify] if not possible. *) 226 221 val unify_gadt: 227 222 equations_level:int -> allow_recursive:bool -> 228 228 - Env.t ref -> type_expr -> type_expr -> unit TypePairs.t 223 223 + Env.t ref -> type_expr -> type_expr -> unit Btype.TypePairs.t 229 224 (* Unify the two types given and update the environment with the 230 225 local constraints. Raise [Unify] if not possible. 231 226 Returns the pairs of types that have been equated. *)

+9 -12

typing/datarepr.ml

reviewed

··· 24 24 let free_vars ?(param=false) ty = 25 25 let ret = ref TypeSet.empty in 26 26 let rec loop ty = 27 27 - let ty = repr ty in 28 27 if try_mark_node ty then 29 29 - match ty.desc with 28 28 + match get_desc ty with 30 29 | Tvar _ -> 31 30 ret := TypeSet.add ty !ret 32 31 | Tvariant row -> 33 32 let row = row_repr row in 34 33 iter_row loop row; 35 34 if not (static_row row) then begin 36 36 - match row.row_more.desc with 35 35 + match get_desc row.row_more with 37 36 | Tvar _ when param -> ret := TypeSet.add ty !ret 38 37 | _ -> loop row.row_more 39 38 end ··· 95 94 96 95 let constructor_descrs ~current_unit ty_path decl cstrs rep = 97 96 let ty_res = newgenconstr ty_path decl.type_params in 98 98 - let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in 97 97 + let num_consts = ref 0 and num_nonconsts = ref 0 in 99 98 List.iter 100 100 - (fun {cd_args; cd_res; _} -> 101 101 - if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; 102 102 - if cd_res = None then incr num_normal) 99 99 + (fun {cd_args; _} -> 100 100 + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) 103 101 cstrs; 104 102 let rec describe_constructors idx_const idx_nonconst = function 105 103 [] -> [] ··· 139 137 cstr_tag = tag; 140 138 cstr_consts = !num_consts; 141 139 cstr_nonconsts = !num_nonconsts; 142 142 - cstr_normal = !num_normal; 143 140 cstr_private = decl.type_private; 144 141 cstr_generalized = cd_res <> None; 145 142 cstr_loc = cd_loc; ··· 169 166 cstr_consts = -1; 170 167 cstr_nonconsts = -1; 171 168 cstr_private = ext.ext_private; 172 172 - cstr_normal = -1; 173 169 cstr_generalized = ext.ext_ret_type <> None; 174 170 cstr_loc = ext.ext_loc; 175 171 cstr_attributes = ext.ext_attributes; ··· 177 173 cstr_uid = ext.ext_uid; 178 174 } 179 175 180 180 - let none = Private_type_expr.create (Ttuple []) 181 181 - ~level:(-1) ~scope:Btype.generic_level ~id:(-1) 182 182 - (* Clearly ill-formed type *) 176 176 + let none = 177 177 + create_expr (Ttuple []) ~level:(-1) ~scope:Btype.generic_level ~id:(-1) 178 178 + (* Clearly ill-formed type *) 179 179 + 183 180 let dummy_label = 184 181 { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; 185 182 lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;

+6 -7

typing/env.ml

reviewed

··· 21 21 open Longident 22 22 open Path 23 23 open Types 24 24 - open Btype 25 24 26 25 open Local_store 27 26 ··· 1340 1339 let memo = Hashtbl.create 16 in 1341 1340 let copy t = 1342 1341 try 1343 1343 - Hashtbl.find memo t.id 1342 1342 + Hashtbl.find memo (get_id t) 1344 1343 with Not_found -> 1345 1344 let t2 = Subst.type_expr Subst.identity t in 1346 1346 - Hashtbl.add memo t.id t2; 1345 1345 + Hashtbl.add memo (get_id t) t2; 1347 1346 t2 1348 1347 in 1349 1348 let f = function ··· 2419 2418 2420 2419 let mark_constructor_description_used usage env cstr = 2421 2420 let ty_path = 2422 2422 - match repr cstr.cstr_res with 2423 2423 - | {desc=Tconstr(path, _, _)} -> path 2421 2421 + match get_desc cstr.cstr_res with 2422 2422 + | Tconstr(path, _, _) -> path 2424 2423 | _ -> assert false 2425 2424 in 2426 2425 mark_type_path_used env ty_path; ··· 2430 2429 2431 2430 let mark_label_description_used usage env lbl = 2432 2431 let ty_path = 2433 2433 - match repr lbl.lbl_res with 2434 2434 - | {desc=Tconstr(path, _, _)} -> path 2432 2432 + match get_desc lbl.lbl_res with 2433 2433 + | Tconstr(path, _, _) -> path 2435 2434 | _ -> assert false 2436 2435 in 2437 2436 mark_type_path_used env ty_path;

+8 -8

typing/includecore.ml

reviewed

··· 101 101 (* Inclusion between manifest types (particularly for private row types) *) 102 102 103 103 let is_absrow env ty = 104 104 - match ty.desc with 105 105 - | Tconstr(Pident _, _, _) -> begin 104 104 + match get_desc ty with 105 105 + | Tconstr(Pident _, _, _) -> 106 106 (* This function is checking for an abstract row on the side that is being 107 107 included into (usually numbered with "2" in this file). In this case, 108 108 the abstract row variable has been subsituted for an object or variant 109 109 type. *) 110 110 - match Ctype.expand_head env ty with 111 111 - | {desc=Tobject _|Tvariant _} -> true 110 110 + begin match get_desc (Ctype.expand_head env ty) with 111 111 + | Tobject _|Tvariant _ -> true 112 112 | _ -> false 113 113 end 114 114 | _ -> false ··· 524 524 match decl1.type_manifest with 525 525 | Some ty1 -> begin 526 526 let ty1 = Ctype.expand_head env ty1 in 527 527 - match ty1.desc with 527 527 + match get_desc ty1 with 528 528 | Tvariant row when Btype.is_constr_row ~allow_ident:true 529 529 (Btype.row_more row) -> 530 530 Some Private_row_type ··· 634 634 635 635 let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = 636 636 let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in 637 637 - match ty1'.desc, ty2'.desc with 637 637 + match get_desc ty1', get_desc ty2' with 638 638 | Tvariant row1, Tvariant row2 639 639 when is_absrow env (Btype.row_more row2) -> begin 640 640 let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in ··· 657 657 match priv2, kind2 with 658 658 | Private, Type_abstract -> begin 659 659 (* Same checks as the [when] guards from above, inverted *) 660 660 - match ty2'.desc with 660 660 + match get_desc ty2' with 661 661 | Tvariant row -> 662 662 not (is_absrow env (Btype.row_more row)) 663 663 | Tobject (fi, _) -> ··· 770 770 if not need_variance then None else 771 771 let abstr = abstr || decl2.type_private = Private in 772 772 let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in 773 773 - let constrained ty = not (Btype.(is_Tvar (repr ty))) in 773 773 + let constrained ty = not (Btype.is_Tvar ty) in 774 774 if List.for_all2 775 775 (fun ty (v1,v2) -> 776 776 let open Variance in

+3 -3

typing/mtype.ml

reviewed

··· 518 518 let lower_nongen nglev mty = 519 519 let open Btype in 520 520 let it_type_expr it ty = 521 521 - let ty = repr ty in 522 522 - match ty with 523 523 - {desc=Tvar _; level} -> 521 521 + match get_desc ty with 522 522 + Tvar _ -> 523 523 + let level = get_level ty in 524 524 if level < generic_level && level > nglev then set_level ty nglev 525 525 | _ -> 526 526 type_iterators.it_type_expr it ty

+8 -7

typing/parmatch.ml

reviewed

··· 339 339 340 340 (* May need a clean copy, cf. PR#4745 *) 341 341 let clean_copy ty = 342 342 - if ty.level = Btype.generic_level then ty 342 342 + if get_level ty = Btype.generic_level then ty 343 343 else Subst.type_expr Subst.identity ty 344 344 345 345 let get_constructor_type_path ty tenv = 346 346 - let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in 347 347 - match ty.desc with 346 346 + let ty = Ctype.expand_head tenv (clean_copy ty) in 347 347 + match get_desc ty with 348 348 | Tconstr (path,_,_) -> path 349 349 | _ -> assert false 350 350 ··· 724 724 match Btype.row_field_repr f with 725 725 | Reither(_, _, false, e) -> 726 726 (* m=false means that this tag is not explicitly matched *) 727 727 - Btype.set_row_field e Rabsent; 727 727 + set_row_field e Rabsent; 728 728 None 729 729 | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) 730 730 row.row_name row.row_fields in ··· 732 732 (* this unification cannot fail *) 733 733 Ctype.unify env row.row_more 734 734 (Btype.newgenty 735 735 - (Tvariant {row with row_fields = []; row_more = Btype.newgenvar(); 735 735 + (Tvariant {row with row_fields = []; 736 736 + row_more = Btype.newgenvar(); 736 737 row_closed = true; row_name = nm})) 737 738 end 738 739 ··· 822 823 823 824 let pats_of_type ?(always=false) env ty = 824 825 let ty' = Ctype.expand_head env ty in 825 825 - match ty'.desc with 826 826 + match get_desc ty' with 826 827 | Tconstr (path, _, _) -> 827 828 begin match Env.find_type_descrs path env with 828 829 | exception Not_found -> [omega] ··· 844 845 | _ -> [omega] 845 846 846 847 let rec get_variant_constructors env ty = 847 847 - match (Ctype.repr ty).desc with 848 848 + match get_desc ty with 848 849 | Tconstr (path,_,_) -> begin 849 850 try match Env.find_type path env, Env.find_type_descrs path env with 850 851 | _, Type_variant (cstrs,_) -> cstrs

+3 -3

typing/patterns.ml

reviewed

··· 194 194 | Some a -> true, [a] 195 195 in 196 196 let type_row () = 197 197 - match Ctype.expand_head q.pat_env q.pat_type with 198 198 - | {desc = Tvariant type_row} -> Btype.row_repr type_row 199 199 - | _ -> assert false 197 197 + match get_desc (Ctype.expand_head q.pat_env q.pat_type) with 198 198 + | Tvariant type_row -> Btype.row_repr type_row 199 199 + | _ -> assert false 200 200 in 201 201 Variant {tag; has_arg; cstr_row; type_row}, pats 202 202 | `Array args ->

+90 -90

typing/printtyp.ml

reviewed

··· 484 484 if List.memq r v then "Clink loop" else 485 485 safe_commu_repr (r::v) !r 486 486 487 487 - let rec safe_repr v = function 487 487 + let rec safe_repr v t = 488 488 + match Transient_expr.coerce t with 488 489 {desc = Tlink t} when not (List.memq t v) -> 489 490 safe_repr (t::v) t 490 490 - | t -> t 491 491 + | t' -> t' 491 492 492 493 let rec list_of_memo = function 493 494 Mnil -> [] ··· 631 632 the {!printing_map} one level further (see also {!Env.run_iter_cont}) 632 633 *) 633 634 634 634 - let same_type t t' = repr t == repr t' 635 635 - 636 635 let rec index l x = 637 636 match l with 638 637 [] -> raise Not_found 639 639 - | a :: l -> if x == a then 0 else 1 + index l x 638 638 + | a :: l -> if eq_type x a then 0 else 1 + index l x 640 639 641 640 let rec uniq = function 642 641 [] -> true 643 643 - | a :: l -> not (List.memq a l) && uniq l 642 642 + | a :: l -> not (List.memq (a : int) l) && uniq l 644 643 645 644 let rec normalize_type_path ?(cache=false) env p = 646 645 try 647 646 let (params, ty, _) = Env.find_type_expansion p env in 648 648 - let params = List.map repr params in 649 649 - match repr ty with 650 650 - {desc = Tconstr (p1, tyl, _)} -> 651 651 - let tyl = List.map repr tyl in 647 647 + match get_desc ty with 648 648 + Tconstr (p1, tyl, _) -> 652 649 if List.length params = List.length tyl 653 653 - && List.for_all2 (==) params tyl 650 650 + && List.for_all2 eq_type params tyl 654 651 then normalize_type_path ~cache env p1 655 652 else if cache || List.length params <= List.length tyl 656 656 - || not (uniq tyl) then (p, Id) 653 653 + || not (uniq (List.map get_id tyl)) then (p, Id) 657 654 else 658 655 let l1 = List.map (index params) tyl in 659 656 let (p2, s2) = normalize_type_path ~cache env p1 in 660 657 (p2, compose l1 s2) 661 661 - | ty -> 658 658 + | _ -> 662 659 (p, Nth (index params ty)) 663 660 with 664 661 Not_found -> ··· 788 785 789 786 let is_non_gen mode ty = 790 787 match mode with 791 791 - | Type_scheme -> is_Tvar ty && ty.level <> generic_level 788 788 + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level 792 789 | Type -> false 793 790 794 791 module Names : sig 795 792 val reset_names : unit -> unit 796 793 797 797 - val add_named_var : type_expr -> unit 794 794 + val add_named_var : transient_expr -> unit 798 795 val add_subst : (type_expr * type_expr) list -> unit 799 796 800 800 - val has_name : type_expr -> bool 797 797 + val has_name : transient_expr -> bool 801 798 802 799 val new_name : unit -> string 803 800 val new_weak_name : type_expr -> unit -> string 804 801 805 805 - val name_of_type : (unit -> string) -> type_expr -> string 806 806 - val check_name_of_type : type_expr -> unit 802 802 + val name_of_type : (unit -> string) -> transient_expr -> string 803 803 + val check_name_of_type : transient_expr -> unit 807 804 808 808 - val remove_names : type_expr list -> unit 805 805 + val remove_names : transient_expr list -> unit 809 806 810 807 val with_local_names : (unit -> 'a) -> 'a 811 808 ··· 817 814 which maps from types to types. The lookup process is 818 815 "type -> apply substitution -> find name". The substitution is presumed to 819 816 be acyclic. *) 820 820 - let names = ref ([] : (type_expr * string) list) 821 821 - let name_subst = ref ([] : (type_expr * type_expr) list) 817 817 + let names = ref ([] : (transient_expr * string) list) 818 818 + let name_subst = ref ([] : (transient_expr * transient_expr) list) 822 819 let name_counter = ref 0 823 820 let named_vars = ref ([] : string list) 824 821 ··· 842 839 | exception Not_found -> ty 843 840 844 841 let add_subst subst = 845 845 - name_subst := subst @ !name_subst 842 842 + name_subst := 843 843 + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) 844 844 + subst 845 845 + @ !name_subst 846 846 847 847 let has_name ty = 848 848 List.mem_assq (substitute ty) !names ··· 876 876 of the union-find class. *) 877 877 let t = substitute t in 878 878 try List.assq t !names with Not_found -> 879 879 - try TypeMap.find t !weak_var_map with Not_found -> 879 879 + try TransientTypeMap.find t !weak_var_map with Not_found -> 880 880 let name = 881 881 match t.desc with 882 882 Tvar (Some name) | Tunivar (Some name) -> ··· 904 904 let check_name_of_type t = ignore(name_of_type new_name t) 905 905 906 906 let remove_names tyl = 907 907 - let tyl = List.map (fun ty -> substitute (repr ty)) tyl in 907 907 + let tyl = List.map substitute tyl in 908 908 names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names 909 909 910 910 let with_local_names f = ··· 920 920 921 921 let refresh_weak () = 922 922 let refresh t name (m,s) = 923 923 - if is_non_gen Type_scheme (repr t) then 923 923 + if is_non_gen Type_scheme t then 924 924 begin 925 925 TypeMap.add t name m, 926 926 String.Set.add name s ··· 932 932 weak_var_map := m 933 933 end 934 934 935 935 - let visited_objects = ref ([] : type_expr list) 936 936 - let aliased = ref ([] : type_expr list) 937 937 - let delayed = ref ([] : type_expr list) 935 935 + let visited_objects = ref ([] : transient_expr list) 936 936 + let aliased = ref ([] : transient_expr list) 937 937 + let delayed = ref ([] : transient_expr list) 938 938 939 939 let add_delayed t = 940 940 if not (List.memq t !delayed) then delayed := t :: !delayed 941 941 942 942 + let proxy ty = Transient_expr.repr (proxy ty) 943 943 + 942 944 let is_aliased ty = List.memq (proxy ty) !aliased 943 943 - let add_alias ty = 944 944 - let px = proxy ty in 945 945 - if not (is_aliased px) then begin 945 945 + let add_alias_proxy px = 946 946 + if not (List.memq px !aliased) then begin 946 947 aliased := px :: !aliased; 947 948 Names.add_named_var px 948 949 end 950 950 + let add_alias ty = add_alias_proxy (proxy ty) 949 951 950 952 let aliasable ty = 951 951 - match ty.desc with 953 953 + match get_desc ty with 952 954 Tvar _ | Tunivar _ | Tpoly _ -> false 953 955 | Tconstr (p, _, _) -> 954 956 not (is_nth (snd (best_type_path p))) ··· 965 967 row.row_fields 966 968 967 969 let rec mark_loops_rec visited ty = 968 968 - let ty = repr ty in 969 970 let px = proxy ty in 970 970 - if List.memq px visited && aliasable ty then add_alias px else 971 971 + if List.memq px visited && aliasable ty then add_alias_proxy px else 971 972 let visited = px :: visited in 972 972 - match ty.desc with 973 973 - | Tvar _ -> Names.add_named_var ty 973 973 + let tty = Transient_expr.repr ty in 974 974 + match tty.desc with 975 975 + | Tvar _ -> Names.add_named_var tty 974 976 | Tarrow(_, ty1, ty2, _) -> 975 977 mark_loops_rec visited ty1; mark_loops_rec visited ty2 976 978 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl ··· 980 982 | Tpackage (_, fl) -> 981 983 List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl 982 984 | Tvariant row -> 983 983 - if List.memq px !visited_objects then add_alias px else 985 985 + if List.memq px !visited_objects then add_alias_proxy px else 984 986 begin 985 987 let row = row_repr row in 986 988 if not (static_row row) then ··· 992 994 iter_row (mark_loops_rec visited) row 993 995 end 994 996 | Tobject (fi, nm) -> 995 995 - if List.memq px !visited_objects then add_alias px else 997 997 + if List.memq px !visited_objects then add_alias_proxy px else 996 998 begin 997 999 if opened_object ty then 998 1000 visited_objects := px :: !visited_objects; ··· 1018 1020 | Tpoly (ty, tyl) -> 1019 1021 List.iter (fun t -> add_alias t) tyl; 1020 1022 mark_loops_rec visited ty 1021 1021 - | Tunivar _ -> Names.add_named_var ty 1023 1023 + | Tunivar _ -> Names.add_named_var tty 1022 1024 1023 1025 let mark_loops ty = 1024 1026 normalize_type ty; ··· 1044 1046 let print_labels = ref true 1045 1047 1046 1048 let rec tree_of_typexp mode ty = 1047 1047 - let ty = repr ty in 1048 1049 let px = proxy ty in 1049 1050 if Names.has_name px && not (List.memq px !delayed) then 1050 1051 let mark = is_non_gen mode ty in ··· 1055 1056 Otyp_var (mark, name) else 1056 1057 1057 1058 let pr_typ () = 1058 1058 - match ty.desc with 1059 1059 + let tty = Transient_expr.repr ty in 1060 1060 + match tty.desc with 1059 1061 | Tvar _ -> 1060 1060 - (*let lev = 1061 1061 - if is_non_gen mode ty then "/" ^ Int.to_string ty.level else "" in*) 1062 1062 let non_gen = is_non_gen mode ty in 1063 1063 let name_gen = 1064 1064 if non_gen then Names.new_weak_name ty else Names.new_name 1065 1065 in 1066 1066 - Otyp_var (non_gen, Names.name_of_type name_gen ty) 1066 1066 + Otyp_var (non_gen, Names.name_of_type name_gen tty) 1067 1067 | Tarrow(l, ty1, ty2, _) -> 1068 1068 let lab = 1069 1069 if !print_labels || is_optional l then string_of_label l else "" 1070 1070 in 1071 1071 let t1 = 1072 1072 if is_optional l then 1073 1073 - match (repr ty1).desc with 1073 1073 + match get_desc ty1 with 1074 1074 | Tconstr(path, [ty], _) 1075 1075 when Path.same path Predef.path_option -> 1076 1076 tree_of_typexp mode ty ··· 1110 1110 if row.row_closed && all_present then 1111 1111 out_variant 1112 1112 else 1113 1113 - let non_gen = is_non_gen mode px in 1113 1113 + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in 1114 1114 let tags = 1115 1115 if all_present then None else Some (List.map fst present) in 1116 1116 Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags) 1117 1117 | _ -> 1118 1118 let non_gen = 1119 1119 - not (row.row_closed && all_present) && is_non_gen mode px in 1119 1119 + not (row.row_closed && all_present) && 1120 1120 + is_non_gen mode (Transient_expr.type_expr px) in 1120 1121 let fields = List.map (tree_of_row_field mode) fields in 1121 1122 let tags = 1122 1123 if all_present then None else Some (List.map fst present) in ··· 1137 1138 (*let print_names () = 1138 1139 List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; 1139 1140 prerr_string "; " in *) 1140 1140 - let tyl = List.map repr tyl in 1141 1141 if tyl = [] then tree_of_typexp mode ty else begin 1142 1142 + let tyl = List.map Transient_expr.repr tyl in 1142 1143 let old_delayed = !delayed in 1143 1144 (* Make the names delayed, so that the real type is 1144 1145 printed once when used as proxy *) ··· 1150 1151 delayed := old_delayed; tr 1151 1152 end 1152 1153 | Tunivar _ -> 1153 1153 - Otyp_var (false, Names.name_of_type Names.new_name ty) 1154 1154 + Otyp_var (false, Names.name_of_type Names.new_name tty) 1154 1155 | Tpackage (p, fl) -> 1155 1156 let fl = 1156 1157 List.map ··· 1161 1162 Otyp_module (tree_of_path Module_type p, fl) 1162 1163 in 1163 1164 if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; 1164 1164 - if is_aliased px && aliasable ty then begin 1165 1165 + if is_aliased (Transient_expr.type_expr px) && aliasable ty then begin 1165 1166 Names.check_name_of_type px; 1166 1167 Otyp_alias (pr_typ (), Names.name_of_type Names.new_name px) end 1167 1168 else pr_typ () ··· 1198 1199 let (fields, rest) = pr_fields fi in 1199 1200 Otyp_object (fields, rest) 1200 1201 | Some (p, ty :: tyl) -> 1201 1201 - let non_gen = is_non_gen mode (repr ty) in 1202 1202 + let non_gen = is_non_gen mode ty in 1202 1203 let args = tree_of_typlist mode tyl in 1203 1204 let (p', s) = best_type_path p in 1204 1205 assert (s = Id); ··· 1210 1211 and tree_of_typfields mode rest = function 1211 1212 | [] -> 1212 1213 let rest = 1213 1213 - match rest.desc with 1214 1214 + match get_desc rest with 1214 1215 | Tvar _ | Tunivar _ -> Some (is_non_gen mode rest) 1215 1216 | Tconstr _ -> Some false 1216 1217 | Tnil -> None ··· 1269 1270 let params = 1270 1271 List.fold_left 1271 1272 (fun tyl ty -> 1272 1272 - let ty = repr ty in 1273 1273 - if List.memq ty tyl then Btype.newgenty (Ttuple [ty]) :: tyl 1273 1273 + if List.exists (eq_type ty) tyl 1274 1274 + then newty2 ~level:generic_level (Ttuple [ty]) :: tyl 1274 1275 else ty :: tyl) 1275 1276 (* Two parameters might be identical due to a constraint but we need to 1276 1277 print them differently in order to make the output syntactically valid. ··· 1293 1294 | Some ty -> 1294 1295 let vars = free_variables ty in 1295 1296 List.iter 1296 1296 - (function {desc = Tvar (Some "_")} as ty -> 1297 1297 - if List.memq ty vars then set_type_desc ty (Tvar None) 1298 1298 - | _ -> ()) 1297 1297 + (fun ty -> 1298 1298 + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars 1299 1299 + then set_type_desc ty (Tvar None)) 1299 1300 params 1300 1301 | None -> () 1301 1302 end; ··· 1309 1310 | Some ty -> 1310 1311 let ty = 1311 1312 (* Special hack to hide variant name *) 1312 1312 - match repr ty with {desc=Tvariant row} -> 1313 1313 - let row = row_repr row in 1314 1314 - begin match row.row_name with 1315 1315 - Some (Pident id', _) when Ident.same id id' -> 1316 1316 - newgenty (Tvariant {row with row_name = None}) 1317 1317 - | _ -> ty 1318 1318 - end 1313 1313 + match get_desc ty with 1314 1314 + Tvariant row -> 1315 1315 + let row = row_repr row in 1316 1316 + begin match row.row_name with 1317 1317 + Some (Pident id', _) when Ident.same id id' -> 1318 1318 + newgenty (Tvariant {row with row_name = None}) 1319 1319 + | _ -> ty 1320 1320 + end 1319 1321 | _ -> ty 1320 1322 in 1321 1323 mark_loops ty; ··· 1355 1357 let vari = 1356 1358 List.map2 1357 1359 (fun ty v -> 1358 1358 - let is_var = is_Tvar (repr ty) in 1360 1360 + let is_var = is_Tvar ty in 1359 1361 if abstr || not is_var then 1360 1362 let inj = 1361 1363 decl.type_kind = Type_abstract && Variance.mem Inj v && ··· 1536 1538 (* Print a class type *) 1537 1539 1538 1540 let method_type (_, kind, ty) = 1539 1539 - match field_kind_repr kind, repr ty with 1540 1540 - Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) 1541 1541 - | _ , ty -> (ty, []) 1541 1541 + match field_kind_repr kind, get_desc ty with 1542 1542 + Fpresent, Tpoly(ty, tyl) -> (ty, tyl) 1543 1543 + | _ , _ -> (ty, []) 1542 1544 1543 1545 let tree_of_metho mode concrete csil (lab, kind, ty) = 1544 1546 if lab <> dummy_method then begin ··· 1547 1549 let virt = not (Concr.mem lab concrete) in 1548 1550 let (ty, tyl) = method_type (lab, kind, ty) in 1549 1551 let tty = tree_of_typexp mode ty in 1550 1550 - Names.remove_names tyl; 1552 1552 + Names.remove_names (List.map Transient_expr.repr tyl); 1551 1553 Ocsg_method (lab, priv, virt, tty) :: csil 1552 1554 end 1553 1555 else csil ··· 1561 1563 then prepare_class_type params cty 1562 1564 else List.iter mark_loops tyl 1563 1565 | Cty_signature sign -> 1564 1564 - let sty = repr sign.csig_self in 1565 1566 (* Self may have a name *) 1566 1566 - let px = proxy sty in 1567 1567 - if List.memq px !visited_objects then add_alias sty 1567 1567 + let px = proxy sign.csig_self in 1568 1568 + if List.memq px !visited_objects then add_alias sign.csig_self 1568 1569 else visited_objects := px :: !visited_objects; 1569 1570 let (fields, _) = 1570 1571 Ctype.flatten_fields (Ctype.object_fields sign.csig_self) ··· 1587 1588 let namespace = Namespace.best_class_namespace p' in 1588 1589 Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) 1589 1590 | Cty_signature sign -> 1590 1590 - let sty = repr sign.csig_self in 1591 1591 + let sty = sign.csig_self in 1591 1592 let self_ty = 1592 1593 if is_aliased sty then 1593 1594 Some (Otyp_var (false, Names.name_of_type Names.new_name (proxy sty))) ··· 1624 1625 in 1625 1626 let tr = 1626 1627 if is_optional l then 1627 1627 - match (repr ty).desc with 1628 1628 + match get_desc ty with 1628 1629 | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> 1629 1630 tree_of_typexp mode ty 1630 1631 | _ -> Otyp_stuff "<hidden>" ··· 1640 1641 (match tree_of_typexp Type_scheme param with 1641 1642 Otyp_var (_, s) -> s 1642 1643 | _ -> "?"), 1643 1643 - if is_Tvar (repr param) then Asttypes.(NoVariance, NoInjectivity) 1644 1644 - else variance 1644 1644 + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) 1645 1645 + else variance 1645 1646 1646 1647 let class_variance = 1647 1648 let open Variance in let open Asttypes in ··· 1673 1674 !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) 1674 1675 1675 1676 let tree_of_cltype_declaration id cl rs = 1676 1676 - let params = List.map repr cl.clty_params in 1677 1677 + let params = cl.clty_params in 1677 1678 1678 1679 reset_except_context (); 1679 1680 List.iter add_alias params; ··· 1955 1956 (* Print a unification error *) 1956 1957 1957 1958 let same_path t t' = 1958 1958 - let t = repr t and t' = repr t' in 1959 1959 - t == t' || 1960 1960 - match t.desc, t'.desc with 1959 1959 + eq_type t t' || 1960 1960 + match get_desc t, get_desc t' with 1961 1961 Tconstr(p,tl,_), Tconstr(p',tl',_) -> 1962 1962 let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in 1963 1963 begin match s1, s2 with ··· 1965 1965 | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> 1966 1966 let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in 1967 1967 List.length tl = List.length tl' && 1968 1968 - List.for_all2 same_type tl tl' 1968 1968 + List.for_all2 eq_type tl tl' 1969 1969 | _ -> false 1970 1970 end 1971 1971 | _ -> ··· 2073 2073 2074 2074 (* Hide variant name and var, to force printing the expanded type *) 2075 2075 let hide_variant_name t = 2076 2076 - match repr t with 2077 2077 - | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> 2078 2078 - newty2 t.level 2076 2076 + match get_desc t with 2077 2077 + | Tvariant row when (row_repr row).row_name <> None -> 2078 2078 + newty2 ~level:(get_level t) 2079 2079 (Tvariant {(row_repr row) with row_name = None; 2080 2080 - row_more = newvar2 (row_more row).level}) 2080 2080 + row_more = newvar2 (get_level (row_more row))}) 2081 2081 | _ -> t 2082 2082 2083 2083 let prepare_expansion Errortrace.{ty; expanded} = ··· 2087 2087 Errortrace.{ty; expanded} 2088 2088 2089 2089 let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = 2090 2090 - match (repr expanded).desc with 2090 2090 + match get_desc expanded with 2091 2091 Tvariant _ | Tobject _ when compact -> 2092 2092 mark_loops ty; Errortrace.{ty; expanded = ty} 2093 2093 | _ -> prepare_expansion ty_exp ··· 2101 2101 Format.pp_print_list ~pp_sep:comma print_tag 2102 2102 2103 2103 let is_unit env ty = 2104 2104 - match (Ctype.expand_head env ty).desc with 2104 2104 + match get_desc (Ctype.expand_head env ty) with 2105 2105 | Tconstr (p, _, _) -> Path.same p Predef.path_unit 2106 2106 | _ -> false 2107 2107 ··· 2115 2115 res 2116 2116 2117 2117 let explanation_diff env t3 t4 : (Format.formatter -> unit) option = 2118 2118 - match t3.desc, t4.desc with 2118 2118 + match get_desc t3, get_desc t4 with 2119 2119 | Tarrow (_, ty1, ty2, _), _ 2120 2120 when is_unit env ty1 && unifiable env ty2 t4 -> 2121 2121 Some (fun ppf -> ··· 2245 2245 explain_object o 2246 2246 | Errortrace.Rec_occur(x,y) -> 2247 2247 reset_and_mark_loops y; 2248 2248 - begin match x.desc with 2248 2248 + begin match get_desc x with 2249 2249 | Tvar _ | Tunivar _ -> 2250 2250 Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]" 2251 2251 type_expr x type_expr y) ··· 2268 2268 | Some explain -> explain ppf 2269 2269 2270 2270 let warn_on_missing_def env ppf t = 2271 2271 - match t.desc with 2271 2271 + match get_desc t with 2272 2272 | Tconstr (p,_,_) -> 2273 2273 begin 2274 2274 try

+30 -31

typing/subst.ml

reviewed

··· 140 140 141 141 let newpersty desc = 142 142 decr new_id; 143 143 - Private_type_expr.create 143 143 + create_expr 144 144 desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id 145 145 146 146 (* ensure that all occurrences of 'Tvar None' are physically shared *) ··· 155 155 156 156 (* Similar to [Ctype.nondep_type_rec]. *) 157 157 let rec typexp copy_scope s ty = 158 158 - let ty = repr ty in 159 159 - match ty.desc with 160 160 - Tvar _ | Tunivar _ as desc -> 161 161 - if s.for_saving || ty.id < 0 then 158 158 + let desc = get_desc ty in 159 159 + match desc with 160 160 + Tvar _ | Tunivar _ -> 161 161 + if s.for_saving || get_id ty < 0 then 162 162 let ty' = 163 163 if s.for_saving then newpersty (norm desc) 164 164 - else newty2 ty.level desc 164 164 + else newty2 ~level:(get_level ty) desc 165 165 in 166 166 - For_copy.save_desc copy_scope ty desc; 167 167 - Private_type_expr.set_desc ty (Tsubst (ty', None)); 168 168 - (* TODO: move this line to btype.ml 169 169 - there is a similar problem also in ctype.ml *) 166 166 + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); 170 167 ty' 171 168 else ty 172 169 | Tsubst (ty, _) -> 173 170 ty 174 171 | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method 175 175 - && field_kind_repr k <> Fabsent && (repr ty).level < generic_level -> 172 172 + && field_kind_repr k <> Fabsent && get_level ty < generic_level -> 176 173 (* do not copy the type of self when it is not generalized *) 177 174 ty 178 175 (* cannot do it, since it would omit substitution ··· 180 177 ty 181 178 *) 182 179 | _ -> 183 183 - let desc = ty.desc in 184 184 - For_copy.save_desc copy_scope ty desc; 185 180 let tm = row_of_type ty in 186 181 let has_fixed_row = 187 182 not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in 188 183 (* Make a stub *) 189 189 - let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in 190 190 - Private_type_expr.set_scope ty' ty.scope; 191 191 - Private_type_expr.set_desc ty (Tsubst (ty', None)); 192 192 - Private_type_expr.set_desc ty' 193 193 - begin if has_fixed_row then 194 194 - match tm.desc with (* PR#7348 *) 184 184 + let ty' = 185 185 + if s.for_saving then newpersty (Tvar None) 186 186 + else newgenstub ~scope:(get_scope ty) 187 187 + in 188 188 + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); 189 189 + let desc = 190 190 + if has_fixed_row then 191 191 + match get_desc tm with (* PR#7348 *) 195 192 Tconstr (Pdot(m,i), tl, _abbrev) -> 196 193 let i' = String.sub i 0 (String.length i - 4) in 197 194 Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil) ··· 221 218 Tobject (t1', ref name') 222 219 | Tvariant row -> 223 220 let row = row_repr row in 224 224 - let more = repr row.row_more in 221 221 + let more = row.row_more in 222 222 + let mored = get_desc more in 225 223 (* We must substitute in a subtle way *) 226 224 (* Tsubst takes a tuple containing the row var and the variant *) 227 227 - begin match more.desc with 225 225 + begin match mored with 228 226 Tsubst (_, Some ty2) -> 229 227 (* This variant type has been already copied *) 230 230 - Private_type_expr.set_desc ty (Tsubst (ty2, None)); 231 231 - (* avoid Tlink in the new type *) 228 228 + (* Change the stub to avoid Tlink in the new type *) 229 229 + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); 232 230 Tlink ty2 233 231 | _ -> 234 232 let dup = 235 235 - s.for_saving || more.level = generic_level || static_row row || 236 236 - match more.desc with Tconstr _ -> true | _ -> false in 233 233 + s.for_saving || get_level more = generic_level || 234 234 + static_row row || is_Tconstr more in 237 235 (* Various cases for the row variable *) 238 236 let more' = 239 239 - match more.desc with 237 237 + match mored with 240 238 Tsubst (ty, None) -> ty 241 239 | Tconstr _ | Tnil -> typexp copy_scope s more 242 240 | Tunivar _ | Tvar _ -> 243 243 - For_copy.save_desc copy_scope more more.desc; 244 244 - if s.for_saving then newpersty (norm more.desc) else 245 245 - if dup && is_Tvar more then newgenty more.desc else more 241 241 + if s.for_saving then newpersty (norm mored) 242 242 + else if dup && is_Tvar more then newgenty mored 243 243 + else more 246 244 | _ -> assert false 247 245 in 248 246 (* Register new type first for recursion *) 249 249 - Private_type_expr.set_desc more 247 247 + For_copy.redirect_desc copy_scope more 250 248 (Tsubst (more', Some ty')); 251 249 (* TODO: check if more' can be eliminated *) 252 250 (* Return a new copy *) ··· 264 262 | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> 265 263 Tlink (typexp copy_scope s t2) 266 264 | _ -> copy_type_desc (typexp copy_scope s) desc 267 267 - end; 265 265 + in 266 266 + Transient_expr.set_stub_desc ty' desc; 268 267 ty' 269 268 270 269 (*

+15 -11

typing/typeclass.ml

reviewed

··· 716 716 let ty' = cty'.ctyp_type in 717 717 Ctype.unify val_env ty' ty 718 718 end; 719 719 - begin match (Ctype.repr ty).desc with 719 719 + begin match get_desc ty with 720 720 Tvar _ -> 721 721 let ty' = Ctype.newvar () in 722 722 Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; ··· 838 838 List.iter 839 839 (fun (lab,kind,ty) -> 840 840 let k = 841 841 - if Btype.field_kind_repr kind = Fpresent then Public else Private in 841 841 + if Types.field_kind_repr kind = Fpresent then Public else Private in 842 842 try Ctype.unify val_env ty 843 843 (Ctype.filter_method val_env lab k self_type) 844 844 with _ -> assert false) ··· 864 864 csig_inher = inher} in 865 865 let methods = get_methods self_type in 866 866 let priv_meths = 867 867 - List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) 867 867 + List.filter (fun (_,kind,_) -> Types.field_kind_repr kind <> Fpresent) 868 868 methods in 869 869 (* ensure that inherited methods are listed too *) 870 870 List.iter (fun (met, _kind, _ty) -> ··· 911 911 912 912 (* Check for private methods made public *) 913 913 let pub_meths' = 914 914 - List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent) 914 914 + List.filter (fun (_,kind,_) -> Types.field_kind_repr kind = Fpresent) 915 915 (get_methods public_self) in 916 916 let names = List.map (fun (x,_,_) -> x) in 917 917 let l1 = names priv_meths and l2 = names pub_meths' in ··· 1220 1220 Typetexp.widen context; 1221 1221 Ctype.end_def (); 1222 1222 1223 1223 - limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type)) 1224 1224 - cl.cl_type; 1225 1225 - limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) 1223 1223 + limited_generalize 1224 1224 + (Ctype.row_variable (Ctype.self_type cl.cl_type)) 1225 1225 + cl.cl_type; 1226 1226 + limited_generalize 1227 1227 + (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) 1226 1228 clty.cltyp_type; 1227 1229 1228 1230 begin match ··· 1444 1446 let (cl_params', cl_type) = Ctype.instance_class params typ in 1445 1447 let ty = Ctype.self_type cl_type in 1446 1448 Ctype.hide_private_methods ty; 1447 1447 - Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; 1449 1449 + Ctype.set_object_name 1450 1450 + obj_id (Ctype.row_variable ty) cl_params ty; 1448 1451 begin try 1449 1452 List.iter2 (Ctype.unify env) cl_params cl_params' 1450 1453 with Ctype.Unify _ -> ··· 1572 1575 Ctype.instance_parameterized_type params (Ctype.self_type typ) 1573 1576 in 1574 1577 Ctype.hide_private_methods cl_ty; 1575 1575 - Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; 1578 1578 + Ctype.set_object_name 1579 1579 + obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; 1576 1580 let cl_abbr = 1577 1581 let arity = List.length cl_params in 1578 1582 { ··· 1614 1618 in 1615 1619 List.iter (fun (lab,kind,_) -> 1616 1620 if lab = dummy_method then 1617 1617 - match Btype.field_kind_repr kind with 1618 1618 - Fvar r -> Btype.set_kind r Fabsent 1621 1621 + match Types.field_kind_repr kind with 1622 1622 + Fvar r -> Types.set_kind r Fabsent 1619 1623 | _ -> () 1620 1624 ) methods 1621 1625 end;

+87 -81

typing/typecore.ml

reviewed

··· 300 300 (type_option texp.exp_type) texp.exp_loc texp.exp_env 301 301 302 302 let extract_option_type env ty = 303 303 - match expand_head env ty with {desc = Tconstr(path, [ty], _)} 304 304 - when Path.same path Predef.path_option -> ty 303 303 + match get_desc (expand_head env ty) with 304 304 + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty 305 305 | _ -> assert false 306 306 307 307 type record_extraction_result = ··· 336 336 | Not_a_record_type | Maybe_a_record_type -> assert false 337 337 338 338 let is_principal ty = 339 339 - (repr ty).level = generic_level || not !Clflags.principal 339 339 + not !Clflags.principal || get_level ty = generic_level 340 340 341 341 (* Typing of patterns *) 342 342 ··· 388 388 (* unification of a type with a Tconstr with freshly created arguments *) 389 389 let unify_head_only ~refine loc env ty constr = 390 390 let path = 391 391 - match (repr constr.cstr_res).desc with 391 391 + match get_desc constr.cstr_res with 392 392 | Tconstr(p, _, _) -> p 393 393 | _ -> assert false in 394 394 let decl = Env.find_type path !env in ··· 399 399 (* make all Reither present in open variants *) 400 400 let finalize_variant pat tag opat r = 401 401 let row = 402 402 - match expand_head pat.pat_env pat.pat_type with 403 403 - {desc = Tvariant row} -> r := row; row_repr row 402 402 + match get_desc (expand_head pat.pat_env pat.pat_type) with 403 403 + Tvariant row -> r := row; row_repr row 404 404 | _ -> assert false 405 405 in 406 406 begin match row_field tag row with ··· 582 582 unify_pat env {p with pat_type = ty} ty_res; 583 583 let refinable = 584 584 lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && 585 585 - match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in 585 585 + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in 586 586 if refinable then begin 587 587 let arg = List.assoc lbl.lbl_pos ppl in 588 588 unify_pat env {arg with pat_type = build_as_type env arg} ty_arg ··· 612 612 let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in 613 613 unify_pat_types ~refine loc env ty (instance expected_ty); 614 614 pattern_force := force :: !pattern_force; 615 615 - match ty.desc with 615 615 + match get_desc ty with 616 616 | Tpoly (body, tyl) -> 617 617 begin_def (); 618 618 init_def generic_level; ··· 661 661 [ty2] 662 662 | _ -> 663 663 unify_pat_types cty.ctyp_loc env ty1 (newty (Ttuple ty_args)); 664 664 - match repr (expand_head !env ty2) with 665 665 - {desc = Ttuple tyl} -> tyl 664 664 + match get_desc (expand_head !env ty2) with 665 665 + Ttuple tyl -> tyl 666 666 | _ -> assert false 667 667 in 668 668 if ids <> [] then ignore begin ··· 670 670 let rem = 671 671 List.fold_left 672 672 (fun rem tv -> 673 673 - match repr tv with 674 674 - {desc = Tconstr(Path.Pident id, [], _)} 675 675 - when List.mem id rem -> 673 673 + match get_desc tv with 674 674 + Tconstr(Path.Pident id, [], _) when List.mem id rem -> 676 675 list_remove id rem 677 676 | _ -> 678 677 raise (Error (cty.ctyp_loc, !env, ··· 805 804 let tyl = List.map (fun _ -> newvar()) decl.type_params in 806 805 let row0 = 807 806 let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in 808 808 - match ty.desc with 807 807 + match get_desc ty with 809 808 Tvariant row when static_row row -> row 810 809 | _ -> raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) 811 810 in ··· 872 871 in 873 872 match decl with 874 873 Some {type_manifest = Some ty} -> 875 875 - begin match repr ty with 876 876 - {desc=Tconstr(p,_,_)} -> expand_path env p 874 874 + begin match get_desc ty with 875 875 + Tconstr(p,_,_) -> expand_path env p 877 876 | _ -> assert false 878 877 end 879 878 | _ -> ··· 887 886 exception Wrong_name_disambiguation of Env.t * wrong_name 888 887 889 888 let get_constr_type_path ty = 890 890 - match (repr ty).desc with 889 889 + match get_desc ty with 891 890 | Tconstr(p, _, _) -> p 892 891 | _ -> assert false 893 892 ··· 1484 1483 No variable information, as we only backtrack on 1485 1484 patterns without variables (cf. assert statements). *) 1486 1485 type state = 1487 1487 - { snapshot: Btype.snapshot; 1486 1486 + { snapshot: snapshot; 1488 1487 levels: Ctype.levels; 1489 1488 env: Env.t; } 1490 1489 let save_state env = ··· 2497 2496 (* List labels in a function type, and whether return type is a variable *) 2498 2497 let rec list_labels_aux env visited ls ty_fun = 2499 2498 let ty = expand_head env ty_fun in 2500 2500 - if List.memq ty visited then 2499 2499 + if TypeSet.mem ty visited then 2501 2500 List.rev ls, false 2502 2502 - else match ty.desc with 2501 2501 + else match get_desc ty with 2503 2502 Tarrow (l, _, ty_res, _) -> 2504 2504 - list_labels_aux env (ty::visited) (l::ls) ty_res 2503 2503 + list_labels_aux env (TypeSet.add ty visited) (l::ls) ty_res 2505 2504 | _ -> 2506 2505 List.rev ls, is_Tvar ty 2507 2506 2508 2507 let list_labels env ty = 2509 2509 - wrap_trace_gadt_instances env (list_labels_aux env [] []) ty 2508 2508 + wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty 2510 2509 2511 2510 (* Check that all univars are safe in a type. Both exp.exp_type and 2512 2511 ty_expected should already be generalized. *) ··· 2514 2513 let pty = instance ty_expected in 2515 2514 begin_def (); 2516 2515 let exp_ty, vars = 2517 2517 - match pty.desc with 2516 2516 + match get_desc pty with 2518 2517 Tpoly (body, tl) -> 2519 2518 (* Enforce scoping for type_let: 2520 2519 since body is not generic, instance_poly only makes ··· 2546 2545 2547 2546 let check_partial_application statement exp = 2548 2547 let rec f delay = 2549 2549 - let ty = (expand_head exp.exp_env exp.exp_type).desc in 2548 2548 + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in 2550 2549 let check_statement () = 2551 2550 match ty with 2552 2551 | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ··· 2616 2615 (* Check that a type is generalizable at some level *) 2617 2616 let generalizable level ty = 2618 2617 let rec check ty = 2619 2619 - let ty = repr ty in 2620 2618 if not_marked_node ty then 2621 2621 - if ty.level <= level then raise Exit else 2619 2619 + if get_level ty <= level then raise Exit else 2622 2620 (flip_mark_node ty; iter_type_expr check ty) 2623 2621 in 2624 2622 try check ty; unmark_type ty; true ··· 2631 2629 2632 2630 let contains_variant_either ty = 2633 2631 let rec loop ty = 2634 2634 - let ty = repr ty in 2635 2632 if try_mark_node ty then 2636 2636 - begin match ty.desc with 2633 2633 + begin match get_desc ty with 2637 2634 Tvariant row -> 2638 2635 let row = row_repr row in 2639 2636 if not (is_fixed row) then ··· 2853 2850 Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), 2854 2851 "format6")) 2855 2852 in 2856 2856 - let is_format = match ty_exp.desc with 2853 2853 + let is_format = match get_desc ty_exp with 2857 2854 | Tconstr(path, _, _) when Path.same path fmt6_path -> 2858 2858 - if !Clflags.principal && ty_exp.level <> generic_level then 2855 2855 + if !Clflags.principal && get_level ty_exp <> generic_level then 2859 2856 Location.prerr_warning loc 2860 2857 (Warnings.Not_principal "this coercion to format6"); 2861 2858 true ··· 2953 2950 assert (sargs <> []); 2954 2951 let rec lower_args seen ty_fun = 2955 2952 let ty = expand_head env ty_fun in 2956 2956 - if List.memq ty seen then () else 2957 2957 - match ty.desc with 2953 2953 + if TypeSet.mem ty seen then () else 2954 2954 + match get_desc ty with 2958 2955 Tarrow (_l, ty_arg, ty_fun, _com) -> 2959 2956 (try unify_var env (newvar()) ty_arg 2960 2957 with Unify _ -> assert false); 2961 2961 - lower_args (ty::seen) ty_fun 2958 2958 + lower_args (TypeSet.add ty seen) ty_fun 2962 2959 | _ -> () 2963 2960 in 2964 2961 let type_sfunct sfunct = ··· 2971 2968 end; 2972 2969 let ty = instance funct.exp_type in 2973 2970 end_def (); 2974 2974 - wrap_trace_gadt_instances env (lower_args []) ty; 2971 2971 + wrap_trace_gadt_instances env (lower_args TypeSet.empty) ty; 2975 2972 funct 2976 2973 in 2977 2974 let funct, sargs = ··· 3052 3049 (* Keep sharing *) 3053 3050 let ty_expected0 = instance ty_expected in 3054 3051 begin try match 3055 3055 - sarg, expand_head env ty_expected, expand_head env ty_expected0 with 3056 3056 - | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> 3052 3052 + sarg, get_desc (expand_head env ty_expected), 3053 3053 + get_desc (expand_head env ty_expected0) 3054 3054 + with 3055 3055 + | Some sarg, Tvariant row, Tvariant row0 -> 3057 3056 let row = row_repr row and row0 = row_repr row0 in 3058 3057 begin match row_field_repr (List.assoc l row.row_fields), 3059 3058 row_field_repr (List.assoc l row0.row_fields) with ··· 3370 3369 let arg = type_exp env sarg in 3371 3370 end_def (); 3372 3371 let tv = newvar () in 3373 3373 - let gen = generalizable tv.level arg.exp_type in 3372 3372 + let gen = generalizable (get_level tv) arg.exp_type in 3374 3373 unify_var env tv arg.exp_type; 3375 3375 - begin match arg.exp_desc, !self_coercion, (repr ty').desc with 3374 3374 + begin match arg.exp_desc, !self_coercion, get_desc ty' with 3376 3375 Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _, 3377 3376 Tconstr(path',_,_) when Path.same path path' -> 3378 3377 (* prerr_endline "self coercion"; *) ··· 3448 3447 let (id, typ) = 3449 3448 filter_self_method env met Private meths privty 3450 3449 in 3451 3451 - if is_Tvar (repr typ) then 3450 3450 + if is_Tvar typ then 3452 3451 Location.prerr_warning loc 3453 3452 (Warnings.Undeclared_virtual_method met); 3454 3453 (Tmeth_val id, None, typ) ··· 3518 3517 generalize_structure typ; 3519 3518 end; 3520 3519 let typ = 3521 3521 - match repr typ with 3522 3522 - {desc = Tpoly (ty, [])} -> 3520 3520 + match get_desc typ with 3521 3521 + Tpoly (ty, []) -> 3523 3522 instance ty 3524 3524 - | {desc = Tpoly (ty, tl); level = l} -> 3525 3525 - if !Clflags.principal && l <> generic_level then 3523 3523 + | Tpoly (ty, tl) -> 3524 3524 + if !Clflags.principal && get_level typ <> generic_level then 3526 3525 Location.prerr_warning loc 3527 3526 (Warnings.Not_principal "this use of a polymorphic method"); 3528 3527 snd (instance_poly false tl ty) 3529 3529 - | {desc = Tvar _} as ty -> 3528 3528 + | Tvar _ -> 3530 3529 let ty' = newvar () in 3531 3531 - unify env (instance ty) (newty(Tpoly(ty',[]))); 3530 3530 + unify env (instance typ) (newty(Tpoly(ty',[]))); 3532 3531 (* if not !Clflags.nolabels then 3533 3532 Location.prerr_warning loc (Warnings.Unknown_method met); *) 3534 3533 ty' ··· 3555 3554 Some 3556 3555 (Meths.fold (fun meth _meth_ty li -> meth::li) !meths []) 3557 3556 | None -> 3558 3558 - match (expand_head env obj.exp_type).desc with 3557 3557 + match get_desc (expand_head env obj.exp_type) with 3559 3558 | Tobject (fields, _) -> 3560 3559 let (fields, _) = Ctype.flatten_fields fields in 3561 3560 let collect_fields li (meth, meth_kind, _meth_ty) = ··· 3648 3647 begin_def (); 3649 3648 let context = Typetexp.narrow () in 3650 3649 let modl = !type_module env smodl in 3651 3651 - Mtype.lower_nongen ty.level modl.mod_type; 3650 3650 + Mtype.lower_nongen (get_level ty) modl.mod_type; 3652 3651 let pres = 3653 3652 match modl.mod_type with 3654 3653 | Mty_alias _ -> Mp_absent ··· 3733 3732 | Pexp_poly(sbody, sty) -> 3734 3733 if !Clflags.principal then begin_def (); 3735 3734 let ty, cty = 3736 3736 - match sty with None -> repr ty_expected, None 3735 3735 + match sty with None -> ty_expected, None 3737 3736 | Some sty -> 3738 3737 let sty = Ast_helper.Typ.force_poly sty in 3739 3738 let cty = Typetexp.transl_simple_type env false sty in 3740 3740 - repr cty.ctyp_type, Some cty 3739 3739 + cty.ctyp_type, Some cty 3741 3740 in 3742 3741 if !Clflags.principal then begin 3743 3742 end_def (); ··· 3747 3746 with_explanation (fun () -> 3748 3747 unify_exp_types loc env (instance ty) (instance ty_expected)); 3749 3748 let exp = 3750 3750 - match (expand_head env ty).desc with 3749 3749 + match get_desc (expand_head env ty) with 3751 3750 Tpoly (ty', []) -> 3752 3751 let exp = type_expect env sbody (mk_expected ty') in 3753 3752 { exp with exp_type = instance ty } ··· 3792 3791 type. *) 3793 3792 let seen = Hashtbl.create 8 in 3794 3793 let rec replace t = 3795 3795 - if Hashtbl.mem seen t.id then () 3794 3794 + if Hashtbl.mem seen (get_id t) then () 3796 3795 else begin 3797 3797 - Hashtbl.add seen t.id (); 3798 3798 - match t.desc with 3796 3796 + Hashtbl.add seen (get_id t) (); 3797 3797 + match get_desc t with 3799 3798 | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty 3800 3799 | _ -> Btype.iter_type_expr replace t 3801 3800 end ··· 3814 3813 (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } 3815 3814 | Pexp_pack m -> 3816 3815 let (p, fl) = 3817 3817 - match Ctype.expand_head env (instance ty_expected) with 3818 3818 - {desc = Tpackage (p, fl)} -> 3816 3816 + match get_desc (Ctype.expand_head env (instance ty_expected)) with 3817 3817 + Tpackage (p, fl) -> 3819 3818 if !Clflags.principal && 3820 3820 - (Ctype.expand_head env ty_expected).level < Btype.generic_level 3819 3819 + get_level (Ctype.expand_head env ty_expected) 3820 3820 + < Btype.generic_level 3821 3821 then 3822 3822 Location.prerr_warning loc 3823 3823 (Warnings.Not_principal "this module packing"); 3824 3824 (p, fl) 3825 3825 - | {desc = Tvar _} -> 3825 3825 + | Tvar _ -> 3826 3826 raise (Error (loc, env, Cannot_infer_signature)) 3827 3827 | _ -> 3828 3828 raise (Error (loc, env, Not_a_packed_module ty_expected)) ··· 3952 3952 and type_ident env ?(recarg=Rejected) lid = 3953 3953 let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in 3954 3954 let is_recarg = 3955 3955 - match (repr desc.val_type).desc with 3955 3955 + match get_desc desc.val_type with 3956 3956 | Tconstr(p, _, _) -> Path.is_constructor_typath p 3957 3957 | _ -> false 3958 3958 in 3959 3959 - begin match is_recarg, recarg, (repr desc.val_type).desc with 3959 3959 + begin match is_recarg, recarg, get_desc desc.val_type with 3960 3960 | _, Allowed, _ 3961 3961 | true, Required, _ 3962 3962 | false, Rejected, _ -> () ··· 4381 4381 let may_coerce = 4382 4382 if not (is_inferred sarg) then None else 4383 4383 let work () = 4384 4384 - match expand_head env ty_expected' with 4385 4385 - {desc = Tarrow(Nolabel,_,ty_res0,_); level} -> 4386 4386 - Some (no_labels ty_res0, level) 4384 4384 + let te = expand_head env ty_expected' in 4385 4385 + match get_desc te with 4386 4386 + Tarrow(Nolabel,_,ty_res0,_) -> 4387 4387 + Some (no_labels ty_res0, get_level te) 4387 4388 | _ -> None 4388 4389 in 4389 4390 (* Need to be careful not to expand local constraints here *) ··· 4403 4404 generalize_structure texp.exp_type 4404 4405 end; 4405 4406 let rec make_args args ty_fun = 4406 4406 - match (expand_head env ty_fun).desc with 4407 4407 + match get_desc (expand_head env ty_fun) with 4407 4408 | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> 4408 4409 let ty = option_none env (instance ty_arg) sarg.pexp_loc in 4409 4410 make_args ((l, Some ty) :: args) ty_fun ··· 4419 4420 texp 4420 4421 end else begin 4421 4422 let warn = !Clflags.principal && 4422 4422 - (lv <> generic_level || (repr ty_fun').level <> generic_level) 4423 4423 + (lv <> generic_level || get_level ty_fun' <> generic_level) 4423 4424 and ty_fun = instance ty_fun' in 4424 4425 let ty_arg, ty_res = 4425 4425 - match expand_head env ty_expected' with 4426 4426 - {desc = Tarrow(Nolabel,ty_arg,ty_res,_)} -> ty_arg, ty_res 4426 4426 + match get_desc (expand_head env ty_expected') with 4427 4427 + Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res 4427 4428 | _ -> assert false 4428 4429 in 4429 4430 unify_exp env {texp with exp_type = ty_fun} ty_expected; ··· 4485 4486 (* funct.exp_type may be generic *) 4486 4487 let result_type omitted ty_fun = 4487 4488 List.fold_left 4488 4488 - (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok))) 4489 4489 + (fun ty_fun (l,ty,lv) -> newty2 ~level:lv (Tarrow(l,ty,ty_fun,Cok))) 4489 4490 ty_fun omitted 4490 4491 in 4491 4492 let has_label l ty_fun = ··· 4497 4498 let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) = 4498 4499 let (ty_arg, ty_res) = 4499 4500 let ty_fun = expand_head env ty_fun in 4500 4500 - match ty_fun.desc with 4501 4501 + match get_desc ty_fun with 4501 4502 | Tvar _ -> 4502 4503 let t1 = newvar () and t2 = newvar () in 4503 4503 - if ty_fun.level >= t1.level && 4504 4504 + if get_level ty_fun >= get_level t1 && 4504 4505 not (is_prim ~name:"%identity" funct) 4505 4506 then 4506 4507 Location.prerr_warning sarg.pexp_loc ··· 4516 4517 result_type (!omitted_parameters @ !eliminated_optional_arguments) 4517 4518 ty_fun 4518 4519 in 4519 4519 - match ty_res.desc with 4520 4520 + match get_desc ty_res with 4520 4521 | Tarrow _ -> 4521 4522 if !Clflags.classic || not (has_label lbl ty_fun) then 4522 4523 raise (Error(sarg.pexp_loc, env, ··· 4554 4555 in 4555 4556 let warned = ref false in 4556 4557 let rec type_args args ty_fun ty_fun0 sargs = 4557 4557 - match expand_head env ty_fun, expand_head env ty_fun0 with 4558 4558 - | {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun', 4559 4559 - {desc=Tarrow (_, ty0, ty_fun0, _)} 4558 4558 + let ty_fun' = expand_head env ty_fun in 4559 4559 + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with 4560 4560 + | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) 4560 4561 when sargs <> [] && commu_repr com = Cok -> 4562 4562 + let lv = get_level ty_fun' in 4561 4563 let may_warn loc w = 4562 4564 if not !warned && !Clflags.principal && lv <> generic_level 4563 4565 then begin ··· 4760 4762 let exp = type_exp env sexp in 4761 4763 end_def(); 4762 4764 let ty = expand_head env exp.exp_type and tv = newvar() in 4763 4763 - if is_Tvar ty && ty.level > tv.level then 4765 4765 + if is_Tvar ty && get_level ty > get_level tv then 4764 4766 Location.prerr_warning 4765 4767 (final_subexpression exp).exp_loc 4766 4768 Warnings.Nonreturning_statement; ··· 4791 4793 (mkloc (Longident.Lident unpack.tu_name.txt) 4792 4794 unpack.tu_name.loc))) 4793 4795 in 4794 4794 - Mtype.lower_nongen ty.level modl.mod_type; 4796 4796 + Mtype.lower_nongen (get_level ty) modl.mod_type; 4795 4797 let pres = 4796 4798 match modl.mod_type with 4797 4799 | Mty_alias _ -> Mp_absent ··· 5108 5110 List.iter2 5109 5111 (fun pat binding -> 5110 5112 let pat = 5111 5111 - match pat.pat_type.desc with 5113 5113 + match get_desc pat.pat_type with 5112 5114 | Tpoly (ty, tl) -> 5113 5115 {pat with pat_type = 5114 5116 snd (instance_poly ~keep_names:true false tl ty)} ··· 5233 5235 List.map2 5234 5236 (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) -> 5235 5237 if is_recursive then current_slot := slot; 5236 5236 - match pat.pat_type.desc with 5238 5238 + match get_desc pat.pat_type with 5237 5239 | Tpoly (ty, tl) -> 5238 5240 if !Clflags.principal then begin_def (); 5239 5241 let vars, ty' = instance_poly ~keep_names:true true tl ty in ··· 5457 5459 | _, _ -> [] 5458 5460 5459 5461 let report_literal_type_constraint const = function 5460 5460 - | Some Errortrace.{ expected = { ty = { desc = Tconstr (typ, [], _) } } } -> 5461 5461 - report_literal_type_constraint typ const 5462 5462 - | Some _ | None -> [] 5462 5462 + | Some tr -> 5463 5463 + begin match get_desc Errortrace.(tr.expected.ty) with 5464 5464 + Tconstr (typ, [], _) -> 5465 5465 + report_literal_type_constraint typ const 5466 5466 + | _ -> [] 5467 5467 + end 5468 5468 + | None -> [] 5463 5469 5464 5470 let report_expr_type_clash_hints exp diff = 5465 5471 match exp with ··· 5559 5565 (function ppf -> 5560 5566 fprintf ppf "but an expression was expected of type"); 5561 5567 | Apply_non_function typ -> 5562 5562 - begin match (repr typ).desc with 5568 5568 + begin match get_desc typ with 5563 5569 Tarrow _ -> 5564 5570 Location.errorf ~loc 5565 5571 "@[<v>@[<2>This function has type@ %a@]\

+37 -38

typing/typedecl.ml

reviewed

··· 142 142 (* Determine if a type's values are represented by floats at run-time. *) 143 143 let is_float env ty = 144 144 match get_unboxed_type_representation env ty with 145 145 - Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float 145 145 + Some ty' -> 146 146 + begin match get_desc ty' with 147 147 + Tconstr(p, _, _) -> Path.same p Predef.path_float 148 148 + | _ -> false 149 149 + end 146 150 | _ -> false 147 151 148 152 (* Determine if a type definition defines a fixed type. (PW) *) ··· 174 178 | Some t -> Ctype.expand_head env t 175 179 in 176 180 let rv = 177 177 - match tm.desc with 181 181 + match get_desc tm with 178 182 Tvariant row -> 179 183 let row = Btype.row_repr row in 180 180 - Btype.set_type_desc tm 184 184 + set_type_desc tm 181 185 (Tvariant {row with row_fixed = Some Fixed_private}); 182 186 if Btype.static_row row then 183 187 (* the syntax hinted at the existence of a row variable, ··· 193 197 r 194 198 | _ -> assert false 195 199 in 196 196 - Btype.set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil)) 200 200 + set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil)) 197 201 198 202 (* Translate one type declaration *) 199 203 ··· 231 235 List.map 232 236 (fun ld -> 233 237 let ty = ld.ld_type.ctyp_type in 234 234 - let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in 238 238 + let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in 235 239 {Types.ld_id = ld.ld_id; 236 240 ld_mutable = ld.ld_mutable; 237 241 ld_type = ty; ··· 271 275 let tret_type = transl_simple_type env false sret_type in 272 276 let ret_type = tret_type.ctyp_type in 273 277 (* TODO add back type_path as a parameter ? *) 274 274 - begin match (Ctype.repr ret_type).desc with 278 278 + begin match get_desc ret_type with 275 279 | Tconstr (p', _, _) when Path.same type_path p' -> () 276 280 | _ -> 277 281 let trace = ··· 480 484 module TypeMap = Btype.TypeMap 481 485 482 486 let rec check_constraints_rec env loc visited ty = 483 483 - let ty = Ctype.repr ty in 484 487 if TypeSet.mem ty !visited then () else begin 485 488 visited := TypeSet.add ty !visited; 486 486 - match ty.desc with 489 489 + match get_desc ty with 487 490 | Tconstr (path, args, _) -> 488 491 let decl = 489 492 try Env.find_type path env ··· 586 589 match decl with 587 590 { type_kind = (Type_variant _ | Type_record _| Type_open); 588 591 type_manifest = Some ty } -> 589 589 - begin match (Ctype.repr ty).desc with 592 592 + begin match get_desc ty with 590 593 Tconstr(path, args, _) -> 591 594 begin try 592 595 let decl' = Env.find_type path env in ··· 624 627 let check_well_founded env loc path to_check ty = 625 628 let visited = ref TypeMap.empty in 626 629 let rec check ty0 parents ty = 627 627 - let ty = Btype.repr ty in 628 630 if TypeSet.mem ty parents then begin 629 631 (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) 630 630 - if match ty0.desc with 632 632 + if match get_desc ty0 with 631 633 | Tconstr (p, _, _) -> Path.same p path 632 634 | _ -> false 633 635 then raise (Error (loc, Recursive_abbrev (Path.name path))) ··· 643 645 in 644 646 if fini then () else 645 647 let rec_ok = 646 646 - match ty.desc with 648 648 + match get_desc ty with 647 649 Tconstr(p,_,_) -> 648 650 !Clflags.recursive_types && Ctype.is_contractive env p 649 651 | Tobject _ | Tvariant _ -> true ··· 660 662 with e -> 661 663 visited := visited'; Some e 662 664 in 663 663 - match ty.desc with 665 665 + match get_desc ty with 664 666 | Tconstr(p, _, _) when arg_exn <> None || to_check p -> 665 667 if to_check p then Option.iter raise arg_exn 666 668 else Btype.iter_type_expr (check ty0 TypeSet.empty) ty; ··· 699 701 700 702 if decl.type_params = [] then () else 701 703 702 702 - let visited = ref [] in 704 704 + let visited = ref TypeSet.empty in 703 705 704 706 let rec check_regular cpath args prev_exp prev_expansions ty = 705 705 - let ty = Ctype.repr ty in 706 706 - if not (List.memq ty !visited) then begin 707 707 - visited := ty :: !visited; 708 708 - match ty.desc with 707 707 + if not (TypeSet.mem ty !visited) then begin 708 708 + visited := TypeSet.add ty !visited; 709 709 + match get_desc ty with 709 710 | Tconstr(path', args', _) -> 710 711 if Path.same path path' then begin 711 712 if not (Ctype.is_equal orig_env false args args') then ··· 799 800 | { type_kind = Type_abstract; 800 801 type_manifest = Some ty; 801 802 type_private = Private; } when is_fixed_type sdecl -> 802 802 - let ty = Ctype.repr ty in 803 803 - let ty' = Btype.newty2 ty.level ty.desc in 803 803 + let ty' = newty2 ~level:(get_level ty) (get_desc ty) in 804 804 if Ctype.deep_occur ty ty' then 805 805 let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in 806 806 - Btype.link_type ty (Btype.newty2 ty.level td); 806 806 + link_type ty (newty2 ~level:(get_level ty) td); 807 807 {decl with type_manifest = Some ty'} 808 808 else decl 809 809 | _ -> decl ··· 1008 1008 let vars = 1009 1009 Ctype.free_variables (Btype.newgenty (Ttuple args)) 1010 1010 in 1011 1011 - List.iter 1012 1012 - (function {desc = Tvar (Some "_")} as ty 1013 1013 - when List.memq ty vars -> 1014 1014 - Btype.set_type_desc ty (Tvar None) 1015 1015 - | _ -> ()) 1016 1016 - typext_params 1011 1011 + List.iter 1012 1012 + (fun ty -> 1013 1013 + if get_desc ty = Tvar (Some "_") 1014 1014 + && List.exists (eq_type ty) vars 1015 1015 + then set_type_desc ty (Tvar None)) 1016 1016 + typext_params 1017 1017 end; 1018 1018 (* Ensure that constructor's type matches the type being extended *) 1019 1019 let cstr_type_path, cstr_type_params = 1020 1020 - match cdescr.cstr_res.desc with 1020 1020 + match get_desc cdescr.cstr_res with 1021 1021 Tconstr (p, _, _) -> 1022 1022 let decl = Env.find_type p env in 1023 1023 p, decl.type_params ··· 1054 1054 Types.Cstr_tuple args 1055 1055 | Some decl -> 1056 1056 let tl = 1057 1057 - match args with 1058 1058 - | [ {desc=Tconstr(_, tl, _)} ] -> tl 1057 1057 + match List.map get_desc args with 1058 1058 + | [ Tconstr(_, tl, _) ] -> tl 1059 1059 | _ -> assert false 1060 1060 in 1061 1061 let decl = Ctype.instance_declaration decl in ··· 1268 1268 raise (Error (loc, Multiple_native_repr_attributes)) 1269 1269 1270 1270 let native_repr_of_type env kind ty = 1271 1271 - match kind, (Ctype.expand_head_opt env ty).desc with 1271 1271 + match kind, get_desc (Ctype.expand_head_opt env ty) with 1272 1272 | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int -> 1273 1273 Some Untagged_int 1274 1274 | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> ··· 1314 1314 end 1315 1315 1316 1316 let rec parse_native_repr_attributes env core_type ty ~global_repr = 1317 1317 - match core_type.ptyp_desc, (Ctype.repr ty).desc, 1317 1317 + match core_type.ptyp_desc, get_desc ty, 1318 1318 get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None 1319 1319 with 1320 1320 | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind -> ··· 1331 1331 1332 1332 let check_unboxable env loc ty = 1333 1333 let check_type acc ty : Path.Set.t = 1334 1334 - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in 1335 1335 - try match ty.desc with 1334 1334 + let ty = Ctype.expand_head_opt env ty in 1335 1335 + try match get_desc ty with 1336 1336 | Tconstr (p, _, _) -> 1337 1337 let tydecl = Env.find_type p env in 1338 1338 if tydecl.type_unboxed_default then ··· 1636 1636 let explain_unbound_single ppf tv ty = 1637 1637 let trivial ty = 1638 1638 explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in 1639 1639 - match (Ctype.repr ty).desc with 1639 1639 + match get_desc ty with 1640 1640 Tobject(fi,_) -> 1641 1641 let (tl, rv) = Ctype.flatten_fields fi in 1642 1642 - if rv == tv then trivial ty else 1642 1642 + if eq_type rv tv then trivial ty else 1643 1643 explain_unbound ppf tv tl (fun (_,_,t) -> t) 1644 1644 "method" (fun (lab,_,_) -> lab ^ ": ") 1645 1645 | Tvariant row -> 1646 1646 let row = Btype.row_repr row in 1647 1647 - if row.row_more == tv then trivial ty else 1647 1647 + if eq_type row.row_more tv then trivial ty else 1648 1648 explain_unbound ppf tv row.row_fields 1649 1649 (fun (_l,f) -> match Btype.row_field_repr f with 1650 1650 Rpresent (Some t) -> t ··· 1747 1747 for native-code compilation@]" 1748 1748 | Unbound_type_var (ty, decl) -> 1749 1749 fprintf ppf "@[A type variable is unbound in this type declaration"; 1750 1750 - let ty = Ctype.repr ty in 1751 1750 begin match decl.type_kind, decl.type_manifest with 1752 1751 | Type_variant (tl, _rep), _ -> 1753 1752 explain_unbound_gen ppf ty tl (fun c ->

+2 -1

typing/typedecl.mli

reviewed

··· 59 59 val is_fixed_type : Parsetree.type_declaration -> bool 60 60 61 61 (* for typeopt.ml *) 62 62 - val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option 62 62 + val get_unboxed_type_representation: 63 63 + Env.t -> type_expr -> type_expr option 63 64 64 65 type native_repr_kind = Unboxed | Untagged 65 66

+14 -17

typing/typedecl_separability.ml

reviewed

··· 63 63 let params = 64 64 match def.type_kind with 65 65 | Type_variant ([{cd_res = Some ret_type}], _) -> 66 66 - begin match Ctype.repr ret_type with 67 67 - | {desc=Tconstr (_, tyl, _)} -> 68 68 - List.map Ctype.repr tyl 66 66 + begin match get_desc ret_type with 67 67 + | Tconstr (_, tyl, _) -> tyl 69 68 | _ -> assert false 70 69 end 71 70 | _ -> def.type_params ··· 128 127 parameters as well as the subtype 129 128 - it performs a shallow traversal of object types, 130 129 while our implementation collects all method types *) 131 131 - match (Ctype.repr ty).desc with 130 130 + match get_desc ty with 132 131 (* these are the important cases, 133 132 on which immediate_subtypes is called from [check_type] *) 134 133 | Tarrow(_,ty1,ty2,_) -> ··· 156 155 | Tpoly (pty, _) -> [pty] 157 156 | Tconstr (_path, tys, _) -> tys 158 157 159 159 - and immediate_subtypes_object_row acc ty = match (Ctype.repr ty).desc with 158 158 + and immediate_subtypes_object_row acc ty = match get_desc ty with 160 159 | Tnil -> acc 161 160 | Tfield (_label, _kind, ty, rest) -> 162 161 let acc = ty :: acc in ··· 169 168 immediate_subtypes_variant_row_field acc rf in 170 169 List.fold_left add_subtype acc desc.row_fields in 171 170 let add_row acc = 172 172 - let row = Ctype.repr desc.row_more in 173 173 - match row.desc with 171 171 + let row = Btype.row_more desc in 172 172 + match get_desc row with 174 173 | Tvariant more -> immediate_subtypes_variant_row acc more 175 174 | _ -> row :: acc 176 175 in ··· 188 187 end 189 188 190 189 let free_variables ty = 191 191 - Ctype.free_variables (Ctype.repr ty) 192 192 - |> List.map (fun {desc; id; _} -> 193 193 - match desc with 194 194 - | Tvar text -> {text; id} 190 190 + Ctype.free_variables ty 191 191 + |> List.map (fun ty -> 192 192 + match get_desc ty with 193 193 + Tvar text -> {text; id = get_id ty} 195 194 | _ -> 196 195 (* Ctype.free_variables only returns Tvar nodes *) 197 196 assert false) ··· 393 392 : Env.t -> type_expr -> mode -> context 394 393 = fun env ty m -> 395 394 let rec check_type hyps ty m = 396 396 - let ty = Ctype.repr ty in 397 395 if Hyps.safe ty m hyps then empty 398 396 else if Hyps.unsafe ty m hyps then worst_case ty 399 397 else 400 398 let hyps = Hyps.add ty m hyps in 401 401 - match (ty.desc, m) with 399 399 + match (get_desc ty, m) with 402 400 (* Impossible case due to the call to [Ctype.repr]. *) 403 401 | (Tlink _ , _ ) -> assert false 404 402 (* Impossible case (according to comment in [typing/types.mli]. *) ··· 407 405 | (_ , Ind ) -> empty 408 406 (* Variable case, add constraint. *) 409 407 | (Tvar(alpha) , m ) -> 410 410 - TVarMap.singleton {text = alpha; id = ty.Types.id} m 408 408 + TVarMap.singleton {text = alpha; id = get_id ty} m 411 409 (* "Separable" case for constructors with known memory representation. *) 412 410 | (Tarrow _ , Sep ) 413 411 | (Ttuple _ , Sep ) ··· 535 533 we build a list of modes by repeated consing into 536 534 an accumulator variable [acc], setting existential variables 537 535 to Ind as we go. *) 538 538 - let param_instance = Ctype.repr param_instance in 539 536 let get context var = 540 537 try TVarMap.find var context with Not_found -> Ind in 541 538 let set_ind context var = ··· 543 540 let is_ind context var = match get context var with 544 541 | Ind -> true 545 542 | Sep | Deepsep -> false in 546 546 - match param_instance.desc with 543 543 + match get_desc param_instance with 547 544 | Tvar text -> 548 548 - let var = {text; id = param_instance.Types.id} in 545 545 + let var = {text; id = get_id param_instance} in 549 546 (get context var) :: acc, (set_ind context var) 550 547 | _ -> 551 548 let instance_exis = free_variables param_instance in

+3 -3

typing/typedecl_unboxed.ml

reviewed

··· 25 25 to the manifest type of private abbreviations. *) 26 26 let rec get_unboxed_type_representation env ty fuel = 27 27 if fuel < 0 then Unavailable else 28 28 - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in 29 29 - match ty.desc with 28 28 + let ty = Ctype.expand_head_opt env ty in 29 29 + match get_desc ty with 30 30 | Tconstr (p, args, _) -> 31 31 begin match Env.find_type p env with 32 32 | exception Not_found -> This ty ··· 40 40 | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], 41 41 Variant_unboxed)} 42 42 -> 43 43 - let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in 43 43 + let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in 44 44 get_unboxed_type_representation env 45 45 (Ctype.apply env type_params ty2 args) (fuel - 1) 46 46 | _ -> This ty

+11 -14

typing/typedecl_variance.ml

reviewed

··· 43 43 let compute_variance env visited vari ty = 44 44 let rec compute_variance_rec vari ty = 45 45 (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) 46 46 - let ty = Ctype.repr ty in 47 46 let vari' = get_variance ty visited in 48 47 if Variance.subset vari vari' then () else 49 48 let vari = Variance.union vari vari' in 50 49 visited := TypeMap.add ty vari !visited; 51 50 let compute_same = compute_variance_rec vari in 52 52 - match ty.desc with 51 51 + match get_desc ty with 53 52 Tarrow (_, ty1, ty2, _) -> 54 53 let open Variance in 55 54 let v = conjugate vari in ··· 144 143 required 145 144 in 146 145 (* Prepare *) 147 147 - let params = List.map Btype.repr decl.type_params in 146 146 + let params = decl.type_params in 148 147 let tvl = ref TypeMap.empty in 149 148 (* Compute occurrences in the body *) 150 149 let open Variance in ··· 159 158 if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else 160 159 let visited = ref TypeSet.empty in 161 160 let rec check ty = 162 162 - let ty = Ctype.repr ty in 163 161 if TypeSet.mem ty !visited then () else begin 164 162 visited := TypeSet.add ty !visited; 165 163 if mem Inj (get_variance ty tvl) then () else 166 166 - match ty.desc with 164 164 + match get_desc ty with 167 165 | Tvar _ -> raise Exit 168 166 | Tconstr _ -> 169 167 let old = !visited in ··· 172 170 with Exit -> 173 171 visited := old; 174 172 let ty' = Ctype.expand_head_opt env ty in 175 175 - if ty == ty' then raise Exit else check ty' 173 173 + if eq_type ty ty' then raise Exit else check ty' 176 174 end 177 175 | _ -> Btype.iter_type_expr check ty 178 176 end ··· 197 195 (* Check propagation from constrained parameters *) 198 196 let args = Btype.newgenty (Ttuple params) in 199 197 let fvl = Ctype.free_variables args in 200 200 - let fvl = List.filter (fun v -> not (List.memq v params)) fvl in 198 198 + let fvl = 199 199 + List.filter (fun v -> not (List.exists (eq_type v) params)) fvl in 201 200 (* If there are no extra variables there is nothing to do *) 202 201 if fvl = [] then () else 203 202 let tvl2 = ref TypeMap.empty in ··· 210 209 params required; 211 210 let visited = ref TypeSet.empty in 212 211 let rec check ty = 213 213 - let ty = Ctype.repr ty in 214 212 if TypeSet.mem ty !visited then () else 215 213 let visited' = TypeSet.add ty !visited in 216 214 visited := visited'; ··· 224 222 Btype.backtrack snap; 225 223 let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in 226 224 if c1 && not c2 || n1 && not n2 then 227 227 - if List.memq ty fvl then 225 225 + if List.exists (eq_type ty) fvl then 228 226 let code = if not i2 then No_variable 229 227 else if c2 || n2 then Variance_not_reflected 230 228 else Variance_not_deducible in ··· 261 259 (* A parameter is constrained if it is either instantiated, 262 260 or it is a variable appearing in another parameter *) 263 261 let constrained vars ty = 264 264 - match ty.desc with 265 265 - | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars 262 262 + match get_desc ty with 263 263 + | Tvar _ -> List.exists (List.exists (eq_type ty)) vars 266 264 | _ -> true 267 265 268 266 let for_constr = function ··· 279 277 compute_variance_type env ~check rloc {decl with type_private = Private} 280 278 (for_constr tl) 281 279 | Some ret_type -> 282 282 - match Ctype.repr ret_type with 283 283 - | {desc=Tconstr (_, tyl, _)} -> 280 280 + match get_desc ret_type with 281 281 + | Tconstr (_, tyl, _) -> 284 282 (* let tyl = List.map (Ctype.expand_head env) tyl in *) 285 285 - let tyl = List.map Ctype.repr tyl in 286 283 let fvl = List.map (Ctype.free_variables ?env:None) tyl in 287 284 let _ = 288 285 List.fold_left2

+5 -5

typing/typemod.ml

reviewed

··· 370 370 T was not used as a path for a packed module 371 371 *) 372 372 let check_usage_of_module_types ~error ~paths ~loc env super = 373 373 - let it_do_type_expr it ty = match ty.desc with 373 373 + let it_do_type_expr it ty = match get_desc ty with 374 374 | Tpackage (p, _) -> 375 375 begin match List.find_opt (Path.same p) paths with 376 376 | Some p -> raise (Error(loc,Lazy.force !env,error p)) ··· 471 471 let rec loop = function 472 472 | [] -> false 473 473 | hd :: tl -> 474 474 - match (Btype.repr hd).desc with 474 474 + match get_desc hd with 475 475 | Tvar _ -> List.memq hd tl || loop tl 476 476 | _ -> true 477 477 in ··· 2191 2191 Ctype.generalize_structure exp.exp_type 2192 2192 end; 2193 2193 let mty = 2194 2194 - match Ctype.expand_head env exp.exp_type with 2195 2195 - {desc = Tpackage (p, fl)} -> 2194 2194 + match get_desc (Ctype.expand_head env exp.exp_type) with 2195 2195 + Tpackage (p, fl) -> 2196 2196 if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then 2197 2197 raise (Error (smod.pmod_loc, env, 2198 2198 Incomplete_packed_module exp.exp_type)); ··· 2202 2202 Location.prerr_warning smod.pmod_loc 2203 2203 (Warnings.Not_principal "this module unpacking"); 2204 2204 modtype_of_package env smod.pmod_loc p fl 2205 2205 - | {desc = Tvar _} -> 2205 2205 + | Tvar _ -> 2206 2206 raise (Typecore.Error 2207 2207 (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) 2208 2208 | _ ->

+12 -8

typing/typeopt.ml

reviewed

··· 23 23 24 24 let scrape_ty env ty = 25 25 let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in 26 26 - match ty.desc with 26 26 + match get_desc ty with 27 27 | Tconstr (p, _, _) -> 28 28 begin match Env.find_type p env with 29 29 | {type_kind = ( Type_variant (_, Variant_unboxed) ··· 38 38 | _ -> ty 39 39 40 40 let scrape env ty = 41 41 - (scrape_ty env ty).desc 41 41 + get_desc (scrape_ty env ty) 42 42 + 43 43 + let scrape_poly env ty = 44 44 + let ty = scrape_ty env ty in 45 45 + match get_desc ty with 46 46 + | Tpoly (ty, _) -> get_desc ty 47 47 + | d -> d 42 48 43 49 let is_function_type env ty = 44 50 match scrape env ty with ··· 69 75 let classify env ty = 70 76 let ty = scrape_ty env ty in 71 77 if maybe_pointer_type env ty = Immediate then Int 72 72 - else match ty.desc with 78 78 + else match get_desc ty with 73 79 | Tvar _ | Tunivar _ -> 74 80 Any 75 81 | Tconstr (p, _args, _abbrev) -> ··· 100 106 assert false 101 107 102 108 let array_type_kind env ty = 103 103 - match scrape env ty with 104 104 - | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) 105 105 - when Path.same p Predef.path_array -> 109 109 + match scrape_poly env ty with 110 110 + | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> 106 111 begin match classify env elt_ty with 107 112 | Any -> if Config.flat_float_array then Pgenarray else Paddrarray 108 113 | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray 109 114 | Addr | Lazy -> Paddrarray 110 115 | Int -> Pintarray 111 116 end 112 112 - | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _) 113 113 - when Path.same p Predef.path_floatarray -> 117 117 + | Tconstr(p, [], _) when Path.same p Predef.path_floatarray -> 114 118 Pfloatarray 115 119 | _ -> 116 120 (* This can happen with e.g. Obj.field *)

+224 -9

typing/types.ml

reviewed

··· 19 19 20 20 (* Type expressions for the core language *) 21 21 22 22 - type type_expr = 22 22 + type transient_expr = 23 23 { mutable desc: type_desc; 24 24 mutable level: int; 25 25 mutable scope: int; 26 26 id: int } 27 27 + 28 28 + and type_expr = transient_expr 27 29 28 30 and type_desc = 29 31 Tvar of string option ··· 72 74 | Cunknown 73 75 | Clink of commutable ref 74 76 75 75 - module TypeOps = struct 77 77 + module TransientTypeOps = struct 76 78 type t = type_expr 77 79 let compare t1 t2 = t1.id - t2.id 78 80 let hash t = t.id 79 81 let equal t1 t2 = t1 == t2 80 82 end 81 83 82 82 - module Private_type_expr = struct 83 83 - let create desc ~level ~scope ~id = {desc; level; scope; id} 84 84 - let set_desc ty d = ty.desc <- d 85 85 - let set_level ty lv = ty.level <- lv 86 86 - let set_scope ty sc = ty.scope <- sc 87 87 - end 88 84 (* *) 89 85 90 86 module Uid = struct ··· 410 406 cstr_tag: constructor_tag; (* Tag for heap blocks *) 411 407 cstr_consts: int; (* Number of constant constructors *) 412 408 cstr_nonconsts: int; (* Number of non-const constructors *) 413 413 - cstr_normal: int; (* Number of non generalized constrs *) 414 409 cstr_generalized: bool; (* Constrained return type? *) 415 410 cstr_private: private_flag; (* Read-only constructor? *) 416 411 cstr_loc: Location.t; ··· 477 472 | Sig_class (id, _, _, _) 478 473 | Sig_class_type (id, _, _, _) 479 474 -> id 475 475 + 476 476 + (* migrating repr from Btype.. *) 477 477 + 478 478 + (**** Definitions for backtracking ****) 479 479 + 480 480 + type change = 481 481 + Ctype of type_expr * type_desc 482 482 + | Ccompress of type_expr * type_desc * type_desc 483 483 + | Clevel of type_expr * int 484 484 + | Cscope of type_expr * int 485 485 + | Cname of 486 486 + (Path.t * type_expr list) option ref * (Path.t * type_expr list) option 487 487 + | Crow of row_field option ref * row_field option 488 488 + | Ckind of field_kind option ref * field_kind option 489 489 + | Ccommu of commutable ref * commutable 490 490 + | Cuniv of type_expr option ref * type_expr option 491 491 + 492 492 + type changes = 493 493 + Change of change * changes ref 494 494 + | Unchanged 495 495 + | Invalid 496 496 + 497 497 + let trail = Local_store.s_table ref Unchanged 498 498 + 499 499 + let log_change ch = 500 500 + let r' = ref Unchanged in 501 501 + !trail := Change (ch, r'); 502 502 + trail := r' 503 503 + 504 504 + (**** Representative of a type ****) 505 505 + 506 506 + let rec field_kind_repr = 507 507 + function 508 508 + Fvar {contents = Some kind} -> field_kind_repr kind 509 509 + | kind -> kind 510 510 + 511 511 + let rec repr_link (t : type_expr) d : type_expr -> type_expr = 512 512 + function 513 513 + {desc = Tlink t' as d'} -> 514 514 + repr_link t d' t' 515 515 + | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> 516 516 + repr_link t d' t' 517 517 + | t' -> 518 518 + log_change (Ccompress (t, t.desc, d)); 519 519 + t.desc <- d; 520 520 + t' 521 521 + 522 522 + let repr_link1 t = function 523 523 + {desc = Tlink t' as d'} -> 524 524 + repr_link t d' t' 525 525 + | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> 526 526 + repr_link t d' t' 527 527 + | t' -> t' 528 528 + 529 529 + let repr t = 530 530 + match t.desc with 531 531 + Tlink t' -> 532 532 + repr_link1 t t' 533 533 + | Tfield (_, k, _, t') when field_kind_repr k = Fabsent -> 534 534 + repr_link1 t t' 535 535 + | _ -> t 536 536 + 537 537 + (* getters for type_expr *) 538 538 + 539 539 + let get_desc t = (repr t).desc 540 540 + let get_level t = (repr t).level 541 541 + let get_scope t = (repr t).scope 542 542 + let get_id t = (repr t).id 543 543 + 544 544 + (* transient type_expr *) 545 545 + 546 546 + module Transient_expr = struct 547 547 + let create desc ~level ~scope ~id = {desc; level; scope; id} 548 548 + let set_desc ty d = ty.desc <- d 549 549 + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d 550 550 + let set_level ty lv = ty.level <- lv 551 551 + let set_scope ty sc = ty.scope <- sc 552 552 + let coerce ty = ty 553 553 + let repr = repr 554 554 + let type_expr ty = ty 555 555 + end 556 556 + 557 557 + (* Comparison for [type_expr]; cannot be used for functors *) 558 558 + 559 559 + let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 560 560 + let compare_type t1 t2 = compare (get_id t1) (get_id t2) 561 561 + 562 562 + (**** Some type creators ****) 563 563 + 564 564 + let new_id = Local_store.s_ref (-1) 565 565 + 566 566 + let create_expr = Transient_expr.create 567 567 + 568 568 + let newty3 ~level ~scope desc = 569 569 + incr new_id; 570 570 + create_expr desc ~level ~scope ~id:!new_id 571 571 + 572 572 + let newty2 ~level desc = 573 573 + newty3 ~level ~scope:Ident.lowest_scope desc 574 574 + 575 575 + (**********************************) 576 576 + (* Utilities for backtracking *) 577 577 + (**********************************) 578 578 + 579 579 + let undo_change = function 580 580 + Ctype (ty, desc) -> Transient_expr.set_desc ty desc 581 581 + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc 582 582 + | Clevel (ty, level) -> Transient_expr.set_level ty level 583 583 + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope 584 584 + | Cname (r, v) -> r := v 585 585 + | Crow (r, v) -> r := v 586 586 + | Ckind (r, v) -> r := v 587 587 + | Ccommu (r, v) -> r := v 588 588 + | Cuniv (r, v) -> r := v 589 589 + 590 590 + type snapshot = changes ref * int 591 591 + let last_snapshot = Local_store.s_ref 0 592 592 + 593 593 + let log_type ty = 594 594 + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) 595 595 + let link_type ty ty' = 596 596 + let ty = repr ty in 597 597 + let ty' = repr ty' in 598 598 + log_type ty; 599 599 + let desc = ty.desc in 600 600 + Transient_expr.set_desc ty (Tlink ty'); 601 601 + (* Name is a user-supplied name for this unification variable (obtained 602 602 + * through a type annotation for instance). *) 603 603 + match desc, ty'.desc with 604 604 + Tvar name, Tvar name' -> 605 605 + begin match name, name' with 606 606 + | Some _, None -> log_type ty'; Transient_expr.set_desc ty' (Tvar name) 607 607 + | None, Some _ -> () 608 608 + | Some _, Some _ -> 609 609 + if ty.level < ty'.level then 610 610 + (log_type ty'; Transient_expr.set_desc ty' (Tvar name)) 611 611 + | None, None -> () 612 612 + end 613 613 + | _ -> () 614 614 + (* ; assert (check_memorized_abbrevs ()) *) 615 615 + (* ; check_expans [] ty' *) 616 616 + (* TODO: consider eliminating set_type_desc, replacing it with link types *) 617 617 + let set_type_desc ty td = 618 618 + let ty = repr ty in 619 619 + if td != ty.desc then begin 620 620 + log_type ty; 621 621 + Transient_expr.set_desc ty td 622 622 + end 623 623 + (* TODO: separate set_level into two specific functions: *) 624 624 + (* set_lower_level and set_generic_level *) 625 625 + let set_level ty level = 626 626 + let ty = repr ty in 627 627 + if level <> ty.level then begin 628 628 + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); 629 629 + Transient_expr.set_level ty level 630 630 + end 631 631 + (* TODO: introduce a guard and rename it to set_higher_scope? *) 632 632 + let set_scope ty scope = 633 633 + let ty = repr ty in 634 634 + if scope <> ty.scope then begin 635 635 + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); 636 636 + Transient_expr.set_scope ty scope 637 637 + end 638 638 + let set_univar rty ty = 639 639 + log_change (Cuniv (rty, !rty)); rty := Some ty 640 640 + let set_name nm v = 641 641 + log_change (Cname (nm, !nm)); nm := v 642 642 + let set_row_field e v = 643 643 + log_change (Crow (e, !e)); e := Some v 644 644 + let set_kind rk k = 645 645 + log_change (Ckind (rk, !rk)); rk := Some k 646 646 + let set_commu rc c = 647 647 + log_change (Ccommu (rc, !rc)); rc := c 648 648 + 649 649 + let snapshot () = 650 650 + let old = !last_snapshot in 651 651 + last_snapshot := !new_id; 652 652 + (!trail, old) 653 653 + 654 654 + let rec rev_log accu = function 655 655 + Unchanged -> accu 656 656 + | Invalid -> assert false 657 657 + | Change (ch, next) -> 658 658 + let d = !next in 659 659 + next := Invalid; 660 660 + rev_log (ch::accu) d 661 661 + 662 662 + let backtrack ~cleanup_abbrev (changes, old) = 663 663 + match !changes with 664 664 + Unchanged -> last_snapshot := old 665 665 + | Invalid -> failwith "Btype.backtrack" 666 666 + | Change _ as change -> 667 667 + cleanup_abbrev (); 668 668 + let backlog = rev_log [] change in 669 669 + List.iter undo_change backlog; 670 670 + changes := Unchanged; 671 671 + last_snapshot := old; 672 672 + trail := changes 673 673 + 674 674 + let rec rev_compress_log log r = 675 675 + match !r with 676 676 + Unchanged | Invalid -> 677 677 + log 678 678 + | Change (Ccompress _, next) -> 679 679 + rev_compress_log (r::log) next 680 680 + | Change (_, next) -> 681 681 + rev_compress_log log next 682 682 + 683 683 + let undo_compress (changes, _old) = 684 684 + match !changes with 685 685 + Unchanged 686 686 + | Invalid -> () 687 687 + | Change _ -> 688 688 + let log = rev_compress_log [] changes in 689 689 + List.iter 690 690 + (fun r -> match !r with 691 691 + Change (Ccompress (ty, desc, d), next) when ty.desc == d -> 692 692 + Transient_expr.set_desc ty desc; r := !next 693 693 + | _ -> ()) 694 694 + log

+86 -14

typing/types.mli

reviewed

··· 55 55 56 56 Note on mutability: TBD. 57 57 *) 58 58 - type type_expr = private 59 59 - { mutable desc: type_desc; 60 60 - mutable level: int; 61 61 - mutable scope: int; 62 62 - id: int } 58 58 + type type_expr 63 59 64 64 - and type_desc = 60 60 + type type_desc = 65 61 | Tvar of string option 66 62 (** [Tvar (Some "a")] ==> ['a] or ['_a] 67 63 [Tvar None] ==> [_] *) ··· 236 232 | Cunknown 237 233 | Clink of commutable ref 238 234 239 239 - module Private_type_expr : sig 240 240 - val create : type_desc -> level: int -> scope: int -> id: int -> type_expr 241 241 - val set_desc : type_expr -> type_desc -> unit 242 242 - val set_level : type_expr -> int -> unit 243 243 - val set_scope : type_expr -> int -> unit 235 235 + (** Getters for type_expr; calls repr before answering a value *) 236 236 + 237 237 + val get_desc: type_expr -> type_desc 238 238 + val get_level: type_expr -> int 239 239 + val get_scope: type_expr -> int 240 240 + val get_id: type_expr -> int 241 241 + 242 242 + (** Transient [type_expr]. 243 243 + Should only be used immediately after [Transient_expr.repr] *) 244 244 + type transient_expr = private 245 245 + { mutable desc: type_desc; 246 246 + mutable level: int; 247 247 + mutable scope: int; 248 248 + id: int } 249 249 + 250 250 + module Transient_expr : sig 251 251 + (** Operations on [transient_expr] *) 252 252 + 253 253 + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr 254 254 + val set_desc: transient_expr -> type_desc -> unit 255 255 + val set_level: transient_expr -> int -> unit 256 256 + val set_scope: transient_expr -> int -> unit 257 257 + val repr: type_expr -> transient_expr 258 258 + val type_expr: transient_expr -> type_expr 259 259 + val coerce: type_expr -> transient_expr 260 260 + (** Coerce without normalizing with [repr] *) 261 261 + 262 262 + val set_stub_desc: type_expr -> type_desc -> unit 263 263 + (** Instantiate a not yet instantiated stub. 264 264 + Fail if already instantiated. *) 244 265 end 245 266 246 246 - module TypeOps : sig 247 247 - type t = type_expr 267 267 + val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr 268 268 + 269 269 + (** Functions and definitions moved from Btype *) 270 270 + 271 271 + val newty3: level:int -> scope:int -> type_desc -> type_expr 272 272 + (** Create a type with a fresh id *) 273 273 + 274 274 + val newty2: level:int -> type_desc -> type_expr 275 275 + (** Create a type with a fresh id and no scope *) 276 276 + 277 277 + val field_kind_repr: field_kind -> field_kind 278 278 + (** Return the canonical representative of an object field kind. *) 279 279 + 280 280 + module TransientTypeOps : sig 281 281 + (** Comparisons for functors *) 282 282 + 283 283 + type t = transient_expr 248 284 val compare : t -> t -> int 249 285 val equal : t -> t -> bool 250 286 val hash : t -> int 251 287 end 288 288 + 289 289 + (** Comparisons for [type_expr]; cannot be used for functors *) 290 290 + 291 291 + val eq_type: type_expr -> type_expr -> bool 292 292 + val compare_type: type_expr -> type_expr -> int 252 293 253 294 (* *) 254 295 ··· 543 584 cstr_tag: constructor_tag; (* Tag for heap blocks *) 544 585 cstr_consts: int; (* Number of constant constructors *) 545 586 cstr_nonconsts: int; (* Number of non-const constructors *) 546 546 - cstr_normal: int; (* Number of non generalized constrs *) 547 587 cstr_generalized: bool; (* Constrained return type? *) 548 588 cstr_private: private_flag; (* Read-only constructor? *) 549 589 cstr_loc: Location.t; ··· 587 627 val bound_value_identifiers: signature -> Ident.t list 588 628 589 629 val signature_item_id : signature_item -> Ident.t 630 630 + 631 631 + (**** Utilities for backtracking ****) 632 632 + 633 633 + type snapshot 634 634 + (* A snapshot for backtracking *) 635 635 + val snapshot: unit -> snapshot 636 636 + (* Make a snapshot for later backtracking. Costs nothing *) 637 637 + val backtrack: cleanup_abbrev:(unit -> unit) -> snapshot -> unit 638 638 + (* Backtrack to a given snapshot. Only possible if you have 639 639 + not already backtracked to a previous snapshot. 640 640 + Calls [cleanup_abbrev] internally *) 641 641 + val undo_compress: snapshot -> unit 642 642 + (* Backtrack only path compression. Only meaningful if you have 643 643 + not already backtracked to a previous snapshot. 644 644 + Does not call [cleanup_abbrev] *) 645 645 + 646 646 + (* Functions to use when modifying a type (only Ctype?) *) 647 647 + val link_type: type_expr -> type_expr -> unit 648 648 + (* Set the desc field of [t1] to [Tlink t2], logging the old 649 649 + value if there is an active snapshot *) 650 650 + val set_type_desc: type_expr -> type_desc -> unit 651 651 + (* Set directly the desc field, without sharing *) 652 652 + val set_level: type_expr -> int -> unit 653 653 + val set_scope: type_expr -> int -> unit 654 654 + val set_name: 655 655 + (Path.t * type_expr list) option ref -> 656 656 + (Path.t * type_expr list) option -> unit 657 657 + val set_row_field: row_field option ref -> row_field -> unit 658 658 + val set_univar: type_expr option ref -> type_expr -> unit 659 659 + val set_kind: field_kind option ref -> field_kind -> unit 660 660 + val set_commu: commutable ref -> commutable -> unit 661 661 + (* Set references, logging the old value *)

+45 -43

typing/typetexp.ml

reviewed

··· 230 230 match decl.type_manifest with 231 231 None -> unify_var 232 232 | Some ty -> 233 233 - if (repr ty).level = Btype.generic_level then unify_var else unify 233 233 + if get_level ty = Btype.generic_level then unify_var else unify 234 234 in 235 235 List.iter2 236 236 (fun (sty, cty) ty' -> ··· 253 253 match decl.type_manifest with 254 254 None -> raise Not_found 255 255 | Some ty -> 256 256 - match (repr ty).desc with 256 256 + match get_desc ty with 257 257 Tvariant row when Btype.static_row row -> () 258 258 | Tconstr (path, _, _) -> 259 259 check (Env.find_type path env) ··· 291 291 (List.combine stl args) params; 292 292 let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in 293 293 let ty = Ctype.expand_head env (newconstr path ty_args) in 294 294 - let ty = match ty.desc with 294 294 + let ty = match get_desc ty with 295 295 Tvariant row -> 296 296 let row = Btype.row_repr row in 297 297 let fields = ··· 353 353 end; 354 354 let t = instance t in 355 355 let px = Btype.proxy t in 356 356 - begin match px.desc with 357 357 - | Tvar None -> Btype.set_type_desc px (Tvar (Some alias)) 358 358 - | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias)) 356 356 + begin match get_desc px with 357 357 + | Tvar None -> set_type_desc px (Tvar (Some alias)) 358 358 + | Tunivar None -> set_type_desc px (Tunivar (Some alias)) 359 359 | _ -> () 360 360 end; 361 361 { ty with ctyp_type = t } ··· 410 410 let cty = transl_type env policy sty in 411 411 let ty = cty.ctyp_type in 412 412 let nm = 413 413 - match repr cty.ctyp_type with 414 414 - {desc=Tconstr(p, tl, _)} -> Some(p, tl) 415 415 - | _ -> None 413 413 + match get_desc cty.ctyp_type with 414 414 + Tconstr(p, tl, _) -> Some(p, tl) 415 415 + | _ -> None 416 416 in 417 417 name := if Hashtbl.length hfields <> 0 then None else nm; 418 418 - let fl = match expand_head env cty.ctyp_type, nm with 419 419 - {desc=Tvariant row}, _ when Btype.static_row row -> 418 418 + let fl = match get_desc (expand_head env cty.ctyp_type), nm with 419 419 + Tvariant row, _ when Btype.static_row row -> 420 420 let row = Btype.row_repr row in 421 421 row.row_fields 422 422 - | {desc=Tvar _}, Some(p, _) -> 422 422 + | Tvar _, Some(p, _) -> 423 423 raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p)) 424 424 | _ -> 425 425 raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) ··· 481 481 (fun tyl (name, ty1) -> 482 482 let v = Btype.proxy ty1 in 483 483 if deep_occur v ty then begin 484 484 - match v.desc with 485 485 - Tvar name when v.level = Btype.generic_level -> 486 486 - Btype.set_type_desc v (Tunivar name); 484 484 + match get_desc v with 485 485 + Tvar name when get_level v = Btype.generic_level -> 486 486 + set_type_desc v (Tunivar name); 487 487 v :: tyl 488 488 | _ -> 489 489 - raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) 489 489 + raise (Error (styp.ptyp_loc, env, 490 490 + Cannot_quantify (name, v))) 490 491 end else tyl) 491 492 [] new_univars 492 493 in ··· 544 545 | Oinherit sty -> begin 545 546 let cty = transl_type env policy sty in 546 547 let nm = 547 547 - match repr cty.ctyp_type with 548 548 - {desc=Tconstr(p, _, _)} -> Some p 549 549 - | _ -> None in 548 548 + match get_desc cty.ctyp_type with 549 549 + Tconstr(p, _, _) -> Some p 550 550 + | _ -> None in 550 551 let t = expand_head env cty.ctyp_type in 551 551 - match t, nm with 552 552 - {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin 553 553 - if opened_object t then 554 554 - raise (Error (sty.ptyp_loc, env, Opened_object nm)); 555 555 - let rec iter_add = function 556 556 - | Tfield (s, _k, ty1, ty2) -> begin 557 557 - add_typed_field sty.ptyp_loc s ty1; 558 558 - iter_add ty2.desc 559 559 - end 560 560 - | Tnil -> () 561 561 - | _ -> assert false in 562 562 - iter_add tf; 563 563 - OTinherit cty 552 552 + match get_desc t, nm with 553 553 + Tobject (tf, _), _ 554 554 + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> 555 555 + begin 556 556 + if opened_object t then 557 557 + raise (Error (sty.ptyp_loc, env, Opened_object nm)); 558 558 + let rec iter_add ty = 559 559 + match get_desc ty with 560 560 + | Tfield (s, _k, ty1, ty2) -> 561 561 + add_typed_field sty.ptyp_loc s ty1; 562 562 + iter_add ty2 563 563 + | Tnil -> () 564 564 + | _ -> assert false 565 565 + in 566 566 + iter_add tf; 567 567 + OTinherit cty 564 568 end 565 565 - | {desc=Tvar _}, Some p -> 569 569 + | Tvar _, Some p -> 566 570 raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p)) 567 571 | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) 568 572 end in ··· 582 586 583 587 (* Make the rows "fixed" in this type, to make universal check easier *) 584 588 let rec make_fixed_univars ty = 585 585 - let ty = repr ty in 586 589 if Btype.try_mark_node ty then 587 587 - begin match ty.desc with 590 590 + begin match get_desc ty with 588 591 | Tvariant row -> 589 592 let row = Btype.row_repr row in 590 593 let more = Btype.row_more row in 591 594 if Btype.is_Tunivar more then 592 592 - Btype.set_type_desc ty 595 595 + set_type_desc ty 593 596 (Tvariant 594 594 - {row with row_fixed=Some(Univar more); 597 597 + {row with row_fixed = Some (Univar more); 595 598 row_fields = List.map 596 599 (fun (s,f as p) -> match Btype.row_field_repr f with 597 600 Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r) ··· 618 621 then try 619 622 r := (loc, v, TyVarMap.find name !type_variables) :: !r 620 623 with Not_found -> 621 621 - if fixed && Btype.is_Tvar (repr ty) then 624 624 + if fixed && Btype.is_Tvar ty then 622 625 raise(Error(loc, env, Unbound_type_variable ("'"^name))); 623 626 let v2 = new_global_var () in 624 627 r := (loc, v, v2) :: !r; ··· 657 660 let univs = 658 661 List.fold_left 659 662 (fun acc v -> 660 660 - let v = repr v in 661 661 - match v.desc with 662 662 - Tvar name when v.level = Btype.generic_level -> 663 663 - Btype.set_type_desc v (Tunivar name); v :: acc 663 663 + match get_desc v with 664 664 + Tvar name when get_level v = Btype.generic_level -> 665 665 + set_type_desc v (Tunivar name); v :: acc 664 666 | _ -> acc) 665 667 [] !pre_univars 666 668 in ··· 753 755 fprintf ppf 754 756 "@[The type %a@ does not expand to a polymorphic variant type@]" 755 757 Printtyp.type_expr ty; 756 756 - begin match ty.desc with 758 758 + begin match get_desc ty with 757 759 | Tvar (Some s) -> 758 760 (* PR#7012: help the user that wrote 'Foo instead of `Foo *) 759 761 Misc.did_you_mean ppf (fun () -> ["`" ^ s])

+1 -1

utils/warnings.ml

reviewed

··· 689 689 let ref_manual_explanation () = 690 690 (* manual references are checked a posteriori by the manual 691 691 cross-reference consistency check in manual/tests*) 692 692 - let[@manual.ref "s:comp-warnings"] chapter, section = 9, 5 in 692 692 + let[@manual.ref "s:comp-warnings"] chapter, section = 11, 5 in 693 693 Printf.sprintf "(See manual section %d.%d)" chapter section 694 694 695 695 let message = function