Commits

Dmitry Grebeniuk  committed 9d11b33

records' construction

  • Participants
  • Parent commits af189d7

Comments (0)

Files changed (2)

File src/cd_Ref.ml

     ()
     =
       ti_record ['z] ?cmp ?eq ?hash ?show
+        ~constr:
+          ( [| (ti_a :> uti) |]
+          , [| "val" |]
+          , fun
+            [ [| v |] -> { val = uget_exn ti_a v }
+            | _ -> assert False
+            ]
+          )
         (fun [ { val } -> [| ti_field "val" ti_a val |] ])
     ;
 
       | 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))
+      | Record_type
+          of (R.ubox -> array (field_name * R.ubox))
+         and array uti
+         and array field_name
+         and (array R.ubox -> R.ubox)
       | Dispatch_method of (meth_name -> type_desc)
       | Lambda of R.uti and R.uti and (unit -> R.ubox)
       | Tuple
       | 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))
+      | Record_type
+          of (R.ubox -> array (field_name * R.ubox))
+         and array uti
+         and array field_name
+         and (array R.ubox -> R.ubox)
       | Dispatch_method of (meth_name -> type_desc)
       | Lambda of R.uti and R.uti and (unit -> R.ubox)
       | Tuple
  = fun
    [ Simple tn -> tn
    | Sum_type _destr _constr -> "(some sum type)"
-   | Record_type (* type_desc_record *) _destr -> "(some record type)"
+   | Record_type (* type_desc_record *) _destr _utis _fields _constr
+       -> "(some record type)"
    | Dispatch_method dm -> type_name_of_type_desc (dm "type_name")
    | Lambda uti_a uti_b _do_apply ->
        let spine = get_lambda_spine uti_b uti_b#type_desc in
         let yargs = destr uy in
         binop_struc_tuple uti "sum type" xargs yargs
 
-    | Record_type destr ->
+    | Record_type destr _utis _fields _constr ->
         let xfields = destr ux in
         let yfields = destr uy in
         let nfields = Array.length xfields in
         let args = Array.map unop_struc_ubox xargs in
         unop_reduce_tuple args
 
-    | Record_type destr ->
+    | Record_type destr _utis _fields _constr ->
         let xfields = destr ux in
         unop_reduce_record
           (Array.map
 
 class ti_record ['a]
   ?cmp ?eq ?hash ?show
+  ?constr
   (destr : ('a -> array (field_name * ubox)))
  =
   object ((self : #ti 'a) : #ticmp_ 'a)
     inherit ti ['a] ()
     ;
 
-    method type_desc = Record_type
-      (fun ub ->
-         destr (uget_exn self ub)
+    value mutable v_type_desc = Simple "<ti_record not inited>";
+    initializer
+      ( let (utis, fields, constr) =
+          match constr with
+          [ None ->
+              ( [||]
+              , [||]
+              , fun _ -> failwith "this record type (%S) can't be constructed"
+                  self#type_name
+              )
+          | Some c -> c
+          ]
+        in
+        v_type_desc :=
+          Record_type
+            (fun ub ->
+               destr (uget_exn self ub)
+            )
+            utis
+            fields
+            (fun uargs -> ubox self (constr uargs))
       )
     ;
 
+    method type_desc = v_type_desc;
     inherit tifull_ops ['a] ?cmp ?eq ?hash ?show ()
     ;