1. Dmitry Grebeniuk
  2. cadastr

Commits

Dmitry Grebeniuk  committed 45732bf

..mid..

  • Participants
  • Parent commits 88fdc41
  • Branches default

Comments (0)

Files changed (7)

File _oasis

View file
  • Ignore whitespace
   BuildDepends: oUnit, cadastr
   Install: false
 
+Executable tests_cdt
+  Path:       test
+  BuildTools: ocamlbuild
+  MainIs:     test_cdt.ml
+  CompiledObject: byte
+  BuildDepends:
+  Install: false
+
 Test all
-  Command: ./test.byte
+  # Command: ./test.byte
+  Command: ./test_cdt.byte
   XCustomClean: true
   XCustomDistclean: true

File src/cd_Array.ml

View file
  • Ignore whitespace
 
     value dump ~t arr =
       arr
-      |> map_to_list (show t)
+      |> map_to_list t#show
       |> String.concat " ; "
       |> sprintf "[| %s |]"
     ;

File src/cd_Typeinfo.ml

View file
  • Ignore whitespace
 
     open Cdt;
 
-    value temp_storage_size = 2
-      (* for binary ops *)
-    ;
-
-value ubox (type aa) (ti : #ti aa) (a : aa) =
-  let module Timod = (value ti#timod : TI with type t = aa) in
-  let module Storage = Timod.Storage in
-  let module On_storage = Timod.On_storage in
-  { ub_store = fun
-      [ UB_STORE_Set -> fun i ->
-          Storage.set (Some a) i
-      | UB_STORE_Clear -> fun i ->
-          Storage.set None i
-      ]
-  ; ub_timono = (ti#tiopt :> timono)
-  }
-;
-
-    module Make_storage (T : sig type tm; end)
-     :
-      STORAGE with type ts = T.tm
+    value ti_no : ti 'a
      =
-      struct
-
-        type ts = T.tm;
-
-        value temp_storage =
-          TlsArray.make temp_storage_size None
+      let type_name = "no_type" in
+      let type_desc = Simple "no_type" in
+      object
+        method type_name = type_name;
+        method type_desc = type_desc;
+        method meths =
+          failwith "Typeinfo.ti_no#meths: can't use methods of ti_no"
         ;
 
-        value set
-         = fun ot i ->
-             TlsArray.set temp_storage i ot
-        ;
-        value get
-         = fun i ->
-             TlsArray.get temp_storage i
+        method temp_store _ _ =
+          failwith "Typeinfo.ti_no#temp_store: can't store"
         ;
 
-        value wrap1
-         = fun f1 ->
-             fun i ->
-               match (get i) with
-               [ None -> assert False
-               | Some x -> f1 x
-               ]
+        method temp_get = 
+          failwith "Typeinfo.ti_no#temp_store: can't get"
         ;
-
-        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_ : TI_OPS_)
-      (S : STORAGE with type ts = T_.t)
-      : ON_STORAGE
-     =
-      struct
-        type t = storage_index;
-        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
-    ;
-
+    (*
     module No_storage
      =
       struct
         ;
       end
     ;
-
+    *)
 
     value cmp_of_compare compare =
       fun a b ->
     value perv_hash = Hashtbl.hash;
 
 
-    (* [No "eq"] for example *)
-    exception No of string
-    ;
-
     value exn_no_eq = No "eq"
       and exn_no_cmp = No "cmp"
       and exn_no_hash = No "hash"
     ;
 
-    module No =
-      struct
-        value eq : 'a -> 'a -> bool = fun _ _ -> raise exn_no_eq;
-        value cmp : 'a -> 'a -> cmp_res = fun _ _ -> raise exn_no_cmp;
-        value hash : 'a -> int = fun _ -> raise exn_no_hash;
-        value show : 'a -> string = fun _ -> "<abstract>";
-      end
-    ;
-
-
     (*********************)
 
-    value tiopt (type tt) ?cmp ?eq ?hash ?show ?(type_desc=Simple) () =
-      let opt ov def =
-        match ov with
-        [ None -> def
-        | Some a -> a
-        ]
-      in
-      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
-      let module Storage = Make_storage (struct type tm = tt; end) in
-      let module Timod_ =
-        struct
-          type t = tt;
-          value opt_cmp = cmp;
-          value opt_eq = eq;
-          value opt_hash = hash;
-          value opt_show = show;
-          value type_desc = type_desc;
-        end
-      in
-      let module On_storage = Make_On_storage(Timod_)(Storage) in
-      let module Timod =
-        struct
-          include Timod_;
-          module Storage = Storage;
-          module On_storage = On_storage;
-        end
-      in
-      let timod = (module Timod : TI with type t = tt)
-      and tiopt =
-      (
-        object
-          method eq = eq;
-          method cmp = cmp;
-          method hash = hash;
-          method show = show;
-          method storage = (module Storage : STORAGE with type ts = tt);
-          method on_storage = (module On_storage : ON_STORAGE);
-          method type_desc = type_desc;
-        end
-      :
-        tiall tt
-      )
-      in
-        (tiopt, timod)
-    ;
-
-
-    value ti_no : ti 'a = fun (type tt) ->
-      object (noself)
-        method tiopt =
-          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#timod : TI with type t = tt)
-              in
-                (module Tmod.Storage : STORAGE with type ts = tt)
-            ;
-            method on_storage =
-              let module Tmod =
-                (value noself#timod : TI with type t = tt)
-              in
-              let module Storage = Tmod.Storage
-              in
-              let module On_storage = Make_On_storage(Tmod)(Storage)
-              in
-                (module On_storage : ON_STORAGE)
-            ;
-            method type_desc = Simple
-            ;
-          end;
-        method timod =
-          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;
-               value type_desc = Simple;
-            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
-            )
-          : TI with type t = tt
-          )
-        ;
-      end
-    ;
-
-
-    value ti = fun (type tt) ?show () ->
-    let (tiopt, timod) = tiopt ?show () in
-    ((
-      object
-        method tiopt = tiopt;
-        method timod = timod;
-      end
-    ) : #ti 'a)
-    ;
-
-
-    value tieq = fun (type tt) ?show ~eq () ->
-    let (tiopt, timod) = tiopt ?show ~eq () in
-    ((
-      object
-        method tiopt = tiopt;
-        method timod = timod;
-        method eq = eq;
-      end
-    ) : #tieq 'a)
-    ;
-
-
-    value eq_of_opt ?eq ~cmp =
-      match eq with
-      [ None -> fun a b -> EQ == cmp a b
-      | Some eq -> eq
-      ]
-    ;
-
     (* [?eq] is derived from [~cmp] if not specified *)
 
-    value ticmpeq = fun ?show ?eq ~cmp () -> 
-      let eq = eq_of_opt ?eq ~cmp in
-      let (tiopt, timod) = tiopt ?show ~cmp ~eq () in
-    (((
-      object
-        method tiopt = tiopt;
-        method timod = timod;
-        method cmp = cmp;
-        method eq = eq;
-      end
-    ) : #tieq 'a) : #ticmp 'a)
-    ;
-
-
     (* receives all possible functions; could be changed in every new version.
        [?eq] is derived from [~cmp] if not specified
-    *)
 
     value tifull ~cmp ?eq ~hash ~show ?(type_desc=Simple) () =
-      let eq = eq_of_opt ?eq ~cmp in
-      let (tiopt, timod) = tiopt ~cmp ~eq ~hash ~show ~type_desc () in
-      let storage = tiopt#storage
-      and on_storage = tiopt#on_storage in
-      ((object
-          method tiopt = tiopt;
-          method timod = timod;
-          method cmp = cmp;
-          method eq = eq;
-          method hash = hash;
-          method show = show;
-          method storage = storage;
-          method on_storage = on_storage;
-          method type_desc = type_desc;
-        end
-       )
-       :
-       tifull 'a
-      )
-    ;
-
-
-    value tiopt_of_timod
-      (type a)
-      (tmod : (module TI with type t = a))
-     : tiall a
-     =
-      let module Ti = (value tmod : TI with type t = a) in
-      let module Storage = Ti.Storage in
-      let module On_storage = Ti.On_storage in
-      let cmp = Ti.opt_cmp
-      and eq = Ti.opt_eq
-      and hash = Ti.opt_hash
-      and show = Ti.opt_show
-      and type_desc = Ti.type_desc
-      in
-      object
-        method cmp = cmp;
-        method eq = eq;
-        method hash = hash;
-        method show = show;
-        method storage = (module Storage : STORAGE with type ts = a);
-        method on_storage = (module On_storage : ON_STORAGE);
-        method type_desc = type_desc;
-      end
-    ;
-
-    value ti_of_timod
-      (type a)
-      (timod : (module TI with type t = a))
-     : ti a
-     =
-      let tiopt = tiopt_of_timod timod in
-      ((
-      object
-        method timod = timod;
-        method tiopt = tiopt;
-      end
-      ) : ti _)
-    ;
-
-    value timod_cmp_of_ticmp (type a)
-     (ticmp : #ticmp a) : (module TICMP with type t = a) =
-      let cmp = ticmp#cmp in
-      let tiopt = ticmp#tiopt in
-      let eq = tiopt#eq
-      and hash = tiopt#hash
-      and show = tiopt#show
-      and type_desc = tiopt#type_desc in
-      let module Storage = (value tiopt#storage : STORAGE with type ts = a) in
-      let module On_storage =
-        (value tiopt#on_storage : ON_STORAGE) in
-      (module
-        (struct
-           type t = a;
-
-           value opt_eq = eq;
-           value opt_cmp = cmp;
-           value opt_hash = hash;
-           value opt_show = show;
-
-           value cmp = cmp;
-
-           module Storage = Storage;
-           module On_storage = On_storage;
-
-           value type_desc = type_desc;
-         end
-        )
-      : TICMP with type t = a
-      )
-    ;
-
-    value teq_of_t ~eq (ti : ti 'a) : tieq 'a =
-      let () = assert (eq == ti#tiopt#eq) in
-      let tiopt = ti#tiopt
-      and timod = ti#timod in
-      object
-        method tiopt = tiopt;
-        method timod = timod;
-        method eq = eq;
-      end
-    ;
-
-    value tifull_of_timod_full
-     : (module TIFULL with type t = 'a) -> tifull 'a
-     = fun (type a) (timod : (module TIFULL with type t = a)) ->
-      let module Ti = (value timod : TIFULL with type t = a) in
-      tifull
-        ~cmp:Ti.cmp
-        ~eq:Ti.eq
-        ~hash:Ti.hash
-        ~show:Ti.show
-        ()
-    ;
-
-
-    (*********************************************************)
 
 
     value ttuple2 (ti1 : #ti _) (ti2 : #ti _) =
-      let ti1 : tiall _ = ti1#tiopt
-      and ti2 : tiall _ = ti2#tiopt in
-      ((
-      tifull
-        ~cmp:(fun (x11, x12) (x21, x22) ->
-                match ti1#cmp x11 x21 with
-                [ EQ -> ti2#cmp x12 x22
-                | (LT | GT) as r -> r
-                ])
-        ~eq:(fun (x11, x12) (x21, x22) ->
-               ti1#eq x11 x21 && ti2#eq x12 x22)
-        ~hash:(fun (v1, v2) -> perv_hash
-                 ( [| ti1#hash v1 ; ti2#hash v2 |] : array int )
-              )
-        ~show:(fun (v1, v2) ->
-                 Printf.sprintf "(%s, %s)" (ti1#show v1) (ti2#show v2))
-        ()
-      ) :> ti _)
-    ;
 
 
     value ti_option (ti : #ti _) =
       ) :> ti _)
     ;
 
-    (********************)
 
+    *)
+    
 
 
-    (*
-    суть:
-    все типы предоставляют rtti мономорфное.
-    ti 'a умеет гадить в rtti's Storage.
-    вызовы методов cmp/show/.. -- через On_storage.
-    *)
-
-(*
-    value store2 = fun f o -> fun a b ->
-      
-    ;
-*)
-
-    value o_use_gen (type aa) ~o ~i ~a ~f =
-      try
-        ( a.ub_store UB_STORE_Set i
-        ; let module O = (value o : ON_STORAGE) in
-          let r = f () in
-          ( finally ()
-          ; r
-          )
-        )
-      with
-      [ e ->
-          ( finally ()
-          ; raise e
-          )
-      ]
-      where finally () =
-        ( a.ub_store UB_STORE_Clear i
-        )
-    ;
-
-    value use1 ~o f a =
-      o_use_gen ~o ~i:0 ~f ~a
-    ;
-
-    value use2 ~o f a b =
-      o_use_gen ~o ~i:0 ~a
-        ~f:(fun () ->
-              o_use_gen ~o ~i:1 ~a:b
-                 ~f
-           )
-    ;
-
-    value type_error msg =
-      failwith ("Cd.Typeinfo type_error: " ^ msg)
-    ;
-
-
+(* старье:
     open Cd_Ops;
     open Printf;
 
     value rec timono_cmp
      : timono -> (ubox -> ubox -> cmp_res)
      = fun ti ->
-(*
-        if ti == timono_no
-        then No.cmp
-        else
-*)
          let r = ti#type_desc in
          let type_name = "<unknown>" (* todo: add type names *) in
          let o = ti#on_storage in
     ;
 
 
-    (* todo: обобщить типы методов, которые "t->t->cmp_res" *)
-
-
-    value ti_tmp_of_timono
-     : timono
-       -> ticmpeq 'a  (* потом добить до tifull *)
-     = fun t ->
-         let cmp = timono_cmp t in
-         ticmpeq
-           ~cmp
-           ()
-    ;
-
-
-    value ti_sum_type
-     : ?name:string -> ?params:list (#ti _) -> ('a -> _)
-       -> ticmpeq 'a  (* потом добить до tifull *)
-     = fun (type aa) ?(name="<some_sum_type>") ?(params=[]) _destruct ->
-         let () = ignore name in
-         let () = ignore params in
-         let module Storage = Make_storage(struct type tm = aa; end) in
-         raise Exit
-    ;
-
-    value ti_variant name args =
-      fun () -> (name, args)
-    ;
-
-    value ti_methods dm =
-      Dispatch_method dm
-    ;
-
     value ti_option2 (ti_a : #ti _) =
       ti_sum_type ~name:"option" ~params:[ti_a] & fun
       [ None -> ti_variant "None" [| |]
       ]
     ;
 
+*)
+
 
   end  (* Typeinfo *)
 ;

File src/cdt.ml

View file
  • Ignore whitespace
 type cmp_res = [ LT | EQ | GT ]
 ;
 
-(***************************************************************)
-
-type storage_index = int
+type type_name = string
+ and variant_name = string
+ and field_name = string
+ and meth_name = string
 ;
 
-module type STORAGE
+type ub_store_cmd =
+  [ UB_ST_Set
+  | UB_ST_Clear
+  ]
+;
+
+
+(* [No "eq"] for example *)
+exception No of string
+;
+
+
+(********** то, что пробуем сейчас: ****************************)
+
+exception TTI_GET
+;
+
+module rec R
+ :
+  sig
+    module Meths
+     :
+      sig
+        type t;
+        value create : unit -> t;
+        value add : meth_name -> R.ubox -> t -> unit;
+        value get : meth_name -> t -> R.ubox;
+      end
+    ;
+
+    class type uti
+     =
+      object
+        method type_name : type_name;
+        method type_desc : R.type_desc;
+        method meths : R.meth_table;
+      end
+    ;
+
+    type meth_table = Meths.t
+    ;
+
+    class type tti ['a]
+     =
+      object
+        inherit uti;
+
+        (* value mutable temp_storage : TlsRef.t (option 'a); *)
+        method temp_store : 'a -> ub_store_cmd -> unit;  (* для част.прим. *)
+        method temp_get : 'a;  (* raises TTI_GET *)
+      end
+    ;
+
+    type type_desc =
+      [ Simple of type_name
+      | Sum_type of (unit -> (variant_name * array ubox))
+      | Record_type of (unit -> array (field_name * ubox))
+      | Dispatch_method of (meth_name -> R.uti)
+      | Lambda of R.uti and R.uti and (unit -> R.ubox)
+      ]
+    and ubox =
+      { ub_store : ub_store_cmd -> unit
+      ; ub_uti : R.uti
+      }
+    ;
+
+  end
  =
-  sig
-    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);
+  struct
+
+    open Printf;
+
+    class type uti
+     =
+      object
+        method type_name : type_name;
+        method type_desc : R.type_desc;
+        method meths : R.meth_table;
+      end
+    ;
+
+    class type tti ['a]
+     =
+      object
+        inherit uti;
+
+        (* value mutable temp_storage : TlsRef.t (option 'a); *)
+        method temp_store : 'a -> ub_store_cmd -> unit;  (* для част.прим. *)
+        method temp_get : 'a;  (* raises TTI_GET *)
+      end
+    ;
+
+    module Meths
+     :
+      sig
+        type t;
+        value create : unit -> t;
+        value add : meth_name -> R.ubox -> t -> unit;
+        value get : meth_name -> t -> R.ubox;
+      end
+     =
+      struct
+        type t = Hashtbl.t meth_name R.ubox;
+        value create () = Hashtbl.create 7;
+        value add mn ub ht =
+          if Hashtbl.mem ht mn
+          then failwith (sprintf "Meths: method %S already exists" mn)
+          else Hashtbl.add ht mn ub
+        ;
+        value get mn ht =
+          try
+            Hashtbl.find ht mn
+          with
+          [ Not_found -> failwith (sprintf
+              "Meths: method %S doesn't exist" mn)
+          ]
+        ;
+      end
+    ;
+
+    value empty_meths : Meths.t = Meths.create ()
+    ;
+
+    type meth_table = Meths.t
+    ;
+
+    type type_desc =
+      [ Simple of type_name
+      | Sum_type of (unit -> (variant_name * array R.ubox))
+      | Record_type of (unit -> array (field_name * R.ubox))
+      | Dispatch_method of (meth_name -> R.uti)
+      | Lambda of R.uti and R.uti and (unit -> R.ubox)
+      ]
+    ;
+
+    type ubox =
+      { ub_store : ub_store_cmd -> unit
+      ; ub_uti : R.uti
+      }
+    ;
+
   end
 ;
 
-
-type storage 'a = (module STORAGE with type ts = 'a)
+include R
 ;
 
 
-module type TI_OPS_
+value ubox
+ : tti 'a -> 'a -> ubox
+ = fun tti a ->
+  { ub_store = tti#temp_store a
+  ; ub_uti = (tti :> uti)
+  }
+;
+
+
+value rec type_name_of_type_desc
+ : type_desc -> type_name
+ = fun
+   [ Simple tn -> tn
+   | Sum_type (* type_desc_sum *) _destr -> "(some sum type)"
+   | Record_type (* type_desc_record *) _destr -> "(some record type)"
+   | Dispatch_method dm -> type_name_of_type_desc ((dm "type_name")#type_desc)
+   | Lambda uti_a uti_b _do_apply ->
+       Printf.sprintf "(%s -> %s)"
+         (uti_type_name uti_a)
+         (uti_type_name uti_b)
+   ]
+
+and uti_type_name
+ : uti -> string
+ = fun uti ->
+     type_name_of_type_desc uti#type_desc
+;
+
+
+value uget_exn
+ : tti 'a -> ubox -> 'a
+ = fun tti ub ->
+     let exp_uti = (tti :> uti)
+     and ub_uti = ub.ub_uti in
+     if exp_uti != ub_uti
+     then
+       failwith (Printf.sprintf "Cdt.uget_exn: expected %s, got %s"
+         (uti_type_name exp_uti)
+         (uti_type_name ub_uti)
+       )
+     else
+       let store = ub.ub_store in
+       let finally () =
+         ( store UB_ST_Clear
+         )
+       in
+       try
+         let () = store UB_ST_Set in
+         let r = tti#temp_get in
+         let () = finally () in
+         r
+       with
+       [ TTI_GET -> assert False
+       | e -> ( finally () ; raise e )
+       ]
+;
+
+
+class ti ['a] type_desc =
+  let meths = Meths.create () in
+  let temp_storage = TlsRef.make (None : option 'a) in
+  let type_name = lazy (type_name_of_type_desc type_desc) in
+  object
+    method meths = meths
+    ;
+    method temp_get =
+      match TlsRef.get temp_storage with
+      [ None -> raise TTI_GET
+      | Some a -> a
+      ]
+    ;
+    method temp_store a =
+      let some_a = Some a in
+      fun
+      [ UB_ST_Set -> TlsRef.set temp_storage some_a
+      | UB_ST_Clear -> TlsRef.set temp_storage None
+      ]
+    ;
+    method type_desc = type_desc
+    ;
+    method type_name = Lazy.force type_name
+    ;
+  end
+;
+
+
+value ti_abs
+ : tti 'a -> tti 'b -> tti ('a -> 'b)
+ = fun ta tb ->
+     let rec do_apply
+      : unit -> ubox
+      = fun () ->
+          let ti_func = Lazy.force ti_lazy in
+          let func = ti_func#temp_get in
+          let arg = ta#temp_get in
+          let res = func arg in
+          ubox tb res
+     and
+     ti_lazy = lazy (
+       (* todo: тут ta/tb развернуть, если они Dispatch_method *)
+       new ti (Lambda (ta :> uti) (tb :> uti) do_apply)
+     )
+     in
+       Lazy.force ti_lazy
+;
+
+
+value expect_abs
+ : uti -> ubox -> (uti * (unit -> ubox))
+ = fun uti_arg ubox_func ->
+     match ubox_func.ub_uti#type_desc with
+     [ Lambda exp_arg exp_res do_apply ->
+         if uti_arg != exp_arg
+         then
+           failwith "Cdt.expect_abs: bad argument type"
+         else
+           (exp_res, do_apply)
+
+     | Simple _
+     | Sum_type _
+     | Record_type _
+         ->
+           failwith "Cdt.expect_abs: functional type expected"
+
+     | Dispatch_method _dm ->
+         assert False
+     ]
+;
+
+
+value rec u_app
+ : ubox -> ubox -> ubox
+ = fun uf ua ->
+     let uti_a = ua.ub_uti in
+     let (exp_res, do_apply) = expect_abs uti_a uf
+     in
+       ( uf.ub_store UB_ST_Set
+       ; ua.ub_store UB_ST_Set
+       ; let res = do_apply () in
+         let () = uf.ub_store UB_ST_Clear
+         and () = ua.ub_store UB_ST_Clear
+         in
+         if exp_res != res.ub_uti
+         then failwith "u_app: bad result type"
+         else res
+       )
+;
+
+
+value entype_abs
+ : ti 'a -> ubox -> ('a -> ubox)
+ = fun ta uf ->
+     let (_exp_res, _do_apply) = expect_abs (ta :> uti) uf in
+     fun a ->
+       let ua = ubox ta a in
+       let ub = u_app uf ua in
+       ub
+;
+
+
+value wrap_func1
+ : ti 'a -> ti 'z -> ubox -> ('a -> 'z)
+ = fun ta tz uf ->
+     let f1 = entype_abs ta uf in
+     fun a ->
+       let uz = f1 a in
+       uget_exn tz uz
+;
+
+
+value wrap_func2
+ : ti 'a -> ti 'b -> ti 'z -> ubox -> ('a -> 'b -> 'z)
+ = fun ta tb tz uf ->
+     let f1 = entype_abs ta uf in
+     fun a ->
+       let ub = f1 a in
+       let f2 = entype_abs tb ub in
+       fun b ->
+         let uz = f2 b in
+         uget_exn tz uz
+;
+
+
+
+class ti_simple ['a] type_name = ti ['a] (Simple type_name)
+;
+
+
+class ticmp ['a] ~cmp type_desc =
+   let () = ignore (cmp (raise Exit) (raise Exit)) in
+   object
+     inherit ti ['a] type_desc;
+     method cmp () = ();
+   end
+;
+
+
+value eq_of_opt ?eq ~cmp =
+  match eq with
+  [ None -> fun a b -> EQ == cmp a b
+  | Some eq -> eq
+  ]
+;
+
+
+(*************
+
+(********** то, что будет потом: *******************************)
+
+module type TI_OPS
  =
   sig
 
   end
 ;
 
-module type ON_STORAGE = TI_OPS_ with type t = storage_index
-;
-type on_storage = (module ON_STORAGE)
-;
-
-type type_name = string
- and variant_name = string
- and field_name = string
-;
-
-type ub_store_cmd =
-  [ UB_STORE_Set
-  | UB_STORE_Clear
-  ]
-;
-
-
-type rtti_method = [= `Cmp | `Eq | `Hash | `Show ]
-;
-
-
-module rec R
- :
-  sig
-    class type timono
-     =
-      object
-        method on_storage : on_storage;
-        method type_desc : R.type_desc;
-      end
-    ;
-    type type_desc =
-      [ Simple
-      | Sum_type of (unit -> (variant_name * array ubox))
-      | Record_type of (unit -> array (field_name * ubox))
-      | Dispatch_method of (rtti_method -> timono)
-      ]
-    and ubox =
-      { ub_store : ub_store_cmd -> storage_index -> unit
-      ; ub_timono : R.timono
-      }
-    ;
-  end
- =
-  struct
-    class type timono =
-      object
-        method on_storage : on_storage;
-        method type_desc : R.type_desc;
-      end
-    ;
-    type type_desc =
-      [ Simple
-      | Sum_type of (unit -> (variant_name * array ubox))
-      | Record_type of (unit -> array (field_name * ubox))
-      | Dispatch_method of (rtti_method -> timono)
-      ]
-    and ubox =
-      { ub_store : ub_store_cmd -> storage_index -> unit
-      ; ub_timono : R.timono
-      }
-    ;
-  end
-;
-
-include R
-;
-
 (* todo: специальное timono_no для пробежки по timono верхнего уровня
    с целью определения того, какие методы предоставлены
    через Dispatch_method (предоставлен == ( != timono_no ) ),
     value fmap : ('a -> 'b) -> (t 'a -> t 'b);
   end
 ;
+
+
+
+*************)

File src/tlsRef.ml

View file
  • Ignore whitespace
 (* reference with semantics of TlsArray.t; built on TlsArray. *)
 
 type ref 'a = TlsArray.t 'a;
+type t 'a = ref 'a;
 
 value make x = TlsArray.make 1 x;
 

File src/tlsRef.mli

View file
  • Ignore whitespace
 (* reference with semantics of TlsArray.t *)
 
 type ref 'a;
+type t 'a;
 
 value make : 'a -> ref 'a;
 

File test/test_cdt.ml

View file
  • Ignore whitespace
+open Cdt;
+
+value () = print_string "kva\n";