;;; read-circle.lisp ;;; ;;; Copyright (C) 2009 Erik Huelsmann ;;; $Id: read-conditional.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License ;;; as published by the Free Software Foundation; either version 2 ;;; of the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; As a special exception, the copyright holders of this library give you ;;; permission to link this library with independent modules to produce an ;;; executable, regardless of the license terms of these independent ;;; modules, and to copy and distribute the resulting executable under ;;; terms of your choice, provided that you also meet, for each linked ;;; independent module, the terms and conditions of the license of that ;;; module. An independent module is a module which is not derived from ;;; or based on this library. If you modify this library, you may extend ;;; this exception to your version of the library, but you are not ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. (in-package "SYSTEM") ;;; Reading circular data: the #= and ## reader macros (from SBCL) ;;; Objects already seen by CIRCLE-SUBST. (defvar *sharp-equal-circle-table*) ;; This function is kind of like NSUBLIS, but checks for circularities and ;; 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) (macrolet ((recursable-element-p (subtree) `(typep ,subtree '(or cons (array t) structure-object standard-object))) (element-replacement (subtree) `(let ((entry (find ,subtree old-new-alist :key #'second))) (if entry (third entry) ,subtree)))) (cond ((not (recursable-element-p tree)) (element-replacement tree)) ((null (gethash tree *sharp-equal-circle-table*)) (cond ((typep tree 'structure-object) (setf (gethash tree *sharp-equal-circle-table*) t) (do ((i 0 (1+ i)) (end (structure-length tree))) ((= i end)) (let* ((old (structure-ref tree i)) (new (circle-subst old-new-alist old))) (unless (eq old new) (structure-set tree i new))))) ;; ((typep tree 'standard-object) ;; (setf (gethash tree *sharp-equal-circle-table*) t) ;; (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))))) ((arrayp tree) (setf (gethash tree *sharp-equal-circle-table*) t) (do ((i 0 (1+ i)) (end (array-total-size tree))) ((>= i end)) (let* ((old (row-major-aref tree i)) (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (row-major-aref tree i) new))))) (t ;; being CONSP as all the other cases have been handled (do ((subtree tree (cdr subtree))) ((or (not (consp subtree)) (gethash subtree *sharp-equal-circle-table*))) ;; CDR no longer a CONS; no need to recurse any further: ;; the case where the CDR is a symbol to be replaced ;; has been handled in the last iteration (setf (gethash subtree *sharp-equal-circle-table*) t) (let* ((c (car subtree)) (d (cdr subtree)) (a (if (recursable-element-p c) (circle-subst old-new-alist c) (element-replacement c))) (b (cond ((consp d) d) ;; CONSes handled in the loop ((recursable-element-p d) ;; ARRAY, STRUCTURE-OBJECT and STANDARD-OBJECT ;; handled in recursive calls (circle-subst old-new-alist d)) (t (element-replacement d))))) (unless (eq a c) (rplaca subtree a)) (unless (eq d b) (rplacd subtree b)))))) tree) (t tree)))) ;;; Sharp-equal works as follows. When a label is assigned (i.e. when ;;; #= is called) we GENSYM a symbol is which is used as an ;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this ;;; gensym. ;;; ;;; When SHARP-SHARP encounters a reference to a label, it returns the ;;; symbol assoc'd with the label. Resolution of the reference is ;;; deferred until the read done by #= finishes. Any already resolved ;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned. ;;; ;;; After reading of the #= form is completed, we add an entry to ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved ;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current ;;; object is searched and any uses of the gensysm token are replaced ;;; with the actual value. (defvar *sharp-sharp-alist* ()) (defun sharp-equal (stream ignore label) (declare (ignore ignore)) (when *read-suppress* (return-from sharp-equal (values))) (unless label (error 'reader-error :stream stream :format-control "Missing label for #=")) (when (or (assoc label *sharp-sharp-alist*) (assoc label *sharp-equal-alist*)) (error 'reader-error :stream stream :format-control "Multiply defined label: #~D=" :format-arguments (list label))) (let* ((tag (gensym)) (*sharp-sharp-alist* (cons (list label tag nil) *sharp-sharp-alist*)) (obj (read stream t nil t))) (when (eq obj tag) (error 'reader-error :stream stream :format-control "Must tag something more than just #~D#" :format-arguments (list label))) (push (list label tag obj) *sharp-equal-alist*) (when (third (car *sharp-sharp-alist*)) ;; set to T on circularity (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20))) (circle-subst *sharp-equal-alist* obj))) obj)) (defun sharp-sharp (stream ignore label) (declare (ignore ignore)) (when *read-suppress* (return-from sharp-sharp nil)) (unless label (error 'reader-error :stream stream :format-control "Missing label for ##")) (let ((entry (assoc label *sharp-equal-alist*))) (if entry (third entry) (let ((pair (assoc label *sharp-sharp-alist*))) (unless pair (error 'reader-error :stream stream :format-control "Object is not labelled #~S#" :format-arguments (list label))) (setf (third pair) t) (second pair))))) (set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+) (set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+)