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