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
 152 ;;; binds specified by TYPE. BASE is the name of the base type, for
 153 ;;; declaration. We make SAFETY locally 0 to inhibit any checking of
 154 ;;; this assertion.
 155 #!-negative-zero-is-not-zero
 156 (defun transform-numeric-bound-test (n-object type base)
 157   (declare (type numeric-type type))
 158   (let ((low (numeric-type-low type))
 159         (high (numeric-type-high type)))
 160     `(locally
 161        (declare (optimize (safety 0)))
 162        (and ,@(when low
 163                 (if (consp low)
 164                     `((> (the ,base ,n-object) ,(car low)))
 165                     `((>= (the ,base ,n-object) ,low))))
 166             ,@(when high
 167                 (if (consp high)
 168                     `((< (the ,base ,n-object) ,(car high)))
 169                     `((<= (the ,base ,n-object) ,high))))))))
 170
 171 #!+negative-zero-is-not-zero
 172 (defun transform-numeric-bound-test (n-object type base)
 173   (declare (type numeric-type type))
 174   (let ((low (numeric-type-low type))
 175         (high (numeric-type-high type))
 176         (float-type-p (csubtypep type (specifier-type 'float)))
 177         (x (gensym))
 178         (y (gensym)))
 179     `(locally
 180        (declare (optimize (safety 0)))
 181        (and ,@(when low
 182                 (if (consp low)
 183                     `((let ((,x (the ,base ,n-object))
 184                             (,y ,(car low)))
 185                         ,(if (not float-type-p)
 186                             `(> ,x ,y)
 187                             `(if (and (zerop ,x) (zerop ,y))
 188                                  (> (float-sign ,x) (float-sign ,y))
 189                                  (> ,x ,y)))))
 190                     `((let ((,x (the ,base ,n-object))
 191                             (,y ,low))
 192                         ,(if (not float-type-p)
 193                             `(>= ,x ,y)
 194                             `(if (and (zerop ,x) (zerop ,y))
 195                                  (>= (float-sign ,x) (float-sign ,y))
 196                                  (>= ,x ,y)))))))
 197             ,@(when high
 198                 (if (consp high)
 199                     `((let ((,x (the ,base ,n-object))
 200                             (,y ,(car high)))
 201                         ,(if (not float-type-p)
 202                              `(< ,x ,y)
 203                              `(if (and (zerop ,x) (zerop ,y))
 204                                   (< (float-sign ,x) (float-sign ,y))
 205                                   (< ,x ,y)))))
 206                     `((let ((,x (the ,base ,n-object))
 207                             (,y ,high))
 208                         ,(if (not float-type-p)
 209                              `(<= ,x ,y)
 210                              `(if (and (zerop ,x) (zerop ,y))
 211                                   (<= (float-sign ,x) (float-sign ,y))
 212                                   (<= ,x ,y)))))))))))
 213
 214 ;;; Do source transformation of a test of a known numeric type. We can
 215 ;;; assume that the type doesn't have a corresponding predicate, since
 216 ;;; those types have already been picked off. In particular, CLASS
 217 ;;; must be specified, since it is unspecified only in NUMBER and
 218 ;;; COMPLEX. Similarly, we assume that COMPLEXP is always specified.
 219 ;;;
 220 ;;; For non-complex types, we just test that the number belongs to the
 221 ;;; base type, and then test that it is in bounds. When CLASS is
 222 ;;; INTEGER, we check to see whether the range is no bigger than
 223 ;;; FIXNUM. If so, we check for FIXNUM instead of INTEGER. This allows
 224 ;;; us to use fixnum comparison to test the bounds.
 225 ;;;
 226 ;;; For complex types, we must test for complex, then do the above on
 227 ;;; both the real and imaginary parts. When CLASS is float, we need
 228 ;;; only check the type of the realpart, since the format of the
 229 ;;; realpart and the imagpart must be the same.
 230 (defun source-transform-numeric-typep (object type)
 231   (let* ((class (numeric-type-class type))
 232          (base (ecase class
 233                  (integer (containing-integer-type type))
 234                  (rational 'rational)
 235                  (float (or (numeric-type-format type) 'float))
 236                  ((nil) 'real))))
 237     (once-only ((n-object object))
 238       (ecase (numeric-type-complexp type)
 239         (:real
 240          `(and (typep ,n-object ',base)
 241                ,(transform-numeric-bound-test n-object type base)))
 242         (:complex
 243          `(and (complexp ,n-object)
 244                ,(once-only ((n-real `(realpart (the complex ,n-object)))
 245                             (n-imag `(imagpart (the complex ,n-object))))
 246                   `(progn
 247                      ,n-imag ; ignorable
 248                      (and (typep ,n-real ',base)
 249                           ,@(when (eq class 'integer)
 250                               `((typep ,n-imag ',base)))
 251                           ,(transform-numeric-bound-test n-real type base)
 252                           ,(transform-numeric-bound-test n-imag type
 253                                                          base))))))))))
 254
 255 ;;; Do the source transformation for a test of a hairy type. AND,
 256 ;;; SATISFIES and NOT are converted into the obvious code. We convert
 257 ;;; unknown types to %TYPEP, emitting an efficiency note if
 258 ;;; appropriate.
 259 (defun source-transform-hairy-typep (object type)
 260   (declare (type hairy-type type))
 261   (let ((spec (hairy-type-specifier type)))
 262     (cond ((unknown-type-p type)
 263            (when (policy nil (> speed inhibit-warnings))
 264              (compiler-note "can't open-code test of unknown type ~S"
 265                             (type-specifier type)))
 266            `(%typep ,object ',spec))
 267           (t
 268            (ecase (first spec)
 269              (satisfies `(if (funcall #',(second spec) ,object) t nil))
 270              ((not and)
 271               (once-only ((n-obj object))
 272                 `(,(first spec) ,@(mapcar #'(lambda (x)
 273                                               `(typep ,n-obj ',x))
 274                                           (rest spec))))))))))
 275
 276 ;;; Do source transformation for TYPEP of a known union type. If a
 277 ;;; union type contains LIST, then we pull that out and make it into a
 278 ;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
 279 ;;; will be a subtype even without there being any (member NIL). We
 280 ;;; just drop through to the general code in this case, rather than
 281 ;;; trying to optimize it.
 282 (defun source-transform-union-typep (object type)
 283   (let* ((types (union-type-types type))
 284          (ltype (specifier-type 'list))
 285          (mtype (find-if #'member-type-p types)))
 286     (cond ((and mtype (csubtypep ltype type))
 287            (let ((members (member-type-members mtype)))
 288              (once-only ((n-obj object))
 289                `(if (listp ,n-obj)
 290                     t
 291                     (typep ,n-obj
 292                            '(or ,@(mapcar #'type-specifier
 293                                           (remove (specifier-type 'cons)
 294                                                   (remove mtype types)))
 295                                 (member ,@(remove nil members))))))))
 296           (t
 297            (once-only ((n-obj object))
 298              `(or ,@(mapcar #'(lambda (x)
 299                                 `(typep ,n-obj ',(type-specifier x)))
 300                             types)))))))
 301
 302 ;;; If necessary recurse to check the cons type.
 303 (defun source-transform-cons-typep (object type)
 304   (let* ((car-type (cons-type-car-type type))
 305          (cdr-type (cons-type-cdr-type type)))
 306     (let ((car-test-p (not (or (type= car-type *wild-type*)
 307                                (type= car-type (specifier-type t)))))
 308           (cdr-test-p (not (or (type= cdr-type *wild-type*)
 309                                (type= cdr-type (specifier-type t))))))
 310       (if (and (not car-test-p) (not cdr-test-p))
 311           `(consp ,object)
 312           (once-only ((n-obj object))
 313             `(and (consp ,n-obj)
 314                   ,@(if car-test-p
 315                         `((typep (car ,n-obj)
 316                                  ',(type-specifier car-type))))
 317                   ,@(if cdr-test-p
 318                         `((typep (cdr ,n-obj)
 319                                  ',(type-specifier cdr-type))))))))))
 320
 321 ;;; Return the predicate and type from the most specific entry in
 322 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 323 (defun find-supertype-predicate (type)
 324   (declare (type ctype type))
 325   (let ((res nil)
 326         (res-type nil))
 327     (dolist (x *backend-type-predicates*)
 328       (let ((stype (car x)))
 329         (when (and (csubtypep type stype)
 330                    (or (not res-type)
 331                        (csubtypep stype res-type)))
 332           (setq res-type stype)
 333           (setq res (cdr x)))))
 334     (values res res-type)))
 335
 336 ;;; Return forms to test that OBJ has the rank and dimensions
 337 ;;; specified by TYPE, where STYPE is the type we have checked against
 338 ;;; (which is the same but for dimensions.)
 339 (defun test-array-dimensions (obj type stype)
 340   (declare (type array-type type stype))
 341   (let ((obj `(truly-the ,(type-specifier stype) ,obj))
 342         (dims (array-type-dimensions type)))
 343     (unless (eq dims '*)
 344       (collect ((res))
 345         (when (eq (array-type-dimensions stype) '*)
 346           (res `(= (array-rank ,obj) ,(length dims))))
 347         (do ((i 0 (1+ i))
 348              (dim dims (cdr dim)))
 349             ((null dim))
 350           (let ((dim (car dim)))
 351             (unless (eq dim '*)
 352               (res `(= (array-dimension ,obj ,i) ,dim)))))
 353         (res)))))
 354
 355 ;;; If we can find a type predicate that tests for the type w/o
 356 ;;; dimensions, then use that predicate and test for dimensions.
 357 ;;; Otherwise, just do %TYPEP.
 358 (defun source-transform-array-typep (obj type)
 359   (multiple-value-bind (pred stype) (find-supertype-predicate type)
 360     (if (and (array-type-p stype)
 361              ;; (If the element type hasn't been defined yet, it's
 362              ;; not safe to assume here that it will eventually
 363              ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
 364              (not (unknown-type-p (array-type-element-type type)))
 365              (type= (array-type-specialized-element-type stype)
 366                     (array-type-specialized-element-type type))
 367              (eq (array-type-complexp stype) (array-type-complexp type)))
 368         (once-only ((n-obj obj))
 369           `(and (,pred ,n-obj)
 370                 ,@(test-array-dimensions n-obj type stype)))
 371         `(%typep ,obj ',(type-specifier type)))))
 372
 373 ;;; Transform a type test against some instance type. The type test is
 374 ;;; flushed if the result is known at compile time. If not properly
 375 ;;; named, error. If sealed and has no subclasses, just test for
 376 ;;; layout-EQ. If a structure then test for layout-EQ and then a
 377 ;;; general test based on layout-inherits. If safety is important,
 378 ;;; then we also check whether the layout for the object is invalid
 379 ;;; and signal an error if so. Otherwise, look up the indirect
 380 ;;; class-cell and call CLASS-CELL-TYPEP at runtime.
 381 ;;;
 382 ;;; KLUDGE: The :WHEN :BOTH option here is probably a suboptimal
 383 ;;; solution to the problem of %INSTANCE-TYPEP forms in byte compiled
 384 ;;; code; it'd probably be better just to have %INSTANCE-TYPEP forms
 385 ;;; never be generated in byte compiled code, or maybe to have a DEFUN
 386 ;;; %INSTANCE-TYPEP somewhere to handle them if they are. But it's not
 387 ;;; terribly important because mostly, %INSTANCE-TYPEP forms *aren't*
 388 ;;; generated in byte compiled code. (As of sbcl-0.6.5, they could
 389 ;;; sometimes be generated when byte compiling inline functions, but
 390 ;;; it's quite uncommon.) -- WHN 20000523
 391 (deftransform %instance-typep ((object spec) * * :when :both)
 392   (assert (constant-continuation-p spec))
 393   (let* ((spec (continuation-value spec))
 394          (class (specifier-type spec))
 395          (name (sb!xc:class-name class))
 396          (otype (continuation-type object))
 397          (layout (let ((res (info :type :compiler-layout name)))
 398                    (if (and res (not (layout-invalid res)))
 399                        res
 400                        nil))))
 401     (/noshow "entering DEFTRANSFORM %INSTANCE-TYPEP" otype spec class name layout)
 402     (cond
 403       ;; Flush tests whose result is known at compile time.
 404       ((not (types-intersect otype class))
 405        (/noshow "flushing constant NIL")
 406        nil)
 407       ((csubtypep otype class)
 408        (/noshow "flushing constant T")
 409        t)
 410       ;; If not properly named, error.
 411       ((not (and name (eq (sb!xc:find-class name) class)))
 412        (compiler-error "can't compile TYPEP of anonymous or undefined ~
 413                         class:~%  ~S"
 414                        class))
 415       (t
 416        ;; Otherwise transform the type test.
 417        (multiple-value-bind (pred get-layout)
 418            (cond
 419              ((csubtypep class (specifier-type 'funcallable-instance))
 420               (values 'funcallable-instance-p '%funcallable-instance-layout))
 421              ((csubtypep class (specifier-type 'instance))
 422               (values '%instancep '%instance-layout))
 423              (t
 424               (values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
 425          (/noshow pred get-layout)
 426          (cond
 427            ((and (eq (class-state class) :sealed) layout
 428                  (not (class-subclasses class)))
 429             ;; Sealed and has no subclasses.
 430             (/noshow "sealed and has no subclasses")
 431             (let ((n-layout (gensym)))
 432               `(and (,pred object)
 433                     (let ((,n-layout (,get-layout object)))
 434                       ,@(when (policy nil (>= safety speed))
 435                               `((when (layout-invalid ,n-layout)
 436                                   (%layout-invalid-error object ',layout))))
 437                       (eq ,n-layout ',layout)))))
 438            ((and (typep class 'basic-structure-class) layout)
 439             (/noshow "structure type tests; hierarchical layout depths")
 440             ;; structure type tests; hierarchical layout depths
 441             (let ((depthoid (layout-depthoid layout))
 442                   (n-layout (gensym)))
 443               `(and (,pred object)
 444                     (let ((,n-layout (,get-layout object)))
 445                       ,@(when (policy nil (>= safety speed))
 446                               `((when (layout-invalid ,n-layout)
 447                                   (%layout-invalid-error object ',layout))))
 448                       (if (eq ,n-layout ',layout)
 449                           t
 450                           (and (> (layout-depthoid ,n-layout)
 451                                   ,depthoid)
 452                                (locally (declare (optimize (safety 0)))
 453                                  (eq (svref (layout-inherits ,n-layout)
 454                                             ,depthoid)
 455                                      ',layout))))))))
 456            (t
 457             (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
 458             `(and (,pred object)
 459                   (class-cell-typep (,get-layout object)
 460                                     ',(find-class-cell name)
 461                                     object)))))))))
 462
 463 #|
 464 ;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
 465 ;;; which corresponds to the value returned by
 466 ;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
 467 ;;; result might change when we encounter a DEFTYPE.
 468 (declaim (maybe-inline upgraded-array-element-ctype-2))
 469 (defun upgraded-array-element-ctype-2 (spec)
 470   (let ((ctype (specifier-type `(array ,spec))))
 471     (values (array-type-specialized-element-type
 472              (specifier-type `(array ,spec)))
 473             (not (unknown-type-p (array-type-element-type ctype))))))
 474 |#
 475
 476 ;;; If the specifier argument is a quoted constant, then we consider
 477 ;;; converting into a simple predicate or other stuff. If the type is
 478 ;;; constant, but we can't transform the call, then we convert to
 479 ;;; %TYPEP. We only pass when the type is non-constant. This allows us
 480 ;;; to recognize between calls that might later be transformed
 481 ;;; successfully when a constant type is discovered. We don't give an
 482 ;;; efficiency note when we pass, since the IR1 transform will give
 483 ;;; one if necessary and appropriate.
 484 ;;;
 485 ;;; If the type is TYPE= to a type that has a predicate, then expand
 486 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
 487 ;;; These transformations can increase space, but it is hard to tell
 488 ;;; when, so we ignore policy and always do them. When byte-compiling,
 489 ;;; we only do transforms that have potential for control
 490 ;;; simplification. Instance type tests are converted to
 491 ;;; %INSTANCE-TYPEP to allow type propagation.
 492 (def-source-transform typep (object spec)
 493   (if (and (consp spec) (eq (car spec) 'quote))
 494       (let ((type (specifier-type (cadr spec))))
 495         (or (let ((pred (cdr (assoc type *backend-type-predicates*
 496                                     :test #'type=))))
 497               (when pred `(,pred ,object)))
 498             (typecase type
 499               (hairy-type
 500                (source-transform-hairy-typep object type))
 501               (union-type
 502                (source-transform-union-typep object type))
 503               (member-type
 504                `(member ,object ',(member-type-members type)))
 505               (args-type
 506                (compiler-warning "illegal type specifier for TYPEP: ~S"
 507                                  (cadr spec))
 508                `(%typep ,object ,spec))
 509               (t nil))
 510             (and (not (byte-compiling))
 511                  (typecase type
 512                    (numeric-type
 513                     (source-transform-numeric-typep object type))
 514                    (sb!xc:class
 515                     `(%instance-typep ,object ,spec))
 516                    (array-type
 517                     (source-transform-array-typep object type))
 518                    (cons-type
 519                     (source-transform-cons-typep object type))
 520                    (t nil)))
 521             `(%typep ,object ,spec)))
 522       (values nil t)))
 523 \f
 524 ;;;; coercion
 525
 526 ;;; old working version
 527 (deftransform coerce ((x type) (* *) * :when :both)
 528   (unless (constant-continuation-p type)
 529     (give-up-ir1-transform))
 530   (let ((tspec (specifier-type (continuation-value type))))
 531     (if (csubtypep (continuation-type x) tspec)
 532         'x
 533         `(the ,(continuation-value type)
 534               ,(cond ((csubtypep tspec (specifier-type 'double-float))
 535                       '(%double-float x))
 536                      ;; FIXME: If LONG-FLOAT is to be supported, we
 537                      ;; need to pick it off here before falling through
 538                      ;; to %SINGLE-FLOAT.
 539                      ((csubtypep tspec (specifier-type 'float))
 540                       '(%single-float x))
 541                      (t
 542                       (give-up-ir1-transform)))))))
 543
 544 ;;; KLUDGE: new broken version -- 20000504
 545 ;;; FIXME: should be fixed or deleted
 546 #+nil
 547 (deftransform coerce ((x type) (* *) * :when :both)
 548   (unless (constant-continuation-p type)
 549     (give-up-ir1-transform))
 550   (let ((tspec (specifier-type (continuation-value type))))
 551     (if (csubtypep (continuation-type x) tspec)
 552         'x
 553         `(if #+nil (typep x type) #-nil nil
 554              x
 555              (the ,(continuation-value type)
 556                   ,(cond ((csubtypep tspec (specifier-type 'double-float))
 557                           '(%double-float x))
 558                          ;; FIXME: If LONG-FLOAT is to be supported,
 559                          ;; we need to pick it off here before falling
 560                          ;; through to %SINGLE-FLOAT.
 561                          ((csubtypep tspec (specifier-type 'float))
 562                           '(%single-float x))
 563                          #+nil
 564                          ((csubtypep tspec (specifier-type 'list))
 565                           '(coerce-to-list x))
 566                          #+nil
 567                          ((csubtypep tspec (specifier-type 'string))
 568                           '(coerce-to-simple-string x))
 569                          #+nil
 570                          ((csubtypep tspec (specifier-type 'bit-vector))
 571                           '(coerce-to-bit-vector x))
 572                          #+nil
 573                          ((csubtypep tspec (specifier-type 'vector))
 574                           '(coerce-to-vector x type))
 575                          (t
 576                           (give-up-ir1-transform))))))))