X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcoerce.lisp;h=8f1507e5658dfea3739365f3119b8f56f0d91d3f;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=37721fff4b890f8228945181103d61c803e685e5;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 37721ff..8f1507e 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -13,33 +13,40 @@ (macrolet ((def (name result access src-type &optional typep) `(defun ,name (object ,@(if typep '(type) ())) + (declare (type ,(ecase src-type + (:list 'list) + (:vector 'vector) + (:sequence 'sequence)) object)) (do* ((index 0 (1+ index)) - (length (length (the ,(ecase src-type - (:list 'list) - (:vector 'vector)) - object))) + (length (length object)) (result ,result) (in-object object)) - ((= index length) result) + ((>= index length) result) (declare (fixnum length index)) + (declare (type vector result)) (setf (,access result index) ,(ecase src-type (:list '(pop in-object)) - (:vector '(aref in-object index)))))))) + (:vector '(aref in-object index)) + (:sequence '(elt in-object index)))))))) (def list-to-vector* (make-sequence type length) aref :list t) (def vector-to-vector* (make-sequence type length) - aref :vector t)) + aref :vector t) + + (def sequence-to-vector* (make-sequence type length) + aref :sequence t)) (defun vector-to-list* (object) + (declare (type vector object)) (let ((result (list nil)) (length (length object))) (declare (fixnum length)) (do ((index 0 (1+ index)) (splice result (cdr splice))) - ((= index length) (cdr result)) + ((>= index length) (cdr result)) (declare (fixnum index)) (rplacd splice (list (aref object index)))))) @@ -69,7 +76,7 @@ (case (first object) ((setf) (fdefinition object)) - ((lambda instance-lambda) + ((lambda) ;; FIXME: If we go to a compiler-only implementation, this can ;; become COMPILE instead of EVAL, which seems nicer to me. (eval `(function ,object))) @@ -115,36 +122,8 @@ object) ((eq type *empty-type*) (coerce-error)) - ((csubtypep type (specifier-type 'character)) + ((type= type (specifier-type 'character)) (character object)) - ((csubtypep type (specifier-type 'function)) - (when (and (legal-fun-name-p object) - (not (fboundp object))) - (error 'simple-type-error - :datum object - ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken - ;; type specifier, since the set of values it describes - ;; isn't in general constant in time. Maybe we could - ;; find a better way of expressing this error? (Maybe - ;; with the UNDEFINED-FUNCTION condition?) - :expected-type '(satisfies fboundp) - :format-control "~S isn't fbound." - :format-arguments (list object))) - (when (and (symbolp object) - (sb!xc:macro-function object)) - (error 'simple-type-error - :datum object - :expected-type '(not (satisfies sb!xc:macro-function)) - :format-control "~S is a macro." - :format-arguments (list object))) - (when (and (symbolp object) - (special-operator-p object)) - (error 'simple-type-error - :datum object - :expected-type '(not (satisfies special-operator-p)) - :format-control "~S is a special operator." - :format-arguments (list object))) - (eval `#',object)) ((numberp object) (cond ((csubtypep type (specifier-type 'single-float)) @@ -227,15 +206,74 @@ (sequence-type-length-mismatch-error type length))) (vector-to-list* object)))) (t (sequence-type-too-hairy (type-specifier type)))) - (coerce-error))) + (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)))) + (coerce-error)))) ((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 (coerce-error)))) + ((and (csubtypep type (specifier-type 'sequence)) + (find-class output-type-spec nil)) + (let ((class (find-class output-type-spec))) + (unless (sb!mop:class-finalized-p class) + (sb!mop:finalize-inheritance class)) + (sb!sequence:make-sequence-like + (sb!mop:class-prototype class) + (length object) :initial-contents object))) + ((csubtypep type (specifier-type 'function)) + (when (and (legal-fun-name-p object) + (not (fboundp object))) + (error 'simple-type-error + :datum object + ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken + ;; type specifier, since the set of values it describes + ;; isn't in general constant in time. Maybe we could + ;; find a better way of expressing this error? (Maybe + ;; with the UNDEFINED-FUNCTION condition?) + :expected-type '(satisfies fboundp) + :format-control "~S isn't fbound." + :format-arguments (list object))) + (when (and (symbolp object) + (sb!xc:macro-function object)) + (error 'simple-type-error + :datum object + :expected-type '(not (satisfies sb!xc:macro-function)) + :format-control "~S is a macro." + :format-arguments (list object))) + (when (and (symbolp object) + (special-operator-p object)) + (error 'simple-type-error + :datum object + :expected-type '(not (satisfies special-operator-p)) + :format-control "~S is a special operator." + :format-arguments (list object))) + (eval `#',object)) (t (coerce-error))))))