0.9.2.43:
[sbcl.git] / src / code / pred.lisp
index ada4bed..d7f5bfa 100644 (file)
@@ -21,7 +21,7 @@
 (defun vector-t-p (x)
   (or (simple-vector-p x)
       (and (complex-vector-p x)
-          (simple-vector-p (%array-data-vector x)))))
+           (simple-vector-p (%array-data-vector x)))))
 \f
 ;;;; primitive predicates. These must be supported directly by the
 ;;;; compiler.
 
 ;;; All the primitive type predicate wrappers share a parallel form..
 (macrolet ((def-type-predicate-wrapper (pred)
-            (let* ((name (symbol-name pred))
-                   (stem (string-left-trim "%" (string-right-trim "P-" name)))
-                   (article (if (position (schar name 0) "AEIOU") "an" "a")))
-              `(defun ,pred (object)
-                 ,(format nil
-                          "Return true if OBJECT is ~A ~A, and NIL otherwise."
-                          article
-                          stem)
-                 ;; (falling through to low-level implementation)
-                 (,pred object)))))
+             (let* ((name (symbol-name pred))
+                    (stem (string-left-trim "%" (string-right-trim "P-" name)))
+                    (article (if (position (schar name 0) "AEIOU") "an" "a")))
+               `(defun ,pred (object)
+                  ,(format nil
+                           "Return true if OBJECT is ~A ~A, and NIL otherwise."
+                           article
+                           stem)
+                  ;; (falling through to low-level implementation)
+                  (,pred object)))))
   (def-type-predicate-wrapper array-header-p)
   (def-type-predicate-wrapper arrayp)
   (def-type-predicate-wrapper atom)
        (t '(integer 0 #.sb!xc:most-positive-fixnum))))
     (integer
      (if (>= object 0)
-        '(integer #.(1+ sb!xc:most-positive-fixnum))
-        'bignum))
+         '(integer #.(1+ sb!xc:most-positive-fixnum))
+         'bignum))
     (standard-char 'standard-char)
     (base-char 'base-char)
     (extended-char 'extended-char)
     ((or array complex) (type-specifier (ctype-of object)))
     (t
      (let* ((classoid (layout-classoid (layout-of object)))
-           (name (classoid-name classoid)))
+            (name (classoid-name classoid)))
        (if (typep object 'instance)
-          (case name
-            (sb!alien-internals:alien-value
-             `(sb!alien:alien
-               ,(sb!alien-internals:unparse-alien-type
-                 (sb!alien-internals:alien-value-type object))))
-            (t
-             (let ((pname (classoid-proper-name classoid)))
-               (if (classoid-p pname)
-                   (classoid-pcl-class pname)
-                   pname))))
-          name)))))
+           (case name
+             (sb!alien-internals:alien-value
+              `(sb!alien:alien
+                ,(sb!alien-internals:unparse-alien-type
+                  (sb!alien-internals:alien-value-type object))))
+             (t
+              (let ((pname (classoid-proper-name classoid)))
+                (if (classoid-p pname)
+                    (classoid-pcl-class pname)
+                    pname))))
+           name)))))
 \f
 ;;;; equality predicates
 
 (defun bit-vector-= (x y)
   (declare (type bit-vector x y))
   (if (and (simple-bit-vector-p x)
-          (simple-bit-vector-p y))
+           (simple-bit-vector-p y))
       (bit-vector-= x y) ; DEFTRANSFORM
       (and (= (length x) (length y))
-          (do ((i 0 (1+ i))
-               (length (length x)))
-              ((= i length) t)
-            (declare (fixnum i))
-            (unless (= (bit x i) (bit y i))
-              (return nil))))))
+           (do ((i 0 (1+ i))
+                (length (length x)))
+               ((= i length) t)
+             (declare (fixnum i))
+             (unless (= (bit x i) (bit y i))
+               (return nil))))))
 
 (defun equal (x y)
   #!+sb-doc
   are the same length and have identical components. Other arrays must be
   EQ to be EQUAL."
   (cond ((eql x y) t)
-       ((consp x)
-        (and (consp y)
-             (equal (car x) (car y))
-             (equal (cdr x) (cdr y))))
-       ((stringp x)
-        (and (stringp y) (string= x y)))
-       ((pathnamep x)
-        (and (pathnamep y) (pathname= x y)))
-       ((bit-vector-p x)
-        (and (bit-vector-p y)
-             (bit-vector-= x y)))
-       (t nil)))
+        ((consp x)
+         (and (consp y)
+              (equal (car x) (car y))
+              (equal (cdr x) (cdr y))))
+        ((stringp x)
+         (and (stringp y) (string= x y)))
+        ((pathnamep x)
+         (and (pathnamep y) (pathname= x y)))
+        ((bit-vector-p x)
+         (and (bit-vector-p y)
+              (bit-vector-= x y)))
+        (t nil)))
 
 ;;; EQUALP comparison of HASH-TABLE values
 (defun hash-table-equalp (x y)
   (declare (type hash-table x y))
   (or (eq x y)
       (and (hash-table-p y)
-          (eql (hash-table-count x) (hash-table-count y))
-          (eql (hash-table-test x) (hash-table-test y))
-          (block comparison-of-entries
-            (maphash (lambda (key x-value)
-                       (multiple-value-bind (y-value y-value-p)
-                           (gethash key y)
-                         (unless (and y-value-p (equalp x-value y-value))
-                           (return-from comparison-of-entries nil))))
-                     x)
-            t))))
+           (eql (hash-table-count x) (hash-table-count y))
+           (eql (hash-table-test x) (hash-table-test y))
+           (block comparison-of-entries
+             (maphash (lambda (key x-value)
+                        (multiple-value-bind (y-value y-value-p)
+                            (gethash key y)
+                          (unless (and y-value-p (equalp x-value y-value))
+                            (return-from comparison-of-entries nil))))
+                      x)
+             t))))
 
 (defun equalp (x y)
   #+nil ; KLUDGE: If doc string, should be accurate: Talk about structures
   arrays must have identical dimensions and EQUALP elements, but may differ
   in their type restriction."
   (cond ((eq x y) t)
-       ((characterp x) (and (characterp y) (char-equal x y)))
-       ((numberp x) (and (numberp y) (= x y)))
-       ((consp x)
-        (and (consp y)
-             (equalp (car x) (car y))
-             (equalp (cdr x) (cdr y))))
-       ((pathnamep x)
-        (and (pathnamep y) (pathname= x y)))
-       ((hash-table-p x)
-        (and (hash-table-p y)
-             (hash-table-equalp x y)))
-       ((typep x 'instance)
-        (let* ((layout-x (%instance-layout x))
-               (len (layout-length layout-x)))
-          (and (typep y 'instance)
-               (eq layout-x (%instance-layout y))
-               (structure-classoid-p (layout-classoid layout-x))
-               (do ((i 1 (1+ i)))
-                   ((= i len) t)
-                 (declare (fixnum i))
-                 (let ((x-el (%instance-ref x i))
-                       (y-el (%instance-ref y i)))
-                   (unless (or (eq x-el y-el)
-                               (equalp x-el y-el))
-                     (return nil)))))))
-       ((vectorp x)
-        (let ((length (length x)))
-          (and (vectorp y)
-               (= length (length y))
-               (dotimes (i length t)
-                 (let ((x-el (aref x i))
-                       (y-el (aref y i)))
-                   (unless (or (eq x-el y-el)
-                               (equalp x-el y-el))
-                     (return nil)))))))
-       ((arrayp x)
-        (and (arrayp y)
-             (= (array-rank x) (array-rank y))
-             (dotimes (axis (array-rank x) t)
-               (unless (= (array-dimension x axis)
-                          (array-dimension y axis))
-                 (return nil)))
-             (dotimes (index (array-total-size x) t)
-               (let ((x-el (row-major-aref x index))
-                     (y-el (row-major-aref y index)))
-                 (unless (or (eq x-el y-el)
-                             (equalp x-el y-el))
-                   (return nil))))))
-       (t nil)))
+        ((characterp x) (and (characterp y) (char-equal x y)))
+        ((numberp x) (and (numberp y) (= x y)))
+        ((consp x)
+         (and (consp y)
+              (equalp (car x) (car y))
+              (equalp (cdr x) (cdr y))))
+        ((pathnamep x)
+         (and (pathnamep y) (pathname= x y)))
+        ((hash-table-p x)
+         (and (hash-table-p y)
+              (hash-table-equalp x y)))
+        ((typep x 'instance)
+         (let* ((layout-x (%instance-layout x))
+                (len (layout-length layout-x)))
+           (and (typep y 'instance)
+                (eq layout-x (%instance-layout y))
+                (structure-classoid-p (layout-classoid layout-x))
+                (do ((i 1 (1+ i)))
+                    ((= i len) t)
+                  (declare (fixnum i))
+                  (let ((x-el (%instance-ref x i))
+                        (y-el (%instance-ref y i)))
+                    (unless (or (eq x-el y-el)
+                                (equalp x-el y-el))
+                      (return nil)))))))
+        ((vectorp x)
+         (let ((length (length x)))
+           (and (vectorp y)
+                (= length (length y))
+                (dotimes (i length t)
+                  (let ((x-el (aref x i))
+                        (y-el (aref y i)))
+                    (unless (or (eq x-el y-el)
+                                (equalp x-el y-el))
+                      (return nil)))))))
+        ((arrayp x)
+         (and (arrayp y)
+              (= (array-rank x) (array-rank y))
+              (dotimes (axis (array-rank x) t)
+                (unless (= (array-dimension x axis)
+                           (array-dimension y axis))
+                  (return nil)))
+              (dotimes (index (array-total-size x) t)
+                (let ((x-el (row-major-aref x index))
+                      (y-el (row-major-aref y index)))
+                  (unless (or (eq x-el y-el)
+                              (equalp x-el y-el))
+                    (return nil))))))
+        (t nil)))
 
 (/show0 "about to do test cases in pred.lisp")
 #!+sb-test
 (let ((test-cases `((0.0 ,(load-time-value (make-unportable-float :single-float-negative-zero)) t)
-                   (0.0 1.0 nil)
-                   (#c(1 0) #c(1.0 0) t)
-                   (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
-                   ("Hello" "hello" t)
-                   ("Hello" #(#\h #\E #\l #\l #\o) t)
-                   ("Hello" "goodbye" nil))))
+                    (0.0 1.0 nil)
+                    (#c(1 0) #c(1.0 0) t)
+                    (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
+                    ("Hello" "hello" t)
+                    ("Hello" #(#\h #\E #\l #\l #\o) t)
+                    ("Hello" "goodbye" nil))))
   (/show0 "TEST-CASES bound in pred.lisp")
   (dolist (test-case test-cases)
     (/show0 "about to do a TEST-CASE in pred.lisp")
     (destructuring-bind (x y expected-result) test-case
       (let* ((result (equalp x y))
-            (bresult (if result 1 0))
-            (expected-bresult (if expected-result 1 0)))
-       (unless (= bresult expected-bresult)
-         (/show0 "failing test in pred.lisp")
-         (error "failed test (EQUALP ~S ~S)" x y))))))
+             (bresult (if result 1 0))
+             (expected-bresult (if expected-result 1 0)))
+        (unless (= bresult expected-bresult)
+          (/show0 "failing test in pred.lisp")
+          (error "failed test (EQUALP ~S ~S)" x y))))))
 (/show0 "done with test cases in pred.lisp")