X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcoerce.lisp;h=f1dca41e23bcb23ce367125109aef3bb56d8b0a1;hb=b956ed4f9cef685d1b49be28dcd2aec1e082d994;hp=7b8a2fcc1b725001e9e43865e4dd46129668d758;hpb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;p=sbcl.git diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 7b8a2fc..f1dca41 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -11,7 +11,7 @@ (in-package "SB!IMPL") -(macrolet ((def-frob (name result access src-type &optional typep) +(macrolet ((def (name result access src-type &optional typep) `(defun ,name (object ,@(if typep '(type) ())) (do* ((index 0 (1+ index)) (length (length (the ,(ecase src-type @@ -27,21 +27,11 @@ (:list '(pop in-object)) (:vector '(aref in-object index)))))))) - (def-frob list-to-simple-string* (make-string length) schar :list) - - (def-frob list-to-bit-vector* (make-array length :element-type '(mod 2)) - sbit :list) - - (def-frob list-to-vector* (make-sequence-of-type type length) + (def list-to-vector* (make-sequence type length) aref :list t) - (def-frob vector-to-vector* (make-sequence-of-type type length) - aref :vector t) - - (def-frob vector-to-simple-string* (make-string length) schar :vector) - - (def-frob vector-to-bit-vector* (make-array length :element-type '(mod 2)) - sbit :vector)) + (def vector-to-vector* (make-sequence type length) + aref :vector t)) (defun vector-to-list* (object) (let ((result (list nil)) @@ -53,24 +43,6 @@ (declare (fixnum index)) (rplacd splice (list (aref object index)))))) -(defun string-to-simple-string* (object) - (if (simple-string-p object) - object - (with-array-data ((data object) - (start) - (end (length object))) - (declare (simple-string data)) - (subseq data start end)))) - -(defun bit-vector-to-simple-bit-vector* (object) - (if (simple-bit-vector-p object) - object - (with-array-data ((data object) - (start) - (end (length object))) - (declare (simple-bit-vector data)) - (subseq data start end)))) - (defvar *offending-datum*); FIXME: Remove after debugging COERCE. ;;; These are used both by the full DEFUN function and by various @@ -80,8 +52,8 @@ ;;; argument type is known. It might be better to do this with ;;; DEFTRANSFORMs, though. (declaim (inline coerce-to-list)) -(declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector)) -(defun coerce-to-function (object) +(declaim (inline coerce-to-vector)) +(defun coerce-to-fun (object) ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because ;; it's so big and because optimizing away the outer ETYPECASE ;; doesn't seem to buy us that much anyway.) @@ -116,18 +88,11 @@ cons) :format-control "~S can't be coerced to a function." :format-arguments (list object))))))) + (defun coerce-to-list (object) (etypecase object (vector (vector-to-list* object)))) -(defun coerce-to-simple-string (object) - (etypecase object - (list (list-to-simple-string* object)) - (string (string-to-simple-string* object)) - (vector (vector-to-simple-string* object)))) -(defun coerce-to-bit-vector (object) - (etypecase object - (list (list-to-bit-vector* object)) - (vector (vector-to-bit-vector* object)))) + (defun coerce-to-vector (object output-type-spec) (etypecase object (list (list-to-vector* object output-type-spec)) @@ -141,10 +106,7 @@ (/show0 "entering COERCE-ERROR") (error 'simple-type-error :format-control "~S can't be converted to type ~S." - :format-arguments (list object output-type-spec))) - (check-result (result) - #!+high-security (aver (typep result output-type-spec)) - result)) + :format-arguments (list object output-type-spec)))) (let ((type (specifier-type output-type-spec))) (cond ((%typep object output-type-spec) @@ -154,18 +116,18 @@ ((csubtypep type (specifier-type 'character)) (character object)) ((csubtypep type (specifier-type 'function)) - #!+high-security - (when (and (or (symbolp object) - (and (listp object) - (= (length object) 2) - (eq (car object) 'setf))) + (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))) - #!+high-security (when (and (symbolp object) (sb!xc:macro-function object)) (error 'simple-type-error @@ -173,7 +135,6 @@ :expected-type '(not (satisfies sb!xc:macro-function)) :format-control "~S is a macro." :format-arguments (list object))) - #!+high-security (when (and (symbolp object) (special-operator-p object)) (error 'simple-type-error @@ -183,64 +144,86 @@ :format-arguments (list object))) (eval `#',object)) ((numberp object) - (let ((res - (cond - ((csubtypep type (specifier-type 'single-float)) - (%single-float object)) - ((csubtypep type (specifier-type 'double-float)) - (%double-float object)) - #!+long-float - ((csubtypep type (specifier-type 'long-float)) - (%long-float object)) - ((csubtypep type (specifier-type 'float)) - (%single-float object)) - ((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)) - (complex object)) - (t - (coerce-error))))) - ;; 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)) - (coerce-error)) - res)) + (cond + ((csubtypep type (specifier-type 'single-float)) + (let ((res (%single-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'double-float)) + (let ((res (%double-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + #!+long-float + ((csubtypep type (specifier-type 'long-float)) + (let ((res (%long-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'float)) + (let ((res (%single-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + 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)))) + ((and (typep object 'rational) + (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 + (coerce-error))))) + ;; 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)) + (coerce-error)) + res)))) ((csubtypep type (specifier-type 'list)) (if (vectorp object) - (vector-to-list* 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)))) + ((csubtypep (specifier-type '(cons nil t)) type) + (if (> (length object) 0) + (vector-to-list* object) + (sequence-type-length-mismatch-error type 0))) + (t (sequence-type-too-hairy (type-specifier type)))) (coerce-error))) - ((csubtypep type (specifier-type 'string)) - (check-result - (typecase object - (list (list-to-simple-string* object)) - (string (string-to-simple-string* object)) - (vector (vector-to-simple-string* object)) - (t - (coerce-error))))) - ((csubtypep type (specifier-type 'bit-vector)) - (check-result - (typecase object - (list (list-to-bit-vector* object)) - (vector (vector-to-bit-vector* object)) - (t - (coerce-error))))) ((csubtypep type (specifier-type 'vector)) - (check-result - (typecase object - (list (list-to-vector* object output-type-spec)) - (vector (vector-to-vector* object output-type-spec)) - (t - (coerce-error))))) + (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)) + (t + (coerce-error)))) (t (coerce-error)))))) @@ -266,7 +249,7 @@ ((csubtypep type (specifier-type 'character)) (character object)) ((csubtypep type (specifier-type 'function)) - (coerce-to-function object)) + (coerce-to-fun object)) ((numberp object) (let ((res (cond