1.0.27.31: repeatable fasl header and debug-source

[sbcl.git] / src / code / coerce.lisp

diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index 37721ff..a4a93f0 100644 (file)
--- 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) ()))
 
 (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))
                 (do* ((index 0 (1+ index))

-                      (length (length (the ,(ecase src-type
-                                              (:list 'list)
-                                              (:vector 'vector))
-                                           object)))
+                      (length (length object))

                       (result ,result)
                       (in-object object))
                       (result ,result)
                       (in-object object))

-                     ((= index length) result)
+                     ((>= index length) result)

                   (declare (fixnum length index))
                   (declare (fixnum length index))

+                  (declare (type vector result))

                   (setf (,access result index)
                         ,(ecase src-type
                            (:list '(pop in-object))
                   (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)
 
   (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)
 
 (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)))
   (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))))))
 
       (declare (fixnum index))
       (rplacd splice (list (aref object index))))))
 

@@ -69,10 +76,13 @@
      (case (first object)
        ((setf)
         (fdefinition object))
      (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)))
         ;; FIXME: If we go to a compiler-only implementation, this can
         ;; become COMPILE instead of EVAL, which seems nicer to me.
         (eval `(function ,object)))

+       ((instance-lambda)
+        (deprecation-warning 'instance-lambda 'lambda)
+        (eval `(function ,object)))

        (t
         (error 'simple-type-error
                :datum object
        (t
         (error 'simple-type-error
                :datum object

@@ -117,34 +127,6 @@
          (coerce-error))
         ((csubtypep type (specifier-type 'character))
          (character object))
          (coerce-error))
         ((csubtypep 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))
         ((numberp object)
          (cond
            ((csubtypep type (specifier-type 'single-float))

@@ -227,15 +209,72 @@
                           (sequence-type-length-mismatch-error type length)))
                     (vector-to-list* object))))
                (t (sequence-type-too-hairy (type-specifier type))))
                           (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))
         ((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))))
            (t
             (coerce-error))))

+        ((and (csubtypep type (specifier-type 'sequence))
+              (find-class output-type-spec nil))
+         (let ((class (find-class output-type-spec)))
+           (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))))))
 
         (t
          (coerce-error))))))