SHARE
TWEET

Untitled

a guest Feb 16th, 2019 79 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Index: typing/typecore.ml
  2. ===================================================================
  3. --- typing/typecore.ml  (revision 13871)
  4. +++ typing/typecore.ml  (working copy)
  5. @@ -363,13 +363,18 @@
  6.  let pattern_force = ref ([] : (unit -> unit) list)
  7.  let pattern_scope = ref (None : Annot.ident option);;
  8.  let allow_modules = ref false
  9. +let allow_gadts   = ref false
  10. +let allow_existentials = ref false
  11.  let module_variables = ref ([] : (string loc * Location.t) list)
  12. -let reset_pattern scope allow =
  13. +let reset_pattern ?scope ?(modules=false) ?(gadts=true) ?(existentials=false)
  14. +    () =
  15.    pattern_variables := [];
  16.    pattern_force := [];
  17.    pattern_scope := scope;
  18. -  allow_modules := allow;
  19. +  allow_modules := modules;
  20.    module_variables := [];
  21. +  allow_gadts := gadts;
  22. +  allow_existentials := existentials;
  23.  ;;
  24.  
  25.  let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
  26. @@ -858,12 +863,14 @@
  27.    | Normal
  28.    | Inside_or
  29.  
  30. +exception Contains_gadt
  31. +
  32.  (* type_pat propagates the expected type as well as maps for
  33.     constructors and labels.
  34.     Unification may update the typing environment. *)
  35. -let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
  36. +let rec type_pat ~constrs ~labels ~mode ~env sp expected_ty =
  37.    let type_pat ?(mode=mode) ?(env=env) =
  38. -    type_pat ~constrs ~labels ~no_existentials ~mode ~env in
  39. +    type_pat ~constrs ~labels ~mode ~env in
  40.    let loc = sp.ppat_loc in
  41.    match sp.ppat_desc with
  42.      Ppat_any ->
  43. @@ -952,15 +959,16 @@
  44.              [Hashtbl.find constrs s, (fun () -> ())]
  45.          | _ ->  Typetexp.find_all_constructors !env lid.loc lid.txt
  46.        in
  47. -      let check_lk tpath constr =
  48. -        if constr.cstr_generalized then
  49. +      (* let check_lk tpath constr =
  50. +        if constr.cstr_generalized then
  51.            raise (Error (lid.loc, !env,
  52.                          Unqualified_gadt_pattern (tpath, constr.cstr_name)))
  53. -      in
  54. +      in *)
  55.        let constr =
  56. -        Constructor.disambiguate lid !env opath constrs ~check_lk in
  57. +        Constructor.disambiguate lid !env opath constrs in
  58. +      if constr.cstr_generalized && not !allow_gadts then raise Contains_gadt;
  59.        Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
  60. -      if no_existentials && constr.cstr_existentials <> [] then
  61. +      if not !allow_existentials && constr.cstr_existentials <> [] then
  62.          raise (Error (loc, !env, Unexpected_existential));
  63.        (* if constructor is gadt, we must verify that the expected type has the
  64.           correct head *)
  65. @@ -1119,13 +1127,10 @@
  66.        unify_pat_types loc !env ty expected_ty;
  67.        { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
  68.  
  69. -let type_pat ?(allow_existentials=false) ?constrs ?labels
  70. -    ?(lev=get_current_level()) env sp expected_ty =
  71. +let type_pat ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty =
  72.    newtype_level := Some lev;
  73.    try
  74. -    let r =
  75. -      type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
  76. -        ~mode:Normal ~env sp expected_ty in
  77. +    let r = type_pat ~constrs ~labels ~mode:Normal ~env sp expected_ty in
  78.      iter_pattern (fun p -> p.pat_env <- !env) r;
  79.      newtype_level := None;
  80.      r
  81. @@ -1139,11 +1144,8 @@
  82.  let partial_pred ~lev env expected_ty constrs labels p =
  83.    let snap = snapshot () in
  84.    try
  85. -    reset_pattern None true;
  86. -    let typed_p =
  87. -      type_pat ~allow_existentials:true ~lev
  88. -        ~constrs ~labels (ref env) p expected_ty
  89. -    in
  90. +    reset_pattern ~modules:true ~existentials:true ();
  91. +    let typed_p = type_pat ~lev ~constrs ~labels (ref env) p expected_ty in
  92.      backtrack snap;
  93.      (* types are invalidated but we don't need them here *)
  94.      Some typed_p
  95. @@ -1172,25 +1174,25 @@
  96.       pv env,
  97.     get_ref module_variables)
  98.  
  99. -let type_pattern ~lev env spat scope expected_ty =
  100. -  reset_pattern scope true;
  101. +let type_pattern ~lev ~gadts env spat scope expected_ty =
  102. +  reset_pattern ?scope ~modules:true ~existentials:true ~gadts ();
  103.    let new_env = ref env in
  104. -  let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
  105. +  let pat = type_pat ~lev new_env spat expected_ty in
  106.    let new_env, unpacks =
  107.      add_pattern_variables !new_env
  108.        ~check:(fun s -> Warnings.Unused_var_strict s)
  109.        ~check_as:(fun s -> Warnings.Unused_var s) in
  110.    (pat, new_env, get_ref pattern_force, unpacks)
  111.  
  112. -let type_pattern_list env spatl scope expected_tys allow =
  113. -  reset_pattern scope allow;
  114. +let type_pattern_list env spatl scope expected_tys modules =
  115. +  reset_pattern ?scope ~modules ();
  116.    let new_env = ref env in
  117.    let patl = List.map2 (type_pat new_env) spatl expected_tys in
  118.    let new_env, unpacks = add_pattern_variables !new_env in
  119.    (patl, new_env, get_ref pattern_force, unpacks)
  120.  
  121.  let type_class_arg_pattern cl_num val_env met_env l spat =
  122. -  reset_pattern None false;
  123. +  reset_pattern ();
  124.    let nv = newvar () in
  125.    let pat = type_pat (ref val_env) spat nv in
  126.    if has_variants pat then begin
  127. @@ -1224,7 +1226,7 @@
  128.      mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")),
  129.                         mknoloc ("selfpat-" ^ cl_num)))
  130.    in
  131. -  reset_pattern None false;
  132. +  reset_pattern ();
  133.    let nv = newvar() in
  134.    let pat = type_pat (ref val_env) spat nv in
  135.    List.iter (fun f -> f()) (get_ref pattern_force);
  136. @@ -1776,8 +1778,6 @@
  137.  (* XXX Should we do something about global type variables too? *)
  138.  
  139.  let duplicate_ident_types loc caselist env =
  140. -  let caselist =
  141. -    List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
  142.    let idents = all_idents (List.map snd caselist) in
  143.    List.fold_left
  144.      (fun env s ->
  145. @@ -3129,34 +3129,10 @@
  146.    let erase_either =
  147.      List.exists contains_polymorphic_variant patterns
  148.      && contains_variant_either ty_arg
  149. -  and has_gadts = List.exists (contains_gadt env) patterns in
  150. -(*  prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
  151. -  let ty_arg =
  152. -    if (has_gadts || erase_either) && not !Clflags.principal
  153. -    then correct_levels ty_arg else ty_arg
  154. -  and ty_res, env =
  155. -    if has_gadts && not !Clflags.principal then
  156. -      correct_levels ty_res, duplicate_ident_types loc caselist env
  157. -    else ty_res, env
  158.    in
  159. -  let lev, env =
  160. -    if has_gadts then begin
  161. -      (* raise level for existentials *)
  162. -      begin_def ();
  163. -      Ident.set_current_time (get_current_level ());
  164. -      let lev = Ident.current_time () in
  165. -      Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
  166. -      (lev, Env.add_gadt_instance_level lev env)
  167. -    end else (get_current_level (), env)
  168. -  in
  169. -(*  if has_gadts then
  170. -    Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
  171. -  begin_def (); (* propagation of the argument *)
  172. -  let ty_arg' = newvar () in
  173.    let pattern_force = ref [] in
  174. -(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
  175. -    Printtyp.raw_type_expr ty_arg; *)
  176. -  let pat_env_list =
  177. +  let mk_pat_env_list lev gadts env ty_arg caselist =
  178. +    let ty_arg' = newvar () in
  179.      List.map
  180.        (fun (spat, sexp) ->
  181.          let loc = sexp.pexp_loc in
  182. @@ -3167,7 +3143,7 @@
  183.              if !Clflags.principal || erase_either
  184.              then Some false else None in
  185.            let ty_arg = instance ?partial env ty_arg in
  186. -          type_pattern ~lev env spat scope ty_arg
  187. +          type_pattern ~lev ~gadts env spat scope ty_arg
  188.          in
  189.          pattern_force := force @ !pattern_force;
  190.          let pat =
  191. @@ -3180,6 +3156,44 @@
  192.          unify_pat env pat ty_arg';
  193.          (pat, (ext_env, unpacks)))
  194.        caselist in
  195. +  let ty_arg =
  196. +    if erase_either && not !Clflags.principal
  197. +    then correct_levels ty_arg else ty_arg
  198. +  and lev = get_current_level () in
  199. +  let pat_env_list, has_gadts =
  200. +    begin_def (); (* propagation of the argument *)
  201. +    let snap = snapshot () in
  202. +    try mk_pat_env_list lev false env ty_arg caselist, false
  203. +    with Contains_gadt ->
  204. +      backtrack snap; pattern_force := [];
  205. +      end_def (); if !Clflags.principal then end_def ();
  206. +      ([], true)
  207. +  in
  208. +(*  let has_gadts = List.exists (contains_gadt env) patterns in *)
  209. +(*  prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
  210. +  let ty_arg, ty_res, lev, env, pat_env_list =
  211. +    if not has_gadts then (ty_arg, ty_res, lev, env, pat_env_list) else
  212. +    (* Prepare for typing GADTs *)
  213. +    let ty_arg =
  214. +      if not erase_either && not !Clflags.principal
  215. +      then correct_levels ty_arg else ty_arg
  216. +    and ty_res, env =
  217. +      if not !Clflags.principal then
  218. +        correct_levels ty_res, duplicate_ident_types loc caselist env
  219. +      else ty_res, env
  220. +    in
  221. +    (* raise level for existentials *)
  222. +    begin_def ();
  223. +    Ident.set_current_time (get_current_level ());
  224. +    let lev = Ident.current_time () in
  225. +    Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
  226. +    let env = Env.add_gadt_instance_level lev env in
  227. +    begin_def (); (* propagation of the argument *)
  228. +    (ty_arg, ty_res, lev, env,
  229. +     mk_pat_env_list lev true env ty_arg caselist)
  230. +  in
  231. +(*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
  232. +    Printtyp.raw_type_expr ty_arg; *)
  233.    (* Check for polymorphic variants to close *)
  234.    let patl = List.map fst pat_env_list in
  235.    if List.exists has_variants patl then begin
  236. @@ -3193,7 +3207,7 @@
  237.    List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
  238.      patl;
  239.    List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;
  240. -  end_def ();
  241. +  end_def (); (* propagation of the argument *)
  242.    List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
  243.    (* type bodies *)
  244.    let in_function = if List.length caselist = 1 then in_function else None in
  245. @@ -3208,7 +3222,7 @@
  246.              end_def ();
  247.              generalize_structure ty; ty
  248.            end
  249. -          else if contains_gadt env spat then correct_levels ty_res
  250. +          else if has_gadts then correct_levels ty_res
  251.            else ty_res in
  252.  (*        Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
  253.            Printtyp.raw_type_expr ty_res'; *)
  254. Index: utils/warnings.ml
  255. ===================================================================
  256. --- utils/warnings.ml   (revision 13871)
  257. +++ utils/warnings.ml   (working copy)
  258. @@ -348,10 +348,12 @@
  259.  ;;
  260.  
  261.  let nerrors = ref 0;;
  262. +let recent = ref [];;
  263.  
  264.  let print ppf w =
  265.    let msg = message w in
  266.    let num = number w in
  267. +  recent := w :: !recent;
  268.    let newlines = ref 0 in
  269.    for i = 0 to String.length msg - 1 do
  270.      if msg.[i] = '\n' then incr newlines;
  271. @@ -371,6 +373,7 @@
  272.  exception Errors of int;;
  273.  
  274.  let check_fatal () =
  275. +  recent := [];
  276.    if !nerrors > 0 then begin
  277.      let e = Errors !nerrors in
  278.      nerrors := 0;
  279. Index: utils/warnings.mli
  280. ===================================================================
  281. --- utils/warnings.mli  (revision 13871)
  282. +++ utils/warnings.mli  (working copy)
  283. @@ -75,5 +75,5 @@
  284.  exception Errors of int;;
  285.  
  286.  val check_fatal : unit -> unit;;
  287. -
  288. -val help_warnings: unit -> unit
  289. +val recent : t list ref;;
  290. +val help_warnings : unit -> unit;;
  291. Index: parsing/location.ml
  292. ===================================================================
  293. --- parsing/location.ml (revision 13871)
  294. +++ parsing/location.ml (working copy)
  295. @@ -261,7 +261,7 @@
  296.  let print_error_cur_file ppf = print_error ppf (in_file !input_name);;
  297.  
  298.  let print_warning loc ppf w =
  299. -  if Warnings.is_active w then begin
  300. +  if Warnings.is_active w && not (List.mem w !Warnings.recent) then begin
  301.      let printw ppf w =
  302.        let n = Warnings.print ppf w in
  303.        num_loc_lines := !num_loc_lines + n
RAW Paste Data
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
 
Top