Commits

Dmitry Grebeniuk  committed 5820fb5

Storage / On_storage compiled, not tested

  • Participants
  • Parent commits 9492053

Comments (0)

Files changed (6)

File src/cd_Bool.ml

     value show = fun [ True -> "True" | False -> "False" ]
     ;
 
-    value opt_cmp = cmp
-      and opt_eq = eq
-      and opt_hash = hash
-      and opt_show = show
+    module Ops_
+     =
+      struct
+        value opt_cmp = cmp
+          and opt_eq = eq
+          and opt_hash = hash
+          and opt_show = show
+        ;
+      end
     ;
 
+    include Ops_;
 
     value monoid_or = new Monoid.t False ( || )
     ;
       Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = bool; end)
     ;
 
+    module On_storage =
+      Cd_Typeinfo.Typeinfo.Make_On_storage
+        (struct
+           include Ops_;
+           type t = bool;
+         end
+        )
+        (Storage)
+    ;
+
   end
 ;

File src/cd_Int.ml

     value show = string_of_int
     ;
 
-
-    value opt_cmp = cmp
-      and opt_eq = eq
-      and opt_hash = hash
-      and opt_show = show
+    module Ops_
+     =
+      struct
+        value opt_cmp = cmp
+          and opt_eq = eq
+          and opt_hash = hash
+          and opt_show = show
+        ;
+      end
     ;
 
+    include Ops_;
+
     module Storage =
-      Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = t; end);
+      Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = t; end)
+    ;
+    module On_storage =
+      Cd_Typeinfo.Typeinfo.Make_On_storage
+        (struct
+           include Ops_;
+           type t = int;
+         end
+        )
+        (Storage)
+    ;
 
   end
 ;

File src/cd_Num.ml

       | x when x < 0 -> LT
       | _ (* when _ > 0 *) -> GT
       ];
-    value opt_show = show;
-    value opt_hash = hash;
-    value opt_eq = eq;
-    value opt_cmp = cmp;
 
+    module Ops_
+     =
+      struct
+        value opt_show = show;
+        value opt_hash = hash;
+        value opt_eq = eq;
+        value opt_cmp = cmp;
+      end
+    ;
+
+    include Ops_;
 
     module Storage =
       Cd_Typeinfo.Typeinfo.Make_storage(struct type tm = t; end)
     ;
+    module On_storage =
+      Cd_Typeinfo.Typeinfo.Make_On_storage
+        (struct
+           include Ops_;
+           type t = num;
+         end
+        )
+        (Storage)
+    ;
 
 
   end

File src/cd_Strings.ml

       end
     ;
 
-    module TFuncs
+    module TFuncs_
      =
       struct
