;;; -*- Mode:Common-Lisp; Package:System; Base:10 -*- ;; RESTRICTED RIGHTS LEGEND ;; ;; Use, duplication, or disclosure by the Government is subject to ;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;; Technical Data and Computer Software clause at 52.227-7013. ;; ;; TEXAS INSTRUMENTS INCORPORATED. ;; P.O. BOX 2909 ;; AUSTIN, TEXAS 78769 ;; MS 2151 ;; ;; Copyright (C) 1988-1989 Texas Instruments Incorporated. All rights reserved. ;;; *-----------------------------------------------------------* ;;; | "Delete System" utility. | ;;; *-----------------------------------------------------------* ;;; User-callable functions: ;;; ;;; DELETE-SYSTEM ;;; UN-MAKE-SYSTEM ;;; UNDEFSYSTEM ;;; UNLOAD-FILE ;;; UNDEFINE-FUNCTION ;; 11/13/87 DNG - Original preliminary version. ;; 11/20/87 DNG - Functionality complete. ;; 11/23/87 DNG - Add handling for NET:*NETWORK-WARM-INITIALIZATION-LIST*; ;; don't delete DEFSYSTEM if needed as a component of another system. ;; 11/25/87 DNG - A couple of adjustments for use on a cold band, and enable ;; deleting itself. ;; 12/03/87 DNG - Call CLEAR-RESOURCE before deleting resource definition. ;; 12/07/87 DNG - Add :BATCH option to DELETE-SYSTEM. ;; 12/14/87 DNG - Fix REMOVE-FROM-LIST to not error on non-existent package. ;; 12/21/87 DNG - Add EXPORT. DELETE-SYSTEM with no arguments invokes ;; DELETABLE-NAMES. Remove ZWEI::COMMAND-NAME property when ;; deleting a Zmacs command function. ;; 12/28/87 DNG - Add UNFASL to *SYSTEM-DELETION-TABLE*. ;; 2/04/88 DNG - Refine DELETABLE-NAMES to skip UNLOAD-FILE for file not loaded. ;; 2/08/88 DNG - Add :VERBOSE option. Keep GET-FILE-LOADED-ID and ;; LOCAL-BINARY-FILE-TYPE when LOAD deleted since DELETE-SYSTEM ;; needs them. Adjust source layout for narrower screen. ;; Fix UNDEFINE-FUNCTION to remove :PREVIOUS-DEFINITION property. ;; 2/11/88 DNG - Remove deleted resource names from *ALL-RESOURCES*. ;; 2/13/88 DNG - Updated UNDEFINE-FUNCTION to delete UCL commands when ;; undefining their function and to remove source file properties. ;; 2/15/88 DNG - Add new function UPDATE-SYSTEM-MENU . ;; 2/16/88 DNG - Fix not not error on source file name which is a string. ;; 2/24/88 DNG - Update for compatibility with new version of MAKE-SYSTEM. ;; 2/26/88 DNG - Fix error on undefined function when deleting PEEK. ;; 2/29/88 DNG - Include BREAK condition in CATCH-ERROR-RESTARTs. Kill window ;; frame before killing its inferior panes. Add special handling for ;; updating NET:*NETWORK-WARM-INITIALIZATION-LIST*. ;; 3/01/88 DNG - Keep functions TV:FUNCTION-SPEC-P and ZWEI:CHAR-SYNTAX . ;; 3/02/88 DNG - Fix removal of system names from *MODULES*. Update SYSTEM ;; key and system menu handling for new S.A.M. data structures. ;; Add handling for NET:*NETWORK-RESET-INITIALIZATION-LIST* etc. ;; 3/03/88 DNG - Added special handling for deleting SYS:BAND-CLEANER. ;; 3/03/88 DNG - Handle new directories "SYS:BASIC-FILE;" and "SYS:LOCAL-FILE;". ;; 3/04/88 DNG - Modify system key and system menu update to not remove ;; systems not present but intended to be available for auto-load. ;; 3/05/88 DNG - More adjustments to *system-deletion-table*. ;; 3/07/88 DNG - Special handling for deleting Lisp Listener. Improved ;; handling of UCL commands implemented as flavor methods. ;; 3/08/88 DNG - Still trying to get the keep-symbols list right for Zmacs. ;; Avoid flavor recompilation when deleting methods when the whole ;; flavor is going to be deleted anyway. ;; 3/11/88 DNG - Fix deletion of secondary DEFSYSTEMs in UNLOAD-FILE. ;; 3/15/88 DNG - Fix to un-make dummy systems TRACE and PEEK. Fix to delete ;; previous definition of a function when only one source file is ;; recorded. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (export '(delete-system unload-file *packages-to-be-cleaned* system-files)) (defparameter *system-deletion-table* '(;; Systems needing special handling: (:ZMACS (progn (when (and (boundp 'zwei:*zmacs-buffer-list*) zwei:*zmacs-buffer-list* (ask-unless-batch "Kill all Zmacs buffers?")) (dolist (b zwei:*zmacs-buffer-list*) (send b :kill))) (delete-system :zmacs :recursivep t ;; functions used by rubout handler in Lisp Listener :keep-symbols (append *keep-symbols* 'zwei:(print-arglist char-syntax print-arglist-internal create-interval create-bp create-line insert make-node mung-bp-interval tick mung-node bp-node mung-line set-line-array-type set-line-length insert-within-line ))))) (:COMPILER (delete-system :COMPILER :keep-symbols (append *keep-symbols* '( LOCAL-DECLARATIONS FILE-LOCAL-DECLARATIONS UNDO-DECLARATIONS-FLAG COMPILER:QC-FILE-IN-PROGRESS ; used in flavors PUTDECL GETDECL ;; used by FASLOAD: COMPILER::EXPR-SXHASH COMPILER::FUNCTION-EXPR-SXHASH COMPILER:INTERPRETED-DEF ; use by FUNCTION-EXPR-SXHASH )) :recursivep t)) (:suggestions (when (or (not (find-system-named :suggestions t t)) (yes-or-no-p "Deleting Suggestions will probably break the window system! Try to do it anyway?")) (delete-system :suggestions :recursivep t))) (:streamer-tape (delete-system :streamer-tape ;; following used by FS:MAGTAPE-FILEHANDLE :keep-symbols (cons (and (find-package "MT") (find-symbol "MT-FILEHANDLE" "MT")) *keep-symbols*) :recursivep t)) (:debug-tools (delete-system :debug-tools ;; this function is used in Zmacs :keep-symbols (cons 'tv:function-spec-p *keep-symbols*) :recursivep t)) ;; Aliases for package names different from the system name: (:MT (delete-system :streamer-tape)) (:NETWORK-FILE-SYSTEM (delete-system :NFS)) (:REMOTE-PROCEDURE-CALL (delete-system :RPC)) (:ZLC (delete-system :zetalisp-support)) (:NSE (delete-system :namespace-editor)) (:SRCCOM (unload-file "SYS:ZMACS;SRCCOM")) ;; Elements of *FEATURES* that are not system names: (:flavors (when (unload-file "SYS:KERNEL;FLAVOR") (remove-feature :flavors))) (:defstruct (when (unload-file "SYS:KERNEL;STRUCTURE") (remove-feature :defstruct))) (:loop (when (unload-file "SYS:KERNEL;LOOP") (remove-feature :loop))) (:sort (when (unload-file "SYS:KERNEL;SORT") (remove-feature :sort))) (:fasload (progn (undefine-function 'fasload) (undefine-function 'fasload-internal) (remove-feature :fasload))) (:trace (when (unload-file '("SYS:KERNEL;TRACE" "SYS:DEBUG-TOOLS;TRACE-WINDOW") :keep-symbols (cons '*trace-output* *keep-symbols*)) (delete-system :trace :recursivep t) (remove-feature :trace))) (:grindef (progn (undefine-function 'grindef) (undefine-function 'grindef-1) (undefine-function 'pprint-def) (remove-feature :grindef))) ;; Other major functions that are not separate systems: (PPRINT (when (unload-file "SYS:KERNEL;PPRINT") (remove-feature :grindef))) (FORMAT (when (unload-file "SYS:KERNEL;FORMAT") (fset 'format #'dummy-format))) (ADVISE (unload-file "SYS:KERNEL;ADVISE")) (APROPOS (unload-file "SYS:KERNEL;APROPOS")) (DESCRIBE (unload-file "SYS:KERNEL;DESCRIBE")) (WHO-CALLS (unload-file "SYS:KERNEL;WHO-CALLS")) (LOAD (let ((*keep-symbols* (list* 'si:get-file-loaded-id 'si:local-binary-file-type *keep-symbols*))) (when (unload-file (function-source-file 'fasload)) (remove-feature :fasload)) (dolist (x '( LOAD FS:LOAD-1 LOAD-PATCHES LOAD-AND-SAVE-PATCHES READFILE)) (when (fboundp x) (delete-system x :recursivep t))) )) ("UNFASL" (unload-file "SYS:COMPILER;UNFASL")) ("FINGER" (progn (unload-file '("SYS:NETWORK-SERVICE;FINGER" "SYS:NETWORK-SERVICE;FINGER-WINDOW")) (delete-system "FINGER" :recursivep t))) (sys:BAND-CLEANER (let ((file (function-source-file 'sys:band-cleaner))) (if file (unload-file file) ;; else band-cleaner has deleted source file properties. (when (and (fboundp 'sys:band-cleaner) (ask-unless-batch "Un-define function ~S ?" 'sys:band-cleaner)) (mapc #'undefine-function 'sys:( band-cleaner delete-debug-info set-debug-info-struct gc-pathnames clean-pathnames cdr-code-plists delete-previous-definition-property )) t)))) ;; Other groups of functions: (:LOCAL-FS ;; local Explorer file system (unload-file '(; release 3 pathnames: "SYS:FILE;FSDEFS" "SYS:FILE;FSMACROS" "SYS:FILE;FSSTR" "SYS:FILE;VBAT" "SYS:FILE;FSGUTS" "SYS:FILE;LOCAL-FILE-ACCESS" ;; release 4 pathnames: "SYS:LOCAL-FILE;FSDEFS" "SYS:LOCAL-FILE;FSMACROS" "SYS:LOCAL-FILE;FSSTR" "SYS:LOCAL-FILE;VBAT" "SYS:LOCAL-FILE;FSGUTS" "SYS:LOCAL-FILE;LOCAL-FILE-ACCESS"))) (:INFIX (unload-file "SYS:KERNEL;INFIX")) (:PLANE (unload-file "SYS:KERNEL;PLANE")) (:PEEK (when (unload-file "SYS:DEBUG-TOOLS;PEEK") (delete-system :peek :recursivep t))) (INSPECT (delete-system :inspector)) (:INSPECTOR (when (unload-file "SYS:DEBUG-TOOLS;INSPECT" :keep-symbols (cons 'tv:function-spec-p *keep-symbols*)) (update-system-keys :inspector) (update-system-menu :inspector))) (:FLAVOR-INSPECTOR (when (unload-file "SYS:DEBUG-TOOLS;FLAVOR-INSPECTOR") (update-system-menu :FLAVOR-INSPECTOR))) (:STEPPER (unload-file "SYS:DEBUG-TOOLS;STEP")) (:WINDOW-DEBUGGER (unload-file "SYS:DEBUG-TOOLS;WINDOW-DEBUG")) (W:LISP-LISTENER (when (unload-file (get-source-file-name 'W:LISP-LISTENER 'DEFFLAVOR)) (delete-system 'W:LISP-LISTENER :recursivep))) ;; Other aliases for non-intuitive names. (:TAR (delete-system :TAR-SUPPORT)) (:BUSNET (delete-system :BN)) (DELETE-SYSTEM ; can't UNLOAD-FILE here because it would break itself. (when (ask-unless-batch "Undefine functions DELETE-SYSTEM, UN-MAKE-SYSTEM, UNDEFSYSTEM, UNLOAD-FILE, and UNDEFINE-FUNCTION?") (when (get-source-file-name 'delete-system 'defun) (mark-not-loaded (get-source-file-name 'delete-system 'defun))) (MAPC #'FMAKUNBOUND '( delete-system deletable-names un-make-system remove-feature debug-print unload-file undefine-function function-spec-remprop delete-documentation delete-source-file-name function-source-file check-processes undefsystem component-system-p deletable-system-p update-system-keys update-system-menu run-cleanup-initializations update-initializations mark-not-loaded selectable-system-p same-system-p )) (makunbound '*system-deletion-table*) ;; Don't delete *packages-to-be-cleaned* because TREE-SHAKE uses and ;; clears it. t)) ) "A-list of names and and how to delete.") (defvar *keep-symbols* nil) (defvar *packages-to-be-cleaned* nil "List of names of packages from which DELETE-SYSTEM has removed some definitions. Need to do (TREE-SHAKE :CLEAN-PACKAGES *PACKAGES-TO-BE-CLEANED*) to remove unused symbols from the packages.") (defvar *no-query* nil) (defvar *verbose-stream* sys:syn-terminal-io) (defvar *deleted-component-systems* '()) (defun delete-system (&optional system &key batch keep-symbols recursivep (verbose t)) (declare (arglist &optional system-name &key batch keep-symbols (verbose t))) "Un-define everything in a system. Warning: there is no guarantee that this won't break something by deleting something that is still needed. Use at your own risk. Without any argument, displays a list of meaningful arguments. KEEP-SYMBOLS is a list of symbols whose definitions should be retained. The BATCH option suppresses queries when true." (if (null system) (progn (format t "~&Meaningful system names are:") (deletable-names) (values)) (let ((*keep-symbols* (or keep-symbols *keep-symbols*)) (*no-query* (or batch *no-query*)) (*verbose-stream* (if recursivep *verbose-stream* (and verbose *verbose-stream* *standard-output*))) (x (and (not recursivep) (assoc system *system-deletion-table* :test #'string-equal))) system-object) (cond ((not (null x)) (eval (second x))) ((setq system-object (si:find-system-named system t t)) (when (or (un-make-system system) (not (getf (system-plist system-object) :made-p t))) (if (component-system-p system-object) (pushnew (system-symbolic-name system-object) *deleted-component-systems* :test #'eq) (when (ask-unless-batch "Delete the DEFSYSTEM for ~A?" (system-name system-object)) (undefsystem system) )) t)) ((and (symbolp system) (fboundp system)) (when (let ((*package* nil)) (ask-unless-batch "Undefine function ~S ?" system)) (undefine-function system))) (t (format *error-output* "~&System ~A not found.~%" system) nil))))) (defun ask-unless-batch (format-string &rest format-args) (or *no-query* (apply #'y-or-n-p format-string format-args))) (defun deletable-names () "Display the list of meaningful arguments for DELETE-SYSTEM." (let ((names nil)) (dolist (x *system-deletion-table*) (let ((form (second x))) (when (member (first form) '(when and progn) :test #'eq) (setq form (second form))) (unless (cond ((eq (first form) 'delete-system) (not (find-system-named (eval (second form)) t t))) ((eq (first form) 'unload-file) (and (stringp (second form)) (null (send (send (pathname (second form)) :generic-pathname) :property-list)))) (t nil)) (push (car x) names)))) (dolist (system *SYSTEMS-LIST*) (when (typep system 'si::SYSTEM) ;loaded system object (let ((keyword (system-symbolic-name system))) (when (deletable-system-p keyword) (pushnew keyword names :test #'string-equal))))) (when (fboundp 'sort) (setq names (sort names #'string-lessp))) (dolist (name names) (format t "~& ~A" name)) (values))) (defun un-make-system (system &key keep-symbols) "Undo the effect of MAKE-SYSTEM to the extent possible." (catch-error-restart ((error break) "Give up deleting system ~A." system) (let ((done nil) (sys (si:find-system-named system t t))) (if (null sys) (format *error-output* "~&System ~A not found.~%" system) ;; Find out which files the system consists of. (let ((system-files (let ((*modules* *modules*) ; work-around SPR 7435 (made (getf (system-plist sys) :made-p #\?))) (prog1 (system-files system (list (if (fboundp 'compile-file) :recompile :reload) :no-reload-system-declaration) '(:fasload :readfile)) (unless (eql made #\?) (setf (getf (system-plist sys) :made-p) made)))))) (dolist (x (si:system-component-systems sys)) (when (and (si:find-system-named x t t) (ask-unless-batch "Un-make component system ~A?" x) (un-make-system x)) (setq done t))) (let ((files system-files) (name-keyword (si:system-symbolic-name sys))) (declare (type keyword name-keyword)) (let ((x (get-source-file-name name-keyword 'defsystem))) ;; check the DEFSYSTEM file itself too (when x (pushnew x system-files :test #'eq))) ;; Undefine everything defined in those files. (when (and (if keep-symbols (unload-file system-files :system name-keyword :keep-symbols keep-symbols) (unload-file system-files :system name-keyword)) (or done files ;; If no queries yet, ask now. (ask-unless-batch "Mark system ~S as not being loaded?" (system-name sys)))) (setq done t) (setf (system-made-p sys) nil) (update-system-keys name-keyword) (update-system-menu name-keyword) ;; Remove from PRINT-HERALD. (let ((x (si:get-patch-system-named sys t t))) (when x (setq sys:patch-systems-list (remove x (the list sys:patch-systems-list) :test #'eq)))) (when (and (boundp '*MODULES*) (member (string name-keyword) *MODULES* :test #'string=) (ask-unless-batch "Remove ~S from the *MODULES* list?" (string name-keyword))) (setf *MODULES* (remove (string name-keyword) (the list *MODULES*) :test #'string=))) (when (boundp '*FEATURES*) (when (and (member name-keyword *FEATURES* :test #'eq) (not (member name-keyword '( :TI :EXPLORER :COMMON-LISP :IEEE-FLOATING-POINT :LISPM :FLAVORS :DEFSTRUCT :LOOP :ELROY :CHAOS :SORT :FASLOAD :STRING :NEWIO :GRINDEF) :test #'eq)) (ask-unless-batch "Remove ~A from the *FEATURES* list?" name-keyword)) (remove-feature name-keyword))) )))) ; end if (return-from un-make-system done)) ) ; end catch-error-restart nil) (defun remove-feature (keyword) (when (member keyword (the list *FEATURES*) :test #'eq) (setf *FEATURES* (remove keyword (the list *FEATURES*) :test #'eq)) t)) (defun debug-print (format-string &rest format-args) (unless (null *verbose-stream*) (fresh-line *verbose-stream*) (apply #'format *verbose-stream* format-string format-args) (fresh-line *verbose-stream*)) (values)) ;; override obsolete declaration in "SYS:UCL;COMMAND" (eval-when (compile) (proclaim '(function undefine-function (t &optional t) t))) (defun unload-file (pathnames &key system (keep-symbols *keep-symbols*)) "Undo the effect of loading a file by undefining everything it defined. Note that this only removes definitions of functions, variables, flavors, etc.; it does not undo the effects of random top-level forms. The KEEP-SYMBOLS argument is a list of symbols which will be left alone." ;; The optional SYSTEM argument is a keyword which is the name of a system; ;; files that are included in any system other than the one indicated will ;; not be unloaded now. (declare (arglist pathnames &key keep-symbols)) (let ((packages ; packages to be scanned for definitions. (list *user-package* ; DEFPACKAGE interns package names in USER *keyword-package*)) ; DEFSYSTEM interns system names as keywords (generic-pathnames nil) ; pathnames to be unloaded (unloaded-pathnames nil) ; pathnames for which undefining actually done. (packages-defined nil) ; packages created by the files being unloaded. (systems-defined nil) ; DEFSYSTEMs found in the files being unloaded. (shared-files nil)) ; files included in more than one system. (when (atom pathnames) (setq pathnames (list pathnames))) (unless (listp keep-symbols) (setq keep-symbols (list keep-symbols))) (let ((systems (and system (list (setq system (force-to-keyword-symbol system)))))) (dolist (path pathnames) (let* ((gp (send (pathname path) :generic-pathname)) (prop (or (send gp :get :file-id-package-alist) (send gp :get :definitions)))) (unless (null prop) ; if loaded (if (and system (let ((x (send gp :get :systems))) (and x (not (equal x systems))))) (pushnew gp shared-files :test #'eq) (progn (dolist (loaded-id prop) (pushnew (car loaded-id) packages :test #'eq)) (push gp generic-pathnames) )))))) (when (and generic-pathnames (not (ask-unless-batch "Going to delete definitions from the following files: ~{ ~A~^ ~} OK to proceed?" generic-pathnames))) (return-from unload-file nil)) (unless (null generic-pathnames) (dolist (gp generic-pathnames) ;; Need to check both logical and physical pathnames because ;; back-translation is broken. [SPR 6960] (let ((physical (send gp :translated-pathname))) (when (or (send physical :get :file-id-package-alist) (send physical :get :definitions)) (pushnew physical generic-pathnames :test #'eq)))) (labels ((unload-pathname-p (generic-pathname) (member generic-pathname generic-pathnames :test #'eq)) (remove-from-list (package-name symbol-name key) (let* ((pkg (find-package package-name)) (symbol (and pkg (find-symbol symbol-name pkg)))) (when (and symbol (boundp symbol)) (dolist (element (symbol-value symbol)) (when (and (unload-pathname-p (function-source-file (funcall key element))) (ask-unless-batch "Remove ~S from ~S?" element symbol)) (set symbol (remove element (the list (symbol-value symbol)) :test #'eq)))))))) (declare (inline unload-pathname-p)) ;; First try to clean up things that will be broken by the undefining. (run-cleanup-initializations #'unload-pathname-p) ; release data structures (when (fboundp 'w:map-over-sheets) (labels ((maybe-kill-window (window) ; kill affected windows (when (and (instancep window) (unload-pathname-p (si:get-source-file-name (type-of window) 'defflavor)) (send window :active-p)) ;; Try killing frame before individual panes. (maybe-kill-window (w:sheet-superior window)) (when (and (send window :active-p) (ask-unless-batch "Kill window ~S?" (send window :name))) (catch-error-restart ((error break) "Give up killing window \"~A\"" window) (send window :kill)))))) (w:map-over-sheets #'maybe-kill-window))) (check-processes #'unload-pathname-p) ; kill affected processes (remove-from-list "ETHERNET" "*ETHERNET-PROTOCOLS*" #'cdr) (remove-from-list "ETHERNET" "RECEIVE-ADDR-PKT-HANDLERS" #'second) (remove-from-list "NAME" "*ENABLE-WHO-AM-I-SERVICE-FUNCTIONS*" #'identity) (remove-from-list "NAME" "*DISABLE-WHO-AM-I-SERVICE-FUNCTIONS*" #'identity) ;; Now start undefining things. (labels ((delete-definition (symbol path kind &optional delete-previous) (and (unload-pathname-p path) (let ((doc-kind kind) (deleted nil)) (block undefine (debug-print " Undefining ~A ~S from \"~A\"." kind symbol path) (case kind ( defun (when delete-previous (function-spec-remprop symbol :previous-definition)) (undefine-function symbol t) (setq doc-kind 'function)) ( defvar (if (member symbol area-list :test #'eq) ;; deleting an area breaks GC (return-from undefine nil) (progn (makunbound symbol) (remprop symbol 'special) (remprop symbol 'compiler:system-constant) (unless (eq (symbol-package symbol) *lisp-package*) (remprop symbol 'compiler::variable-type)) (setq doc-kind 'variable)))) ( defflavor (let ((fl (get symbol 'si:flavor))) (unless (null fl) (when (and (typep fl 'si:flavor) (get 'ucl::command 'si:flavor)) (catch-error-restart ((error break) "Give up checking flavor ~S for ~Ss." symbol 'ucl::command) (dolist (mte (si:flavor-method-table fl)) (dolist (meth (cdddr mte)) (let ((command (getf (si:meth-plist meth) 'ucl::command))) (when (instancep command) ;; remove from UCL command tables (send command :send-if-handles :kill))) )))) (if (fboundp 'undefflavor) (undefflavor symbol) (remprop symbol 'si::flavor))))) ( defstruct (remprop symbol 'sys::defstruct-description) (remprop symbol 'sys::setf-method) (remprop symbol 'named-structure-invoke) (setq doc-kind 'structure)) ( defresource (when (get-resource-structure symbol) (catch-error-restart ((error break) "Give up clearing resource ~S." symbol) (clear-resource symbol))) (remprop symbol 'defresource) (remprop symbol 'sys::resource-allocator) (remprop symbol 'sys::resource-cleanup-function) (setq *all-resources* (remove symbol (the list *all-resources*) :test #'eq :count 1)) ) ( defsignal (remprop symbol 'eh:make-condition-function)) ( si::encapsulation ;; from FDEFINE with 3rd argument NIL (let ((def (si:fdefinition-safe symbol t))) (if def ; restore unencapsulated definition (fset symbol def) (undefine-function symbol t)))) ( defpackage (let ((pkg (find-package symbol))) (unless (null pkg) (pushnew pkg packages-defined :test #'eq) (unless (member pkg packages :test #'eq) (push-end pkg packages)) (return-from undefine nil)))) ( defsystem ;; don't delete until the end (push symbol systems-defined)) ( provide (if (boundp '*MODULES*) (setf *MODULES* (remove (string symbol) (the list *MODULES*) :test #'string=)) (return-from undefine nil))) ( :medium ; from NET:DEFINE-MEDIUM (if (boundp 'net:*all-mediums*) (setq net:*all-mediums* (remove symbol (the list net:*all-mediums*) :key #'(lambda (x) (send x :name)) :test #'eq)) (return-from undefine nil))) ( otherwise (comment ; temporary for debugging (cerror "Continue." "Unrecognized source file definition kind: ~S" kind)) (return-from undefine nil))) (setq deleted t) (pushnew path unloaded-pathnames :test #'eq) ) ; end block (when doc-kind (delete-documentation symbol doc-kind)) deleted))) (delete-from-source-file-property (fspec source-files) (declare (list source-files)) (let ((changed nil)) (if (atom source-files) (unless (null source-files) (when (delete-definition fspec source-files 'defun t) (function-spec-remprop fspec :source-file-name)) (setq changed t)) (let ((new source-files)) (dolist (x source-files) (do ((paths (rest x) (rest paths)) (patched nil)) ((null paths)) (cond ((delete-definition fspec (first paths) (first x) (or patched (null (rest paths)))) (if (or (null (rest paths)) patched) (setq new (remove x (the list new) :test #'eq :count 1)) (setf (rest x) (rest paths))) (setq changed t)) ((and (pathnamep (first paths)) (send (first paths) :get :patch-file)) (setq patched t)) (t (return)))) ) (when changed (if (null new) (function-spec-remprop fspec :source-file-name) (function-spec-putprop fspec new :source-file-name) )))) changed)) (delete-definitions-from-symbol (symbol) (unless (member symbol keep-symbols :test #'eq) (let ((changed (delete-from-source-file-property symbol (get symbol :source-file-name)))) (do ((tail (symbol-plist symbol) (cddr tail))) ((atom tail)) (let ((property (first tail)) (value (second tail))) (when (cond ((symbolp value) (if (eq property 'inline) (not (fboundp symbol)) (and (functionp value t) (unload-pathname-p (function-source-file value))))) ((instancep value) (or (and ;; instance of deleted flavor? (not (type-specifier-p (type-of value))) (symbolp property) (eq (symbol-package property) (symbol-package symbol))) (and (eq property 'special) (unload-pathname-p value)))) #| ;; No, don't do this now; wait until ;; *all-flavor-names* is scanned later so ;; that if the whole defflavor is deleted ;; we don't have to recompile combined ;; methods as the methods are removed. ((typep value 'si:flavor) ;; A flavor that has not been deleted, but ;; maybe some of its methods should be ;; deleted. (catch-error-restart ((error break) "Give up scanning methods of flavor ~S." symbol) (dolist (mte (flavor-method-table value)) (dolist (meth (cdddr mte)) (delete-from-source-file-property (meth-function-spec meth) (getf (meth-plist meth) ':source-file-name) )))) nil) |# (t nil)) (remprop symbol property) (setq changed t)))) changed)))) (let ((inherited-packages nil)) ;; don't use DOLIST below because of the (PUSH-END PKG PACKAGES) above. (do ((pkgs packages (cdr pkgs))) ((null pkgs)) (let ((pkg (first pkgs)) (deletions nil)) (debug-print "Scanning local symbols in package ~A" (package-name pkg)) (do-local-symbols (symbol pkg) (when (delete-definitions-from-symbol symbol) (setq deletions t))) (when deletions ;; using name instead of package object in case user calls ;; KILL-PACKAGE. (pushnew (package-name pkg) *packages-to-be-cleaned* :test #'equal)) (dolist (used (sys:pack-use-list pkg)) (unless (or (member used packages :test #'eq) (member used inherited-packages :test #'eq)) (push used inherited-packages))) )) (dolist (pkg inherited-packages) (debug-print "Scanning external symbols in package ~A" (package-name pkg)) (do-external-symbols (symbol pkg) (delete-definitions-from-symbol symbol)))) (when (boundp 'function-spec-hash-table) (debug-print "Scanning ~A." 'function-spec-hash-table) (maphash #'(lambda (key value) (let ((fspec (first key)) (property (second key))) (when (eq property ':source-file-name) (delete-from-source-file-property fspec value)) )) function-spec-hash-table)) (debug-print "Scanning flavor methods.") (catch-error-restart ((error break) "Give up scanning flavor methods.") (dolist (flavor *all-flavor-names*) (let ((fl (get flavor 'si:flavor))) (when (and (typep fl 'si:flavor) (not (member flavor keep-symbols :test #'eq))) (dolist (mte (si:flavor-method-table fl)) (dolist (meth (cdddr mte)) (delete-from-source-file-property (si:meth-function-spec meth) (getf (si:meth-plist meth) :source-file-name) ))))))) ) ; end labels (update-initializations #'unload-pathname-p packages) ;; Finished undefining; update the generic pathnames. (dolist (gp unloaded-pathnames) (debug-print "Marking pathname \"~A\" as no longer being loaded." gp) (mark-not-loaded gp)) )) ; end of (unless (null generic-pathnames) ... (when system (dolist (gp (nconc shared-files generic-pathnames)) (let ((systems (send gp :get :systems))) (unless (null systems) (setq systems (remove system (the list systems) :test #'eq)) (if (null systems) (send gp :remprop :systems) (send gp :putprop systems :systems)) (pushnew gp unloaded-pathnames :test #'eq))))) (dolist (symbol systems-defined) (let (x) (unless (or (eq symbol system) (null (setq x (find-system-named symbol t t))) (system-made-p x) (component-system-p x)) (undefsystem symbol)))) (values unloaded-pathnames packages-defined))) (defun mark-not-loaded (generic-pathname) (send generic-pathname :remprop :file-id-package-alist) (send generic-pathname :remprop :definitions) (when (null (send generic-pathname :get :random-forms)) (send generic-pathname :remprop :compile-data) (send generic-pathname :remprop :qfasl-source-file-unique-id) (send generic-pathname :remprop :fasload-host) ; from FS:MAKE-FASLOAD-PATHNAME (send generic-pathname :remprop :macros-expanded)) (send generic-pathname :remprop :mode) (send generic-pathname :remprop :package) (send generic-pathname :remprop :base) (send generic-pathname :remprop :fonts) (values)) (defun function-spec-remprop (function-spec property) (if (symbolp function-spec) (remprop function-spec property) (with-stack-list (key function-spec property) (remhash key function-spec-hash-table)))) (defun undefine-function (function-spec &optional leave-source-file-name) ;; Similar to UNDEFUN, but no error if not currently defined and no query ;; about undefining. (when (and (fdefinedp function-spec) (not (and (consp function-spec) (eq (car function-spec) ':location)))) (catch-error-restart ((error break) "Give up undefining function ~S." function-spec) (let ((old (function-spec-get function-spec :previous-definition)) (source (and (not leave-source-file-name) (function-spec-get function-spec :source-file-name)))) (if old (progn ; restore previous definition (fdefine function-spec old t t) (function-spec-remprop function-spec :previous-definition) (unless (atom source) (let ((tem (assoc 'defun source))) (when (and tem (cdr tem)) (pop (cdr tem)))))) (progn (fundefine function-spec) (when (symbolp function-spec) (remprop function-spec 'INLINE) (unless (fboundp 'ed) (remprop function-spec 'ZWEI::LISP-INDENT-OFFSET)) (unless (eq (symbol-package function-spec) *lisp-package*) (remprop function-spec 'compiler::FUNCTION-RESULT-TYPE)) (let ((x (get function-spec 'SYS::SETF-METHOD))) (when (and x (symbolp x) (not (fboundp x))) (remprop function-spec 'SYS::SETF-METHOD)))) (let ((x (function-spec-get function-spec 'ucl::command))) (when (instancep x) ;; remove from UCL command tables and menus (send x :send-if-handles :kill))) (if (atom source) (unless (null source) (function-spec-remprop function-spec :source-file-name)) (function-spec-putprop function-spec (delete 'defun (the list source) :test #'eq :key #'car) :source-file-name)) ))) (when (and (consp function-spec) (eq (car function-spec) ':method)) (delete-flavor-method-table-entry (second function-spec) (third function-spec))) t))) (defun delete-documentation (symbol kind) (when (eq kind 'function) (remprop symbol 'zwei::command-name)) (let ((prop (get symbol 'sys::documentation-property))) (unless (eq (getf prop kind :undefined) :undefined) (remf prop kind) (if (null prop) (remprop symbol 'sys::documentation-property) (setf (get symbol 'sys::documentation-property) prop)) t))) (defun delete-source-file-name (symbol kind) (declare (symbol kind)) (let ((prop (remove kind (the list (get symbol :source-file-name)) :key #'car))) (if (null prop) (remprop symbol :source-file-name) (setf (get symbol :source-file-name) prop))) (values)) (defun function-source-file (function) (let ((fspec (function-name function))) (and (validate-function-spec fspec) (or (get-source-file-name fspec 'defun) (get-source-file-name (function-parent fspec) 'defun))))) (defun check-processes (path-predicate) (labels ((endangered (x) (typecase x (null nil) (symbol (when (or (funcall path-predicate (get-source-file-name x 'defun)) (funcall path-predicate (get-source-file-name x 'defvar)) (funcall path-predicate (get-source-file-name x 'defflavor)) ;;(not (or (boundp x) (fboundp x) ;; (get x 'si:flavor))) ) x)) (cons (dolist (elt x nil) (let ((y (endangered elt))) (when y (return y))))) (compiled-function (endangered (function-name x))) (t nil)))) (dolist (proc sys:all-processes (values)) (let ((needs (or (endangered (send proc :wait-function)) (endangered (send proc :wait-argument-list)) (endangered (send proc :initial-form))))) (when (and needs (ask-unless-batch "Process \"~A\" depends on ~S; kill it?" (send proc :name) needs)) (send proc :kill)))))) (defun undefsystem (system-name) ;; Undo DEFSYSTEM by deleting the system definition. (let* ((system (find-system-named system-name t t)) keyword (result nil)) (declare (symbol keyword)) (if (null system) (setq keyword (find-symbol (string system-name) *keyword-package*)) (progn (debug-print "Deleting the DEFSYSTEM for ~A." system-name) (setq *systems-list* (remove system (the list *systems-list*) :test #'eq :count 1)) (setq keyword (system-symbolic-name system)) (let* ((pathname (get-source-file-name keyword 'defsystem))) (unless (null pathname) (debug-print "Marking pathname \"~A\" as no longer being loaded." pathname) (dolist (loaded-id (send pathname :get :file-id-package-alist)) (setf (cdr (second loaded-id)) 0) ; reset time stamp ) (when (ask-unless-batch "Cancel the SET-SYSTEM-SOURCE-FILE for ~A?" keyword) (delete-source-file-name keyword 'defsystem) )) (setq *deleted-component-systems* (delete keyword *deleted-component-systems* :test #'eq)) ) (dolist (name (system-component-systems system)) (let ((other (find-system-named name t t))) (when (and other (member (system-symbolic-name other) *deleted-component-systems* :test #'eq) (not (getf (system-plist other) :made-p t)) (not (component-system-p other)) (ask-unless-batch "Delete the DEFSYSTEM for ~A?" (system-name other))) (undefsystem other) ))) (setq result t) )) ; end of if (when (and keyword (null (get-source-file-name keyword 'defsystem)) (member keyword *systems-list* :test #'eq)) (debug-print "Cancelling the SET-SYSTEM-SOURCE-FILE for ~A." keyword) (setq *systems-list* (remove keyword (the list *systems-list*) :test #'eq :count 1)) (setq result t)) result )) (defun component-system-p (system) ;; Is this system a component of some other system? (dolist (other *SYSTEMS-LIST* nil) (when (and (typep other 'si::SYSTEM) ;loaded system object (deletable-system-p (system-symbolic-name other))) (dolist (component (SYSTEM-COMPONENT-SYSTEMS other)) (when (or (string-equal component (system-name system)) (member component (system-nicknames system) :test #'string-equal)) (return-from component-system-p other)))))) (defun deletable-system-p (system-keyword) (not (member system-keyword '( :system :mini-system :system2 :initial-system :kernel :minprod) :test #'eq))) (defun selectable-system-p (name) ;; Can this system be invoked from the SYSTEM key or system menu without ;; using something that is no longer defined? (let ((system (find-system-named (if (consp name) (eval name) name) t t))) (and (typep system 'sys:system) (let* ((plist (si:get-system-access-list system nil)) (finder (getf plist :instance-finder))) (or ;; Is it currently defined? (case (getf plist :instance-type) (:EVAL (fboundp (car-safe finder))) (:FLAVOR (get finder 'si:flavor)) ((NIL) (return-from selectable-system-p nil)) (t t)) ;; Or can it be auto-loaded? (and (fboundp 'fasload) (not (system-made-p system)) (not (null (system-transformations system)))) ))))) (defun same-system-p (name1 name2) (when (consp name1) (setq name1 (eval name1))) (when (consp name2) (setq name2 (eval name2))) (or (string-equal name1 name2) (let ((system1 (find-system-named name1 t t)) (system2 (find-system-named name2 t t))) (and system1 system2 (eq system1 system2))))) (defun update-system-keys (&optional deleted-system-name) ;; Delete SYSTEM and TERM key assignments for things that aren't defined anymore. (let ((question "Delete ~:@C (\"~A\") from the ~A key?")) (when (boundp 'tv:*system-keys*) (flet ((undefinedp (thing) (and (symbolp thing) (not (get thing 'si:flavor)) (not (boundp thing)) (not (fboundp thing))))) (dolist (x tv:*system-keys*) (let ((finder (second x))) (when (and (typecase finder (keyword (or (same-system-p finder deleted-system-name) (not (selectable-system-p finder)))) (atom (undefinedp finder)) (t (dolist (e finder nil) (when (undefinedp e) (return t))))) (ask-unless-batch question (first x) (third x) 'system)) (setq tv:*system-keys* (remove x (the list tv:*system-keys*) :test #'eq))))))) (when (boundp 'tv:*terminal-keys*) (dolist (x tv:*terminal-keys*) (let ((fn (second x))) (when (consp fn) (setq fn (car fn))) (when (and (symbolp fn) (not (fboundp fn)) (ask-unless-batch question (first x) (third x) 'term)) (setq tv:*terminal-keys* (remove x (the list tv:*terminal-keys*) :test #'eq)) )))) (values))) (defun update-system-menu (&optional deleted-system-name) ;; Delete system menu items that use things that aren't defined anymore. (when (fboundp 'TV:COLUMN-TYPE-KEYWORD-TO-COLUMN-VARIABLE) (dolist (column '(:USER-AIDS :PROGRAMS :WINDOWS :DEBUG)) (let ((var (TV:COLUMN-TYPE-KEYWORD-TO-COLUMN-VARIABLE column))) (when (boundp var) (labels ((delete-item-p (item) (and (case (TV:SYSTEM-MENU-ITEM-KEYWORD item) (:EVAL (let* ((form (TV:SYSTEM-MENU-ITEM-FORM item)) (fn (car-safe form))) (case fn (TV:SELECT-OR-CREATE-WINDOW-OF-FLAVOR (when (and (consp (second form)) (eq (first (second form)) 'quote) (not (type-specifier-p (second (second form))))) ;; Window flavor not defined anymore T)) (W::FIND-SYSTEM-INSTANCE (or (same-system-p (second form) deleted-system-name) (not (selectable-system-p (second form))))) (t (not (fboundp fn)))))) ((:WINDOW-OP :FUNCALL) (not (functionp (TV:SYSTEM-MENU-ITEM-FORM item) t))) (:BUTTONS (let ((*no-query* t)) (dolist (sub-item (TV:SYSTEM-MENU-ITEM-FORM item) t) (unless (or (null sub-item) (delete-item-p sub-item)) (return nil))))) (t nil)) (ask-unless-batch "Delete ~S from the system menu?" (TV:SYSTEM-MENU-ITEM-NAME item))) )) (dolist (item (symbol-value var)) (when (delete-item-p item) (W:DELETE-FROM-SYSTEM-MENU-COLUMN column (TV:SYSTEM-MENU-ITEM-NAME item))))))))) (values)) (defun run-cleanup-initializations (path-predicate) ;; Run any clean-up initializations that are going to be deleted later. (labels ((run-cleanup (var path-predicate) (when (boundp var) (dolist (init (symbol-value var)) ; for each initialization (let ((form (si:init-form init)) (pathname (si:init-source-file init)) (name (si:init-name init))) (cond ((and (consp form) (eq (car form) 'initializations) (consp (second form)) (eq (car (second form)) 'quote) (symbolp (second (second form)))) (run-cleanup (second (second form)) path-predicate)) ((and (or (funcall path-predicate pathname) (and (consp form) (symbolp (car form)) (fboundp (car form)) (funcall path-predicate (get-source-file-name (car form) 'defun)) )) (ask-unless-batch "~A now?" name)) (catch-error-restart ((error break) "Abort the ~A initialization." name) (eval form) )))))) )) (dolist (var '(sys:Logout-Initialization-List sys:Full-GC-Initialization-List sys:Before-Cold-Initialization-List NET:*NETWORK-BEFORE-COLD-INITIALIZATION-LIST*)) (run-cleanup var path-predicate))) (values)) (defun update-initializations (path-predicate packages) ;; Delete initializations that use functions that are no longer defined. (when (boundp 'si:Initialization-Keywords) (labels ((update-init (var) (when (boundp var) (dolist (init (symbol-value var)) ; for each initialization (let ((form (si:init-form init)) (pathname (si:init-source-file init))) (when (and (consp form) (eq (car form) 'initializations) (consp (second form)) (eq (car (second form)) 'quote) (symbolp (second (second form)))) (update-init (second (second form)))) (when (or (funcall path-predicate pathname) (and (consp form) (symbolp (car form)) (not (fboundp (car form))) (member (symbol-package (car form)) packages :test #'eq) (let ((*print-length* 5)(*print-level* 2)) (ask-unless-batch "Delete ~S [\"~A\"] from ~A?" form (si:init-name init) var)))) (debug-print "Deleting ~S from ~A by ~A." (si:init-name init) var pathname) (delete-initialization (si:init-name init) nil var))) )))) (dolist (x si:Initialization-Keywords) ; for each initialization list (update-init (second x))) (mapc #'update-init '( NET:*NETWORK-RESET-INITIALIZATION-LIST* NET:*NETWORK-WARM-INITIALIZATION-LIST* NET:*NETWORK-SYSTEM-INITIALIZATION-LIST* NET:*NETWORK-COLD-INITIALIZATION-LIST* NET:*NETWORK-BEFORE-COLD-INITIALIZATION-LIST* ZWEI::*EDITOR-INITIALIZATION-LIST* CHAOS:SERVER-ALIST)) (when (find-package :NSE) (update-init (find-symbol "*EDITOR-INITIALIZATION-LIST*" :NSE))) ) (values))) (defun dummy-format (stream format-string &rest format-args) ;; Crude dummy version of FORMAT for use when the real one has been deleted. (cond ((null stream) (return-from dummy-format format-string)) ((stringp stream) (dotimes (i (length format-string)) (vector-push-extend (char format-string i) stream)) (return-from dummy-format nil)) ((eq stream 't) (setq stream *standard-output*))) (print format-string stream) (dolist (arg format-args) (prin1 arg) (write-char #\space stream)) nil) ;;; -- The following are temporary system patches for use under release 3. -- ;;; (Already fixed in source for release 4.) (eval-when (eval compile) (setf (get 'when 'may-surround-defun) t)) (when (eql (get-system-version) 3) (unless (fboundp 'sys:system-files) ;; This function new in System patch 4.25. ;; Needs to be in a separate file because it has to be compiled on release 3 ;; in order to work on release 3. (load (send sys:fdefine-file-pathname :new-pathname :name "system-files" :type nil :version :newest))) ;; The following function has been modified by P.H.D. to fix SPR 6931. 11/13/87 ;; "(when (and null..." clause added 11/16/87 by D.N.G. because error still happens sometimes. ;; Modified again by P.H.D. 11/17/87 ;; and by D.N.G 11/18/87 to use FLET to avoid duplication of code. sys: (defun perform-flavor-redefinition (flavor-name &optional for-undefflavor-p &aux fl nfl) (setq fl (get flavor-name 'flavor)) (when (and (null fl) for-undefflavor-p) (cerror "Continue." "Undefined flavor ~S encountered." flavor-name) (return-from perform-flavor-redefinition nil)) (cond ((flavor-method-hash-table fl) (setq nfl (make-flavor)) (copy-array-contents fl nfl) (copy-method-table fl nfl t);Copy, but discard combined methods (setq fl nfl) (setf (flavor-plist fl) (copy-list (flavor-plist fl) property-list-area)) (setf (flavor-mapped-instance-variables fl) (copy-list (flavor-mapped-instance-variables fl))) (remprop (locf (flavor-plist fl)) 'mapped-component-flavors);They are used only by the combined ;methods, which we just flushed. (setf (flavor-component-mapping-table-alist fl) ()) (setf (flavor-component-mapping-table-vector fl) ()) (setf (get flavor-name 'flavor) fl) (format *error-output* (if for-undefflavor-p "~&Flavor ~S no longer instantiable; old instances are not affected.~%" "~&Flavor ~S changed incompatibly; old instances will not get the new version.~%") flavor-name)) ;; Even if this flavor wasn't instantiated, ;; probably some of its dependents were, ;; and their hash tables and combined methods point to our method table. (t (copy-method-table fl fl t))) (setf (flavor-instance-size fl) ());Defuse error check (flet ((update-depended-on-by (flavor-name list) (dolist (f list (values)) (let ((fs (compilation-flavor f))) (when (and fs (member flavor-name (flavor-depended-on-by fs) :test #'eq)) (setf (flavor-depended-on-by fs) (delete flavor-name (the list (flavor-depended-on-by fs)) :test #'eq))))))) (update-depended-on-by flavor-name (or (flavor-depends-on-all fl) (flavor-depends-on fl))) (update-depended-on-by flavor-name (flavor-includes fl)) ) (setf (flavor-depends-on-all fl) ());Will need to be flavor-composed again (setf (flavor-method-hash-table fl) ());Will need to be method-composed again (setf (flavor-which-operations fl) ()) (dolist (fn (flavor-depended-on-by fl)) (perform-flavor-redefinition fn for-undefflavor-p)) fl) (DEFUN PROVIDE (MODULE) "Mark MODULE as being already loaded." (LET ((module (STRING module))) (when (record-source-file-name (intern module *keyword-package*) 'provide) (UNLESS (MEMBER module *MODULES* :test #'STRING=) (PUSH module *MODULES*) t)))) ;;PHD 4/15/87 added no-memory feature. ;;DNG 11/23/87 don't error if resource has been undefined. (defun clear-resources-without-memory () "This function will clear resources without memory." (mapcar #'(lambda (name) (if (member name *resources-without-memory* :test #'eq) (progn (setf (get name 'no-memory) t) (when (get-resource-structure name) (clear-resource name))) (remprop name 'no-memory))) *all-resources*)) ) ; end when release 3 (when (and (eql (get-system-version) 4) (not (fboundp 'sys:system-files))) (load-patches 'system :noselective)) ; need patch 4.25 (when (and (get-system-version :ucl) (not (fdefinedp '(:handler ucl::command :kill)))) ;; temporary for use prior to window patch 4.42. (load (send sys:fdefine-file-pathname :new-pathname :name "ucl-delete" :type nil :version :newest)))