;;; -*- 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 52.227-7013. *
;1;;*
;1;; TEXAS INSTRUMENTS INCORPORATED, P.O. BOX 2909 AUSTIN, TEXAS 78769  *
;1;; Copyright (C) 1987-1989 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. 
(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 objects3.*")))
    
    (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)))

(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 debug-info-struct		   ;1either...*
	      (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)))))