From 092f6bb7e1d3dd18bf0fbf9383a75a622adb81ab Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 5 Mar 2015 13:53:40 -0700
Subject: [PATCH] =?UTF-8?q?add=20`object-or-false=3D=3F`?=

---
 .../scribblings/reference/class.scrbl         | 14 ++++++++++
 .../racket-test-core/tests/racket/object.rktl | 25 +++++++++++++++++
 .../racket/private/class-internal.rkt         | 27 ++++++++++++++-----
 3 files changed, 60 insertions(+), 6 deletions(-)

diff --git a/pkgs/racket-doc/scribblings/reference/class.scrbl b/pkgs/racket-doc/scribblings/reference/class.scrbl
index b8f7d8b445..d3875ac67e 100644
--- a/pkgs/racket-doc/scribblings/reference/class.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/class.scrbl
@@ -2463,6 +2463,20 @@ This procedure is similar in spirit to
 ]}
 
 
+@defproc[(object-or-false=? [a (or/c object? #f)] [b (or/c object? #f)]) boolean?]{
+
+Like @racket[object=?], but accepts @racket[#f] for either argument and
+returns @racket[#t] if both arguments are @racket[#f].
+
+@defexamples[#:eval class-ctc-eval
+   (object-or-false=? #f (new object%))
+   (object-or-false=? (new object%) #f)
+   (object-or-false=? #f #f)
+   ]
+
+@history[#:added "6.1.1.8"]}
+
+
 @defproc[(object->vector [object object?] [opaque-v any/c #f]) vector?]{
 
 Returns a vector representing @racket[object] that shows its
diff --git a/pkgs/racket-test-core/tests/racket/object.rktl b/pkgs/racket-test-core/tests/racket/object.rktl
index f54fc4d493..c29d320ded 100644
--- a/pkgs/racket-test-core/tests/racket/object.rktl
+++ b/pkgs/racket-test-core/tests/racket/object.rktl
@@ -1631,6 +1631,31 @@
 
 )
 
+;; ----------------------------------------
+;; object=?
+
+(let ([c% (class object% (super-new))])
+  (let ([o1 (new c%)]
+        [o2 (new c%)])
+    (test #f object=? o1 o2)
+    (test #t object=? o1 o1)
+    
+    (err/rt-test (object=? o1 #f))
+    (err/rt-test (object=? #f o1))
+    (err/rt-test (object=? 'a o1))
+    (err/rt-test (object=? o1 'a))
+    (err/rt-test (object=? #f #f))
+    
+    (test #f object-or-false=? o1 o2)
+    (test #t object-or-false=? o1 o1)
+    (test #f object-or-false=? o1 #f)
+    (test #f object-or-false=? #f o1)
+    (test #t object-or-false=? #f #f)
+    
+    (err/rt-test (object-or-false=? #f 'a))
+    (err/rt-test (object-or-false=? 'a o1))
+    (err/rt-test (object-or-false=? o1 'a))
+    (err/rt-test (object-or-false=? #f 'a))))
 
 ;; ----------------------------------------
 ;; Implementing printable<%>
diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt
index e55a575bcc..ffc9ab1745 100644
--- a/racket/collects/racket/private/class-internal.rkt
+++ b/racket/collects/racket/private/class-internal.rkt
@@ -37,7 +37,7 @@
            mixin
            interface interface* interface?
            object% object? externalizable<%> printable<%> writable<%> equal<%>
-           object=?
+           object=? object-or-false=?
            new make-object instantiate
            send send/apply send/keyword-apply send* send+ dynamic-send
            class-field-accessor class-field-mutator with-method
@@ -4272,10 +4272,25 @@ An example
                                  rest)))])))))))))
 
 (define (object=? o1 o2)
-  (unless (object? o1)
-    (raise-argument-error 'object=? "object?" 0 o1 o2))
-  (unless (object? o2)
-    (raise-argument-error 'object=? "object?" 1 o1 o2))
+  (cond
+   [(not (object? o1))
+    (raise-argument-error 'object=? "object?" 0 o1 o2)]
+   [(not (object? o2))
+    (raise-argument-error 'object=? "object?" 1 o1 o2)]
+   [else
+    (or (eq? o1 o2) (-object=? o1 o2))]))
+
+(define (object-or-false=? o1 o2)
+  (cond
+   [(and o1 (not (object? o1)))
+    (raise-argument-error 'object-or-false=? "(or/c object? #f)" 0 o1 o2)]
+   [(and o2 (not (object? o2)))
+    (raise-argument-error 'object-or-false=? "(or/c object? #f)" 1 o1 o2)]
+   [else
+    (or (eq? o1 o2)
+        (and o1 o2 (-object=? o1 o2)))]))
+
+(define (-object=? o1 o2)
   (let* ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
          [orig-o2 (if (has-original-object? o2) (original-object o2) o2)]
          [orig-orig-o1 (if (wrapped-object? orig-o1)
@@ -4683,7 +4698,7 @@ An example
          class?
          mixin
          (rename-out [_interface interface]) interface* interface?
-         object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
+         object% object? object=? object-or-false=? externalizable<%> printable<%> writable<%> equal<%>
          new make-object instantiate
          get-field set-field! field-bound? field-names
          dynamic-get-field dynamic-set-field!