Commits

Anonymous committed 220c3b1

functor parameter working

Comments (0)

Files changed (7)

     utils/misc.cmx typing/ident.cmx typing/btype.cmx typing/subst.cmi 
 typing/typeclass.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
-    typing/subst.cmi typing/stypes.cmi typing/spot.cmi typing/printtyp.cmi \
-    typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
-    typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/includeclass.cmi typing/ident.cmi \
-    typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
-    parsing/asttypes.cmi typing/typeclass.cmi 
+    typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi \
+    typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/typeclass.cmi 
 typing/typeclass.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
-    typing/subst.cmx typing/stypes.cmx typing/spot.cmx typing/printtyp.cmx \
-    typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
-    typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
-    parsing/location.cmx typing/includeclass.cmx typing/ident.cmx \
-    typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
-    parsing/asttypes.cmi typing/typeclass.cmi 
+    typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx \
+    typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \
+    parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \
+    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/typeclass.cmi 
 typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/stypes.cmi typing/spot.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \

ocamlspot/ocamlspot.ml

 	    (Kind.to_string use) (Path.name path)
       | Module _todo ->
 	  Format.fprintf ppf "Module: (...)" 
+      | Functor_parameter id ->
+	  Format.fprintf ppf "Functor_parameter: %s" (Ident.name id)
       | Non_expansive b ->
           Format.fprintf ppf "Non_expansive: %b" b
 
       let rec t = function
         | Structure (_, str) -> structure str
         | Closure (_, e, _, _, _) -> env e
-        | Ident _ | Error _ -> ()
+        | Ident _ | Error _ | Parameter _ -> ()
       and env e = binding e.binding
       and binding b =
         match !b with
       include Format
       let rec t ppf = function
         | Ident id -> Format.fprintf ppf "Ident(%a)" PIdent.format id
+        | Parameter id -> Format.fprintf ppf "Parameter(%a)" PIdent.format id
         | Structure (pid, str) -> 
 	    Format.fprintf ppf "@[<v2>Module(%a)@ %a@]"
 	      PIdent.format pid
           lazy begin
 	    match !!(find_path (* ? find_path *) env (Kind.Module, p)) with
             | Ident _ -> (try assert false with e -> Error e)
+            | Parameter pid -> Parameter pid
 	    | Closure _ -> (try assert false with e -> Error e)
             | Error exn -> Error exn
 	    | Structure (_pid, str) -> 
 	  let v2 = module_expr env None mexp2 in
 	  lazy begin match !!v1 with
           | Ident _ -> assert false
+          | Parameter pid -> Parameter pid
 	  | Structure _ -> assert false
           | Error exn -> Error exn
 	  | Closure (_, env, id, _mty, mexp) -> 
               lazy begin match !!v with
  	      | Structure (_, str) -> 
                   List.map (fun (id, (k, v)) -> (k, Ident0.name id), v) str
+              | Parameter pid -> 
+                  List.map (fun (k,id) -> 
+                    (k, Ident0.name id), eager (Parameter pid)) kids
               | Ident _ -> assert false
 	      | Closure _ -> assert false
 	      | Error _ -> [] (* error *)
     let structure_flat env flat = 
       let str = structure env flat in
       List.fold_left (fun str -> function
-	| Str_module (id, Mod_functor (id, _mty, _mexp)) ->
-	    id, (Kind.Module, Parameter { PIdent.path = env.Env.path;
-					  ident = id }) :: str
+	| Str_module (_id, Mod_functor (id, _mty, _mexp)) ->
+	    (id, (Kind.Module, eager (Parameter { PIdent.path = env.Env.path;
+					          ident = Some id }))) 
+            :: str
 	| _ -> str) str flat
   end
 
 	    | Annot.Str ( Abstraction.Str_value id
 	                | Abstraction.Str_type id
 	                | Abstraction.Str_exception id
-			| Abstraction.Str_module (id, _)
 			| Abstraction.Str_modtype id
 			| Abstraction.Str_class id
-			| Abstraction.Str_cltype id ) -> 
-			    Hashtbl.add tbl id loc
-              (* Str_include ? *)			      
-	    | _ -> ()) lannots;
+			| Abstraction.Str_cltype id   
+			| Abstraction.Str_module (id, _) )  ->
+                            Hashtbl.add tbl id loc
+	    | Annot.Str ( Abstraction.Str_include _ ) -> ()
+            | Annot.Functor_parameter id ->
+                Hashtbl.add tbl id loc
+            | _ -> ()) lannots;
 	  tbl
         in
         let flat = 
 	    | Annot.Type _ 
             | Annot.Use _
 	    | Annot.Module _ 
