X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=4f47e172178744b148aa04c313c2c8fc1ee5338d;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=bada4f66f376ffed35033c2c587d236a946360d6;hpb=7ce5108fd5ec5b599d4ae9e8aedc1a0d458af102;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index bada4f6..4f47e17 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -238,7 +238,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)
@@ -602,7 +603,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 +616,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
+               "~@<open coding coercion to ~S not implemented.~:@>"
+               tval)))))))