Commits

Anonymous committed b84e5f4

..dev..

  • Participants
  • Parent commits a5143d1

Comments (0)

Files changed (9)

   Path:       src
   BuildTools: ocamlbuild
   BuildDepends: num
-  Modules:    Cadastr, Monoid, Cd_All, Cd_Int, Cd_List, Cd_Ops, Cd_Byte, Cd_Bytes, Cd_Chars, Cd_Strings, Cd_Array, Cd_Typeinfo, Cdt, Cd_Types, Cd_Option, Cd_Num, Cd_Tuples, Cd_Bool, TlsArray, TlsArray_st, TlsArray_mt, TlsRef
+  Modules:    Cadastr, Monoid, Cd_All, Cd_Int, Cd_List, Cd_Ops, Cd_Byte, Cd_Bytes, Cd_Chars, Cd_Strings, Cd_Array, Cd_Typeinfo, Cdt, Cd_Types, Cd_Option, Cd_Num, Cd_Tuples, Cd_Bool, TlsArray, TlsArray_st, TlsArray_mt, TlsRef, Cd_Ref
 
 Executable tests
   Path:       test
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 5b1dd90615357f5a9f81df64860c9a64) *)
+(* DO NOT EDIT (digest: 8ec964d083ae5c21877694eb69fbb014) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
                            "TlsArray";
                            "TlsArray_st";
                            "TlsArray_mt";
-                           "TlsRef"
+                           "TlsRef";
+                           "Cd_Ref"
                         ];
                       lib_internal_modules = [];
                       lib_findlib_parent = None;

File src/cadastr.mllib

 # OASIS_START
-# DO NOT EDIT (digest: aa7370431df928d4fb93cc5b5d9464c5)
+# DO NOT EDIT (digest: 2175a82f3c03343db93d84fa9706a3a0)
 Cadastr
 Monoid
 Cd_All
 TlsArray_st
 TlsArray_mt
 TlsRef
+Cd_Ref
 # OASIS_STOP

File src/cd_All.ml

 module Typeinfo = Cd_Typeinfo.Typeinfo;
 module Num = Cd_Num.Num;
 module Bool = Cd_Bool.Bool;
+module Ref = Cd_Ref.Ref;
 include Cd_Tuples;
 
 include Cd_Ops;

File src/cd_Array.ml

     ;
 
 
+    value map2to1
+     : ! 'a 'b 'z . ('a -> 'b -> 'z) -> array 'a -> array 'b -> array 'z
+     = fun f a b ->
+         let len = Array.length a in
+         if len <> Array.length b
+         then invalid_arg "Array.map2to1: different lengths"
+         else
+           if len = 0
+           then [| |]
+           else
+             let z0 = f a.(0) b.(0) in
+             let z = Array.make len z0 in
+             let () =
+               for i = 1 to len - 1 do
+                 ( z.(i) := f a.(i) b.(i)
+                 )
+                 done
+             in
+               z
+    ;
 
 
   end

File src/cd_List.ml

             [ [] -> ti_variant vnil [| |]
             | [h :: t] -> ti_variant vcons [| ubox ti_elem h ; ubox self t |]
             ])
+            [| |] (* todo: list construction here *)
           in fun
           [ "cmp" -> proc "List.0" "List.1"
           | _ -> proc "List.nil" "List.cons"

File src/cd_Ref.ml

+module Ref
+ =
+  struct
+
+    type t 'a = ref 'a;
+
+    open Cdt
+    ;
+
+    class ti ['z]
+    ?cmp ?eq ?hash ?show
+    (ti_a : #Cdt.ti 'a)
+    ()
+    =
+      ti_record ['z] ?cmp ?eq ?hash ?show
+        (fun [ { val } -> [| ti_field "val" ti_a val |] ])
+    ;
+
+  end
+;

File src/cd_Tuples.ml

   end
 ;
 
+
+
+module Tuple3
+ =
+  struct
+
+    type t 'a 'b 'c = ('a * 'b * 'c);
+
+
+    open Cdt
+    ;
+
+    class ti ['z]
+    ?cmp ?eq ?hash ?show
+    (ti1 : #Cdt.ti 'a)
+    (ti2 : #Cdt.ti 'b)
+    (ti3 : #Cdt.ti 'c)
+    () =
+      object (self : #tifull ('a * 'b * 'c))
+
+        constraint 'z = ('a * 'b * 'c);
+
+        inherit Cdt.ti ['z] ()
+        ;
+
+        method type_desc = Tuple
+          (fun ub ->
+             let (a, b, c) = (uget_exn self ub) in
+             [| ubox ti1 a ; ubox ti2 b ; ubox ti3 c |]
+          )
+        ;
+
+        inherit tifull_ops [_] ?cmp ?eq ?hash ?show ()
+        ;
+
+      end
+    ;
+
+  end
+;
+
 exception Meth_exists
 ;
 
+exception Deser
+;
+
 
 value failwith fmt = Printf.ksprintf failwith fmt
 ;
 
     type type_desc =
       [ Simple of type_name
-      | Sum_type of (R.ubox -> (variant_name * (meth_name -> array ubox)))
+      | Sum_type
+          of (R.ubox -> (variant_name * (meth_name -> array R.ubox)))
+         and (array (variant_name * array R.uti * (array R.ubox -> R.ubox)))
       | Record_type of (R.ubox -> array (field_name * ubox))
       | Dispatch_method of (meth_name -> type_desc)
       | Lambda of R.uti and R.uti and (unit -> R.ubox)
 
     type type_desc =
       [ Simple of type_name
-      | Sum_type of (R.ubox -> (variant_name * (meth_name -> array R.ubox)))
+      | Sum_type
+          of (R.ubox -> (variant_name * (meth_name -> array R.ubox)))
+         and (array (variant_name * array R.uti * (array R.ubox -> R.ubox)))
       | Record_type of (R.ubox -> array (field_name * R.ubox))
       | Dispatch_method of (meth_name -> type_desc)
       | Lambda of R.uti and R.uti and (unit -> R.ubox)
  : type_desc -> type_name
  = fun
    [ Simple tn -> tn
-   | Sum_type (* type_desc_sum *) _destr -> "(some sum type)"
+   | Sum_type _destr _constr -> "(some sum type)"
    | Record_type (* type_desc_record *) _destr -> "(some record type)"
    | Dispatch_method dm -> type_name_of_type_desc (dm "type_name")
    | Lambda uti_a uti_b _do_apply ->
   and binop_struc_typedesc uti type_desc ux uy =
     match type_desc with
     [ Simple tn -> fail uti "it's simple type %S" tn
-    | Sum_type destr ->
+    | Sum_type destr _constr ->
         let (xname, xgetargs) = destr ux in
         let (yname, ygetargs) = destr uy in
         match binop_is_result (binop_constructor xname yname) with
   and unop_struc_typedesc uti type_desc ux =
     match type_desc with
     [ Simple tn -> fail uti "it's simple type %S" tn
-    | Sum_type destr ->
+    | Sum_type destr _constr ->
         let (xname, xgetargs) = destr ux in
         let args = Array.map unop_struc_ubox (xgetargs unop_meth_name) in
         unop_reduce_sum_type xname args
 
 (*******************)
 
+type ctr_var 'z = (variant_name * array uti * (array ubox -> 'z))
+;
+
+value ti_ctr_variant1
+ : variant_name -> ti 'a -> ('a -> 'z) -> ctr_var 'z
+ = fun vn tia ctr1 ->
+     ( vn
+     , [| (tia :> uti) |]
+     , fun
+       [ [| ua |] -> ctr1 (uget_exn tia ua)
+       | _ -> assert False
+       ]
+     )
+;
+
+value ti_ctr_variant2
+ : variant_name -> ti 'a -> ti 'b -> ('a -> 'b -> 'z) -> ctr_var 'z
+ = fun vn tia tib ctr2 ->
+     ( vn
+     , [| (tia :> uti); (tib :> uti) |]
+     , fun
+       [ [| ua; ub |] -> ctr2 (uget_exn tia ua) (uget_exn tib ub)
+       | _ -> assert False
+       ]
+     )
+;
+
+value ti_ctr_variant3
+ : variant_name
+   -> ti 'a -> ti 'b -> ti 'c
+   -> ('a -> 'b -> 'c -> 'z)
+   -> ctr_var 'z
+ = fun vn tia tib tic ctr3 ->
+     ( vn
+     , [| (tia :> uti); (tib :> uti); (tic :> uti) |]
+     , fun
+       [ [| ua; ub; uc |] -> ctr3
+           (uget_exn tia ua) (uget_exn tib ub) (uget_exn tic uc)
+       | _ -> assert False
+       ]
+     )
+;
+
 
 class ti_sum_type ['a]
   ?cmp ?eq ?hash ?show
+  ?(constr = [| |])
   (destr : ('a -> (variant_name * (meth_name -> array ubox))))
  =
   object ((self : #ti 'a) : #ticmp_ 'a)
     inherit ti ['a] ()
     ;
 
-    method type_desc = Sum_type
-      (fun ub ->
-         destr (uget_exn self ub)
+    value mutable v_type_desc = Simple "<not_inited>";
+    initializer
+      (v_type_desc :=
+         Sum_type
+           (fun ub ->
+              destr (uget_exn self ub)
+           )
+           (Array.map
+              (fun (vn, utis, ctr_t) ->
+                 let ctr_u = fun uarr -> ubox self (ctr_t uarr)
+                 in
+                 (vn, utis, ctr_u)
+              )
+              constr
+           )
       )
     ;
 
+    method type_desc = v_type_desc
+    ;
+
     inherit tifull_ops ['a] ?cmp ?eq ?hash ?show ()
     ;
 
     value fmap : ('a -> 'b) -> (t 'a -> t 'b);
   end
 ;
+
+
+class type early ['input, 'state, 'result]
+ =
+  object
+    method ezero : 'result;
+    method eadd : 'state -> 'input -> [= `Cont of 'state | `Res of 'result ];
+  end
+;