;;; constant. At worst, it will convert to %TYPEP, which will prevent
;;; spurious attempts at transformation (and possible repeated
;;; warnings.)
-(deftransform typep ((object type) * * :node node)
+(deftransform typep ((object type &optional env) * * :node node)
(unless (constant-lvar-p type)
(give-up-ir1-transform "can't open-code test of non-constant type"))
+ (unless (and (constant-lvar-p env) (null (lvar-value env)))
+ (give-up-ir1-transform "environment argument present and not null"))
(multiple-value-bind (expansion fail-p)
(source-transform-typep 'object (lvar-value type))
(if fail-p
`(%typep ,object ',spec))
(t
(ecase (first spec)
- (satisfies `(if (funcall #',(second spec) ,object) t nil))
+ (satisfies
+ `(if (funcall (global-function ,(second spec)) ,object) t nil))
((not and)
(once-only ((n-obj object))
`(,(first spec) ,@(mapcar (lambda (x)
;;; specified by TYPE, where STYPE is the type we have checked against
;;; (which is the same but for dimensions and element type).
;;;
-;;; Secondary return value is true if generated tests passing imply
-;;; that the array has a header.
+;;; Secondary return value is true if passing the generated tests implies that
+;;; the array has a header.
(defun test-array-dimensions (obj type stype)
(declare (type array-type type stype))
(let ((obj `(truly-the ,(type-specifier stype) ,obj))
(= (%array-rank ,obj) 0))
t))
((not (array-type-complexp type))
- (values (unless (eq '* (car dims))
- `((= (vector-length ,obj) ,@dims)))
- nil))
+ (if (csubtypep stype (specifier-type 'vector))
+ (values (unless (eq '* (car dims))
+ `((= (vector-length ,obj) ,@dims)))
+ nil)
+ (values (if (eq '* (car dims))
+ `((not (array-header-p ,obj)))
+ `((not (array-header-p ,obj))
+ (= (vector-length ,obj) ,@dims)))
+ nil)))
(t
(values (unless (eq '* (car dims))
`((if (array-header-p ,obj)
;; not safe to assume here that it will eventually
;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
(not (unknown-type-p (array-type-element-type type)))
- (eq (array-type-complexp stype) (array-type-complexp type)))
- (once-only ((n-obj obj))
- (multiple-value-bind (tests headerp)
- (test-array-dimensions n-obj type stype)
- `(and (,pred ,n-obj)
- ,@tests
- ,@(test-array-element-type n-obj type stype headerp))))
- `(%typep ,obj ',(type-specifier type)))))
+ (or (eq (array-type-complexp stype) (array-type-complexp type))
+ (and (eql (array-type-complexp stype) :maybe)
+ (eql (array-type-complexp type) t))))
+ (once-only ((n-obj obj))
+ (multiple-value-bind (tests headerp)
+ (test-array-dimensions n-obj type stype)
+ `(and (,pred ,n-obj)
+ ,@(when (and (eql (array-type-complexp stype) :maybe)
+ (eql (array-type-complexp type) t))
+ ;; KLUDGE: this is a bit lame; if we get here,
+ ;; we already know that N-OBJ is an array, but
+ ;; (NOT SIMPLE-ARRAY) doesn't know that. On the
+ ;; other hand, this should get compiled down to
+ ;; two widetag tests, so it's only a bit lame.
+ `((typep ,n-obj '(not simple-array))))
+ ,@tests
+ ,@(test-array-element-type n-obj type stype headerp))))
+ `(%typep ,obj ',(type-specifier type)))))
;;; Transform a type test against some instance type. The type test is
;;; flushed if the result is known at compile time. If not properly
(t nil))
`(%typep ,object ',type))))
-(define-source-transform typep (object spec)
+(define-source-transform typep (object spec &optional env)
;; 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
;; lvar, 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)
+ (if (and (not env)
+ (consp spec)
(eq (car spec) 'quote)
(or (not *allow-instrumenting*)
(policy *lexenv* (= store-coverage-data 0))))
(deftransform coerce ((x type) (* *) * :node node)
(unless (constant-lvar-p type)
(give-up-ir1-transform))
- (let ((tspec (ir1-transform-specifier-type (lvar-value type))))
+ (let* ((tval (lvar-value type))
+ (tspec (ir1-transform-specifier-type tval)))
(if (csubtypep (lvar-type x) tspec)
'x
;; Note: The THE here makes sure that specifiers like
;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
((csubtypep tspec (specifier-type 'float))
'(%single-float x))
- ((and (csubtypep tspec (specifier-type 'simple-vector))
- ;; Can we avoid checking for dimension issues like
- ;; (COERCE FOO '(SIMPLE-VECTOR 5)) returning a
- ;; vector of length 6?
- (or (policy node (< safety 3)) ; no need in unsafe code
- (and (array-type-p tspec) ; no need when no dimensions
- (equal (array-type-dimensions tspec) '(*)))))
- `(if (simple-vector-p x)
+ ;; Special case STRING and SIMPLE-STRING as they are union types
+ ;; in SBCL.
+ ((member tval '(string simple-string))
+ `(if (typep x ',tval)
+ x
+ (replace (make-array (length x) :element-type 'character) x)))
+ ;; Special case VECTOR
+ ((eq tval 'vector)
+ `(if (vectorp x)
x
(replace (make-array (length x)) x)))
- ;; FIXME: other VECTOR types?
+ ;; Handle specialized element types for 1D arrays.
+ ((csubtypep tspec (specifier-type '(array * (*))))
+ ;; Can we avoid checking for dimension issues like (COERCE FOO
+ ;; '(SIMPLE-VECTOR 5)) returning a vector of length 6?
+ (if (or (policy node (< safety 3)) ; no need in unsafe code
+ (and (array-type-p tspec) ; no need when no dimensions
+ (equal (array-type-dimensions tspec) '(*))))
+ ;; We can!
+ (let ((array-type
+ (if (csubtypep tspec (specifier-type 'simple-array))
+ 'simple-array
+ 'array)))
+ (dolist (etype
+ #+sb-xc-host '(t bit character)
+ #-sb-xc-host sb!kernel::*specialized-array-element-types*
+ (give-up-ir1-transform))
+ (when etype
+ (let ((spec `(,array-type ,etype (*))))
+ (when (csubtypep tspec (specifier-type spec))
+ ;; Is the result required to be non-simple?
+ (let ((result-simple
+ (or (eq 'simple-array array-type)
+ (neq *empty-type*
+ (type-intersection
+ tspec (specifier-type 'simple-array))))))
+ (return
+ `(if (typep x ',spec)
+ x
+ (replace
+ (make-array (length x) :element-type ',etype
+ ,@(unless result-simple
+ (list :fill-pointer t
+ :adjustable t)))
+ x)))))))))
+ ;; No, duh. Dimension checking required.
+ (give-up-ir1-transform
+ "~@<~S specifies dimensions other than (*) in safe code.~:@>"
+ tval)))
(t
- (give-up-ir1-transform)))))))
-
-
+ (give-up-ir1-transform
+ "~@<open coding coercion to ~S not implemented.~:@>"
+ tval)))))))
projects / sbcl.git / blobdiff