variant-genfuns.ml

(*
(define-class foo (make-foo))
(define-class bar (make-bar))
(define-generic (m obj))
(define-method (m (f foo)) 1)
(define-method (m (b bar)) 2)
(print (m (make-foo))) ; => 1
(print (m (make-bar))) ; => 2
(define-method (m (f foo)) 3)
(print (m (make-foo))) ; => 3

(define-generic (equals x y))
(define-method (equals (f1 foo) y)
  (typecase y
    ((f2 foo) #t)
    (else #f)))
(define-method (equals (b1 bar) y)
  (typecase y
    ((b2 bar) #t)
    (else #f)))
(equals (make-foo) (make-foo)) ; => #t
(equals (make-foo) (make-bar)) ; => #f
(equals (make-bar) (make-foo)) ; => #f
(equals (make-bar) (make-bar)) ; => #t
*)

(* utilities *)
exception Unbound;;
let refer cell =
  match !cell with
  | `Def value -> value
  | `Undef -> raise Unbound;;  
let apply funcell args =
  match refer funcell with
  | `Fun fn -> fn args;;
(* cells *)
let make_foo_cell = ref `Undef;;
let make_bar_cell = ref `Undef;;
let m_genfun_cell = ref `Undef;;
let m_foo_method_cell = ref `Undef;;
let m_bar_method_cell = ref `Undef;;
let equals_genfun_cell = ref `Undef;;
let equals_foo_method_cell = ref `Undef;;
let equals_bar_method_cell = ref `Undef;;
(* effects *)
make_foo_cell := `Def (`Fun (fun () -> `Foo));;
make_bar_cell := `Def (`Fun (fun () -> `Bar));;
m_genfun_cell := `Def (`Fun (fun (obj) ->
  match obj with
  | `Foo as self -> apply m_foo_method_cell (self)
  | `Bar as self -> apply m_bar_method_cell (self)));;
m_foo_method_cell := `Def (`Fun (fun (`Foo) -> 1));;
m_bar_method_cell := `Def (`Fun (fun (`Bar) -> 2));;
print_string (string_of_int (apply m_genfun_cell (apply make_foo_cell ())));;
print_string (string_of_int (apply m_genfun_cell (apply make_bar_cell ())));;
m_foo_method_cell := `Def (`Fun (fun (`Foo) -> 3));;
print_string (string_of_int (apply m_genfun_cell (apply make_foo_cell ())));;

equals_genfun_cell := `Def (`Fun (fun (obj, y) ->
  match obj with
  | `Foo as self -> apply equals_foo_method_cell (self, y)
  | `Bar as self -> apply equals_bar_method_cell (self, y)));;
equals_foo_method_cell := `Def (`Fun (fun (`Foo, y) ->
  match y with
  | `Foo -> true
  | _ -> false));;
equals_bar_method_cell := `Def (`Fun (fun (`Bar, y) ->
  match y with
  | `Bar -> true
  | _ -> false));;
print_string (string_of_bool (apply equals_genfun_cell (apply make_foo_cell (), apply make_foo_cell ())));;
print_string (string_of_bool (apply equals_genfun_cell (apply make_foo_cell (), apply make_bar_cell ())));;
print_string (string_of_bool (apply equals_genfun_cell (apply make_bar_cell (), apply make_foo_cell ())));;
print_string (string_of_bool (apply equals_genfun_cell (apply make_bar_cell (), apply make_bar_cell ())));;