+
         value cmp (x : string) (y : string) =
           match  Pervasives.compare x y  with
           [ 0 -> Cdt.EQ
           and opt_show = show
         ;
 
+      end
+    ;
+
+    module TFuncs
+     =
+      struct
+
+        include TFuncs_;
+
         module Storage = Typeinfo.Make_storage(struct type tm = string; end);
 
+        module On_storage = Typeinfo.Make_On_storage
+          (struct
+             include TFuncs_;
+             type t = string;
+           end
+          )
+          (Storage)
+        ;
+
       end
     ;
 
      =
       struct
 
+        include TFuncs;
         type t = string;
 
-        include TFuncs;
-
       end
     ;
 

File src/cd_Typeinfo.ml

          = fun i ->
              TlsArray.get temp_storage i
         ;
+
+        value wrap1
+         = fun f1 ->
+             fun i ->
+               match (get i) with
+               [ None -> assert False
+               | Some x -> f1 x
+               ]
+        ;
+
+        value wrap2
+         = fun f2 ->
+             fun i j ->
+               match ((get i), (get j)) with
+               [ (None, _) | (_, None) -> assert False
+               | (Some x, Some y) -> f2 x y
+               ]
+        ;
+
+      end
+    ;
+
+
+    module Make_On_storage
+      (T_ : T_OPS_)
+      (S : STORAGE with type ts = T_.t)
+      : T_OPS_ with type t = int
+     =
+      struct
+        type t = int;
+        value opt_cmp = S.wrap2 T_.opt_cmp;
+        value opt_eq = S.wrap2 T_.opt_eq;
+        value opt_hash = S.wrap1 T_.opt_hash;
+        value opt_show = S.wrap1 T_.opt_show;
       end
     ;
 
          = fun _i ->
              fail ()
         ;
+        value wrap1
+         = fun _f1 _i ->
+             fail ()
+        ;
+        value wrap2
+         = fun _f1 _i _j ->
+             fail ()
+        ;
       end
     ;
 
       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_eq = eq;
+          value opt_hash = hash;
+          value opt_show = show;
+        end
+      in
+      let module On_storage = Make_On_storage(Tmod_)(Storage) in
       let module Tmod =
         struct
-          type t = tt;
-          value opt_eq = eq;
-          value opt_cmp = cmp;
-          value opt_hash = hash;
-          value opt_show = show;
+          include Tmod_;
           module Storage = Storage;
+          module On_storage = On_storage;
         end
       in
-
       let tmod = (module Tmod : T with type t = tt)
       and topt =
       (
           method hash = hash;
           method show = show;
           method storage = (module Storage : STORAGE with type ts = tt);
+          method on_storage = (module On_storage : T_OPS_ with type t = int);
         end
       :
         tall tt
               in
                 (module Tmod.Storage : STORAGE with type ts = tt)
             ;
+            method on_storage =
+              let module Tmod =
+                (value noself#tmod : T with type t = tt)
+              in
+              let module Storage = Tmod.Storage
+              in
+              let module On_storage = Make_On_storage(Tmod)(Storage)
+              in
+                (module On_storage : T_OPS_ with type t = int)
+            ;
           end;
         method tmod =
-          (module
-            (struct
-               type t = tt;
+          let module No_any =
+            struct
                value opt_eq = No.eq;
                value opt_show = No.show;
                value opt_hash = No.hash;
                value opt_cmp = No.cmp;
+            end
+          in
+          (module
+            (struct
+               type t = tt;
+               include No_any;
                module Storage =
                  struct
                    type ts = tt;
                    include No_storage;
                  end
                ;
+               module On_storage =
+                 struct
+                   type t = int;
+                   include No_any;
+                 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
+      let storage = topt#storage
+      and on_storage = topt#on_storage in
       ((object
           method topt = topt;
           method tmod = tmod;
           method hash = hash;
           method show = show;
           method storage = storage;
+          method on_storage = on_storage;
         end
        )
        :
      =
       let module T = (value tmod : T with type t = a) in
       let module Storage = T.Storage in
+      let module On_storage = T.On_storage in
       let cmp = T.opt_cmp
       and eq = T.opt_eq
       and hash = T.opt_hash
         method hash = hash;
         method show = show;
         method storage = (module Storage : STORAGE with type ts = a);
+        method on_storage =
+          (module On_storage : T_OPS_ with type t = int);
       end
     ;
 
       and hash = topt#hash
       and show = topt#show in
       let module Storage = (value topt#storage : STORAGE with type ts = a) in
+      let module On_storage =
+        (value topt#on_storage : T_OPS_ with type t = int) in
       (module
         (struct
            type t = a;
            value cmp = cmp;
 
            module Storage = Storage;
+           module On_storage = On_storage;
          end
         )
       : TCMP with type t = a
     type ts;
     value set : option ts -> int -> unit;
     value get : int -> option ts;
+    value wrap1 : (ts -> 'a) -> (int -> 'a);
+    value wrap2 : (ts -> ts -> 'a) -> (int -> int -> 'a);
   end
 ;
 
 
     module Storage : STORAGE with type ts = t;
 
+    module On_storage : T_OPS_ with type t = int;
+
   end
 ;
 
 type tmod_cmp 'a = (module TCMP with type t = 'a)
 ;
 
+type on_storage = (module T_OPS_ with type t = int)
+;
+
 (***************************************************************)
 
 class type tall ['a] =
     method cmp : 'a -> 'a -> cmp_res;
     method hash : 'a -> int;
     method show : 'a -> string;
+
     method storage : storage 'a;
+    method on_storage : on_storage;
   end
 ;