Commits

camlspotter committed 47ebb5f

No $abst at let x,y = d in

Comments (0)

Files changed (7)

dcamltests/Makefile.targets

 constraint2.cmo \
 derivable.cmo \
 eq.cmo \
-error_multi.cmo \
 error_unmatched_pattern.cmo \
 expansive.cmo \
 explicit.cmo \
 inherit.cmo \
 loop.cmo \
 multi.cmo \
+multi_error.cmo \
 new_resolution.cmo \
 new_resolution2.cmo \
 nodes.cmo \
 oo002.cmo \
 opvar.cmo \
 rec.cmo \
+rec_error.cmo \
 record.cmo \
 resolve.cmo \
 stdlib.cmo \

dcamltests/non_dabstractable.ml

 let x : int * int = M.v (* ok, since it is equivalent with the following *)
 let x = (M.v : int * int)
 
+let _ = let x,y = M.v in x + y
 let (x : int * int) = M.v (* does not work *)
 
-let _ = let x,y = M.v in x + y
 
-

ocamlspot/tests/Makefile.targets

 included_and_flat.cmo \
 inherit.cmo \
 inherit2.cmo \
+interface.cmo \
 intermodule.cmo \
 localvar.cmo \
 module.cmo \

typing/dispatch.ml

 open Btype
 open Ctype
 
