;;;; files for more information.
(in-package "SB!IMPL")
-
-(file-comment
- "$Header$")
\f
;;;; miscellaneous non-primitive predicates
"Return T if X is NIL, otherwise return NIL."
(not object))
-;;; All the primitive type predicates share a parallel form..
-(macrolet
- ((frob ()
- `(progn
- ,@(mapcar (lambda (pred)
- (let* ((name (symbol-name pred))
- (stem (string-right-trim name "P-"))
- (article (if (find (schar name 0) "AEIOU")
- "an"
- "a")))
- `(defun ,pred (object)
- ,(format nil
- "Return T if OBJECT is ~A ~A, ~
- and NIL otherwise."
- article
- stem)
- (,pred object))))
- '(array-header-p
- arrayp
- atom
- base-char-p
- bignump
- bit-vector-p
- characterp
- code-component-p
- consp
- compiled-function-p
- complexp
- complex-double-float-p
- complex-float-p
- #!+long-float complex-long-float-p
- complex-rational-p
- complex-single-float-p
- ;; (COMPLEX-VECTOR-P is not included here since
- ;; it's awkward to express the type it tests for
- ;; in the Common Lisp type system, and since
- ;; it's only used in the implementation of a few
- ;; specialized things.)
- double-float-p
- fdefn-p
- fixnump
- floatp
- functionp
- integerp
- listp
- long-float-p
- lra-p
- null
- numberp
- rationalp
- ratiop
- realp
- short-float-p
- sb!kernel:simple-array-p
- simple-bit-vector-p
- simple-string-p
- simple-vector-p
- single-float-p
- stringp
- %instancep
- symbolp
- system-area-pointer-p
- weak-pointer-p
- vectorp
- unsigned-byte-32-p
- signed-byte-32-p
- simple-array-unsigned-byte-2-p
- simple-array-unsigned-byte-4-p
- simple-array-unsigned-byte-8-p
- simple-array-unsigned-byte-16-p
- simple-array-unsigned-byte-32-p
- simple-array-signed-byte-8-p
- simple-array-signed-byte-16-p
- simple-array-signed-byte-30-p
- simple-array-signed-byte-32-p
- simple-array-single-float-p
- simple-array-double-float-p
- #!+long-float simple-array-long-float-p
- simple-array-complex-single-float-p
- simple-array-complex-double-float-p
- #!+long-float simple-array-complex-long-float-p
- )))))
- (frob))
+;;; 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)))))
+ (def-type-predicate-wrapper array-header-p)
+ (def-type-predicate-wrapper arrayp)
+ (def-type-predicate-wrapper atom)
+ (def-type-predicate-wrapper base-char-p)
+ (def-type-predicate-wrapper bignump)
+ (def-type-predicate-wrapper bit-vector-p)
+ (def-type-predicate-wrapper characterp)
+ (def-type-predicate-wrapper code-component-p)
+ (def-type-predicate-wrapper consp)
+ (def-type-predicate-wrapper compiled-function-p)
+ (def-type-predicate-wrapper complexp)
+ (def-type-predicate-wrapper complex-double-float-p)
+ (def-type-predicate-wrapper complex-float-p)
+ #!+long-float (def-type-predicate-wrapper complex-long-float-p)
+ (def-type-predicate-wrapper complex-rational-p)
+ (def-type-predicate-wrapper complex-single-float-p)
+ ;; (COMPLEX-VECTOR-P is not included here since it's awkward to express
+ ;; the type it tests for in the Common Lisp type system, and since it's
+ ;; only used in the implementation of a few specialized things.)
+ (def-type-predicate-wrapper double-float-p)
+ (def-type-predicate-wrapper fdefn-p)
+ (def-type-predicate-wrapper fixnump)
+ (def-type-predicate-wrapper floatp)
+ (def-type-predicate-wrapper functionp)
+ (def-type-predicate-wrapper integerp)
+ (def-type-predicate-wrapper listp)
+ (def-type-predicate-wrapper long-float-p)
+ (def-type-predicate-wrapper lra-p)
+ (def-type-predicate-wrapper null)
+ (def-type-predicate-wrapper numberp)
+ (def-type-predicate-wrapper rationalp)
+ (def-type-predicate-wrapper ratiop)
+ (def-type-predicate-wrapper realp)
+ (def-type-predicate-wrapper short-float-p)
+ (def-type-predicate-wrapper sb!kernel:simple-array-p)
+ (def-type-predicate-wrapper simple-bit-vector-p)
+ (def-type-predicate-wrapper simple-string-p)
+ (def-type-predicate-wrapper simple-vector-p)
+ (def-type-predicate-wrapper single-float-p)
+ (def-type-predicate-wrapper stringp)
+ (def-type-predicate-wrapper %instancep)
+ (def-type-predicate-wrapper symbolp)
+ (def-type-predicate-wrapper system-area-pointer-p)
+ (def-type-predicate-wrapper weak-pointer-p)
+ (def-type-predicate-wrapper vectorp)
+ (def-type-predicate-wrapper unsigned-byte-32-p)
+ (def-type-predicate-wrapper signed-byte-32-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-2-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-4-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-8-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-16-p)
+ (def-type-predicate-wrapper simple-array-unsigned-byte-32-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-8-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-16-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-30-p)
+ (def-type-predicate-wrapper simple-array-signed-byte-32-p)
+ (def-type-predicate-wrapper simple-array-single-float-p)
+ (def-type-predicate-wrapper simple-array-double-float-p)
+ #!+long-float (def-type-predicate-wrapper simple-array-long-float-p)
+ (def-type-predicate-wrapper simple-array-complex-single-float-p)
+ (def-type-predicate-wrapper simple-array-complex-double-float-p)
+ #!+long-float (def-type-predicate-wrapper simple-array-complex-long-float-p))
\f
;;; Return the specifier for the type of object. This is not simply
;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
#!+sb-doc
"Return the element type that will actually be used to implement an array
with the specifier :ELEMENT-TYPE Spec."
- (type-specifier
- (array-type-specialized-element-type
- (specifier-type `(array ,spec)))))
+ (if (unknown-type-p (specifier-type spec))
+ (error "undefined type: ~S" spec)
+ (type-specifier (array-type-specialized-element-type
+ (specifier-type `(array ,spec))))))
\f
;;;; equality predicates
(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 -0.0 t)
(0.0 1.0 nil)
("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))))))
+(/show0 "done with test cases in pred.lisp")