5
5
;;; Carnegie Mellon University, and has been placed in the public domain.
8
"$Header: /project/cmucl/cvsroot/src/code/sharpm.lisp,v 1.26 2005/11/08 17:12:29 rtoy Exp $")
8
"$Header: /project/cmucl/cvsroot/src/code/sharpm.lisp,v 1.27 2007/06/22 21:45:25 rtoy Exp $")
10
10
;;; **********************************************************************
243
243
;; substitutes in arrays and structures as well as lists. The first arg is an
244
244
;; alist of the things to be replaced assoc'd with the things to replace them.
246
(defun circle-subst (old-new-alist tree)
246
(defun circle-subst (repl-table tree)
247
247
(cond ((not (typep tree '(or cons (array t) structure-object
248
248
standard-object)))
249
(let ((entry (find tree old-new-alist :key #'second)))
250
(if entry (third entry) tree)))
249
(multiple-value-bind (value presentp)
250
(gethash tree repl-table)
251
254
((null (gethash tree *sharp-equal-circle-table*))
252
255
(setf (gethash tree *sharp-equal-circle-table*) t)
253
256
(cond ((typep tree '(or structure-object standard-object))
255
258
(end (%instance-length tree)))
257
260
(let* ((old (%instance-ref tree i))
258
(new (circle-subst old-new-alist old)))
261
(new (circle-subst repl-table old)))
259
262
(unless (eq old new)
260
263
(setf (%instance-ref tree i) new)))))
264
267
(do ((i start (1+ i)))
266
269
(let* ((old (aref data i))
267
(new (circle-subst old-new-alist old)))
270
(new (circle-subst repl-table old)))
268
271
(unless (eq old new)
269
272
(setf (aref data i) new))))))
271
(let ((a (circle-subst old-new-alist (car tree)))
272
(d (circle-subst old-new-alist (cdr tree))))
274
(let ((a (circle-subst repl-table (car tree)))
275
(d (circle-subst repl-table (cdr tree))))
273
276
(unless (eq a (car tree))
275
278
(unless (eq d (cdr tree))
283
(defun maybe-create-tables ()
284
(unless *sharp-equal-final-table*
285
(setf *sharp-equal-final-table*
286
(make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eql)))
287
(unless *sharp-equal-temp-table*
288
(setf *sharp-equal-temp-table*
289
(make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eql)))
290
(unless *sharp-equal-repl-table*
291
(setf *sharp-equal-repl-table*
292
(make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eq))))
280
294
;;; Sharp-equal works as follows. When a label is assigned (ie when #= is
281
295
;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
282
296
;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
291
305
;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
292
306
;;; and any uses of the gensysm token are replaced with the actual value.
294
(defvar *sharp-sharp-alist* ())
296
310
(defun sharp-equal (stream ignore label)
297
311
(declare (ignore ignore))
298
312
(when *read-suppress* (return-from sharp-equal (values)))
300
314
(%reader-error stream "Missing label for #=." label))
301
(when (or (assoc label *sharp-sharp-alist*)
302
(assoc label *sharp-equal-alist*))
315
(maybe-create-tables)
316
(when (or (nth-value 1 (gethash label *sharp-equal-final-table*))
317
(nth-value 1 (gethash label *sharp-equal-temp-table*)))
303
318
(%reader-error stream "Multiply defined label: #~D=" label))
304
(let* ((tag (gensym))
305
(*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
306
(obj (read stream t nil t)))
308
(%reader-error stream "Have to tag something more than just #~D#."
310
(push (list label tag obj) *sharp-equal-alist*)
311
(let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
312
(circle-subst *sharp-equal-alist* obj))))
319
(let* ((tag (gensym)))
320
(setf (gethash label *sharp-equal-temp-table*) tag)
321
(let ((obj (read stream t nil t)))
323
(%reader-error stream "Have to tag something more than just #~D#."
325
(setf (gethash tag *sharp-equal-repl-table*) obj)
326
(let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
327
(circle-subst *sharp-equal-repl-table* obj))
328
(setf (gethash label *sharp-equal-final-table*) obj))))
314
330
(defun sharp-sharp (stream ignore label)
315
331
(declare (ignore ignore))
318
334
(%reader-error stream "Missing label for ##." label))
320
(let ((entry (assoc label *sharp-equal-alist*)))
323
(let ((pair (assoc label *sharp-sharp-alist*)))
325
(%reader-error stream "Object is not labelled #~S#" label))
336
(maybe-create-tables)
337
;; Don't read ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that it requires
338
;; you to implement forward references, because forward references are
339
;; disallowed in "2.4.8.16 Sharpsign Sharpsign".
340
(multiple-value-bind (finalized-object successp)
341
(gethash label *sharp-equal-final-table*)
344
(multiple-value-bind (temporary-tag successp)
345
(gethash label *sharp-equal-temp-table*)
348
(%reader-error stream "reference to undefined label #~D#" label))))))
added
removed
src/code/sharpm.lisp
