X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=c1f818d5b344c12596201b7f2e7e53c9c0764048;hb=72a1d0dbc877f559f63baa4285c655a92c21c649;hp=bada4f66f376ffed35033c2c587d236a946360d6;hpb=7ce5108fd5ec5b599d4ae9e8aedc1a0d458af102;p=sbcl.git diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index bada4f6..c1f818d 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -57,9 +57,11 @@ ;;; 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 @@ -238,7 +240,8 @@ `(%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) @@ -405,14 +408,24 @@ ;; 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 @@ -573,14 +586,15 @@ (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)))) @@ -602,7 +616,8 @@ (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 @@ -614,18 +629,56 @@ ;; 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 + "~@" + tval)))))))