Skip to content
Snippets Groups Projects
Commit 41144bbe authored by wlott's avatar wlott
Browse files

Only allow dumping of structures that have been explicitly allowed.

parent 66ef3ec2
No related branches found
No related tags found
No related merge requests found
...@@ -7,11 +7,11 @@ ...@@ -7,11 +7,11 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.34 1991/11/24 23:00:39 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.35 1991/12/14 18:12:00 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.34 1991/11/24 23:00:39 wlott Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.35 1991/12/14 18:12:00 wlott Exp $
;;; ;;;
;;; This file contains stuff that knows about dumping FASL files. ;;; This file contains stuff that knows about dumping FASL files.
;;; ;;;
...@@ -88,8 +88,11 @@ ...@@ -88,8 +88,11 @@
;; ;;
;; Except with list objects, the key and the value are always the same. In a ;; Except with list objects, the key and the value are always the same. In a
;; list, the key will be some tail of the value. ;; list, the key will be some tail of the value.
(circularity-table (make-hash-table :test #'eq) :type hash-table)) (circularity-table (make-hash-table :test #'eq) :type hash-table)
;;
;; Hash table of structures that are allowed to be dumped. If we try to
;; dump a structure that isn't in this hash table, we lose.
(valid-structures (make-hash-table :test #'eq) :type hash-table))
;;; This structure holds information about a circularity. ;;; This structure holds information about a circularity.
;;; ;;;
...@@ -125,6 +128,11 @@ ...@@ -125,6 +128,11 @@
;;; ;;;
(defvar *cold-load-dump* nil) (defvar *cold-load-dump* nil)
;;; Used to turn off the structure validation during dumping of source info.
;;;
(defvar *dump-only-valid-structures* t)
;;;; Utilities: ;;;; Utilities:
...@@ -458,7 +466,8 @@ ...@@ -458,7 +466,8 @@
(dump-fop 'lisp::fop-misc-trap file))))) (dump-fop 'lisp::fop-misc-trap file)))))
;; Dump the debug info. ;; Dump the debug info.
(let ((info (debug-info-for-component component))) (let ((info (debug-info-for-component component))
(*dump-only-valid-structures* nil))
(dump-object info file) (dump-object info file)
(let ((info-handle (dump-pop file))) (let ((info-handle (dump-pop file)))
(dump-push info-handle file) (dump-push info-handle file)
...@@ -634,7 +643,8 @@ ...@@ -634,7 +643,8 @@
;;; ;;;
(defun fasl-dump-source-info (info file) (defun fasl-dump-source-info (info file)
(declare (type source-info info) (type fasl-file file)) (declare (type source-info info) (type fasl-file file))
(let ((res (debug-source-for-info info))) (let ((res (debug-source-for-info info))
(*dump-only-valid-structures* nil))
(dump-object res file) (dump-object res file)
(let ((res-handle (dump-pop file))) (let ((res-handle (dump-pop file)))
(dolist (info-handle (fasl-file-debug-info file)) (dolist (info-handle (fasl-file-debug-info file))
...@@ -790,7 +800,10 @@ ...@@ -790,7 +800,10 @@
;;; if it's in the EQ table. ;;; if it's in the EQ table.
;;; ;;;
(defun fasl-constant-already-dumped (constant file) (defun fasl-constant-already-dumped (constant file)
(if (gethash constant (fasl-file-eq-table file)) t nil)) (if (or (gethash constant (fasl-file-eq-table file))
(gethash constant (fasl-file-valid-structures file)))
t
nil))
;;; FASL-NOTE-HANDLE-FOR-CONSTANT -- interface. ;;; FASL-NOTE-HANDLE-FOR-CONSTANT -- interface.
;;; ;;;
...@@ -804,6 +817,15 @@ ...@@ -804,6 +817,15 @@
(setf (gethash constant table) handle)) (setf (gethash constant table) handle))
(undefined-value)) (undefined-value))
;;; FASL-VALIDATE-STRUCTURE -- interface.
;;;
;;; Note that the specified structure can just be dumped by enumerating the
;;; slots.
;;;
(defun fasl-validate-structure (structure file)
(setf (gethash structure (fasl-file-valid-structures file)) t)
(undefined-value))
;;;; Number Dumping: ;;;; Number Dumping:
...@@ -1235,6 +1257,10 @@ ...@@ -1235,6 +1257,10 @@
;;; Dump a structure. ;;; Dump a structure.
(defun dump-structure (struct file) (defun dump-structure (struct file)
(when *dump-only-valid-structures*
(unless (gethash struct (fasl-file-valid-structures file))
(error "Attempt to dump invalid structure:~% ~S~%How did this happen?"
struct)))
(note-potential-circularity struct file) (note-potential-circularity struct file)
(do ((index 0 (1+ index)) (do ((index 0 (1+ index))
(length (structure-length struct)) (length (structure-length struct))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment