1 ;;;; code to detect whether a package has changed
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB-COLD")
17 (hash-table (make-hash-table :test 'eq)
21 ;;; Return a SNAPSHOT object representing the current state of the
22 ;;; package associated with PACKAGE-DESIGNATOR.
24 ;;; This could be made more sensitive, checking for more things, such as
25 ;;; type definitions and documentation strings.
26 (defun take-snapshot (package-designator)
27 (let ((package (find-package package-designator))
28 (result (make-snapshot)))
30 (error "can't find package ~S" package-designator))
31 (do-symbols (symbol package)
32 (multiple-value-bind (symbol-ignore status)
33 (find-symbol (symbol-name symbol) package)
34 (declare (ignore symbol-ignore))
35 (let ((symbol-properties nil))
39 ((:internal :external)
41 (push (cons :symbol-value (symbol-value symbol))
43 (when (fboundp symbol)
44 (push (cons :symbol-function (symbol-function symbol))
46 (when (macro-function symbol)
47 (push (cons :macro-function (macro-function symbol))
49 (when (special-operator-p symbol)
50 (push :special-operator
52 (push status symbol-properties)
53 (setf (gethash symbol (snapshot-hash-table result))
56 (compile 'take-snapshot)
58 (defun snapshot-diff (x y)
59 (let ((xh (snapshot-hash-table x))
60 (yh (snapshot-hash-table y))
63 (maphash (lambda (key avalue)
64 (declare (ignore avalue))
65 (multiple-value-bind (bvalue bvalue?) (gethash key bh)
66 (declare (ignore bvalue))
73 (maphash (lambda (key xvalue)
74 (multiple-value-bind (yvalue yvalue?) (gethash key yh)
76 (unless (equalp xvalue yvalue)
77 (push (list key xvalue yvalue)
81 (compile 'snapshot-diff)
83 ;;;; symbols in package COMMON-LISP which change regularly in the course of
84 ;;;; execution even if we don't mess with them, so that reporting changes
85 ;;;; would be more confusing than useful
88 (let ((result (make-hash-table :test 'eq)))
89 (dolist (symbol `(;; These change regularly:
95 ;; These are bound when compiling and/or loading:
97 *compile-file-truename*
98 *compile-file-pathname*
101 ;; These change because CMU CL uses them as internal
105 #+cmu (cl::*gc-trigger*
107 cl::*internal-symbol-output-function*
111 cl::read-buffer-length
112 cl::*string-output-streams*
113 cl::*available-buffers*
114 cl::*current-unwind-protect-block*
116 cl::*free-fop-tables*
117 ;; These two are changed by PURIFY.
118 cl::*static-space-free-pointer*
119 cl::*static-space-end-pointer*)
121 (setf (gethash symbol result) t))
124 ;;; specialized version of SNAPSHOT-DIFF to check on the COMMON-LISP package,
125 ;;; throwing away reports of differences in variables which are known to change
128 ;;; Note: The warnings from this code were somewhat useful when first setting
129 ;;; up the cross-compilation system, have a rather low signal/noise ratio in
130 ;;; the mature system. They can generally be safely ignored.
133 (defun cl-snapshot-diff (cl-snapshot)
134 (remove-if (lambda (entry)
135 (gethash (first entry) *cl-ignorable-diffs*))
136 (snapshot-diff cl-snapshot (take-snapshot :common-lisp))))
137 (defun warn-when-cl-snapshot-diff (cl-snapshot)
138 (let ((cl-snapshot-diff (cl-snapshot-diff cl-snapshot)))
139 (when cl-snapshot-diff
140 (let ((*print-length* 30)
142 (warn "CL snapshot differs:")
143 (print cl-snapshot-diff *error-output*)))))
144 (compile 'cl-snapshot-diff)
145 (compile 'warn-when-cl-snapshot-diff))