X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsharpm.lisp;h=ca56de25bd5c35a3e0608b8d9828d21142a89bdd;hb=fd324a9d981355d8bc10d2bd469cb54c4c9108fd;hp=0d4508ca22cbc19b7d0bea1c05bea2c5d593c53c;hpb=fced4ded7356f1ce4afacd0dc6b2990506e28c47;p=sbcl.git

diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index 0d4508c..ca56de2 100644
--- 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)))
 
@@ -303,9 +310,14 @@
   (let ((entry (assoc label *sharp-equal-alist*)))
     (if entry
         (third entry)
-        (let ((pair (assoc label *sharp-sharp-alist*)))
+        (let (;; Has this label been defined previously? (Don't read
+              ;; ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that
+              ;; it requires you to implement forward references,
+              ;; because forward references are disallowed in
+              ;; "2.4.8.16 Sharpsign Sharpsign".)
+              (pair (assoc label *sharp-sharp-alist*)))
           (unless pair
-            (%reader-error stream "object is not labelled #~S#" label))
+            (%reader-error stream "reference to undefined label #~D#" label))
           (cdr pair)))))
 
 ;;;; conditional compilation: the #+ and #- readmacros