src/compiler/typetran.lisp

   1 ;;;; This file contains stuff that implements the portable IR1
   2 ;;;; semantics of type tests and coercion. The main thing we do is
   3 ;;;; convert complex type operations into simpler code that can be
   4 ;;;; compiled inline.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!C")
  16 \f
  17 ;;;; type predicate translation
  18 ;;;;
  19 ;;;; We maintain a bidirectional association between type predicates
  20 ;;;; and the tested type. The presence of a predicate in this
  21 ;;;; association implies that it is desirable to implement tests of
  22 ;;;; this type using the predicate. These are either predicates that
  23 ;;;; the back end is likely to have special knowledge about, or
  24 ;;;; predicates so complex that the only reasonable implentation is
  25 ;;;; via function call.
  26 ;;;;
  27 ;;;; Some standard types (such as SEQUENCE) are best tested by letting
  28 ;;;; the TYPEP source transform do its thing with the expansion. These
  29 ;;;; types (and corresponding predicates) are not maintained in this
  30 ;;;; association. In this case, there need not be any predicate
  31 ;;;; function unless it is required by the Common Lisp specification.
  32 ;;;;
  33 ;;;; The mapping between predicates and type structures is considered
  34 ;;;; part of the backend; different backends can support different
  35 ;;;; sets of predicates.
  36
  37 (defmacro define-type-predicate (name type)
  38   #!+sb-doc
  39   "Define-Type-Predicate Name Type
  40   Establish an association between the type predicate Name and the
  41   corresponding Type. This causes the type predicate to be recognized for
  42   purposes of optimization."
  43   `(%define-type-predicate ',name ',type))
  44 (defun %define-type-predicate (name specifier)
  45   (let ((type (specifier-type specifier)))
  46     (setf (gethash name *backend-predicate-types*) type)
  47     (setf *backend-type-predicates*
  48           (cons (cons type name)
  49                 (remove name *backend-type-predicates*
  50                         :key #'cdr)))
  51     (%deftransform name '(function (t) *) #'fold-type-predicate)
  52     name))
  53 \f
  54 ;;;; IR1 transforms
  55
  56 ;;; If we discover the type argument is constant during IR1
  57 ;;; optimization, then give the source transform another chance. The
  58 ;;; source transform can't pass, since we give it an explicit
  59 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
  60 ;;; spurious attempts at transformation (and possible repeated
  61 ;;; warnings.)
  62 (deftransform typep ((object type))
  63   (unless (constant-continuation-p type)
  64     (give-up-ir1-transform "can't open-code test of non-constant type"))
  65   `(typep object ',(continuation-value type)))
  66
  67 ;;; If the continuation OBJECT definitely is or isn't of the specified
  68 ;;; type, then return T or NIL as appropriate. Otherwise quietly
  69 ;;; GIVE-UP-IR1-TRANSFORM.
  70 (defun ir1-transform-type-predicate (object type)
  71   (declare (type continuation object) (type ctype type))
  72   (let ((otype (continuation-type object)))
  73     (cond ((not (types-intersect otype type))
  74            'nil)
  75           ((csubtypep otype type)
  76            't)
  77           (t
  78            (give-up-ir1-transform)))))
  79
  80 ;;; Flush %TYPEP tests whose result is known at compile time.
  81 (deftransform %typep ((object type))
  82   (unless (constant-continuation-p type) (give-up-ir1-transform))
  83   (ir1-transform-type-predicate
  84    object
  85    (specifier-type (continuation-value type))))
  86
  87 ;;; This is the IR1 transform for simple type predicates. It checks
  88 ;;; whether the single argument is known to (not) be of the
  89 ;;; appropriate type, expanding to T or NIL as appropriate.
  90 (deftransform fold-type-predicate ((object) * * :node node :defun-only t)
  91   (let ((ctype (gethash (leaf-name
  92                          (ref-leaf
  93                           (continuation-use
  94                            (basic-combination-fun node))))
  95                         *backend-predicate-types*)))
  96     (assert ctype)
  97     (ir1-transform-type-predicate object ctype)))
  98
  99 ;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
 100 ;;; at load time.
 101 (deftransform find-class ((name) ((constant-argument symbol)) *
 102                           :when :both)
 103   (let* ((name (continuation-value name))
 104          (cell (find-class-cell name)))
 105     `(or (class-cell-class ',cell)
 106          (error "class not yet defined: ~S" name))))
 107 \f
 108 ;;;; standard type predicates
 109
 110 ;;; FIXME: needed only at cold load time, can be uninterned afterwards;
 111 ;;; or perhaps could just be done at toplevel
 112 (defun define-standard-type-predicates ()
 113   (define-type-predicate arrayp array)
 114   ; (The ATOM predicate is handled separately as (NOT CONS).)
 115   (define-type-predicate bit-vector-p bit-vector)
 116   (define-type-predicate characterp character)
 117   (define-type-predicate compiled-function-p compiled-function)
 118   (define-type-predicate complexp complex)
 119   (define-type-predicate complex-rational-p (complex rational))
 120   (define-type-predicate complex-float-p (complex float))
 121   (define-type-predicate consp cons)
 122   (define-type-predicate floatp float)
 123   (define-type-predicate functionp function)
 124   (define-type-predicate integerp integer)
 125   (define-type-predicate keywordp keyword)
 126   (define-type-predicate listp list)
 127   (define-type-predicate null null)
 128   (define-type-predicate numberp number)
 129   (define-type-predicate rationalp rational)
 130   (define-type-predicate realp real)
 131   (define-type-predicate simple-bit-vector-p simple-bit-vector)
 132   (define-type-predicate simple-string-p simple-string)
 133   (define-type-predicate simple-vector-p simple-vector)
 134   (define-type-predicate stringp string)
 135   (define-type-predicate %instancep instance)
 136   (define-type-predicate funcallable-instance-p funcallable-instance)
 137   (define-type-predicate symbolp symbol)
 138   (define-type-predicate vectorp vector))
 139
 140 (define-standard-type-predicates)
 141 \f
 142 ;;;; transforms for type predicates not implemented primitively
 143 ;;;;
 144 ;;;; See also VM dependent transforms.
 145
 146 (def-source-transform atom (x)
 147   `(not (consp ,x)))
 148 \f
 149 ;;;; TYPEP source transform
 150
 151 ;;; Return a form that tests the variable N-Object for being in the binds
 152 ;;; specified by Type. Base is the name of the base type, for declaration. We
 153 ;;; make safety locally 0 to inhibit any checking of this assertion.
 154 #!-negative-zero-is-not-zero
 155 (defun transform-numeric-bound-test (n-object type base)
 156   (declare (type numeric-type type))
 157   (let ((low (numeric-type-low type))
 158         (high (numeric-type-high type)))
 159     `(locally
 160        (declare (optimize (safety 0)))
 161        (and ,@(when low
 162                 (if (consp low)
 163                     `((> (the ,base ,n-object) ,(car low)))
 164                     `((>= (the ,base ,n-object) ,low))))
 165             ,@(when high
 166                 (if (consp high)
 167                     `((< (the ,base ,n-object) ,(car high)))
 168                     `((<= (the ,base ,n-object) ,high))))))))
 169
 170 #!+negative-zero-is-not-zero
 171 (defun transform-numeric-bound-test (n-object type base)
 172   (declare (type numeric-type type))
 173   (let ((low (numeric-type-low type))
 174         (high (numeric-type-high type))
 175         (float-type-p (csubtypep type (specifier-type 'float)))
 176         (x (gensym))
 177         (y (gensym)))
 178     `(locally
 179        (declare (optimize (safety 0)))
 180        (and ,@(when low
 181                 (if (consp low)
 182                     `((let ((,x (the ,base ,n-object))
 183                             (,y ,(car low)))
 184                         ,(if (not float-type-p)
 185                             `(> ,x ,y)
 186                             `(if (and (zerop ,x) (zerop ,y))
 187                                  (> (float-sign ,x) (float-sign ,y))
 188                                  (> ,x ,y)))))
 189                     `((let ((,x (the ,base ,n-object))
 190                             (,y ,low))
 191                         ,(if (not float-type-p)
 192                             `(>= ,x ,y)
 193                             `(if (and (zerop ,x) (zerop ,y))
 194                                  (>= (float-sign ,x) (float-sign ,y))
 195                                  (>= ,x ,y)))))))
 196             ,@(when high
 197                 (if (consp high)
 198                     `((let ((,x (the ,base ,n-object))
 199                             (,y ,(car high)))
 200                         ,(if (not float-type-p)
 201                              `(< ,x ,y)
 202                              `(if (and (zerop ,x) (zerop ,y))
 203                                   (< (float-sign ,x) (float-sign ,y))
 204                                   (< ,x ,y)))))
 205                     `((let ((,x (the ,base ,n-object))
 206                             (,y ,high))
 207                         ,(if (not float-type-p)
 208                              `(<= ,x ,y)
 209                              `(if (and (zerop ,x) (zerop ,y))
 210                                   (<= (float-sign ,x) (float-sign ,y))
 211                                   (<= ,x ,y)))))))))))
 212
 213 ;;; Do source transformation of a test of a known numeric type. We can
 214 ;;; assume that the type doesn't have a corresponding predicate, since
 215 ;;; those types have already been picked off. In particular, CLASS
 216 ;;; must be specified, since it is unspecified only in NUMBER and
 217 ;;; COMPLEX. Similarly, we assume that COMPLEXP is always specified.
 218 ;;;
 219 ;;; For non-complex types, we just test that the number belongs to the
 220 ;;; base type, and then test that it is in bounds. When CLASS is
 221 ;;; INTEGER, we check to see whether the range is no bigger than
 222 ;;; FIXNUM. If so, we check for FIXNUM instead of INTEGER. This allows
 223 ;;; us to use fixnum comparison to test the bounds.
 224 ;;;
 225 ;;; For complex types, we must test for complex, then do the above on
 226 ;;; both the real and imaginary parts. When CLASS is float, we need
 227 ;;; only check the type of the realpart, since the format of the
 228 ;;; realpart and the imagpart must be the same.
 229 (defun source-transform-numeric-typep (object type)
 230   (let* ((class (numeric-type-class type))
 231          (base (ecase class
 232                  (integer (containing-integer-type type))
 233                  (rational 'rational)
 234                  (float (or (numeric-type-format type) 'float))
 235                  ((nil) 'real))))
 236     (once-only ((n-object object))
 237       (ecase (numeric-type-complexp type)
 238         (:real
 239          `(and (typep ,n-object ',base)
 240                ,(transform-numeric-bound-test n-object type base)))
 241         (:complex
 242          `(and (complexp ,n-object)
 243                ,(once-only ((n-real `(realpart (the complex ,n-object)))
 244                             (n-imag `(imagpart (the complex ,n-object))))
 245                   `(progn
 246                      ,n-imag ; ignorable
 247                      (and (typep ,n-real ',base)
 248                           ,@(when (eq class 'integer)
 249                               `((typep ,n-imag ',base)))
 250                           ,(transform-numeric-bound-test n-real type base)
 251                           ,(transform-numeric-bound-test n-imag type
 252                                                          base))))))))))
 253
 254 ;;; Do the source transformation for a test of a hairy type. AND,
 255 ;;; SATISFIES and NOT are converted into the obvious code. We convert
 256 ;;; unknown types to %TYPEP, emitting an efficiency note if
 257 ;;; appropriate.
 258 (defun source-transform-hairy-typep (object type)
 259   (declare (type hairy-type type))
 260   (let ((spec (hairy-type-specifier type)))
 261     (cond ((unknown-type-p type)
 262            (when (policy nil (> speed brevity))
 263              (compiler-note "can't open-code test of unknown type ~S"
 264                             (type-specifier type)))
 265            `(%typep ,object ',spec))
 266           (t
 267            (ecase (first spec)
 268              (satisfies `(if (funcall #',(second spec) ,object) t nil))
 269              ((not and)
 270               (once-only ((n-obj object))
 271                 `(,(first spec) ,@(mapcar #'(lambda (x)
 272                                               `(typep ,n-obj ',x))
 273                                           (rest spec))))))))))
 274
 275 ;;; Do source transformation for Typep of a known union type. If a
 276 ;;; union type contains LIST, then we pull that out and make it into a
 277 ;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
 278 ;;; will be a subtype even without there being any (member NIL). We
 279 ;;; just drop through to the general code in this case, rather than
 280 ;;; trying to optimize it.
 281 (defun source-transform-union-typep (object type)
 282   (let* ((types (union-type-types type))
 283          (ltype (specifier-type 'list))
 284          (mtype (find-if #'member-type-p types)))
 285     (cond ((and mtype (csubtypep ltype type))
 286            (let ((members (member-type-members mtype)))
 287              (once-only ((n-obj object))
 288                `(if (listp ,n-obj)
 289                     t
 290                     (typep ,n-obj
 291                            '(or ,@(mapcar #'type-specifier
 292                                           (remove (specifier-type 'cons)
 293                                                   (remove mtype types)))
 294                                 (member ,@(remove nil members))))))))
 295           (t
 296            (once-only ((n-obj object))
 297              `(or ,@(mapcar #'(lambda (x)
 298                                 `(typep ,n-obj ',(type-specifier x)))
 299                             types)))))))
 300
 301 ;;; MNA: cons compound-type patch
 302 ;;; FIXIT: all commented out
 303 ; ;;; Source-Transform-Cons-Typep
 304 ; ;;;
 305 ; ;;; If necessary recurse to check the cons type.
 306 ; ;;;
 307 ; (defun source-transform-cons-typep (object type)
 308 ;   (let* ((car-type (cons-type-car-type type))
 309 ;        (cdr-type (cons-type-cdr-type type)))
 310 ;     (let ((car-test-p (not (or (type= car-type *wild-type*)
 311 ;                              (type= car-type (specifier-type t)))))
 312 ;         (cdr-test-p (not (or (type= cdr-type *wild-type*)
 313 ;                              (type= cdr-type (specifier-type t))))))
 314 ;       (if (and (not car-test-p) (not cdr-test-p))
 315 ;         `(consp ,object)
 316 ;         (once-only ((n-obj object))
 317 ;                    `(and (consp ,n-obj)
 318 ;                      ,@(if car-test-p
 319 ;                            `((typep (car ,n-obj)
 320 ;                               ',(type-specifier car-type))))
 321 ;                      ,@(if cdr-test-p
 322 ;                            `((typep (cdr ,n-obj)
 323 ;                               ',(type-specifier cdr-type))))))))))
 324
 325 ;;; Return the predicate and type from the most specific entry in
 326 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 327 (defun find-supertype-predicate (type)
 328   (declare (type ctype type))
 329   (let ((res nil)
 330         (res-type nil))
 331     (dolist (x *backend-type-predicates*)
 332       (let ((stype (car x)))
 333         (when (and (csubtypep type stype)
 334                    (or (not res-type)
 335                        (csubtypep stype res-type)))
 336           (setq res-type stype)
 337           (setq res (cdr x)))))
 338     (values res res-type)))
 339
 340 ;;; Return forms to test that OBJ has the rank and dimensions
 341 ;;; specified by TYPE, where STYPE is the type we have checked against
 342 ;;; (which is the same but for dimensions.)
 343 (defun test-array-dimensions (obj type stype)
 344   (declare (type array-type type stype))
 345   (let ((obj `(truly-the ,(type-specifier stype) ,obj))
 346         (dims (array-type-dimensions type)))
 347     (unless (eq dims '*)
 348       (collect ((res))
 349         (when (eq (array-type-dimensions stype) '*)
 350           (res `(= (array-rank ,obj) ,(length dims))))
 351         (do ((i 0 (1+ i))
 352              (dim dims (cdr dim)))
 353             ((null dim))
 354           (let ((dim (car dim)))
 355             (unless (eq dim '*)
 356               (res `(= (array-dimension ,obj ,i) ,dim)))))
 357         (res)))))
 358
 359 ;;; If we can find a type predicate that tests for the type w/o
 360 ;;; dimensions, then use that predicate and test for dimensions.
 361 ;;; Otherwise, just do %TYPEP.
 362 (defun source-transform-array-typep (obj type)
 363   (multiple-value-bind (pred stype) (find-supertype-predicate type)
 364     (if (and (array-type-p stype)
 365              ;; (If the element type hasn't been defined yet, it's
 366              ;; not safe to assume here that it will eventually
 367              ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
 368              (not (unknown-type-p (array-type-element-type type)))
 369              (type= (array-type-specialized-element-type stype)
 370                     (array-type-specialized-element-type type))
 371              (eq (array-type-complexp stype) (array-type-complexp type)))
 372         (once-only ((n-obj obj))
 373           `(and (,pred ,n-obj)
 374                 ,@(test-array-dimensions n-obj type stype)))
 375         `(%typep ,obj ',(type-specifier type)))))
 376
 377 ;;; Transform a type test against some instance type. The type test is
 378 ;;; flushed if the result is known at compile time. If not properly
 379 ;;; named, error. If sealed and has no subclasses, just test for
 380 ;;; layout-EQ. If a structure then test for layout-EQ and then a
 381 ;;; general test based on layout-inherits. If safety is important,
 382 ;;; then we also check whether the layout for the object is invalid
 383 ;;; and signal an error if so. Otherwise, look up the indirect
 384 ;;; class-cell and call CLASS-CELL-TYPEP at runtime.
 385 ;;;
 386 ;;; KLUDGE: The :WHEN :BOTH option here is probably a suboptimal
 387 ;;; solution to the problem of %INSTANCE-TYPEP forms in byte compiled
 388 ;;; code; it'd probably be better just to have %INSTANCE-TYPEP forms
 389 ;;; never be generated in byte compiled code, or maybe to have a DEFUN
 390 ;;; %INSTANCE-TYPEP somewhere to handle them if they are. But it's not
 391 ;;; terribly important because mostly, %INSTANCE-TYPEP forms *aren't*
 392 ;;; generated in byte compiled code. (As of sbcl-0.6.5, they could
 393 ;;; sometimes be generated when byte compiling inline functions, but
 394 ;;; it's quite uncommon.) -- WHN 20000523
 395 (deftransform %instance-typep ((object spec) * * :when :both)
 396   (assert (constant-continuation-p spec))
 397   (let* ((spec (continuation-value spec))
 398          (class (specifier-type spec))
 399          (name (sb!xc:class-name class))
 400          (otype (continuation-type object))
 401          (layout (let ((res (info :type :compiler-layout name)))
 402                    (if (and res (not (layout-invalid res)))
 403                        res
 404                        nil))))
 405     (/noshow "entering DEFTRANSFORM %INSTANCE-TYPEP" otype spec class name layout)
 406     (cond
 407       ;; Flush tests whose result is known at compile time.
 408       ((not (types-intersect otype class))
 409        (/noshow "flushing constant NIL")
 410        nil)
 411       ((csubtypep otype class)
 412        (/noshow "flushing constant T")
 413        t)
 414       ;; If not properly named, error.
 415       ((not (and name (eq (sb!xc:find-class name) class)))
 416        (compiler-error "can't compile TYPEP of anonymous or undefined ~
 417                         class:~%  ~S"
 418                        class))
 419       (t
 420        ;; Otherwise transform the type test.
 421        (multiple-value-bind (pred get-layout)
 422            (cond
 423              ((csubtypep class (specifier-type 'funcallable-instance))
 424               (values 'funcallable-instance-p '%funcallable-instance-layout))
 425              ((csubtypep class (specifier-type 'instance))
 426               (values '%instancep '%instance-layout))
 427              (t
 428               (values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
 429          (/noshow pred get-layout)
 430          (cond
 431            ((and (eq (class-state class) :sealed) layout
 432                  (not (class-subclasses class)))
 433             ;; Sealed and has no subclasses.
 434             (/noshow "sealed and has no subclasses")
 435             (let ((n-layout (gensym)))
 436               `(and (,pred object)
 437                     (let ((,n-layout (,get-layout object)))
 438                       ,@(when (policy nil (>= safety speed))
 439                               `((when (layout-invalid ,n-layout)
 440                                   (%layout-invalid-error object ',layout))))
 441                       (eq ,n-layout ',layout)))))
 442            ((and (typep class 'basic-structure-class) layout)
 443             (/noshow "structure type tests; hierarchical layout depths")
 444             ;; structure type tests; hierarchical layout depths
 445             (let ((depthoid (layout-depthoid layout))
 446                   (n-layout (gensym)))
 447               `(and (,pred object)
 448                     (let ((,n-layout (,get-layout object)))
 449                       ,@(when (policy nil (>= safety speed))
 450                               `((when (layout-invalid ,n-layout)
 451                                   (%layout-invalid-error object ',layout))))
 452                       (if (eq ,n-layout ',layout)
 453                           t
 454                           (and (> (layout-depthoid ,n-layout)
 455                                   ,depthoid)
 456                                (locally (declare (optimize (safety 0)))
 457                                  (eq (svref (layout-inherits ,n-layout)
 458                                             ,depthoid)
 459                                      ',layout))))))))
 460            (t
 461             (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
 462             `(and (,pred object)
 463                   (class-cell-typep (,get-layout object)
 464                                     ',(find-class-cell name)
 465                                     object)))))))))
 466
 467 #|
 468 ;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
 469 ;;; which corresponds to the value returned by
 470 ;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
 471 ;;; result might change when we encounter a DEFTYPE.
 472 (declaim (maybe-inline upgraded-array-element-ctype-2))
 473 (defun upgraded-array-element-ctype-2 (spec)
 474   (let ((ctype (specifier-type `(array ,spec))))
 475     (values (array-type-specialized-element-type
 476              (specifier-type `(array ,spec)))
 477             (not (unknown-type-p (array-type-element-type ctype))))))
 478 |#
 479
 480 ;;; If the specifier argument is a quoted constant, then we consider
 481 ;;; converting into a simple predicate or other stuff. If the type is
 482 ;;; constant, but we can't transform the call, then we convert to
 483 ;;; %TYPEP. We only pass when the type is non-constant. This allows us
 484 ;;; to recognize between calls that might later be transformed
 485 ;;; successfully when a constant type is discovered. We don't give an
 486 ;;; efficiency note when we pass, since the IR1 transform will give
 487 ;;; one if necessary and appropriate.
 488 ;;;
 489 ;;; If the type is TYPE= to a type that has a predicate, then expand
 490 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
 491 ;;; These transformations can increase space, but it is hard to tell
 492 ;;; when, so we ignore policy and always do them. When byte-compiling,
 493 ;;; we only do transforms that have potential for control
 494 ;;; simplification. Instance type tests are converted to
 495 ;;; %INSTANCE-TYPEP to allow type propagation.
 496 (def-source-transform typep (object spec)
 497   (if (and (consp spec) (eq (car spec) 'quote))
 498       (let ((type (specifier-type (cadr spec))))
 499         (or (let ((pred (cdr (assoc type *backend-type-predicates*
 500                                     :test #'type=))))
 501               (when pred `(,pred ,object)))
 502             (typecase type
 503               (hairy-type
 504                (source-transform-hairy-typep object type))
 505               (union-type
 506                (source-transform-union-typep object type))
 507               (member-type
 508                `(member ,object ',(member-type-members type)))
 509               (args-type
 510                (compiler-warning "illegal type specifier for TYPEP: ~S"
 511                                  (cadr spec))
 512                `(%typep ,object ,spec))
 513               (t nil))
 514             (and (not (byte-compiling))
 515                  (typecase type
 516                    (numeric-type
 517                     (source-transform-numeric-typep object type))
 518                    (sb!xc:class
 519                     `(%instance-typep ,object ,spec))
 520                    (array-type
 521                     (source-transform-array-typep object type))
 522                    ;; MNA: cons compound-type patch
 523                    ;; FIXIT: all commented
 524 ;                    (cons-type
 525 ;                     (source-transform-cons-typep object type))
 526                    (t nil)))
 527             `(%typep ,object ,spec)))
 528       (values nil t)))
 529 \f
 530 ;;;; coercion
 531
 532 ;;; old working version
 533 (deftransform coerce ((x type) (* *) * :when :both)
 534   (unless (constant-continuation-p type)
 535     (give-up-ir1-transform))
 536   (let ((tspec (specifier-type (continuation-value type))))
 537     (if (csubtypep (continuation-type x) tspec)
 538         'x
 539         `(the ,(continuation-value type)
 540               ,(cond ((csubtypep tspec (specifier-type 'double-float))
 541                       '(%double-float x))
 542                      ;; FIXME: If LONG-FLOAT is to be supported, we
 543                      ;; need to pick it off here before falling through
 544                      ;; to %SINGLE-FLOAT.
 545                      ((csubtypep tspec (specifier-type 'float))
 546                       '(%single-float x))
 547                      (t
 548                       (give-up-ir1-transform)))))))
 549
 550 ;;; KLUDGE: new broken version -- 20000504
 551 #+nil
 552 (deftransform coerce ((x type) (* *) * :when :both)
 553   (unless (constant-continuation-p type)
 554     (give-up-ir1-transform))
 555   (let ((tspec (specifier-type (continuation-value type))))
 556     (if (csubtypep (continuation-type x) tspec)
 557         'x
 558         `(if #+nil (typep x type) #-nil nil
 559              x
 560              (the ,(continuation-value type)
 561                   ,(cond ((csubtypep tspec (specifier-type 'double-float))
 562                           '(%double-float x))
 563                          ;; FIXME: If LONG-FLOAT is to be supported,
 564                          ;; we need to pick it off here before falling
 565                          ;; through to %SINGLE-FLOAT.
 566                          ((csubtypep tspec (specifier-type 'float))
 567                           '(%single-float x))
 568                          #+nil
 569                          ((csubtypep tspec (specifier-type 'list))
 570                           '(coerce-to-list x))
 571                          #+nil
 572                          ((csubtypep tspec (specifier-type 'string))
 573                           '(coerce-to-simple-string x))
 574                          #+nil
 575                          ((csubtypep tspec (specifier-type 'bit-vector))
 576                           '(coerce-to-bit-vector x))
 577                          #+nil
 578                          ((csubtypep tspec (specifier-type 'vector))
 579                           '(coerce-to-vector x type))
 580                          (t
 581                           (give-up-ir1-transform))))))))