Commits

Anonymous committed f87489f

+ mutable storage for 'universal'-like types (for runtime typeinfo of complex types)

  • Participants
  • Parent commits 317d396

Comments (0)

Files changed (7)

File src/cd_Bool.ml

     value monoid_and = new Monoid.t True ( && )
     ;
 
+    module Storage =
+      Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = bool; end)
+    ;
+
   end
 ;

File src/cd_Int.ml

  =
   struct
 
+    open Cdt;
+
     type t = int;
 
     value compare = Pervasives.compare;
 
 
 
-    open Cdt;
-
     value cmp (x : int) (y : int) =
       match  Pervasives.compare x y  with
       [ 0 -> EQ
       and opt_show = show
     ;
 
+    module Storage =
+      Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = t; end);
+
   end
 ;

File src/cd_Num.ml

  =
   struct
 
+    open Cdt;
+
     include Num;
 
     type t = num;
 
 
     open Cd_Typeinfo;
-    open Cdt;
 
     value show = string_of_num;
     value hash = Typeinfo.perv_hash;
     value opt_eq = eq;
     value opt_cmp = cmp;
 
+
+    module Storage =
+      Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = t; end)
+    ;
+
+
   end
 ;

File src/cd_Strings.ml

         value opt_eq : string -> string -> bool;
         value opt_hash : string -> int;
         value opt_show : string -> string;
+        module Storage : STORAGE with type ts = string;
       end
     ;
 
           and opt_show = show
         ;
 
+        module Storage = Typeinfo.Make_storage(struct type tm = string; end);
+
       end
     ;
 

File src/cd_Typeinfo.ml

 
     open Cdt;
 
+    value temp_storage_size = 2
+      (* for binary ops *)
+    ;
+
+    module Make_storage (T : sig type tm; end)
+     :
+      STORAGE with type ts = T.tm
+     =
+      struct
+
+        type ts = T.tm;
+
+        value temp_storage =
+          TlsArray.make temp_storage_size None
+        ;
+
+        value set
+         = fun ot i ->
+             TlsArray.set temp_storage i ot
+        ;
+        value get
+         = fun i ->
+             TlsArray.get temp_storage i
+        ;
+      end
+    ;
+
+    module No_storage
+     =
+      struct
+        value fail () =
+          failwith "Cadastr: can't use 't_no' values in generic functions \
+                    when the concrete type is required"
+        ;
+        value set
+         : option 'a -> int -> unit
+         = fun _ot _i ->
+             fail ()
+        ;
+        value get
+         : int -> option 'a
+         = fun _i ->
+             fail ()
+        ;
+      end
+    ;
+
+
     value cmp_of_compare compare =
       fun a b ->
         match compare a b with
       let eq = opt eq No.eq
       and cmp = opt cmp No.cmp
       and hash = opt hash No.hash
-      and show = opt show No.show in
-
+      and show = opt show No.show
+      in
+      let module Storage = Make_storage (struct type tm = tt; end) in
       let module Tmod =
         struct
           type t = tt;
           value opt_cmp = cmp;
           value opt_hash = hash;
           value opt_show = show;
+          module Storage = Storage;
         end
       in
 
           method cmp = cmp;
           method hash = hash;
           method show = show;
+          method storage = (module Storage : STORAGE with type ts = tt);
         end
       :
         tall tt
 
 
     value t_no : t 'a = fun (type tt) ->
-      object
+      object (noself)
         method topt =
-          object
+          object (_self)
             method eq (* : tt -> tt -> bool*) = No.eq;
             method cmp = No.cmp;
             method hash = No.hash;
             method show = No.show;
+            method storage =
+              let module Tmod =
+                (value noself#tmod : T with type t = tt)
+              in
+                (module Tmod.Storage : STORAGE with type ts = tt)
+            ;
           end;
         method tmod =
           (module
                value opt_show = No.show;
                value opt_hash = No.hash;
                value opt_cmp = No.cmp;
+               module Storage =
+                 struct
+                   type ts = tt;
+                   include No_storage;
+                 end
+               ;
              end
             )
           : T with type t = tt
     value tfull ~cmp ?eq ~hash ~show () =
       let eq = eq_of_opt ?eq ~cmp in
       let (topt, tmod) = topt ~cmp ~eq ~hash ~show () in
+      let storage = topt#storage in
       ((object
           method topt = topt;
           method tmod = tmod;
           method eq = eq;
           method hash = hash;
           method show = show;
+          method storage = storage;
         end
        )
        :
     value topt_of_tmod (type a) (tmod : (module T with type t = a)) : tall a
      =
       let module T = (value tmod : T with type t = a) in
+      let module Storage = T.Storage in
       let cmp = T.opt_cmp
       and eq = T.opt_eq
       and hash = T.opt_hash
         method eq = eq;
         method hash = hash;
         method show = show;
+        method storage = (module Storage : STORAGE with type ts = a);
       end
     ;
 
       let eq = topt#eq
       and hash = topt#hash
       and show = topt#show in
+      let module Storage = (value topt#storage : STORAGE with type ts = a) in
       (module
         (struct
            type t = a;
            value opt_show = show;
 
            value cmp = cmp;
+
+           module Storage = Storage;
          end
         )
       : TCMP with type t = a
 
 (***************************************************************)
 
+module type STORAGE
+ =
+  sig
+    type ts;
+    value set : option ts -> int -> unit;
+    value get : int -> option ts;
+  end
+;
+
+
+type storage 'a = (module STORAGE with type ts = 'a)
+;
+
+
 module type T
  =
   sig
     value opt_hash : t -> int;
     value opt_show : t -> string;
 
+    module Storage : STORAGE with type ts = t;
+
   end
 ;
 
     method cmp : 'a -> 'a -> cmp_res;
     method hash : 'a -> int;
     method show : 'a -> string;
+    method storage : storage 'a;
   end
 ;
 

File test/test.ml

+(*
+   TODO: проверить, будет ли t_no кидать исключение при попытке
+   работать со storage.
+*)
+
 (* TODO: проверить, как trie over map будет жить в случае
      nocasestringmap#merge .. casestringmap -- по идее, должно
      обломать на сравнении типов map_rw [Nocasestring.t, 'v] vs