Commits

camlspotter committed f94b747

quick fix for include

Comments (0)

Files changed (8)

     | AStr_class     of Ident.t
     | AStr_cltype    of Ident.t
     | AStr_include   of module_expr * (Ident.t * (Kind.t * Ident.t)) list
+    | AStr_included  of Ident.t * module_expr * Kind.t * Ident.t
 
   let rec format_module_expr ppf = function
     | AMod_ident p -> fprintf ppf "%s" (Path.name p)
               Ident.format id' 
               Ident.format id))
           aliases
+    | AStr_included (id, mexp, kind, id') ->
+        fprintf ppf "@[<v4>included %s %a = %a@ { @[<v>%a@] }@]"
+          (Kind.name kind)
+          Ident.format id
+          Ident.format id'
+          format_module_expr mexp
 
   let ident_of_structure_item : structure_item -> (Kind.t * Ident.t) option = function
     | AStr_value id        -> Some (Kind.Value, id)
     | AStr_class id        -> Some (Kind.Class, id)
     | AStr_cltype id       -> Some (Kind.Class_type, id)
     | AStr_include _       -> None
+    | AStr_included (id, _, kind, _) -> Some (kind, id)
 
   module Module_expr = struct
     (* cache key is Typedtree.module_expr *)
 	| AStr_include (mexp1, aliases1), AStr_include (mexp2, aliases2) ->
             aliases1 = aliases2
             && Module_expr.equal mexp1 mexp2
+	| AStr_included (id1, mexp1, kind1, id1'), AStr_included (id2, mexp2, kind2, id2') ->
+            id1 = id2 && kind1 = kind2 && id1' = id2'
+            && Module_expr.equal mexp1 mexp2
 	| (AStr_value _ | AStr_type _ | AStr_exception _ | AStr_modtype _ 
-	  | AStr_class _ | AStr_cltype _ | AStr_module _ | AStr_include _),
+	  | AStr_class _ | AStr_cltype _ | AStr_module _ | AStr_include _ | AStr_included _),
 	  (AStr_value _ | AStr_type _ | AStr_exception _ | AStr_modtype _ 
-	  | AStr_class _ | AStr_cltype _ | AStr_module _ | AStr_include _) -> false
+	  | AStr_class _ | AStr_cltype _ | AStr_module _ | AStr_include _ | AStr_included _) -> false
 
       let hash = Hashtbl.hash
     end
     | Tmodtype_abstract -> AMod_abstract
     | Tmodtype_manifest mty -> module_type mty
 
+(* This is wrong. This only flatten module related things and 
+   non modules like patterns are never flattened. 
+
+
   let rec flatten str = List.concat_map flatten_item str
 
   and flatten_item item = match item with
     | AMod_constraint (m, _) -> flatten_module_expr m
     | AMod_unpack m -> flatten_module_expr m
     | AMod_abstract -> []
+*)
 end
 
 let protect name f v = try f v with e ->
 }
 *)
 
-(* add env 
-and structure_item =
-  { str_desc : structure_item_desc;
-    str_loc : Location.t;
-    str_env : Env.t
-  }
-*)
+      method! structure_item sitem = 
+        begin match sitem.str_desc with (* CR jfuruse; todo add env *)
+        | Tstr_include (mexp, idents) ->
+            let loc = sitem.str_loc in
+            let id_kid_list = aliases_of_include mexp idents in
+            let m = module_expr mexp in
+            List.iter (fun (id, (k, id')) -> 
+              record loc (Str (AStr_included (id, m, k, id')))) id_kid_list
+        | _ -> ()
+        end;
+        super#structure_item sitem
+
       method! structure_item_desc sid =
         begin match sid with
         | Tstr_primitive (id, {loc}, _) -> 
         | Tstr_class_type lst ->
             List.iter (fun (id, {loc}, _) -> 
               record loc (Str (AStr_cltype id))) lst
-        | Tstr_include (_mexp, _idents) -> () (* CR jfuruse: TODO *)
+        | Tstr_include (_mexp, _idents) -> () (* done in #structure_item *)
         | Tstr_eval _ 
         | Tstr_value _ 
         | Tstr_class _  
     | AStr_class     of Ident.t
     | AStr_cltype    of Ident.t
     | AStr_include   of module_expr * (Ident.t * (Kind.t * Ident.t)) list
+    | AStr_included  of Ident.t * module_expr * Kind.t * Ident.t
 
   val ident_of_structure_item : structure_item -> (Kind.t * Ident.t) option
 
   val structure : Typedtree.structure -> module_expr
   val signature : Typedtree.signature -> module_expr
 
-  val flatten : structure -> structure
-
   open Format
   val format_module_expr : formatter -> module_expr -> unit
   val format_structure : formatter -> structure -> unit
             | AStr_modtype   _ -> Kind.Module_type
             | AStr_class     _ -> Kind.Class
             | AStr_cltype    _ -> Kind.Class_type
+            | AStr_included (_, _, kind, _) -> kind
             | AStr_module _ | AStr_include _ -> assert false
           in
           (id, (kind, eager v)) :: str
           in
           (id, (Kind.Module_type, v)) :: str
 
+      | AStr_included (id', mexp, k, id) ->
+          (* shared include should share the result of mexp *)
+          (* be careful: everything must be done lazily *)
+          let v = lazy begin
+            (* createate it lazily for recursiveness of flat *)
+            let env = Env.overrides env0 str in
+            !!(module_expr env None(*?*) mexp)
+          end in
+          let kid_ztbl = 
+            lazy begin match !!v with
+            | Structure (_, str, _ (* CR jfuruse *) ) -> 
+                List.map (fun (id, (k, v)) -> (k, id), v) str
+            | Parameter pid -> [ (k, id), eager (Parameter pid) ]
+            | Ident _ -> assert false
+            | Closure _ -> assert false
+            | Error _ -> [] (* error *)
+            end
+          in
+          let v = lazy begin
+            let kid_tbl = !!kid_ztbl in
+              (* include does not preserve id stamp, so we must ignore them *)
+            match 
+              List.find_map_opt (fun ((k', id'), v) -> 
+                if k = k' && Ident0.name id = Ident0.name id' then Some v else None) kid_tbl
+            with
+            | Some vz -> !!vz
+            | None -> 
+                Format.eprintf "INCLUDE ERROR: %s %a in @[%a@]@."
+                  (Kind.name k)
+                  Ident.format id
+                  (Format.list ";@ " (fun ppf ((k,id), _) -> 
+                    Format.fprintf ppf "%s %a" (Kind.name k) Ident.format id))
+                  kid_tbl;
+                Error (Failure "not found in include")
+          end in
+          (id', (k, v)) :: str
+
       | AStr_include (mexp, aliases) ->
           (* be careful: everything must be done lazily *)
           let v = lazy begin
           let tree = lazy begin
             List.fold_left Tree.add Tree.empty rannots
           end in
-          let flat = Spot.Abstraction.flatten str in
+          (* CR jfuruse: it is almost the same as id_def_regions_list *)
+          let flat = List.filter_map (fun (loc, annot) -> match annot with
+              | Annot.Str sitem -> Some sitem
+              | _ -> None) loc_annots
+          in
           Debug.format "cmt loaded: flat created from %s@." path;
           Debug.format "cmt analysis done from %s@." path;
           { cmt; path;

tests/Makefile.targets

 external_include.cmo \
 fstclassmodule.cmo \
 fstclassmodule2.cmo \
+function_arg.cmo \
 functor.cmo \
 functor_app.cmo \
 functor_call.cmo \
 include_functor_app.cmo \
 include_override.cmo \
 included_and_flat.cmo \
+included_value.cmo \
 inherit.cmo \
 inherit2.cmo \
 interface.cmo \

tests/function_arg.ml

+let (* function1 => *) function1 (* <= function1 *) (* fun arg x => *) x (* <= fun arg x *) = x (* ? fun arg x *)
+let (* function2 => *) function2 (* <= function1 *) = fun (* fun arg x2 => *) x (* <= fun arg x2 *) -> x (* ? fun arg x2 *)

tests/signature2.mli

-(* S => *)
-module type S = sig type (* S.t => *) t (* <= S.t *) end
-(* <= S *)
+module type (* S => *) S (* <= S *) = sig type (* S.t => *) t (* <= S.t *) end
+
 
 module M : S (* ? S *)
 
-type (* type t => *) t = Bar (* <= type t *)
+type (* type t => *) t (* <= type t *) = Bar 
 
 type u = t (* ? type t *)