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