;;; -*- 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 252.227-7013.
;; 
;; 			TEXAS INSTRUMENTS INCORPORATED.
;; 				 P.O. BOX 149149
;; 			      AUSTIN, TEXAS 78714-9149
;; 				    MS 2151
;; 
;;  Copyright (C) 1988,1989,1990 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.
;;	-----  The following changes are for release 7.0  -----
;;  9/08/89 DNG - Fix UPDATE-SYSTEM-KEYS for SPR 10608 and 10609.
;; 11/30/89 DAB _ Modified unload-file to remove DEFVAR from (PROFILE:ALL-PROFILE-VARIABLES) [10666]
;; 11/30/89 DAB - Added special handling for CHAOSNET and VISIDOC-SERVER in  *system-deletion-table*. [10665]
;; 04/19/90 DAB - Added special handling for NAME in *system-deletion-table*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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)))
	  (:CHAOSNET (delete-system :chaosnet  ; DAB 11-30-89 Add special handling for CHAOSNET [10665]
				 ;; These variables are used by NFS.
				 :keep-symbols (list* 'fs:server-login
						      'fs:server-login-id
						      *keep-symbols*)
				 :recursivep t))
	  (:NAME (delete-system :name  ; DAB 11-30-89 Add special handling for NAMEspace
				;; These variables are used by NFS.
				:keep-symbols (list* 'name:initialize-name-service  ; DAB 04-19-90 Added special handling for NAME
						     *keep-symbols*)
				:recursivep t))
	  (:visidoc-server (let ((server-list  (when (find-symbol "*visidoc-server-namespaces*" 'dox) ; DAB 11-30-89
						 (symbol-value (find-symbol "*visidoc-server-namespaces*" 'dox)))))
			     (debug-print "   Flushing Visidoc Servers.")
			     ;; DAB 11-30-89 Visidoc Server namespaces must be clear before deleting system.
			     (dolist (Server server-list)
			       (name:delete-namespace (send server :domain-name)))
			     (delete-system :visidoc-server :keep-symbols *keep-symbols* :recursivep t)))

	  ;; 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
					   (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)))

(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.
  ;;  9/08/89 DNG - Make sure (FIRST X) is a character [could be NIL] before 
  ;;		calling ASK-UNLESS-BATCH.  [SPR 10608, 10609]
  (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)))))
		       (or (not (characterp (first x)))
			   (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)))