10.\7f\7fCVS: ----------------------------------------------------------------------

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

diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index e720699..ca56de2 100644 (file)
--- a/src/code/sharpm.lisp
+++ b/src/code/sharpm.lisp
@@ -225,20 +225,18 @@
 ;; substitutes in arrays and structures as well as lists. The first arg is an
 ;; alist of the things to be replaced assoc'd with the things to replace them.
 (defun circle-subst (old-new-alist tree)
-  (cond ((not (typep tree
-                     '(or cons (array t) structure-object standard-object)))
+  (cond ((not (typep tree '(or cons (array t) instance funcallable-instance)))
          (let ((entry (find tree old-new-alist :key #'second)))
            (if entry (third entry) tree)))
         ((null (gethash tree *sharp-equal-circle-table*))
          (setf (gethash tree *sharp-equal-circle-table*) t)
-         (cond ((typep tree '(or structure-object standard-object))
-                (do ((i 1 (1+ i))
-                     (end (%instance-length tree)))
-                    ((= i end))
-                  (let* ((old (%instance-ref tree i))
-                         (new (circle-subst old-new-alist old)))
-                    (unless (eq old new)
-                      (setf (%instance-ref tree i) new)))))
+         (cond ((consp tree)
+                (let ((a (circle-subst old-new-alist (car tree)))
+                      (d (circle-subst old-new-alist (cdr tree))))
+                  (unless (eq a (car tree))
+                    (rplaca tree a))
+                  (unless (eq d (cdr tree))
+                    (rplacd tree d))))
                ((arrayp tree)
                 (with-array-data ((data tree) (start) (end))
                   (declare (fixnum start end))
@@ -248,13 +246,22 @@
                            (new (circle-subst old-new-alist old)))
                       (unless (eq old new)
                         (setf (aref data i) new))))))
-               (t
-                (let ((a (circle-subst old-new-alist (car tree)))
-                      (d (circle-subst old-new-alist (cdr tree))))
-                  (unless (eq a (car tree))
-                    (rplaca tree a))
-                  (unless (eq d (cdr tree))
-                    (rplacd tree d)))))
+               ((typep tree 'instance)
+                (do ((i 1 (1+ i))
+                     (end (%instance-length tree)))
+                    ((= i end))
+                  (let* ((old (%instance-ref tree i))
+                         (new (circle-subst old-new-alist old)))
+                    (unless (eq old new)
+                      (setf (%instance-ref tree i) new)))))
+               ((typep tree 'funcallable-instance)
+                (do ((i 1 (1+ i))
+                     (end (- (1+ (get-closure-length tree)) sb!vm:funcallable-instance-info-offset)))
+                    ((= i end))
+                  (let* ((old (%funcallable-instance-info tree i))
+                         (new (circle-subst old-new-alist old)))
+                    (unless (eq old new)
+                      (setf (%funcallable-instance-info tree i) new))))))
          tree)
         (t tree)))