~ chicken-r7rs (master) 1318d0141a3b34bc4d79cbc03c02eba5f0ebb9e1

commit 1318d0141a3b34bc4d79cbc03c02eba5f0ebb9e1
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jul 6 18:59:15 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sat Jul 6 18:59:15 2013 +0000

    Add boolean=? to r7rs, and export 'not' and 'boolean?'

diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 42e450d..af87a3b 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -9,7 +9,9 @@
   assoc assq assv
   begin
   binary-port?
+  |#
   boolean? boolean=?
+  #|
   bytevector-append bytevector-copy bytevector-copy!
   bytevector-length bytevector-u8-ref bytevector-u8-set!
   bytevector?
@@ -113,7 +115,9 @@
   modulo remainder
   negative? positive?
   newline
+  |#
   not
+  #|
   null?
   number->string string->number
   number?
diff --git a/scheme.base.scm b/scheme.base.scm
index 6f1ebc0..f8adb07 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -100,6 +100,28 @@
 ;;;
 (include "synrules.scm")
 
+
+;;;
+;;; 6.3 Booleans
+;;;
+
+;(: boolean=? ((procedure #:enforce) (boolean boolean #!rest boolean) boolean))
+(: boolean=? (boolean boolean #!rest boolean -> boolean))
+
+(define (boolean=? b1 b2 . rest)
+  ;; Loop across all args, checking for booleans.  Don't shortcut and
+  ;; stop when we find nonequality.
+  (let lp ((b1 b1)
+           (b2 b2)
+           (rest rest)
+           (result (eq? b1 b2)))
+    (##sys#check-boolean b1 'boolean=?)
+    (##sys#check-boolean b2 'boolean=?)
+    (if (null? rest)
+        (and result (eq? b1 b2))
+        (lp b2 (car rest) (cdr rest) (and result (eq? b1 b2))))))
+
+
 ;;;
 ;;; 6.11. Exceptions
 ;;;
@@ -210,5 +232,4 @@
 
 (define (eof-object) #!eof)
 
-
 )
diff --git a/tests/run.scm b/tests/run.scm
index f5e48b7..4be5c94 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -17,6 +17,24 @@
  (test #f (read-from-string "#false"))
  (test-error (read-from-string "#faux")))
 
+(test-group "boolean=?"
+  (test #t (boolean=? #t #t))
+  (test #t (boolean=? #t #t #t #t))
+  (test #t (boolean=? #f #f))
+  (test #t (boolean=? #f #f #f #f))
+  (test #f (boolean=? #f #t))
+  (test #f (boolean=? #f #t #t #t))
+  (test #f (boolean=? #f #f #t #t))
+  (test #f (boolean=? #f #f #f #t))
+  (test #f (boolean=? #t #f #f #f))
+  (test #f (boolean=? #t #f #f #t))
+  (test #f (boolean=? #t #t #f #t))
+  (test #f (boolean=? #f #f #f #t))
+  (test #f (boolean=? #f #t #f #f))
+  (test-error (boolean=? #f))
+  (test-error (boolean=? #f 1))
+  (test-error "no shortcutting" (boolean=? #f #t 2)))
+
 (define-syntax catch
   (syntax-rules ()
     ((_ . body) (handle-exceptions e e . body))))