+            | Annot.Functor_parameter _
 	    | Annot.Non_expansive _ -> st ) [] lannots
         in
         { version = version;
 	env.Env.binding := Some str; (* dirty hack *)
         env
       in
-      let find_loc id =
+      let find_loc pid =
         (* CR jfuruse: loading twice... *)
-        Debug.format "Finding %a@." PIdent.format id;
-        let file = Load.load ~load_paths: [] (spot_of_file id.PIdent.path) in
-	match id.PIdent.ident with
-	| Some id -> Hashtbl.find file.id_def_locations id
+        Debug.format "Finding %a@." PIdent.format pid;
+        let file = Load.load ~load_paths: [] (spot_of_file pid.PIdent.path) in
+	match pid.PIdent.ident with
 	| None -> Location.none (* the whole file *)
+	| Some id -> 
+            begin try
+                Hashtbl.find file.id_def_locations id
+              with
+              | Not_found ->
+                  Format.eprintf "Error: find location of id %a failed@."
+                    PIdent.format pid;
+                  raise Not_found
+            end
       in
       
 (* obsolete code
         Debug.format "Value=%a@." Value.Format.t v;
         match v with
         | Value.Ident id -> id, find_loc id
+        | Value.Parameter id -> id, find_loc id
         | Value.Structure (id, _)  -> id, find_loc id
         | Value.Closure (id, _, _, _, _) -> id, find_loc id
         | Value.Error (Failure s) -> Format.eprintf "Error %s@." s; assert false
 	Abstraction.Format.structure file.File.flat;
       let str = 
         let env = File.invalid_env file in
-	let str = Eval.structure env file.File.flat in
+	let str = Eval.structure_flat env file.File.flat in
         env.Env.binding := Some str; (* dirty hack (dup code) *)
         str
       in

ocamlspot/tests/functor_parameter.ml

-module F(A : sig val x : int end) = struct
-  let y = A.x
+module F(A : (* A => *) sig val x : int end (* <= A *)) = struct
+  let y = A.x (* ? A *)
 end

ocamlspot/tests/immediate_include.ml

+include struct let (* x => *) x (* <= x *) = 1 end
+
+let _ = x (* ? x *)
     | Str of Abstraction.structure_item 
     | Use of Kind.t * Path.t
     | Module of Abstraction.module_expr
+    | Functor_parameter of Ident.t
     | Non_expansive of bool
 
   let equal t1 t2 =
     | Module mexp1, Module mexp2 -> mexp1 == mexp2
     | Use (k1,p1), Use (k2,p2) -> k1 = k2 && p1 = p2
     | Non_expansive b1, Non_expansive b2 -> b1 = b2
-    | (Type _ | Str _ | Module _ | Use _ | Non_expansive _),
-      (Type _ | Str _ | Module _ | Use _ | Non_expansive _) -> false 
+    | Functor_parameter id1, Functor_parameter id2 -> id1 = id2
+    | (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _),
+      (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _) -> false 
 
   let recorded = (Hashtbl.create 1023 : (Location.t, t) Hashtbl.t)
 
     | Str of Abstraction.structure_item 
     | Use of Kind.t * Path.t
     | Module of Abstraction.module_expr
+    | Functor_parameter of Ident.t
     | Non_expansive of bool
 
   val record : Location.t -> t -> unit

typing/typemod.ml

   | Pmod_functor(name, smty, sbody) ->
       let mty = transl_modtype env smty in
       let (id, newenv) = Env.enter_module name mty env in
+      Spot.Annot.record smty.pmty_loc (* CR jfuruse: name shoud have its position  *) (Spot.Annot.Functor_parameter id);
       let body = type_module None newenv sbody in
       rm { mod_desc = Tmod_functor(id, mty, body);
            mod_type = Tmty_functor(id, mty, body.mod_type);