;;; -*- Mode: Common-Lisp; Package: SYS; Base: 10.; Patch-File: T -*- ;;; Reason: Modified unload-file to remove variables (defined by DEFVAR) from (PROFILE:ALL-PROFILE-VARIABLES) [10666] ;;; 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, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 11/30/89 07:50:48 by BERGER, ;;; while running on ARIES from band LODX ;;; With SYSTEM 6.26, VIRTUAL-MEMORY 6.3, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.8, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, IMAGEN 6.1, ;;; SUGGESTIONS 6.1, MAIL-DAEMON 6.3, MAIL-READER 6.6, TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.4, ;;; PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.26, CLEH 6.5, IP 3.56, Experimental CLX 6.7, ;;; CLUE 6.35, X11M 6.17, Experimental BUG 11.17, PRINTER 6.3, Experimental SHRINK-TOOLS 6.1, ;;; microcode 429, Band Name: rel6.0 10/23 #!C ; From file DELETE-SYSTEM.LISP#> BAND-TOOLS; SYS: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: BAND-TOOLS; DELETE-SYSTEM.#" (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 (when (and (find-package 'profile) (get (locf (symbol-plist symbol)) ; DAB 11-30-89 Check if variable is 'profile:variable-name)) ;in PROFILE. (debug-print " Removing PROFILE variable ~S from ~A classes." symbol (get (locf (symbol-plist symbol)) 'profile:classes)) (eval `(profile:UNDEFINE-PROFILE-VARIABLE ; DAB 11-30-89 If so remove it. ,symbol)) ) (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))) ))