;; 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))
(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)))
(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)))))
\f
;;;; conditional compilation: the #+ and #- readmacros
(flet ((guts (stream not-p)
- (unless (if (handler-case
- (let ((*package* *keyword-package*)
- (*read-suppress* nil))
- (featurep (read stream t nil t)))
- (reader-package-error
- (condition)
- (declare (ignore condition))
- nil))
+ (unless (if (let ((*package* *keyword-package*)
+ (*read-suppress* nil))
+ (featurep (read stream t nil t)))
(not not-p)
not-p)
(let ((*read-suppress* t))