;;; -*- Mode:Common-Lisp; Package:USER; Base:10; Fonts:(CPTFONT CPTFONTB HL12BI) -*-

2;;;   Test band-shrinking tools.*

(defvar *failure-count* 0)
(proclaim '(ftype (function (&rest t) t)
		  sys:delete-system sys:band-cleaner sys:tree-shake))

(defun 1shrink-test* (&rest args &key selective verbose keep-symbols
		    (purge-packages '("USER" "IP" "CHAOS" "ZWEI" "MAIL"))
		    (kill-packages '())
		    dribble-file disk-save-partition (unit 0) partition-comment
		    &aux result)
  2"Test the band-shrinking tools by trimming and disk-saving the current band.
This will cut a network band down to approximately a delivery band plus 
windows, UCL, and Lisp Listener."*
  (check-type disk-save-partition (or null string))
  (check-type partition-comment (or null string))
  (check-type unit (integer 0 99))
  (check-type keep-symbols (or list symbol))
  (check-type purge-packages (or list package))
  (if dribble-file
      (with-open-file ( copy-stream dribble-file :direction ':output )
	(let (( *standard-output* (make-broadcast-stream copy-stream
							 *standard-output*)))
	  (format t "~&Shrink test     ")
	  (when disk-save-partition
	    (format t "~A:~D ~S ~S    "
		    si:local-host unit disk-save-partition
		    (or partition-comment "")))
	  (time:print-current-time)
	  (terpri)
	  (apply #'shrink-test :dribble-file nil :disk-save-partition nil args)
	  (format t "~2%Finished at ")(time:print-current-time) (terpri) )
	(setq result (truename copy-stream)))
    (let ((more tv:more-processing-global-enable)
	  (*failure-count* 0))
      (unwind-protect
	  (progn ;; Set instead of bind else GC notifications don't see it.
	    (setq tv:more-processing-global-enable selective)
	    (make-system 'shrink-tools (if selective :noop :noselective))
	    (dolist (x '( profile ; this first because it saves Zmacs buffers
			 serial printer mt glossary mailer mail-reader
			 visidoc  "font editor" unfasl who-calls
			 compiler finger converse chaosnet-window chaosnet
			 "namespace editor" :network-extras imagen
			 vt100 telnet IP infix plane ZLC
			 notify :network nfs-server hostat
			 peek inspect debug-tools zmacs "hard copy menu" meter
			 datalink trace grindef advise apropos
			 "Network Data-Link Displays"))
	      (format *debug-io* "~&Deleting ~A ...~%" x)
	      (sys:1delete-system* x :batch (not selective) :verbose verbose
				   :keep-symbols keep-symbols))
	    (dolist (x '( print-file profile fed si:unfasl who-calls compile 
			 compile-file finger chaos:reset vt100 telnet plane-aref
			 zlc:globalize zlc:array-dimension-n zlc:status
			 hostat peek inspect inspect-flavor ed trace grindef
			 advise apropos))
	      (when (fboundp x)
		(failure "function ~S was not deleted." x)))
	    (dolist (x '( serial printer mt glossary mailer mail-reader
			 visidoc  profile fed
			 compiler converse chaosnet-window chaosnet
			 "namespace editor" imagen
			 vt100 telnet IP 
			 notify :network nfs-server hostat
			 peek debug-tools zmacs "hard copy menu" meter
			 datalink trace))
	      (when (or (si:get-system-version x)
			(si:system-made-p x))
		(failure "system ~A was not deleted." x))
	      (when (member x *modules* :test #'string=)
		(failure "~S was not removed from *MODULES* list."
			(string x)))
	      (when (and (symbolp x)
			 (member (find-symbol (string x) *keyword-package*)
				 *features* :test #'eq))
		(failure "~A was not removed from *FEATURES* list."
			x))
	      )
	    (when (boundp 'tv:*system-keys*)
	      (dolist (c '(#\B #\C #\M #\F #\V #\T #\P #\I #\E #\H))
		(when (assoc (the character c) tv:*system-keys*)
		  (failure "~S was not removed from the SYSTEM key." c))))
	    (when (fboundp 'TV:COLUMN-TYPE-KEYWORD-TO-COLUMN-VARIABLE)
	      (dolist (column '(:USER-AIDS :PROGRAMS :DEBUG))
		(let ((var (TV:COLUMN-TYPE-KEYWORD-TO-COLUMN-VARIABLE column)))
		  (when (boundp var)
		    (dolist (item (symbol-value var))
		      (unless (string-equal (car item) "Lisp Listener")
			(failure "~S was not removed from the system menu."
				 (car item))
			))))))
	    (unless (and selective
			 (not (y-or-n-p "Run BAND-CLEANER?")))
	      (si:1band-cleaner* :unused-pathnames nil))
	    (sys:delete-system 'sys:band-cleaner :batch (not selective)
			       :verbose verbose)
	    (sys:delete-system 'sys:delete-system :batch (not selective)
			       :verbose verbose)
	    (sys:1tree-shake* :clean-packages
			        (set-difference sys:*packages-to-be-cleaned*
						purge-packages
						:test #'string-equal)
			      :purge-packages purge-packages
			      :kill-packages kill-packages
			      :keep-symbols keep-symbols
			      :batch (not selective) :undo-previous-training t
			      :kamikaze t)
	    (dolist (x '((CHAOS 500) (IP 1500) (MAIL 500) (NSE 600)
			 (TELNET 400) (ZWEI 4000)))
	      (let ((pkg (find-package (first x))))
		(when (and pkg
			   (> (sys:pack-number-of-symbols pkg) (second x)))
		  (failure "too many symbols left in package ~A."
			  (first x)))))
	    )
	(setq tv:more-processing-global-enable more)
	)
      (format t "~2&Test completed with ~S failures.~%" *failure-count*)
      ))
  (beep)
  (let ((no-query nil))
    (when (and disk-save-partition
	       (let ((tv:more-processing-global-enable nil))
		 (with-timeout ((* 60. 30.) ; 30 seconds
				(format *query-io* "Timed out, Yes.")
				(setq no-query t) t)
		   (y-or-n-p "DISK-SAVE to ~S?" disk-save-partition))))
      (fmakunbound 'shrink-test)
      (1gc-and-disk-save* disk-save-partition unit
			:partition-comment partition-comment :no-query no-query)))
  result)

(defun failure (format-string &rest format-args)
  (incf *failure-count*)
  (format t "~&*** Failure: ")
  (apply #'format t format-string format-args)
  (values))