Plaster

(in-package :sb-c) (defknown coerce (t type-specifier &rest t) t ;; Note: ;; This is not FLUSHABLE because it's defined to signal errors. (movable) ;; :DERIVE-TYPE RESULT-TYPE-SPEC-NTH-ARG 1 ? Nope... (COERCE 1 'COMPLEX) ;; returns REAL/INTEGER, not COMPLEX. ) (in-package :sb-impl) (declaim (inline coerce-error)) (defun coerce-error (object output-type-spec &optional args) (declare (optimize allow-non-returning-tail-call)) (error 'simple-type-error :format-control "~S can't be converted to type ~ ~/sb-impl:print-type-specifier/~ ~@[ with custom coercion arguments ~S~]." :format-arguments (list object output-type-spec args) :datum object :expected-type output-type-spec)) (defgeneric coerce-object (object output-type-spec &rest args) (:method (object output-type-spec &rest args) (coerce-error object output-type-spec args))) (defun coerce (object output-type-spec &rest args) "Coerce the Object to an object of type Output-Type-Spec." (declare (explicit-check)) (let ((type (specifier-type output-type-spec))) (flet ((defer () (apply #'coerce-object object output-type-spec args))) (cond (args (defer)) ((%%typep object type) object) ((eq type *empty-type*) (defer)) ((type= type (specifier-type 'character)) (character object)) ((numberp object) (cond ((csubtypep type (specifier-type 'single-float)) (let ((res (%single-float object))) (unless (typep res output-type-spec) (defer)) res)) ((csubtypep type (specifier-type 'double-float)) (let ((res (%double-float object))) (unless (typep res output-type-spec) (defer)) res)) #+long-float ((csubtypep type (specifier-type 'long-float)) (let ((res (%long-float object))) (unless (typep res output-type-spec) (defer)) res)) ((csubtypep type (specifier-type 'float)) (let ((res (%single-float object))) (unless (typep res output-type-spec) (defer)) res)) (t (let ((res (cond ((csubtypep type (specifier-type '(complex single-float))) (complex (%single-float (realpart object)) (%single-float (imagpart object)))) ((csubtypep type (specifier-type '(complex double-float))) (complex (%double-float (realpart object)) (%double-float (imagpart object)))) #+long-float ((csubtypep type (specifier-type '(complex long-float))) (complex (%long-float (realpart object)) (%long-float (imagpart object)))) ((csubtypep type (specifier-type '(complex float))) (complex (%single-float (realpart object)) (%single-float (imagpart object)))) ((and (typep object 'rational) ; TODO jmoringe unreachable? (csubtypep type (specifier-type '(complex float)))) ;; Perhaps somewhat surprisingly, ANSI specifies ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, ;; not dispatching on ;; *READ-DEFAULT-FLOAT-FORMAT*. By analogy, we ;; do the same for complex numbers. -- CSR, ;; 2002-08-06 (complex (%single-float object))) ((csubtypep type (specifier-type 'complex)) (complex object)) (t (defer))))) ;; If RES has the wrong type, that means that rule of ;; canonical representation for complex rationals was ;; invoked. According to the Hyperspec, (coerce 7/2 ;; 'complex) returns 7/2. Thus, if the object was a ;; rational, there is no error here. (unless (or (typep res output-type-spec) (rationalp object)) (defer)) res)))) ((csubtypep type (specifier-type 'list)) (if (vectorp object) (cond ((type= type (specifier-type 'list)) (vector-to-list* object)) ((type= type (specifier-type 'null)) (if (= (length object) 0) 'nil (sequence-type-length-mismatch-error type (length object)))) ((cons-type-p type) (multiple-value-bind (min exactp) (sb-kernel::cons-type-length-info type) (let ((length (length object))) (if exactp (unless (= length min) (sequence-type-length-mismatch-error type length)) (unless (>= length min) (sequence-type-length-mismatch-error type length))) (vector-to-list* object)))) (t (sequence-type-too-hairy (type-specifier type)))) (if (sequencep object) (cond ((type= type (specifier-type 'list)) (sb-sequence:make-sequence-like nil (length object) :initial-contents object)) ((type= type (specifier-type 'null)) (if (= (length object) 0) 'nil (sequence-type-length-mismatch-error type (length object)))) ((cons-type-p type) (multiple-value-bind (min exactp) (sb-kernel::cons-type-length-info type) (let ((length (length object))) (if exactp (unless (= length min) (sequence-type-length-mismatch-error type length)) (unless (>= length min) (sequence-type-length-mismatch-error type length))) (sb-sequence:make-sequence-like nil length :initial-contents object)))) (t (sequence-type-too-hairy (type-specifier type)))) (defer)))) ((csubtypep type (specifier-type 'vector)) (typecase object ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length ;; errors are caught there. -- CSR, 2002-10-18 (list (list-to-vector* object output-type-spec)) (vector (vector-to-vector* object output-type-spec)) (sequence (sequence-to-vector* object output-type-spec)) (t (defer)))) ((and (csubtypep type (specifier-type 'sequence)) (find-class output-type-spec nil)) (let ((prototype (sb-mop:class-prototype (sb-pcl:ensure-class-finalized (find-class output-type-spec))))) (sb-sequence:make-sequence-like prototype (length object) :initial-contents object))) ((csubtypep type (specifier-type 'function)) (coerce-to-fun object)) (t (defer)))))) ;;;;;;;;;;;;;;;;;;;;;;; CL-USER> (defclass foo () ()) #<STANDARD-CLASS COMMON-LISP-USER::FOO> CL-USER> (defmethod sb-impl::coerce-object (object (type (eql 'foo)) &key) (make-instance 'foo)) #<STANDARD-METHOD SB-IMPL::COERCE-OBJECT (T (EQL FOO)) {1017F904A3}> CL-USER> (coerce 42 'foo) #<FOO {1018403F43}> ;; warning: brain damage CL-USER> (defmethod sb-impl::coerce-object (object (type (eql 'list)) &key) (list object)) #<STANDARD-METHOD SB-IMPL::COERCE-OBJECT (T (EQL LIST)) {10186F24C3}> CL-USER> (coerce 42 'list) (42)