;;; -*- Mode:Common-Lisp; Package:SYSTEM; Fonts:(MEDFNT HL12B HL12I MEDFNT MEDFNB); Base:10 -*-
;;;
;Ï1;;                                    RESTRICTED RIGHTS LEGEND Ï*
;Ï1;; Use,  duplication, or  disclosure  by  the  Government is subject to restrictionsÏ*
;Ï1;; as set forth in subdivision (c)(1)(ii) of the Rights in Technical Data andÏ*
;Ï1;; Computer Software clause at 252.227-7013. Ï*
;Ï1;;Ï*
;Ï1;; TEXAS INSTRUMENTS INCORPORATED, P.O. BOX 149149 AUSTIN, TEXAS 78714-9149  Ï*
;Ï1;; Copyright (C) 1987,1988,1989,1990 Texas Instruments Incorporated. All rights reserved.Ï*

;;  2/05/88 DNG - Separate GC'ing of pathnames from clearing pathname properties.
;;  2/08/88 DNG - Add "Done" message at end.
;;  2/09/88 DNG - Warn if any pathnames are created while they are being GC'd.
;;  2/20/88 DNG - GC'ing of unused pathnames moved to "PATHNAME;BASIC-FLAVORS" file.
;;  2/25/88 DNG - Save :QFASL-SOURCE-FILE-UNIQUE-ID property when keeping 
;;		Zmacs properties and type is other than LISP.
;;  3/01/88 DNG - Wrap IGNORE-ERRORS around GET-DEBUG-INFO-STRUCT.
;;  3/05/88 DNG - Modify DELETE-DEBUG-INFO to keep the interpreted definitions 
;;		of DEFSUBST functions that can be used as the destination of
;;		SETF.  Keep property COMPILER:SYSTEM-CONSTANT for CONSTANTP.
;;  3/21/88 DNG - Fix DELETE-DEBUG-INFO to preserve SETF of SECOND, THIRD, 
;;		etc. by checking for SETF-EXPAND property as well as SETF-METHOD.
;;  11/30/88 LER - Fix DELETE-DEBUG-INFO to prevent error on an interpreted function
;;                 which has debug info represented as a list. 
;;  10/05/89 DNG - In DELETE-DEBUG-INFO, don't discard the debug info 
;;		structure of a generic function because it is needed by %CLASS-DESCRIPTION 
;;		for method dispatch [see TICLOS::%FEF-CLASS-DESCRIPTION ].
(export '(BAND-CLEANER))

(DEFUN BAND-CLEANER (&key 
		     (unused-pathnames nil)
		     (cdr-code-plists t)
		     (previous-defs t)
		     (debug-structures nil)
		     (doc-strings t)
		     (zmacs-properties :zmacs-loaded-p)
		     (compiler-properties :compiler-loaded-p)
		     (arglists-and-local-maps nil)
		     (pathname-properties :make-system)
		     (verbose t))
  Ï2"Selectively remove or improve on the following items from a band:
UNUSED-PATHNAMES: true => delete old pathname objects (takes awhile)
PATHNAME-PROPERTIES: true =>deletes all property list items from generic pathnames
              :make-system => delete  property list items that are not used by make-system
CDR-CODE-PLISTS:  true => benefits size and speed of property lists
PREVIOUS-DEFS:    true => removes previous definition information
DEBUG-STRUCTURES: true => removes debug structures entirely (not recommended for use)
DOC-STRINGS:     true => removes documentation strings,descriptive arglists, function-parent,
                self-flavor, macros-expanded and value lists from debug-info structure, also compacts
                the patch-systems-list
ZMACS-PROPERTIES: true => removes source file, zmacs-buffer and zmacs indentation properties.
           :zmacs-loaded-p => will remove zmacs properties only if zmacs has
                 not been loaded.  A value of nil will preserve zmacs properties.
COMPILER-PROPERTIES:    true => removes compiler propeties {P1,OPTIMIZERS,etc.} 
               and arglists from the symbol plist and interpreted definitions from the debug-info-structures
          :compiler-loaded-p => will remove arguments only if the compiler is not in
          the band.  A value of nil will preserve compiler properties
ARGLISTS-AND-LOCAL-MAPS:   true => remove arglist and local maps from debug info structure
VERBOSE:  True => progress messages are printed."Ï*
   
  (let ((ship-min-plist-to-cdr-code          2))

    (when compiler-properties
      (if (eq compiler-properties :compiler-loaded-p)
	  (setf compiler-properties (not (fboundp 'compile)))	  
	  (if (fboundp 'compile)
	      (cerror "Continue, deleting properties"
		      "Compiler will no longer be functional after removing its properties"))))
	      
    (when  zmacs-properties
      (if (eq zmacs-properties :zmacs-loaded-p)
	  (setf zmacs-properties (not (fboundp 'ed)))
	  (if (fboundp 'ed)
	      (unless (y-or-n-p "Meta point will no longer work in Zmacs.  Continue? (Y/N)")
		(return-from band-cleaner (values))))))

    (if (and  arglists-and-local-maps (fboundp 'ucl:check-function-arglist))
          (unless (y-or-n-p "Functions with arguments will no longer work.  Continue? (Y/N)")
		  (return-from band-cleaner (values))))
    
    (setf sys:*flavor-compilations* () )
    (setf sys:warnings-pathnames nil)
    
    ;Ï1; ORDERING NOTE:  The call to CDR-CODE-PLISTS must come last in the following sequenceÏ*
    (when (or doc-strings zmacs-properties compiler-properties
	      debug-structures arglists-and-local-maps)
      (when verbose (format t "Ï3~%Deleting debug information...Ï*"))
      (delete-debug-info :user  doc-strings
			 :zwei zmacs-properties
			 :compiler compiler-properties
			 :debug-info-struct debug-structures
			 :arglists-and-local-maps arglists-and-local-maps))
    
    (when doc-strings (reset-systems-list verbose))
    
    (if previous-defs
	(progn
	  (when verbose (format t "Ï3~%Deleting previous definitions...Ï*"))
	  (delete-previous-definition-property verbose)
	  (when verbose (princ "Ï3done.Ï*")))	 
	(when verbose (format t "Ï3~%Skip deleting previous definitions.Ï*")))
    
    (if cdr-code-plists
	(progn
	  (when verbose (format t "Ï3~%CDR CODING property lists...Ï*"))
	  (cdr-code-plists ship-min-plist-to-cdr-code verbose)
	  (when verbose (princ "Ï3done.Ï*")))
	(when verbose (format t "Ï3~%Skip CDR CODING property lists.Ï*")))
    
    (if unused-pathnames
	(let ((count (hash-table-count fs:*pathname-hash-table*)))
	  (when verbose (format t "Ï3~%Removing old pathname objects...Ï*"))
	  (setf si:fasloaded-file-truenames nil)	   ;this list isn't used
	  (setf si:cold-load-function-property-lists nil)
	  (gc-pathnames)
	  (when verbose
	    (format t " Deleted ~S out of ~S pathnames."
		    (- count (hash-table-count fs:*pathname-hash-table*)) count)
	    ))
	(when verbose (format t "Ï3~%Skip Ï*removal of pathname objectsÏ3.Ï*")))
    
    (when pathname-properties
      (when verbose (format t "Ï3~%Removing Ï*pathname properties Ï3...Ï*"))
      (clean-pathnames pathname-properties compiler-properties zmacs-properties))
    (when verbose (format t "Ï3~%Ï*Done."))
    );Ï1;letÏ*
  (values)
  )

(Defmacro DO-EVERY-OTHER ((var list resultform) &BODY body)
  Ï2"Iterate BODY with VAR bound to every other successive element of the value of LIST.
If LIST is exhausted, RESULTFORM is executed and returned.
RETURN and GO can be used inside the BODY."Ï*
  (LET ((iteration-var (GENSYM)))
    `(DO ((,iteration-var ,list (CDDR ,iteration-var))
	  (,var ))
	 ((NULL ,iteration-var) ,resultform)
       (SETQ ,var (CAR ,iteration-var))
       . ,body)))

(unless (fboundp 'ticlos:generic-function-p) ; ensure defined for use below
  (setf (symbol-function 'ticlos:generic-function-p) #'ignore))

(defun Ï4delete-debug-infoÏ* (&optional &key
			    (user t)
			    (zwei t)
			    (compiler nil)
			    (arglists-and-local-maps nil)
			    (debug-info-struct nil))
  Ï2"This function goes through the the system and blows away 
   the debug information.  A non-nil value for:
   USER removes documentation strings, descriptive arglists, function-parent, self-flavor,
       macros-expanded and value lists;
   ZWEI removes indention information and source file pathnames;
   COMPILER deletes interpreted definitions from debug-info-struct and removes from the 
           symbol-plist the compiler information and arglist.
   ARGLISTS-AND-LOCAL-MAPS deletes the argument lists and deletes local maps 
                         from the debug-info-struct
  DEBUG-INFO-STRUCT deletes the debug information structure completely
                   (error-handler backtraces will not be meaningfull).
   Caution:  use of this may make it difficult or impossible
   to develop, debug, or compile code."Ï*
  (dolist (pkg (list-all-packages))
      (do-local-symbols (atom pkg)
	  (if (fboundp atom)
		Ï2     ; The property :COMPILATION-DEFINED should be removed from symbols whoseÏ*
		Ï2     ; function cell is not emptyÏ*
		(remprop atom :compilation-defined)
		(when compiler (remprop atom :compilation-defined)))
	  (if (and debug-info-struct		   ;Ï1either...Ï*
		   (not (ticlos:generic-function-p atom)))
	      (set-debug-info-struct atom nil)   ;Ï1...stomp the debug info structure completelyÏ*
	      ;;Ï1...or selectivelyÏ*
	      (let ((debug-structure (if (fboundp atom)
					 (ignore-errors ; could be indirected to undefined symbol
					   (get-debug-info-struct atom)))))     
		(when (debug-info-struct-p debug-structure)

		  (when user
			               Ï1;; Remove the following from the property list andÏ*
			               Ï1;; store it back into the debug-info-structÏ*
			(let ((dbis-temp-plist (DBIS-PLIST debug-structure)))
			     (remf dbis-temp-plist :documentation)
			     (remf dbis-temp-plist :descriptive-arglist)
			     (remf dbis-temp-plist :values)
			     (remf dbis-temp-plist :self-flavor)
			     (remf dbis-temp-plist :function-parent)			     
			           Ï1; retain :macros-expanded for functions having the INLINE Ï*
			           Ï1; property if the compiler information is not being deleted also.Ï*
			     (when (or compiler (not (get atom 'inline)))
				   (remf dbis-temp-plist :macros-expanded))
			     (put-debug-info-field
			       debug-structure :plist dbis-temp-plist)))
		  Ï1;; Remove interpreted definitions of compiled functions unlessÏ*
		  Ï1;; needed by the compiler or by the SETF macro.Ï*
		  (unless (or (not compiler)
			      (and (not (getl atom '(si:setf-method si::setf-expand)))
				   (compiled-subst? (symbol-function atom))
				   (ignore-errors
				     (let ((body (parse-body
						   (cdr (si:lambda-exp-args-and-body
							  (si:get-debug-info-field
							    debug-structure
							    :interpreted-definition)))
						   nil t)))
				       (and (= (length body) 1)
					    (let ((exp (macroexpand (first body))))
					      (if (symbolp exp)
						  (not (get exp 'compiler:system-constant))
						(getl (first exp)
						      '(si:setf-method si::setf-expand))
						)))))))
		    (put-debug-info-field debug-structure :interpreted-definition nil)
		    )
		  (when arglists-and-local-maps     Ï1 ; don't remove arglists of special forms,Ï*
			Ï1     Ï*	Ï1                  Ï*     Ï1   ; it will break the evaluator, also leave
                                               Ï*            Ï1      ; microcode function arglists intact
                                                 Ï*            Ï1    ; for the compilerÏ*
			(when (and compiler (not (special-form-p atom))
				   (not (typep (function atom) 'microcode-function)))
			      (put-debug-info-field debug-structure :arglist nil))
		    (put-debug-info-field debug-structure :local-map nil))
		  )))
	
	(when user			   ;Ï1remove documentation propertiesÏ*
	  (remprop atom :documentation)
	  (remprop atom 'sys:documentation-property))
	(when zwei			Ï1   Ï*
	  (remprop atom 'zwei:lisp-indent-offset)  ;Ï1remove editor indention adviceÏ*
	  (remprop atom :source-file-name) ;Ï1and source file namesÏ*
	  (remprop atom 'zwei:zmacs-buffers))
	(when compiler			   ;Ï1remove compiler propertiesÏ*
	    (let ((compiler-package (find-package 'compiler))
		  (compiler-keywords
		    (and (fboundp 'disassemble)
			 Ï1; keep properties needed by disassemblerÏ*
			 '( compiler:no-reg compiler:dest))))
	      (when (fboundp 'constantp)
		(push 'compiler:system-constant compiler-keywords))
	      (do-every-other (i (symbol-plist atom))
		(when (and (symbolp i)
			   (eq (symbol-package i) compiler-package)
			   (not (member i compiler-keywords :test #'eq)))
		      (remprop atom i)))
                        Ï1             ; the following arglist is used for checking number of
                      Ï*                 Ï1; args by the compiler and for documentation of subprimitivesÏ*
	      (remprop atom 'arglist)))
	))Ï1  ;; dolistÏ*
  (when zwei
	Ï1; size of this array used to be 2400, change to makunbound after fix in kernel;flavor is madeÏ*
    (setf zwei:*all-flavor-names-aarray*
	  (make-array 120 :type 'art-q-list :leader-list '(0 nil)))
    (setf zwei:*zmacs-completion-aarray*  nil)
    (maphash #'(lambda (key ignore)	   ;Ï1remove source file name from function spec tableÏ*
		 (when (eq (second key) :source-file-name)
		   (remhash key function-spec-hash-table)))
	     function-spec-hash-table)))

(defsubst Ï4set-debug-info-struct-into-fefÏ* (fef value)
  (let ((%inhibit-read-only t))
    (and (typep fef 'compiled-function)
	 (%p-store-contents-offset value  fef %fef-debugging-info-word))))

(defsubst Ï4set-debug-info-struct-into-ucodeÏ* (uentry value)
  (let ((%inhibit-read-only t))
    (and (typep uentry 'microcode-function)
	 (setf (aref #'micro-code-entry-debug-info-area (%pointer uentry)) value))))

(defun Ï4set-debug-info-structÏ* (function-object value &optional unencapsulated)
  (typecase function-object
    (symbol
     (set-debug-info-struct (if  unencapsulated
				 (unencapsulate-function-spec function-object)
				 (symbol-function function-object)) value))
    (compiled-function 
     (set-debug-info-struct-into-fef function-object value))
    (microcode-function
     (set-debug-info-struct-into-ucode function-object value))
    (closure 
     (set-debug-info-struct (closure-function function-object) value))
    (t nil)))

(defun Ï4gc-pathnamesÏ* ()
  Ï2"This function clears the pathname hash table, does a full
   gc, then scans the pathname area and reinstalls the survivors."Ï*
  (without-interrupts
    (fs:clear-pathnames-before-gc)
    (unwind-protect
	(si:gc-immediately :max-gen 3 :promote nil)
      (fs:restore-pathnames-after-gc))))

(defun Ï4clean-pathnamesÏ* (pathname-properties compiler-properties zmacs-properties)
  ;; Clean up pathname properties
  (maphash
    #'(lambda (key value)
	(declare (ignore key))
	(send value :reset-print-names)
	(send value :remprop :random-forms)
	(send value :remprop :definitions)
	(send value :remprop :macros-expanded)
	;;  delete all properties except those used by make-system
	(when (and pathname-properties (send value :plist))
	  (if (string-equal pathname-properties :make-system)
	      ;Ï1; remove all but make system propertiesÏ*
	      (let ((maksys-keywords '(:file-id-package-alist
					:systems
					:patch-file)))
		(do ((tail (send value :plist) (cddr tail)))
		    ((null tail))
		  (let ((prop (first tail)))
		    (unless (or (member prop maksys-keywords :test #'eq)
				(and (eq prop :COLD-LOAD) ; used in COMPILER:CHECK-COLD
				     (not compiler-properties))
				(and (eq prop :QFASL-SOURCE-FILE-UNIQUE-ID)
				     ;; Used by FS:GENERIC-PATHNAME-SOURCE-PATHNAME
				     ;; Need to keep if type is not LISP in order for
				     ;; META-. to be able to find the source file.
				     (not zmacs-properties)
				     (pathnamep (second tail))
				     (neq (send (second tail) :CANONICAL-TYPE) :LISP))
				)
		      (send value :remprop prop)))))
	    ;Ï1; remove all propertiesÏ*
	    (send value :set-property-list nil))
	  ))
    fs:*pathname-hash-table*)
  (values))


(DEFUN Ï4CDR-CODE-PLISTSÏ* (min-length-to-cdr-code verbose)
Ï1  ;; This function searches all symbols in all packages for plists equal to or longer than
  ;; MIN-LENGTH-TO-CDR-CODE.  Each such plist is then replaced with its CDR-CODED
  ;; version.  If the symbol is not in the resident symbol area, then the new CDR-CODED
  ;; list is consed in the same area as the symbol.
Ï2  Ï*Ï*
  (let ((count (length (list-all-packages))))
    (dolist (pkg (list-all-packages))
      (when verbose
	(format t "Ï3~D Ï*" count)
	(decf count))
      (do-local-symbols (symbol pkg)
	(when (>= (length (symbol-plist symbol)) min-length-to-cdr-code)
	  ;Ï1; then this plist is long enough for CDR-CODING to do some goodÏ*
	  (let ((default-cons-area sys:property-list-area))
	    (setf (symbol-plist symbol) (copy-list (symbol-plist symbol))))))))
  );Ï1;cdr-code-plistsÏ*


(DEFUN Ï4DELETE-PREVIOUS-DEFINITION-PROPERTYÏ* (verbose)
  ;Ï1; This function deletes the :PREVIOUS-DEFINITION property from all symbols in all packages and fromÏ*
  ;Ï1; the function-spec hash table.Ï*
  (let ((count (length (list-all-packages))))
    (dolist (pkg (list-all-packages))
      (when verbose
	(format t "Ï3~D Ï*" count)
	(decf count))
      (do-local-symbols (symbol pkg)
	(remf (symbol-plist symbol) :previous-definition))))
  
  (maphash #'(lambda (key value)
	       (declare (ignore value))
	       (when (eq (second key) :previous-definition)
		 (remhash key function-spec-hash-table)))
	   function-spec-hash-table)
  );Ï1;delete-previous-definition-propertyÏ*

(defun reset-systems-list (verbose)
  "Clean up the patch-systems-list by removing all but the last item for each system"
  (when verbose (format nil "~%Cleaning up patched systems list~%"))
  ;;  the fourth element is the list of patches, save the patch level number and 
  ;;  clear the descriptions and authors
  (dolist (sys-name sys:patch-systems-list)
    (setf (fourth sys-name) (list (list (car (car (fourth sys-name))) "" "" NIL)))))

