Skip to content

Instantly share code, notes, and snippets.

@manuel
Last active December 13, 2015 18:28
Show Gist options
  • Save manuel/4955546 to your computer and use it in GitHub Desktop.
Save manuel/4955546 to your computer and use it in GitHub Desktop.
(*
(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 ())));;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment