;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
+;;; FIXME: Many of the functions in this file could probably be
+;;; byte-compiled, since they're one-pass, cons-heavy code.
+
(in-package "SB!C")
\f
;;;; type predicate translation
;;;; part of the backend; different backends can support different
;;;; sets of predicates.
+;;; Establish an association between the type predicate NAME and the
+;;; corresponding TYPE. This causes the type predicate to be
+;;; recognized for purposes of optimization.
(defmacro define-type-predicate (name type)
- #!+sb-doc
- "Define-Type-Predicate Name Type
- Establish an association between the type predicate Name and the
- corresponding Type. This causes the type predicate to be recognized for
- purposes of optimization."
`(%define-type-predicate ',name ',type))
(defun %define-type-predicate (name specifier)
(let ((type (specifier-type specifier)))
(declare (type continuation object) (type ctype type))
(let ((otype (continuation-type object)))
(cond ((not (types-intersect otype type))
- 'nil)
+ nil)
((csubtypep otype type)
- 't)
+ t)
(t
(give-up-ir1-transform)))))
`(or (class-cell-class ',cell)
(error "class not yet defined: ~S" name))))
\f
-;;;; standard type predicates
+;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
+;;;; plus at least one oddball (%INSTANCEP)
+;;;;
+;;;; Various other type predicates (e.g. low-level representation
+;;;; stuff like SIMPLE-ARRAY-SINGLE-FLOAT-P) are defined elsewhere.
-;;; FIXME: needed only at cold load time, can be uninterned afterwards;
-;;; or perhaps could just be done at toplevel
-(defun define-standard-type-predicates ()
+;;; FIXME: This function is only called once, at top level. Why not
+;;; just expand all its operations into toplevel code?
+(defun !define-standard-type-predicates ()
(define-type-predicate arrayp array)
; (The ATOM predicate is handled separately as (NOT CONS).)
(define-type-predicate bit-vector-p bit-vector)
(define-type-predicate funcallable-instance-p funcallable-instance)
(define-type-predicate symbolp symbol)
(define-type-predicate vectorp vector))
-
-(define-standard-type-predicates)
+(!define-standard-type-predicates)
\f
;;;; transforms for type predicates not implemented primitively
;;;;
\f
;;;; TYPEP source transform
-;;; Return a form that tests the variable N-Object for being in the binds
-;;; specified by Type. Base is the name of the base type, for declaration. We
-;;; make safety locally 0 to inhibit any checking of this assertion.
+;;; Return a form that tests the variable N-OBJECT for being in the
+;;; binds specified by TYPE. BASE is the name of the base type, for
+;;; declaration. We make SAFETY locally 0 to inhibit any checking of
+;;; this assertion.
#!-negative-zero-is-not-zero
(defun transform-numeric-bound-test (n-object type base)
(declare (type numeric-type type))
(declare (type hairy-type type))
(let ((spec (hairy-type-specifier type)))
(cond ((unknown-type-p type)
- (when (policy nil (> speed brevity))
+ (when (policy nil (> speed inhibit-warnings))
(compiler-note "can't open-code test of unknown type ~S"
(type-specifier type)))
`(%typep ,object ',spec))
`(typep ,n-obj ',x))
(rest spec))))))))))
-;;; Do source transformation for Typep of a known union type. If a
+;;; Do source transformation for TYPEP of a known union type. If a
;;; union type contains LIST, then we pull that out and make it into a
;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
;;; will be a subtype even without there being any (member NIL). We
(let* ((types (union-type-types type))
(ltype (specifier-type 'list))
(mtype (find-if #'member-type-p types)))
- (cond ((and mtype (csubtypep ltype type))
- (let ((members (member-type-members mtype)))
- (once-only ((n-obj object))
- `(if (listp ,n-obj)
- t
- (typep ,n-obj
- '(or ,@(mapcar #'type-specifier
- (remove (specifier-type 'cons)
- (remove mtype types)))
- (member ,@(remove nil members))))))))
- (t
- (once-only ((n-obj object))
- `(or ,@(mapcar #'(lambda (x)
- `(typep ,n-obj ',(type-specifier x)))
- types)))))))
+ (if (and mtype (csubtypep ltype type))
+ (let ((members (member-type-members mtype)))
+ (once-only ((n-obj object))
+ `(or (listp ,n-obj)
+ (typep ,n-obj
+ '(or ,@(mapcar #'type-specifier
+ (remove (specifier-type 'cons)
+ (remove mtype types)))
+ (member ,@(remove nil members)))))))
+ (once-only ((n-obj object))
+ `(or ,@(mapcar (lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
+ types))))))
+
+;;; Do source transformation for TYPEP of a known intersection type.
+(defun source-transform-intersection-typep (object type)
+ (once-only ((n-obj object))
+ `(and ,@(mapcar (lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
+ (intersection-type-types type)))))
;;; If necessary recurse to check the cons type.
(defun source-transform-cons-typep (object type)
',(find-class-cell name)
object)))))))))
-#|
-;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
-;;; which corresponds to the value returned by
-;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
-;;; result might change when we encounter a DEFTYPE.
-(declaim (maybe-inline upgraded-array-element-ctype-2))
-(defun upgraded-array-element-ctype-2 (spec)
- (let ((ctype (specifier-type `(array ,spec))))
- (values (array-type-specialized-element-type
- (specifier-type `(array ,spec)))
- (not (unknown-type-p (array-type-element-type ctype))))))
-|#
-
;;; If the specifier argument is a quoted constant, then we consider
;;; converting into a simple predicate or other stuff. If the type is
;;; constant, but we can't transform the call, then we convert to
;;; simplification. Instance type tests are converted to
;;; %INSTANCE-TYPEP to allow type propagation.
(def-source-transform typep (object spec)
+ ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
+ ;; since that would overlook other kinds of constants. But it turns
+ ;; out that the DEFTRANSFORM for TYPEP detects any constant
+ ;; continuation, transforms it into a quoted form, and gives this
+ ;; source transform another chance, so it all works out OK, in a
+ ;; weird roundabout way. -- WHN 2001-03-18
(if (and (consp spec) (eq (car spec) 'quote))
(let ((type (specifier-type (cadr spec))))
(or (let ((pred (cdr (assoc type *backend-type-predicates*
(source-transform-hairy-typep object type))
(union-type
(source-transform-union-typep object type))
+ (intersection-type
+ (source-transform-intersection-typep object type))
(member-type
`(member ,object ',(member-type-members type)))
(args-type
projects / sbcl.git / blobdiff