API tools faq
paste
Guest User

Untitled

a guest
Feb 16th, 2019
108
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.53 KB | None | 0 0
raw download clone embed print report
  1. Index: typing/ctype.mli
  2. ===================================================================
  3. --- typing/ctype.mli (revision 13527)
  4. +++ typing/ctype.mli (working copy)
  5. @@ -83,6 +83,9 @@
  6. val filter_row_fields:
  7. bool -> (label * row_field) list -> (label * row_field) list
  8.  
  9. +val in_current_module: Path.t -> bool
  10. +val in_pervasives: Path.t -> bool
  11. +
  12. val generalize: type_expr -> unit
  13. (* Generalize in-place the given type *)
  14. val iterative_generalization: int -> type_expr list -> type_expr list
  15. Index: typing/typedecl.ml
  16. ===================================================================
  17. --- typing/typedecl.ml (revision 13527)
  18. +++ typing/typedecl.ml (working copy)
  19. @@ -476,11 +476,22 @@
  20.  
  21. (* Compute variance *)
  22.  
  23. -let compute_variance env tvl nega posi cntr ty =
  24. +(* membership robust to unification *)
  25. +let rec mem_repr ty s =
  26. + TypeSet.mem ty s ||
  27. + match ty.desc with
  28. + Tlink ty' -> mem_repr ty' s
  29. + | _ -> false
  30. +
  31. +(* widen = assume abstract types not accessibke from the initial
  32. + environment to be bivariant *)
  33. +let compute_variance widen env tvl nega posi cntr ty =
  34. let pvisited = ref TypeSet.empty
  35. and nvisited = ref TypeSet.empty
  36. and cvisited = ref TypeSet.empty in
  37. let rec compute_variance_rec posi nega cntr ty =
  38. + (* Is expand_head really safe here? In theory, unification always
  39. + keeps nodes from the right hand term... *)
  40. let ty = Ctype.repr ty in
  41. if (not posi || TypeSet.mem ty !pvisited)
  42. && (not nega || TypeSet.mem ty !nvisited)
  43. @@ -501,16 +512,24 @@
  44. if tl = [] then () else begin
  45. try
  46. let decl = Env.find_type path env in
  47. - List.iter2
  48. - (fun ty (co,cn,ct) ->
  49. - compute_variance_rec
  50. - (posi && co || nega && cn)
  51. - (posi && cn || nega && co)
  52. - (cntr || ct)
  53. - ty)
  54. - tl decl.type_variance
  55. + if widen && decl.type_manifest <> None then
  56. + compute_variance_rec posi nega cntr (Ctype.expand_head env ty)
  57. + else if widen
  58. + && decl.type_kind = Type_abstract
  59. + && not (Ctype.in_pervasives path)
  60. + then ()
  61. + else
  62. + List.iter2
  63. + (fun ty (co,cn,ct) ->
  64. + compute_variance_rec
  65. + (posi && co || nega && cn)
  66. + (posi && cn || nega && co)
  67. + (cntr || ct)
  68. + ty)
  69. + tl decl.type_variance
  70. with Not_found ->
  71. - List.iter (compute_variance_rec true true true) tl
  72. + if not widen then
  73. + List.iter (compute_variance_rec true true true) tl
  74. end
  75. | Tobject (ty, _) ->
  76. compute_same ty
  77. @@ -541,9 +560,9 @@
  78. compute_variance_rec nega posi cntr ty;
  79. List.iter
  80. (fun (ty, covar, convar, ctvar) ->
  81. - if TypeSet.mem ty !pvisited then covar := true;
  82. - if TypeSet.mem ty !nvisited then convar := true;
  83. - if TypeSet.mem ty !cvisited then ctvar := true)
  84. + if mem_repr ty !pvisited then covar := true;
  85. + if mem_repr ty !nvisited then convar := true;
  86. + if mem_repr ty !cvisited then ctvar := true)
  87. tvl
  88.  
  89. let make_variance ty = (ty, ref false, ref false, ref false)
  90. @@ -569,7 +588,7 @@
  91. let tvl1 = List.map make_variance fvl in
  92. let tvl2 = List.map make_variance fvl in
  93. let tvl = tvl0 @ tvl1 in
  94. - List.iter (fun (cn,ty) -> compute_variance env tvl true cn cn ty) tyl;
  95. + List.iter (fun (cn,ty) -> compute_variance false env tvl true cn cn ty) tyl;
  96. let required =
  97. List.map (fun (c,n as r) -> if c || n then r else (true,true))
  98. required
  99. @@ -578,17 +597,18 @@
  100. (fun (ty, co, cn, ct) (c, n) ->
  101. if not (Btype.is_Tvar ty) then begin
  102. co := c; cn := n; ct := n;
  103. - compute_variance env tvl2 c n n ty
  104. + compute_variance true env tvl2 c n n ty
  105. end)
  106. tvl0 required;
  107. List.iter2
  108. (fun (ty, c1, n1, t1) (_, c2, n2, t2) ->
  109. - if !c1 && not !c2 || !n1 && not !n2
  110. - then raise (Error(loc, Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
  111. + if !c1 && not !c2 || !n1 && not !n2 then
  112. + let code = if !c2 || !n2 then -1 else -2 in
  113. + raise (Error(loc, Bad_variance (code, (!c1,!n1), (!c2,!n2)))))
  114. tvl1 tvl2;
  115. let pos = ref 0 in
  116. List.map2
  117. - (fun (_, co, cn, ct) (c, n) ->
  118. + (fun (ty, co, cn, ct) (c, n) ->
  119. incr pos;
  120. if !co && not c || !cn && not n
  121. then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n))));
  122. @@ -1152,10 +1172,14 @@
  123. | 3 when not teen -> "rd"
  124. | _ -> "th"
  125. in
  126. - if n < 1 then
  127. + if n = -1 then
  128. fprintf ppf "@[%s@ %s@]"
  129. "In this definition, a type variable has a variance that"
  130. "is not reflected by its occurrence in type parameters."
  131. + else if n = -2 then
  132. + fprintf ppf "@[%s@ %s@]"
  133. + "In this definition, a type variable cannot be deduced"
  134. + "from the type parameters."
  135. else
  136. fprintf ppf "@[%s@ %s@ %s %d%s %s %s,@ %s %s@]"
  137. "In this definition, expected parameter"
  138. Index: testsuite/tests/typing-gadts/omega07.ml
  139. ===================================================================
  140. --- testsuite/tests/typing-gadts/omega07.ml (revision 13527)
  141. +++ testsuite/tests/typing-gadts/omega07.ml (working copy)
  142. @@ -10,7 +10,7 @@
  143. type ('a,'b) sum = Inl of 'a | Inr of 'b
  144.  
  145. type zero = Zero
  146. -type _ succ
  147. +type 'a succ = Succ of 'a
  148. type _ nat =
  149. | NZ : zero nat
  150. | NS : 'a nat -> 'a succ nat
  151. @@ -60,7 +60,7 @@
  152.  
  153. type tp
  154. type nd
  155. -type (_,_) fk
  156. +type ('a,'b) fk = Fk of 'a * 'b
  157. type _ shape =
  158. | Tp : tp shape
  159. | Nd : nd shape
  160. @@ -559,7 +559,7 @@
  161. (* 5.9/5.10 Language with binding *)
  162.  
  163. type rnil
  164. -type (_,_,_) rcons
  165. +type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
  166.  
  167. type _ is_row =
  168. | Rnil : rnil is_row
  169. @@ -714,7 +714,7 @@
  170. | Pexp : pexp mode
  171. | Pval : pval mode
  172.  
  173. -type (_,_) tarr
  174. +type ('a,'b) tarr = Tarr of 'a * 'b
  175. type tint
  176.  
  177. type (_,_) rel =
  178. Index: testsuite/tests/typing-gadts/omega07.ml.principal.reference
  179. ===================================================================
  180. --- testsuite/tests/typing-gadts/omega07.ml.principal.reference (revision 13527)
  181. +++ testsuite/tests/typing-gadts/omega07.ml.principal.reference (working copy)
  182. @@ -1,7 +1,7 @@
  183.  
  184. # * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b
  185. type zero = Zero
  186. -type _ succ
  187. +type 'a succ = Succ of 'a
  188. type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
  189. # type (_, _) seq =
  190. Snil : ('a, zero) seq
  191. @@ -16,7 +16,7 @@
  192. val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
  193. # * type tp
  194. type nd
  195. -type (_, _) fk
  196. +type ('a, 'b) fk = Fk of 'a * 'b
  197. type _ shape =
  198. Tp : tp shape
  199. | Nd : nd shape
  200. @@ -176,7 +176,7 @@
  201. Const 3)
  202. val v4 : int = 6
  203. # type rnil
  204. -type (_, _, _) rcons
  205. +type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
  206. type _ is_row =
  207. Rnil : rnil is_row
  208. | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
  209. @@ -280,7 +280,7 @@
  210. # type pexp
  211. type pval
  212. type _ mode = Pexp : pexp mode | Pval : pval mode
  213. -type (_, _) tarr
  214. +type ('a, 'b) tarr = Tarr of 'a * 'b
  215. type tint
  216. type (_, _) rel =
  217. IntR : (tint, int) rel
  218. Index: testsuite/tests/typing-gadts/omega07.ml.reference
  219. ===================================================================
  220. --- testsuite/tests/typing-gadts/omega07.ml.reference (revision 13527)
  221. +++ testsuite/tests/typing-gadts/omega07.ml.reference (working copy)
  222. @@ -1,7 +1,7 @@
  223.  
  224. # * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b
  225. type zero = Zero
  226. -type _ succ
  227. +type 'a succ = Succ of 'a
  228. type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
  229. # type (_, _) seq =
  230. Snil : ('a, zero) seq
  231. @@ -16,7 +16,7 @@
  232. val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
  233. # * type tp
  234. type nd
  235. -type (_, _) fk
  236. +type ('a, 'b) fk = Fk of 'a * 'b
  237. type _ shape =
  238. Tp : tp shape
  239. | Nd : nd shape
  240. @@ -176,7 +176,7 @@
  241. Const 3)
  242. val v4 : int = 6
  243. # type rnil
  244. -type (_, _, _) rcons
  245. +type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
  246. type _ is_row =
  247. Rnil : rnil is_row
  248. | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
  249. @@ -280,7 +280,7 @@
  250. # type pexp
  251. type pval
  252. type _ mode = Pexp : pexp mode | Pval : pval mode
  253. -type (_, _) tarr
  254. +type ('a, 'b) tarr = Tarr of 'a * 'b
  255. type tint
  256. type (_, _) rel =
  257. IntR : (tint, int) rel
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!