;;; -*- Mode: Common-Lisp; Package: SYS; Base: 10.; Patch-File: T -*-

;;; Reason: Added special handling for CHAOSNET and VISIDOC-SERVER in  *system-deletion-table*. [10665]

;;;                           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.

;;; Patch file for SHRINK-TOOLS version 6.3
;;; Written 11/30/89 08:10:32 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.É#É"


(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))
	  (:visidoc-server (let ((server-list  (when (find-symbol "*VISIDOC-SERVER-NAMESPACES*" 'dox)
						 (symbol-value (find-symbol "*VISIDOC-SERVER-NAMESPACES*" 'dox)))))
			     (debug-print "   Flushing Visidoc Servers.")
			     (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.")
))
