Commits

Anonymous committed 3ed3c08

new method 'phys_eq' for all types' dictionaries

  • Participants
  • Parent commits 6b31d53

Comments (0)

Files changed (1)

 ;
 
 
-class virtual ti ['a] () =
+class virtual ti_ ['a] () =
   let meths = Meths.create () in
   let type_id = Type_id.next () in
 (*
 
 class ti_type_descd ['a] type_desc =
   object
-    inherit ti ['a] ();
+    inherit ti_ ['a] ();
     method type_desc = type_desc;
   end
 ;
 ;
 
 
+(********************)
+
+value uti_add_meth
+ : #uti -> meth_name -> ubox -> unit
+ = fun uti meth_name uf ->
+(*
+  let () =
+    Printf.printf "adding method %S to type %S (type_id=%i)\n%!"
+      meth_name uti#type_name (uti#type_id :> int)
+  in
+*)
+  try
+    Meths.add meth_name uf uti#meths
+  with
+  [ Meth_exists ->
+      failwith
+        "can't add method %S to type %S (type_id=%i): method already exists"
+        meth_name
+        (uti#type_name)
+        (uti#type_id :> int)
+  ]
+;
+
+
+value add_phys_eq (ti : #ti_ 'a) =
+  uti_add_meth
+    ti
+    "phys_eq"
+    (let ti__t_bool = ti_abs (ti :> tti _) ti_bool__base in
+     let ti__t_t_bool = ti_abs (ti :> tti _) ti__t_bool in
+     ubox ti__t_t_bool ( == )
+    )
+;
+
+
+class virtual ti ['a] ()
+ =
+  object (self)
+    inherit ti_ ['a] ();
+    initializer (add_phys_eq self);
+  end
+;
+
+
 value expect_abs
  : uti -> ubox -> (uti * (ubox -> ubox -> ubox))
  = fun uti_arg ubox_func ->
 
 
 
-(********************)
-
-value uti_add_meth
- : #uti -> meth_name -> ubox -> unit
- = fun uti meth_name uf ->
-(*
-  let () =
-    Printf.printf "adding method %S to type %S (type_id=%i)\n%!"
-      meth_name uti#type_name (uti#type_id :> int)
-  in
-*)
-  try
-    Meths.add meth_name uf uti#meths
-  with
-  [ Meth_exists ->
-      failwith
-        "can't add method %S to type %S (type_id=%i): method already exists"
-        meth_name
-        (uti#type_name)
-        (uti#type_id :> int)
-  ]
-;
-
-
 (*****************************************************)
 
 
   ?type_desc
   (tti : #tti 'a)
  =
-  object
+  object (self)
     inherit ti_based_on ['a] ?type_desc (tti : #tti 'a);
     inherit tifull_ops ['a] ?cmp ?eq ?hash ?show ();
+
+    initializer (add_phys_eq self);
+    (* because [ti_based_on] doesn't inherit [ti] *)
+
   end
 ;