+let debug = 
+  try ignore (Sys.getenv "DCAML_DISPATCH_DEBUG"); true 
+  with _ -> false
+
+let x = Format.eprintf "%s%a"
+
+let debugf (fmt : (_, Format.formatter, unit) format) =
+  if debug then Format.eprintf fmt 
+  else Format.ifprintf Format.err_formatter fmt
+
 module Make(Typecore : sig
   type error
   exception Error of Location.t * error
       Misc.try_finally (fun () ->
 (*
 	begin 
-	  Format.eprintf "Entering rec : ";
+	  debugf "Entering rec : ";
 	  match patopt with
-	  | None -> Format.eprintf "NONE : "
+	  | None -> debugf "NONE : "
 	  | Some pat ->
 	      match pat.pat_desc with
-	      | Tpat_var id -> Format.eprintf "pattern %s : " (Ident.unique_name id)
-	      | _ -> Format.eprintf "??? : "
+	      | Tpat_var id -> debugf "pattern %s : " (Ident.unique_name id)
+	      | _ -> debugf "??? : "
 	end;
-	Format.eprintf "ids: %s@." 
+	debugf "ids: %s@." 
 	  (String.concat " " (List.map (fun id -> Ident.unique_name id) ids));
 *)
         enter patopt ids;
 
     let add_call ~at:pat id exp =
 (*
-		Format.eprintf "Add call %s at %s@."
+		debugf "Add call %s at %s@."
 		  (Ident.unique_name id)
 		  (match pat.pat_desc with
 		  | Tpat_var id -> Ident.unique_name id
     let fix_calls ~at:pat abstracts id_types =
 (*
       begin match pat.pat_desc with
-      | Tpat_var id -> Format.eprintf "pattern %s : " (Ident.unique_name id)
-      | _ -> Format.eprintf "??? : "
+      | Tpat_var id -> debugf "pattern %s : " (Ident.unique_name id)
+      | _ -> debugf "??? : "
       end;
 *)
       let cs = try !(Pattern_table.find calls pat) with Not_found -> [] in
 (*
-      Format.eprintf "calls: %s@." 
+      debugf "calls: %s@." 
 	(String.concat " " (List.map (fun (id, _) -> Ident.unique_name id) cs));
 *)
       Pattern_table.remove calls pat;
                 unify_exp_with_dispatch e.exp_env e exp.exp_type
               with
               | exn ->
-                  Format.eprintf "fix_call error %a XXX %a@."
+                  debugf "fix_call error %a XXX %a@."
                     Ctype.Print.type_expr exp.exp_type
                     Ctype.Print.type_expr e.exp_type;
                   raise exn
   end
 
   module Let : sig
-    val enter : Typedtree.pattern option -> Ident.t list -> (unit -> 'a) -> 'a * t list
+
+    val enter : 
+      Typedtree.pattern option 
+      -> Ident.t list
+      -> (unit -> 'a) 
+      -> 'a * t list
+      
     val in_top : unit -> bool
+
   end = struct
+
     let level = ref 0 
+
     let enter patopt idents f =
       Misc.try_finally (fun () ->
         incr level;
         Stack.enter (fun () -> Recursives.enter patopt idents f))
         (fun () -> decr level)
+
     let in_top () = assert (!level >= 0); !level = 0
+
   end
 
   module Resolve = struct
       let paths =
         try value_paths env mpath mty with
         | Not_found ->
-            Format.eprintf "value_paths raised Not_found: %s@."
+            debugf "value_paths raised Not_found: %s@."
               (Path.name mpath);
             raise Not_found
       in
             let mpath_t, mpath, mty =
               try type_is_mpath_t env typ with
               | Not_found ->
-                  Format.eprintf "type %a (= %a) is not mpath_t@."
+                  debugf "type %a (= %a) is not mpath_t@."
                     Printtyp.type_expr typ
                     Printtyp.type_expr (expand_head env typ);
                   raise Not_found
             in
-            Format.eprintf "%a => %s@." Printtyp.type_expr typ (Path.name mpath_t);
+            debugf "%a => %s@." Printtyp.type_expr typ (Path.name mpath_t);
             let candidates_in_mpath = candidates env ~mpath_t ~mpath mty in
 
             (* It also searches a module named Overload *)
 
             (* or *)
             List.fold_left (fun st (path, vdesc) ->
-              Format.eprintf "Checking %s : %a@." (Path.name path)
+              debugf "Checking %s : %a@." (Path.name path)
                 Printtyp.type_expr vdesc.val_type;
               let ty = instance vdesc.val_type in
               let snap = Btype.snapshot () in
                     unify_exp env arg t;
                     check_args u args
                 | _ ->
-                    Format.eprintf "retype failiure: %a@." Printtyp.type_expr ty;
+                    debugf "retype failiure: %a@." Printtyp.type_expr ty;
                     assert false
           in
           check_args e.exp_type args
       match dispatches with
       | [] -> ()
       | _ ->
-          Format.eprintf "Checking %d dispatches@." (List.length dispatches);
+          debugf "Checking %d dispatches@." (List.length dispatches);
           match resolve (List.map (fun d -> d.parent.exp_env, d.ty) dispatches) with
           | [] ->
-              Format.eprintf "no solution@.";
+              debugf "no solution@.";
               unresolved_closed (List.hd dispatches)
           | [exps] ->
               List.iter2 (fun d exp ->
-                begin try retype exp with e -> Format.eprintf "retype failure@.";
+                begin try retype exp with e -> debugf "retype failure@.";
                   raise e; end;
                 d.holder := Some exp) dispatches exps
           | _ ->
-              Format.eprintf "ambiguous@.";
+              debugf "ambiguous@.";
               unresolved_closed (List.hd dispatches)
 
     let checks = ref []
         check_closed !checks
       with
       | Error(_loc, err) as e ->
-          Format.eprintf "@[<2>Dispatch.Resolve.all failed!!!@ @[%a@]@]@." report_error err;
+          debugf "@[<2>Dispatch.Resolve.all failed!!!@ @[%a@]@]@." report_error err;
         raise e
       | e ->
-          Format.eprintf "Dispatch.Resolve.all failed!!! %s@." (Printexc.to_string e); 
+          debugf "Dispatch.Resolve.all failed!!! %s@." (Printexc.to_string e); 
           raise e
     ) (fun () -> checks := [])
   end
     in
     Stack.rev_add rev_disps;
     if rev_disps = [] then exp
-    else begin
+    else
       re { exp_desc = Texp_apply(exp, List.rev rev_apps);
            exp_loc = exp.exp_loc;
            exp_type = ty;
            exp_env = env }
-    end
+  ;;
 
   (* CR jfuruse: recursive let self *)  
   let abstract rec_id_opt exp (dispatches : t list) =
     else Stack.rev_add remains;
     re exp_abstracted, List.rev rev_abstracts
 
+  let no_abstract dispatches =
+    let top = Let.in_top () in 
+    if top then Resolve.add dispatches (* delay *)
+    else Stack.rev_add dispatches
 end

typing/dispatch.mli

       
   module Let : sig
     val enter :
-      pattern option
-      -> Ident.t list
-      -> (unit -> 'a)
-      -> 'a * t list
+      pattern option   (* defined pattern in the let polymorphism *)
+      -> Ident.t list  (* mutual-recursively defined ids *)
+      -> (unit -> 'a)  (* function which calls [apply] in this let *)
+      -> 'a * t list   (* the result of the function and dispatches
+			  added in the function *)
   end
 
   module Resolve : sig
     -> expression
     -> t list
     -> expression * (string * Ident.t * type_expr) list
+
+  val no_abstract : t list -> unit
 end

typing/typecore.ml

 module Dispatch = Dispatch.Make(D)
   
 let rec type_exp env sexp = 
-  (* type_exp_ + dispatch applications *)
+  (* type_exp_ + dispatch applications. *)
   Dispatch.apply env (type_exp_ env sexp)
 
 and type_exp_ env sexp =
 (* Typing of an expression with an expected type.
    Some constructs are treated specially to provide better error messages. *)
 
-and type_expect ?in_function ?(dispatch_apply=false) env sexp ty_expected =
+and type_expect ?in_function env sexp ty_expected =
   match sexp.pexp_desc with
     Pexp_constant(Const_string s as cst) ->
       let exp =
             | _ -> instance Predef.type_string
             end;
           exp_env = env } in
-      let exp = if dispatch_apply then Dispatch.apply env exp else exp in
+      let exp = Dispatch.apply env exp in
       unify_exp env exp ty_expected;
       exp
   | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct ~dispatch_apply env sexp.pexp_loc lid sarg explicit_arity ty_expected
+      type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
-      let body = type_expect ~dispatch_apply new_env sbody ty_expected in
+      let body = type_expect new_env sbody ty_expected in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = sexp.pexp_loc;
         exp_env = env }
   | Pexp_sequence(sexp1, sexp2) ->
       let exp1 = type_statement env sexp1 in
-      let exp2 = type_expect ~dispatch_apply env sexp2 ty_expected in
+      let exp2 = type_expect env sexp2 ty_expected in
       re {
         exp_desc = Texp_sequence(exp1, exp2);
         exp_loc = sexp.pexp_loc;
                                 {pexp_loc = sexp.pexp_loc; pexp_desc =
                                  Pexp_let(Default, [spat, smatch], sbody)}])}
       in
-      type_expect ?in_function ~dispatch_apply env sfun ty_expected
+      type_expect ?in_function env sfun ty_expected
   | Pexp_function (l, _, caselist) ->
       (* CR jfuruse: think about Dispatch.apply *)
       let (loc, ty_fun) =
         exp_env = env }
   | Pexp_when(scond, sbody) ->
       let cond = type_expect env scond (instance Predef.type_bool) in
-      let body = type_expect ~dispatch_apply env sbody ty_expected in
+      let body = type_expect env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
         exp_loc = sexp.pexp_loc;
         spat,
         (* reset dispatch info and enter the definition of pat *)
         Dispatch.Let.enter (Some pat) defined_idents (fun () ->
-          let d_abstable = Dispatch.expression_may_have_implicit_dabst spat in
+          let d_abstable = Dispatch.pattern_may_have_implicit_dabst spat in
           if d_abstable then 
-            (* since [sexp] may have implicit $-absts, its type might disagree
-               with [pat.pat_type] which has the full $-dabsts explicitly or
-               miss some of them. Therefore we cannot use [type_expect].
-
-               we do not need Dispatch.apply against the [sexp]
-               since such applications are immediately abstracted by
-               Dispatch.abstract. So type_exp_ instead of type_exp *)
-	    type_exp_ exp_env sexp
+	    (* We here temporarily apply dispatch args 
+	       for the all $-absts. *)
+	    (* CR: We must perform the same thing like type_expect later *)
+	    type_exp exp_env sexp
           else 
-            type_expect ~dispatch_apply:true exp_env sexp pat.pat_type) )
+	    (* We cannot have implicit $-absts, therefore we can use
+	       type_expect. *)
+            type_expect exp_env sexp pat.pat_type) )
 	  spat_sexp_list pat_list
   in
 
           | Recursive, [id, _] -> Some id (* only works with one let rec *)
           | _ -> None
         in
-        let exp, abstracts = Dispatch.abstract rec_id exp dispatches in
+        let exp, abstracts = 
+	  if pattern_may_have_implicit_dabst then 
+	    Dispatch.abstract rec_id exp dispatches 
+	  else begin
+	    Dispatch.no_abstract dispatches; 
+	    exp, []
+	  end
+	in
         let pat =
           if pattern_may_have_implicit_dabst then begin
 	    match

typing/typecore.mli

         Env.t * Env.t * Env.t
 val type_expect:
         ?in_function:(Location.t * type_expr) ->
-        ?dispatch_apply:bool ->
         Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
 val type_exp:
         Env.t -> Parsetree.expression -> Typedtree.expression
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.