;;; -*- indent-tabs-mode: nil -*- ;;; Sample DUMP-SYSTEM implementations for some ASDF systems ;;; FIXME: To dump a system defining generic functions (like McCLIM) ;;; that a different system adds methods to (like Climacs), make sure to ;;; dump the former system before loading the latter. ;;; ;;; Otherwise there will be unresolvable references to Climacs functions ;;; in the dumpfile for McCLIM. (defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :xmls)))) (sb-heapdump:dump-packages :xmls "xmls.heap" :if-exists :rename-and-delete)) (defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :cxml)))) (sb-heapdump:dump-packages '("RUNE-DOM" "RUNES" "RUNES-ENCODING" "UTF8-RUNES" "CXML" "SAX" "DOM" "UTF8-DOM" "CXML-XMLS" "DOMTEST" "XMLCONF" "DOMTEST-TESTS") "test.heap" :if-exists :rename-and-delete :systems '(:cxml-runes :cxml-xml :cxml-dom :cxml-test :cxml) :system-packages '(:cxml-system))) (defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :clx)))) (sb-heapdump:dump-packages ;; The test stuff is apparently loaded only when compiling clx for the ;; first time (and must then be dumped, too), not when loading clx later(?). ;; Let's just ignore the non-existent package for now. (remove nil (mapcar #'find-package '(:gl :glx :xlib :clipboard :gl-test))) "clx.heap" :if-exists :rename-and-delete :initializer (let ((event-keys xlib::*event-key-vector*)) (lambda (packages) (loop for event-key across event-keys for i from 0 do (setf (get event-key 'xlib::event-code) i)) (setf *features* (union *features* '(:clx-ext-render :clx-mit-r5 :clx-mit-r4 :xlib :clx :clx-little-endian :clx-ansi-common-lisp))) packages)) :systems '(:clx) :system-packages '(:clx-system))) #| (load "/home/david/src/lisp/clx_0.7.1/demo/menu") (xlib::just-say-lisp) |# (defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :mcclim)))) (let ((packages (mapcar #'find-package '("IMAGE" "CLIM-CLX" "CLIM-XCOMMON" "CLIM-POSTSCRIPT" "CLIM-FFI" "GOATEE" "CLIM-USER" "CLIM-DEMO" "CLIM-INTERNALS" "CLIM-BACKEND" "CLIM-EXTENSIONS" "CLIM-SYS" "CLIM" "CLIM-LISP" "CLIM-MOP" "CLIM-LISP-PATCH")))) (sb-heapdump:dump-packages packages "mcclim.heap" :if-exists :rename-and-delete ;; Pfui, dagegen ist CLX ja noch brav und benutzt einen Indicator ;; aus seinem eigenen Paket. :initializer (let* ((ports climi::*server-path-search-order*) (types (loop for port in ports collect (get port :port-type))) (parsers (loop for port in ports collect (get port :server-path-parser)))) (lambda (x) (loop for port in ports for type in types for parser in parsers do (setf (get port :port-type) type) (setf (get port :server-path-parser) parser)) (pushnew :clim *features*) (pushnew :mcclim *features*) x)) :systems '(:mcclim :clim :clim-lisp :clim-core :goatee-core :clim-postscript :clim-clx :clim-opengl :clim-objc-support :clim-beagle :clim-looks :clim-clx-user :clim-examples :scigraph :clim-listener) :system-packages '(:mcclim.system)))) (defun dump-clim-application (packages pathname &rest args &key (initializer #'identity) force &allow-other-keys) (let ((p (mapcar #'find-package packages))) (flet ((extract-hash-table (sym) (let ((hash-table (symbol-value sym)) (alist '())) (maphash (lambda (k v) (when (member (symbol-package k) p) (when (typep v 'class) (pushnew (class-name v) force)) (push (cons k v) alist))) hash-table) (cons sym alist))) (restore-hash-table (x) (let ((table (symbol-value (car x)))) (loop for (k . v) in (cdr x) do (setf (gethash k table) v)))) ;; climacs-specific hack to find anonymous command tables (extract-climacs-tables (sym) (let ((hash-table (symbol-value sym)) (anonymous-command-tables '()) (alist '())) (maphash (lambda (k v) (when (member (symbol-package k) p) (dolist (mi (slot-value v 'climi::keystroke-items)) (pushnew (clim:command-menu-item-value (clim:menu-item-value mi)) anonymous-command-tables)))) hash-table) (dolist (name anonymous-command-tables) (push (cons name (gethash name hash-table)) alist)) (cons sym alist)))) (let ((data (list (extract-hash-table 'climi::*command-tables*) (extract-climacs-tables 'climi::*command-tables*) (extract-hash-table 'climi::*command-parser-table*) (extract-hash-table 'climi::*presentation-type-table*) (extract-hash-table 'climi::*presentation-type-abbreviations*)))) (apply #'sb-heapdump:dump-packages packages pathname :force (cons #'dump-clim-application force) :initializer (lambda (x) (mapc #'restore-hash-table data) (funcall initializer x)) ;; CLIM wants the +foo-ink+s to be unique objects. :customizer (lambda (object) (dolist (var '(climi::*unsupplied-argument-marker* climi::*numeric-argument-marker* clim:+foreground-ink+ clim:+foreground-ink+ clim:+background-ink+ clim:+flipping-ink+) t) (when (eq object (symbol-value var)) (return (values :fixup var))))) :load-time-customizer (lambda (sym ignore) ignore (symbol-value sym)) args))))) (defmethod sb-heapdump:dump-system ((c (eql (asdf:find-system :climacs)))) (dump-clim-application '("CLIMACS-SLIDEMACS-EDITOR" "CLIMACS-TTCN3-SYNTAX" "CLIMACS-GUI" "ESA" "CLIMACS-LISP-SYNTAX" "CLIMACS-CL-SYNTAX" "CLIMACS-PROLOG-SYNTAX" "CLIMACS-HTML-SYNTAX" "CLIMACS-FUNDAMENTAL-SYNTAX" "CLIMACS-PANE" "UNDO" "CLIMACS-KILL-RING" "CLIMACS-SYNTAX" "CLIMACS-ABBREV" "CLIMACS-BASE" "CLIMACS-BUFFER" "BINSEQ" "AUTOMATON" "EQV-HASH" "FLEXICHAIN") "climacs.heap" :force (list 'clim:form #'clim:command-table #'(setf clim:command-table)) :initializer (lambda (x) (setf (fdefinition 'clim:command-table) #'clim:command-table) (setf (fdefinition '(setf clim:command-table)) #'(setf clim:command-table)) x) :systems '(:climacs :climacs.tests :flexichain) :system-packages '(:climacs.system :flexichain-system) :if-exists :rename-and-delete)) #| (sb-heapdump:relocate-dumpfiles '("clx.heap" "mcclim.heap" "climacs.heap")) (sb-heapdump:make-executable "climacs.heap":main-function 'climacs-gui:climacs) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; simple DUMP-OBJECT tests ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| (sb-heapdump::dump-object (let ((x (make-hash-table))) (setf (gethash 'foo x) 'bar) x) "test.heap" :if-exists :rename-and-delete) (sb-heapdump::dump-object (lambda ()) "test.heap" :if-exists :rename-and-delete) (defun ff (x) (if (zerop x) 1 (* x (ff (1- x))))) (sb-heapdump::dump-object #'ff "test.heap" :force t :if-exists :rename-and-delete) (sb-heapdump::dump-object '("foo" "bar") "test.heap" :force t :if-exists :rename-and-delete) (sb-heapdump::dump-object (list (sb-ext:make-weak-pointer :foo)) "test.heap" :force t :if-exists :rename-and-delete) (sb-heapdump::dump-object '("foo" "bar") "test.heap" :initializer #'print :if-exists :rename-and-delete) (sb-heapdump::dump-object '("baz" "quux") "test.heap" :initializer #'print :if-exists :append) |#