Commits

Dmitry Grebeniuk  committed 8cf2d85

.

  • Participants
  • Parent commits c0cd3b4

Comments (0)

Files changed (4)

   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, Cd_Ref, Cd_Partapp, Cd_Int64
+  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, Cd_Partapp, Cd_Int64, Cd_Ser
 
 Executable tests
   Path:       test
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: df577f7ab6ae7601fc2f49fb9b6b369d) *)
+(* DO NOT EDIT (digest: 2a327b29764ff7e7ab6a0146eb42f243) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
                            "TlsRef";
                            "Cd_Ref";
                            "Cd_Partapp";
-                           "Cd_Int64"
+                           "Cd_Int64";
+                           "Cd_Ser"
                         ];
                       lib_internal_modules = [];
                       lib_findlib_parent = None;

File src/cadastr.mllib

 # OASIS_START
-# DO NOT EDIT (digest: 5d2727e4cf196b12e583727005d60ffa)
+# DO NOT EDIT (digest: 8de1e26b6e9c119a5e13bbcfbf009466)
 Cadastr
 Monoid
 Cd_All
 Cd_Ref
 Cd_Partapp
 Cd_Int64
+Cd_Ser
 # OASIS_STOP

File src/cd_Ser.ml

+(* it's dumb for now, but it's required for parvel. *)
+
+
+open Cd_All; open Cdt;
+open Printf;
+
+
+value ti_int = (ti_int :> ti int);
+value ti_string = (ti_string :> ti string);
+value ti_unit = (ti_unit :> ti unit);
+
+
+
+value marshal_ser typename x =
+  Marshal.to_string (typename, x) []
+;
+
+value marshal_deser (type a) typename s =
+  let (tn, (x : a)) = Marshal.from_string s 0 in
+  if tn <> typename
+  then
+    let () = eprintf "deser: expected %S, got %S\n%!" typename tn in
+    raise Deser
+  else x
+;
+
+
+
+
+
+value ustrs_of_uvals
+ : array ubox -> array string
+ = fun uvals ->
+     let ustrs : array string =
+       Array.map
+         (fun ub ->
+            let ser = get_meth_untyped "ser" ub.ub_uti in
+            uget_exn ti_string (u_app ser ub)
+         )
+         uvals
+     in
+       ustrs
+;
+
+
+value rec ti_ser_td
+ : ti 'a -> type_desc -> ('a -> string)
+ = fun ti td ->
+     match td with
+     [ Simple tn ->
+         fun a -> marshal_ser tn a
+     | Sum_type destr _constr ->
+         fun a ->
+           let (variant_name, disp) = destr (ubox ti a) in
+           let () = printf "ti_ser: variant_name = %S\n%!" variant_name in
+           let uvals = disp "ser" in
+           let ustrs = ustrs_of_uvals uvals in
+           let () = Array.iter (printf "ti_ser: %S\n%!") ustrs in
+           let () = print_newline () in
+           marshal_ser ti#type_name (variant_name, ustrs)
+
+     | Tuple destr _utis _constr ->
+         fun a ->
+           let uvals = destr (ubox ti a) in
+           let ustrs = ustrs_of_uvals uvals in
+           marshal_ser ti#type_name ustrs
+
+     | Record_type _
+     | Lambda _ _ _
+         ->
+           assert False
+(*
+     | Record_type of (R.ubox -> array (field_name * R.ubox))
+     | Lambda of R.uti and R.uti and (unit -> R.ubox)
+     | Tuple of (R.ubox -> array R.ubox)
+*)
+     | Dispatch_method meth ->
+         ti_ser_td ti (meth "ser")
+     ]
+;
+
+
+
+value uvals_of_ustrs
+ : array string -> array uti -> array ubox
+ = fun ustrs utis ->
+             Array.map2to1
+               (fun str uti ->
+                  let deser = get_meth_untyped "deser" uti in
+                  u_app deser (ubox ti_string str)
+               )
+               ustrs
+               utis
+;
+
+
+value rec ti_deser_td
+ : ti 'a -> type_desc -> (string -> 'a)
+ = fun ti td ->
+     match td with
+     [ Dispatch_method meth ->
+         ti_deser_td ti (meth "deser")
+     | Simple tn ->
+         fun a -> marshal_deser tn a
+     | Sum_type _destr constr ->
+         fun s ->
+           let (variant_name, ustrs) =
+             marshal_deser ti#type_name s
+           in
+           let () = printf "ti_deser: variant_name = %S\n%!" variant_name in
+           let (utis, ctr_u) =
+             inner 0
+             where rec inner i =
+               if i = Array.length constr
+               then failwith "ti_deser: bad variant name"
+               else
+                 let (vn, utis, ctr_u) = constr.(i) in
+                 if vn = variant_name
+                 then (utis, ctr_u)
+                 else inner (i + 1)
+           in
+           let () = Array.iter (printf "ti_deser: %S\n%!") ustrs in
+           let () = print_newline () in
+           let uvals : array ubox =
+             uvals_of_ustrs
+               ustrs
+               utis
+           in
+           uget_exn ti & ctr_u uvals
+
+     | Record_type _
+     | Lambda _ _ _
+         ->
+           assert False
+
+     | Tuple _destr utis constr
+         ->
+           fun s ->
+             let ustrs : array string = marshal_deser ti#type_name s in
+             uget_exn ti & constr (uvals_of_ustrs ustrs utis)
+     ]
+;
+
+
+
+value ti_add_ser_deser
+ : #ti 'a -> unit
+ = fun ti ->
+     (
+         uti_add_meth (ti :> uti) "ser" &
+           ubox (ti_abs ti ti_string) &
+             (ti_ser_td ti ti#type_desc)
+     ;
+         uti_add_meth (ti :> uti) "deser" &
+           ubox (ti_abs ti_string ti) &
+             (ti_deser_td ti ti#type_desc)
+     )
+;
+
+
+value ti_ser
+ : #ti 'a -> 'a -> string
+ = fun ti ->
+     get_meth_typed1 "ser" ti ti ti_string
+;
+
+
+value ti_deser
+ : #ti 'a -> string -> 'a
+ = fun ti ->
+     get_meth_typed1 "deser" ti ti_string ti
+;
+