X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpred.lisp;h=1acb8741fdb2c458759b3117bb81ae5268c76c0c;hb=672ac5849b408281b5ca0dfc3fd58d418de2b272;hp=208f63758b69af2f66f84aaa2e67f370608d62d3;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 208f637..1acb874 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") ;;;; miscellaneous non-primitive predicates @@ -34,89 +31,80 @@ "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)) ;;; Return the specifier for the type of object. This is not simply ;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different @@ -144,9 +132,10 @@ #!+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)))))) ;;;; equality predicates @@ -258,6 +247,8 @@ (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) @@ -266,10 +257,14 @@ ("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")