From 89c02a59d6f2696a5ae1ebc77298fc8137506415 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Tue, 7 Aug 2007 17:05:22 +0200
Subject: Overload EQUAL and EQUALP for Objective C objects.

darcs-hash:6548e8584e8dd49cb17f6055c0cedd6927cba7f1
---
 Lisp/defpackage.lisp |  6 ++++
 Lisp/tests.lisp      | 20 +++++++++++++
 Lisp/utilities.lisp  | 82 +++++++++++++++++++++++++++++++++++++++++++++++-----
 3 files changed, 101 insertions(+), 7 deletions(-)
 create mode 100644 Lisp/tests.lisp

(limited to 'Lisp')

diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index c3fcc2e..6fd992a 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -1,6 +1,8 @@
 (defpackage #:mulk.objective-cl
   (:nicknames #:objcl #:objective-cl #:mulk.objcl)
   (:use #:cl #:cffi #:split-sequence)
+  (:shadow #:equal
+           #:equalp)
 
            ;; Functions
   (:export #:initialise-runtime
@@ -11,6 +13,10 @@
            #:find-objc-class
            #:find-selector
 
+           ;; Generic functions
+           #:equal
+           #:equalp
+
            ;; Special variables
            #:*trace-method-calls*
 
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
new file mode 100644
index 0000000..7c2b496
--- /dev/null
+++ b/Lisp/tests.lisp
@@ -0,0 +1,20 @@
+(defpackage #:mulk.objective-cl.tests
+  (:use #:cl #:lift #:mulk.objective-cl))
+(in-package #:mulk.objective-cl.tests)
+
+
+(defun run-all-tests ()
+  (run-tests :suite 'objective-cl))
+
+
+(deftestsuite objective-cl ()
+  ())
+
+
+(deftestsuite method-invocation (objective-cl)
+  ()
+  (:equality-test #'equal)
+  (:tests
+   ((ensure (functionp (fn #'+ _ 10))))
+   ((ensure-same (mapcar (fn (cons _ _)) '(1 2 3))
+                 '((1 . 1) (2 . 2) (3 . 3))))))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index f35a4d8..a82e123 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -1,10 +1,78 @@
 (in-package #:mulk.objective-cl)
 
 
-(defun apply-macro (macro-name arg &rest args)
-  "Because FOREIGN-FUNCALL is a macro.  Why, oh why is this?"
-  (funcall
-   (compile nil
-            `(lambda ()
-               (,macro-name ,@(butlast (cons arg args))
-                            ,@(car (last (cons arg args))))))))
\ No newline at end of file
+(defgeneric equal (x y))
+(defgeneric equalp (x y))
+
+
+(defun truep (b)
+  (not (or (zerop b)
+           (null b))))
+
+
+(defun id-equal (x y)
+  (declare (type (or id objc-class exception) x y))
+  (truep (invoke x :is-equal y)))
+
+
+(defmethod equal (x y)
+  (cl:equal x y))
+
+(defmethod equal ((x id) y)
+  (id-equal x y))
+
+(defmethod equal (x (y id))
+  (id-equal x y))
+
+(defmethod equal ((x objc-class) y)
+  (id-equal x y))
+
+(defmethod equal (x (y objc-class))
+  (id-equal x y))
+
+(defmethod equal ((x exception) y)
+  (id-equal x y))
+
+(defmethod equal (x (y exception))
+  (id-equal x y))
+
+(defmethod equal ((x selector) (y selector))
+  (equal (selector-name x) (selector-name y)))
+
+(defmethod equal ((x selector) (y string))
+  (equal (selector-name x) y))
+
+(defmethod equal ((x string) (y selector))
+  (equal x (selector-name y)))
+
+
+(defmethod equalp (x y)
+  (cl:equalp x y))
+
+(defmethod equalp ((x id) y)
+  (equal x y))
+
+(defmethod equalp (x (y id))
+  (equal x y))
+
+(defmethod equalp ((x objc-class) y)
+  (equal x y))
+
+(defmethod equalp (x (y objc-class))
+  (equal x y))
+
+(defmethod equalp ((x exception) y)
+  (equal x y))
+
+(defmethod equalp (x (y exception))
+  (equal x y))
+
+;; FIXME: Does this even make sense?
+(defmethod equalp ((x selector) (y selector))
+  (equalp (selector-name x) (selector-name y)))
+
+(defmethod equalp ((x selector) (y string))
+  (equalp (selector-name x) y))
+
+(defmethod equalp ((x string) (y selector))
+  (equalp x (selector-name y)))
-- 
cgit v1.2.3