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

;;; Reason: Fix DELETE-DEBUG-INFO to prevent error on an interpreted function which has debug info represented as a list. 
;;;    LER 11/30/88

;;;                           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) 1988 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 11/30/88 11:15:19 by reiner,
;;; while running on NOVEMBER from band LOD1
;;; With SYSTEM 5.8, VIRTUAL-MEMORY 5.4, EH 5.1, MAKE-SYSTEM 5.1, MICRONET 5.2, LOCAL-FILE 5.0,
;;;  BASIC-PATHNAME 5.1, NETWORK-SUPPORT-COLD 5.0, BASIC-NAMESPACE 5.1, NETWORK-NAMESPACE 5.0,
;;;  DISK-IO 5.3, DISK-LABEL 5.1, BASIC-FILE 5.3, MAC-PATHNAME 5.0, NETWORK-PATHNAME 5.0,
;;;  COMPILER 5.0, TV 5.1, DATALINK 5.4, CHAOSNET 5.3, GC 5.1, MEMORY-AUX 5.0, NVRAM 5.0,
;;;  SYSLOG 5.0, STREAMER-TAPE 5.3, UCL 5.0, INPUT-EDITOR 5.0, METER 5.0, ZWEI 5.5,
;;;  DEBUG-TOOLS 5.0, NETWORK-SUPPORT 5.0, NETWORK-SERVICE 5.0, DATALINK-DISPLAYS 5.0,
;;;  FONT-EDITOR 5.0, SERIAL 5.0, PRINTER 5.5, MAC-PRINTER-TYPES 5.0, PRINTER-TYPES 5.2,
;;;  IMAGEN 5.1, SUGGESTIONS 5.0, MAIL-DAEMON 5.0, MAIL-READER 5.0, TELNET 5.0, VT100 5.0,
;;;  NAMESPACE-EDITOR 5.1, PROFILE 5.0, VISIDOC 5.3, IP 3.29, Experimental BUG 10.2,
;;;  SHRINK-TOOLS 5.0,  microcode 583, Band Name: Rel 5.0 + IP 10/7

#!C
; From file BAND-CLEANER.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; BAND-CLEANER.É#É"


(defun delete-debug-info (&optional &key
			    (user t)
			    (zwei t)
			    (compiler nil)
			    (arglists-and-local-maps nil)
			    (debug-info-struct nil))
  "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)
		     ; The property :COMPILATION-DEFINED should be removed from symbols whose
		     ; function cell is not empty
		(remprop atom :compilation-defined)
		(when compiler (remprop atom :compilation-defined)))
	  (if debug-info-struct		   ;either...
	      (set-debug-info-struct atom nil)   ;...stomp the debug info structure completely
	      ;;...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
			               ;; Remove the following from the property list and
			               ;; 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)			     
			           ; retain :macros-expanded for functions having the INLINE 
			           ; 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)))
		  ;; Remove interpreted definitions of compiled functions unless
		  ;; 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      ; don't remove arglists of special forms,
			     	                          ; it will break the evaluator, also leave
                                                                 ; microcode function arglists intact
                                                                 ; 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			   ;remove documentation properties
	  (remprop atom :documentation)
	  (remprop atom 'sys:documentation-property))
	(when zwei			   
	  (remprop atom 'zwei:lisp-indent-offset)  ;remove editor indention advice
	  (remprop atom :source-file-name) ;and source file names
	  (remprop atom 'zwei:zmacs-buffers))
	(when compiler			   ;remove compiler properties
	    (let ((compiler-package (find-package 'compiler))
		  (compiler-keywords
		    (and (fboundp 'disassemble)
			 ; 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)))
                                     ; the following arglist is used for checking number of
                                       ; args by the compiler and for documentation of subprimitives
	      (remprop atom 'arglist)))
	))  ;; dolist
  (when zwei
	; 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)	   ;remove source file name from function spec table
		 (when (eq (second key) :source-file-name)
		   (remhash key function-spec-hash-table)))
	     function-spec-hash-table)))

))
