diff --git a/compiler/dump.lisp b/compiler/dump.lisp index 58c16e764d63116c4af3e72866d8d63125014549..e57253eaa76d0820e290cbed58796d3738efb441 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.79 2003/06/10 16:52:36 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.80 2003/06/30 14:59:03 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -278,32 +278,21 @@ (dump-fop 'lisp::fop-pop file) (incf (fasl-file-table-free file)))) -;;; circular-cons-p -- Internal -;;; -;;; Test for the kind of circularities that would cause equal not to -;;; return, but allow other kinds of shared structure. - -(defun circular-cons-p (obj) - (unless (consp obj) - (return-from circular-cons-p nil)) - (let ((circ-hash (make-hash-table :test #'eq))) - (labels ((circular-cons-p-aux (obj top-level) - (do* ((sublist obj (cdr sublist))) - ((not (consp sublist)) - nil) - (let ((car-list (car sublist))) - (when (gethash sublist circ-hash) - (return-from circular-cons-p t)) - (setf (gethash sublist circ-hash) t) - (when (consp car-list) - (circular-cons-p-aux car-list nil)))) - (when (not top-level) - (do ((sublist obj (cdr sublist))) - ((not (consp sublist)) - nil) - (remhash sublist circ-hash))) - nil)) - (circular-cons-p-aux obj t)))) +;;; non-circular-cons-p -- Internal +;;; +;;; Return true if LIST is definitely not circular. + +(defun non-circular-list-p (list) + (declare (list list)) + (or (null list) + (labels ((safe-cddr (obj) + (when (and (consp obj) (consp (cdr obj))) + (cddr obj)))) + (loop for tortoise = list then (cdr tortoise) + for hare = (safe-cddr list) then (safe-cddr hare) + when (not (consp tortoise)) return t + when (consp (car tortoise)) return nil + when (eq hare tortoise) return nil)))) ;;; EQUAL-CHECK-TABLE -- Internal ;;; @@ -897,10 +886,10 @@ (typecase x (symbol (dump-symbol x file)) (list - (cond (*coalesce-constants* ;(and (not (circular-cons-p x))) + (cond ((and *coalesce-constants* (non-circular-list-p x)) (unless (equal-check-table x file) - (dump-list x file) - (equal-save-object x file))) + (dump-list x file) + (equal-save-object x file))) (t (dump-list x file) (eq-save-object x file)))) diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index dc94fac814e941adf1ef998b4c274a02563f7117..187073d7c8763e23947c16ac75c2cdfb9e0057b6 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -59,6 +59,8 @@ New in this release: - DISASSEMBLE disassembling closure/funcallable instance functions. - (SETF EXT:WEAK-POINTER-VALUE) has been added. + - CMUCL no longer entering an infinite loop when dumping + circular constant lists to fasl files. * Numerous ANSI compliance fixes: - Many bugs in CMUCL's type system detected by Paul Dietz'