From 6ab944d415d1a758c87b10ef1c891469dad515be Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cantab.net>
Date: Wed, 28 Feb 2007 12:56:26 +0000
Subject: [PATCH] 1.0.3.3: 	Make the #=/## reader macro work on
 funcallable instances.

---
 NEWS                     |    2 ++
 src/code/sharpm.lisp     |   41 ++++++++++++++++++++++++-----------------
 tests/reader.impure.lisp |   16 ++++++++++++++++
 version.lisp-expr        |    2 +-
 4 files changed, 43 insertions(+), 18 deletions(-)

diff --git a/NEWS b/NEWS
index 029754f..934ee22 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.4 relative to sbcl-1.0.3:
   * bug fix: >= and <= gave wrong results when used with NaNs.
+  * bug fix: the #= and ## reader macros now interact reasonably with
+    funcallable instances.
 
 changes in sbcl-1.0.3 relative to sbcl-1.0.2:
   * new platform: NetBSD/PPC.  (thanks to Aymeric Vincent)
diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index e720699..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)))
 
diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp
index 8b60a5d..bb37bdf 100644
--- a/tests/reader.impure.lisp
+++ b/tests/reader.impure.lisp
@@ -58,6 +58,22 @@
     (read-from-string "#1=[#1#]")
   (assert (eq (value res) res))
   (assert (= pos 8)))
+;;; much, much, later (in Feb 2007), CSR noticed that the problem
+;;; still exists for funcallable instances.
+(defclass funcallable-box (box sb-mop:funcallable-standard-object) ()
+  (:metaclass sb-mop:funcallable-standard-class))
+(defun read-funcallable-box (stream char)
+  (declare (ignore char))
+  (let ((objects (read-delimited-list #\} stream t)))
+    (unless (= 1 (length objects))
+      (error "Unknown box reader syntax"))
+    (make-instance 'funcallable-box :value (first objects))))
+(set-macro-character #\{ 'read-funcallable-box)
+(set-syntax-from-char #\} #\))
+(multiple-value-bind (res pos)
+    (read-from-string "#1={#1#}")
+  (assert (eq (value res) res))
+  (assert (= pos 8)))
 
 ;;; CSR managed to break the #S reader macro in the process of merging
 ;;; SB-PCL:CLASS and CL:CLASS -- make sure it works
diff --git a/version.lisp-expr b/version.lisp-expr
index 22b59aa..0cea3f8 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.3.2"
+"1.0.3.3"
-- 
1.7.10.4