;-*- Mode:Common-Lisp; Package:SI; Base:10. -*-



;;;                           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
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved.

;These things were written by RMS.  You can use them,
;if you return all improvements for redistribution.

;;; Record warnings about objects processed by file-transducers, etc.
;;; (primarily the compiler).

;To perform an operation on a file and report warnings on "objects" in it,
;do something like this:
;(FILE-OPERATION-WITH-WARNINGS (generic-pathname operation-name whole-file-p)
;   ... loop over the objects
;   (OBJECT-OPERATION-WITH-WARNINGS (object-name location-funcion)
;     ... do the operation, and maybe issue a warning with
;     (RECORD-WARNING type severity location-info format-string args...)
;     ...)
;   ...)

;Operation names include :COMPILE and :EVAL.
;Location-function and location-info are features not really used yet;
;just use nil for now.
;Severity is a keyword; the meanings of severities are not yet defined.
;Whole-file-p should eval to T if you are processing everything in the file.
;It tells the warnings system to assume that any objects you don't mention
;should have their warnings forgotten.


;Warnings about files are on the :warnings property of a generic pathname;
;all the warnings about all objects not in files
;go in the variable non-file-warnings-operation-alist.

(DEFVAR NON-FILE-WARNINGS-OPERATION-ALIST NIL "Warnings datum for objects not in files.") 


(DEFVAR WARNINGS-PATHNAMES '(T)
   "All generic pathnames that have warnings, plus T for non-file objects.") 

;These are used in printing out objects mentioned in warnings

(DEFPARAMETER WARNINGS-PRINLEVEL 4) 

(DEFPARAMETER WARNINGS-PRINLENGTH 4) 


(DEFPROP :COMPILE "compilation" NAME-AS-ACTION) 

(DEFPROP :COMPILE "compiling" NAME-AS-PRESENT-PARTICIPLE) 

(DEFPROP :COMPILE "compiled" NAME-AS-PAST-PARTICIPLE) 

(DEFPROP :COMPILE "compiler" NAME-AS-AGENT) 


(DEFPROP :EVAL "evaluation" NAME-AS-ACTION) 

(DEFPROP :EVAL "evaluating" NAME-AS-PRESENT-PARTICIPLE) 

(DEFPROP :EVAL "evaluated" NAME-AS-PAST-PARTICIPLE) 

(DEFPROP :EVAL "evaluator" NAME-AS-AGENT)

;;12/07/87 CLM - added the following forms so that the CWARNS file
;;in batch make-systems can capture the warnings issued for Loads 
;;and Reads as well as compiles.

(DEFPROP :LOAD "loading" NAME-AS-ACTION) 

(DEFPROP :LOAD "loading" NAME-AS-PRESENT-PARTICIPLE) 

(DEFPROP :LOAD "loaded" NAME-AS-PAST-PARTICIPLE) 

(DEFPROP :LOAD "loader" NAME-AS-AGENT)


(DEFPROP :FASLOAD "loading" NAME-AS-ACTION) 

(DEFPROP :FASLOAD "loading" NAME-AS-PRESENT-PARTICIPLE) 

(DEFPROP :FASLOAD "loaded" NAME-AS-PAST-PARTICIPLE) 

(DEFPROP :FASLOAD "loader" NAME-AS-AGENT)
 

(DEFPROP :READ "reading" NAME-AS-ACTION) 

(DEFPROP :READ "reading" NAME-AS-PRESENT-PARTICIPLE) 

(DEFPROP :READ "read" NAME-AS-PAST-PARTICIPLE) 

(DEFPROP :READ "reader" NAME-AS-AGENT)
 

;Wherever found, the file-warnings-operation-alist is a list of file-warnings-datums,
;each recording the information about one kind of operation 
;(eg, :COMPILE for compilation).

(DEFSTRUCT (FILE-WARNINGS-DATUM (:CONC-NAME FILE-WARNINGS-) (:CONSTRUCTOR MAKE-FILE-WARNINGS (OPERATION))
  (:CALLABLE-CONSTRUCTORS NIL) (:ALTERANT ALTER-FILE-WARNINGS-DATUM) (:PREDICATE NIL)
  (:COPIER NIL) (:TYPE :LIST*))
 ;; The file operation (such as :COMPILE) this is about.
  OPERATION
  ;; The editor buffer these warnings have been printed into.
  EDITOR-BUFFER
  ;; The alist of objects in the file and their warnings.
  OBJECT-ALIST) 

;The object-alist is the warnings about that operation (such as, compilation)
;on objects in that file.  It is a list of object-warnings-datums.

;This data type records the warnings on one object (eg, one function) in a file
;(or maybe, not in a file).

(DEFSTRUCT (OBJECT-WARNINGS-DATUM (:CONC-NAME OBJECT-WARNINGS-)
  (:CONSTRUCTOR MAKE-OBJECT-WARNINGS (NAME LOCATION-FUNCTION)) (:CALLABLE-CONSTRUCTORS NIL)
  (:ALTERANT ALTER-OBJECT-WARNINGS-DATUM) (:PREDICATE NIL) (:COPIER NIL) (:TYPE :LIST*))
 ;; The name of the object this is about.
  NAME
  ;; Information for finding this object's definition.
  ;; If NIL, use Edit Definition on the object name.
  ;; If any other symbol, use its :location-function property to visit the warning site(s).
  LOCATION-FUNCTION
  ;; random other info, perhaps provided for the editor to use.
  PLIST
  ;; The warnings for this object.
  WARNINGS) 

;This data type contains one warning.
;The type SI:PREMATURE-WARNINGS-MARKER
;(with severity NIL) is a marker that follows any premature warnings
;(for unnamed data before this object).

(DEFSTRUCT (WARNING-DATUM (:CONC-NAME WARNING-)
  (:CONSTRUCTOR MAKE-WARNING (TYPE SEVERITY LOCATION-INFO FORMAT-STRING FORMAT-ARGS))
  (:CALLABLE-CONSTRUCTORS NIL) (:ALTERANT ALTER-WARNING-DATUM) (:PREDICATE NIL) (:COPIER NIL)
  (:TYPE :LIST*))
 ;; A keyword saying what the warning is about.
  TYPE
  ;; A keyword giving the severity level of this warning.
  SEVERITY
  LOCATION-INFO
  ;; The next two are used for printing the warning.
  FORMAT-STRING
  FORMAT-ARGS) 

;Given a generic pathname, or t or nil for non-file objects,
;return the file-warnings-operation-alist for it.

(DEFUN FILE-WARNINGS-OPERATION-ALIST (GENERIC-PATHNAME)
  "Returns the list of file-warnings-datums for the specified file.
There is a file-warnings-datum in the value for each operation
for which this file has any warnings.  You can SETF this."
  (IF (MEMBER GENERIC-PATHNAME '(T NIL) :TEST #'EQ)
    NON-FILE-WARNINGS-OPERATION-ALIST
    (FUNCALL GENERIC-PATHNAME :GET :WARNINGS))) 


(DEFDECL FILE-WARNINGS-OPERATION-ALIST SETF
   ((FILE-WARNINGS-OPERATION-ALIST PN) SET-FILE-WARNINGS-OPERATION-ALIST PN VALUE)) 


(DEFUN SET-FILE-WARNINGS-OPERATION-ALIST (GENERIC-PATHNAME NEW-ALIST)
  (AND NEW-ALIST (NOT (MEMBER GENERIC-PATHNAME WARNINGS-PATHNAMES :TEST #'EQ))
     (PUSH GENERIC-PATHNAME WARNINGS-PATHNAMES))
  (IF (MEMBER GENERIC-PATHNAME '(T NIL) :TEST #'EQ)
    (SETQ NON-FILE-WARNINGS-OPERATION-ALIST NEW-ALIST)
    (FUNCALL GENERIC-PATHNAME :PUTPROP NEW-ALIST :WARNINGS))) 


(DEFUN EXAMINE-FILE-WARNINGS (GENERIC-PATHNAME OPERATION)
  "Return the file-warnings-datum for the specified file and operation, or NIL.
T or NIL as the pathname refers to non-file objects.
The operation is a keyword such as :COMPILE."
  (ASSOC OPERATION (FILE-WARNINGS-OPERATION-ALIST GENERIC-PATHNAME) :TEST #'EQ)) 


(DEFUN FILE-WARNINGS-OPERATIONS (GENERIC-PATHNAME)
  "Returns a list of all operations for which warnings are recorded for the specified file.
An operation is a keyword such as :COMPILE.
T or NIL used as an argument refers to non-file objects."
  (LOOP FOR OPER IN (FILE-WARNINGS-OPERATION-ALIST GENERIC-PATHNAME) WHEN
     (FILE-WARNINGS-OBJECT-ALIST OPER) COLLECT (CAR OPER))) 


(DEFUN WARNINGS-PATHNAMES NIL
  "Returns a list of all generic pathnames that have warnings recorded for them.
T or NIL as an element of the value refers to non-file objects."
  (REMOVE-IF-NOT #'FILE-HAS-WARNINGS-P WARNINGS-PATHNAMES)) 


(DEFUN FILE-HAS-WARNINGS-P (GENERIC-PATHNAME)
  "Returns T if the specified file has any warnings recorded for it.
T or NIL as an argument refers to non-file objects."
  (LOOP FOR OPER IN (FILE-WARNINGS-OPERATION-ALIST GENERIC-PATHNAME) WHEN
     (FILE-WARNINGS-OBJECT-ALIST OPER) RETURN T)) 

;Copies the fixed part of an object-warnings-datum.
;This is the only part that is modified destructively.
;The warnings list itself is only pushed onto or changed wholesale.

(DEFUN COPY-OBJECT-WARNINGS (OBJECT-WARNINGS)
  (LIST* (FIRST OBJECT-WARNINGS) (SECOND OBJECT-WARNINGS) (COPY-LIST (THIRD OBJECT-WARNINGS))
	 (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS))) 

;; Macros for use by things that record warnings.


;This is the file-warnings-datum we are currently recording warnings in.

(DEFVAR FILE-WARNINGS-DATUM NIL) 

;This is the generic pathname we are recording warnings for a file operation on,
;or T if we are recording warnings for an object not associated with any file.
;or NIL if we are not set up for recording warnings about anything.

(DEFVAR FILE-WARNINGS-PATHNAME NIL) 

;This is the link in the object-alist after which we are adding new objects.
;Everything up to here is the "front half" of the object alist.
;Everything after is the "back half".
;The back half is thrown away at the end of a whole-file operation.

(DEFVAR FILE-WARNINGS-PUSHING-LOCATION NIL) 

;This is a list of warnings recorded when there was no object set up to warn about.
;They are put here, and the next time an object is started, they are attached to it.

(DEFVAR PREMATURE-WARNINGS NIL) 

;This is a list of warnings recorded when there was no object set up,
;but which apply directly to the next object to be set up
;rather than to something anonymous that preceded it.

(DEFVAR PREMATURE-WARNINGS-THIS-OBJECT NIL) 

;Macros FILE-OPERATION-WITH-WARNINGS and NON-FILE-OPERATION-WITH-WARNINGS
;are in LMMAC.

;At the beginning of an operation on a file,
;make an object for warnings on this file and operation if there isn't one,
;and also initialize the list of objects we have had warnings on this time thru.
;Specify T or NIL as the pathname for a non-file-associated operation.

(DEFUN BEGIN-FILE-OPERATION (GENERIC-PATHNAME OPERATION-TYPE &AUX (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
  (OR GENERIC-PATHNAME (SETQ GENERIC-PATHNAME T))
  (OR (EQ FILE-WARNINGS-PATHNAME GENERIC-PATHNAME)
     (LET ((FILE-WARNINGS-OPERATION-ALIST (FILE-WARNINGS-OPERATION-ALIST GENERIC-PATHNAME)))
       (OR (MEMBER GENERIC-PATHNAME WARNINGS-PATHNAMES :TEST #'EQ)
	  (PUSH GENERIC-PATHNAME WARNINGS-PATHNAMES))
       (OR (ASSOC OPERATION-TYPE FILE-WARNINGS-OPERATION-ALIST :TEST #'EQ)
	  (PROGN
	    (PUSH (MAKE-FILE-WARNINGS OPERATION-TYPE) FILE-WARNINGS-OPERATION-ALIST)
	    (SET-FILE-WARNINGS-OPERATION-ALIST GENERIC-PATHNAME FILE-WARNINGS-OPERATION-ALIST)))
       (SETQ FILE-WARNINGS-DATUM (ASSOC OPERATION-TYPE FILE-WARNINGS-OPERATION-ALIST :TEST #'EQ))
       (SETQ FILE-WARNINGS-PUSHING-LOCATION
	     (LOCF (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM)))
       (SETQ FILE-WARNINGS-PATHNAME GENERIC-PATHNAME)
       (SETQ PREMATURE-WARNINGS NIL)
       (SETQ PREMATURE-WARNINGS-THIS-OBJECT NIL)
       T))) 

;At the end of an operation on a file,
;flush the info on objects that didn't get warnings this time.

(DEFUN END-FILE-OPERATION NIL
  (SETF (CDR FILE-WARNINGS-PUSHING-LOCATION) NIL)) 

;Macro OBJECT-OPERATION-WITH-WARNINGS is in LMMAC.

;This is the object-name of the object we are currently recording warnings on,
;or NIL if we are not set up to record warnings on an object.

(DEFVAR OBJECT-WARNINGS-OBJECT-NAME NIL) 

;This is the location-info for the object we are going to record warnings on.

(DEFVAR OBJECT-WARNINGS-LOCATION-FUNCTION NIL) 

;This is the object-warnings-datum in which we are recording warnings.

(DEFVAR OBJECT-WARNINGS-DATUM NIL) 


(DEFVAR OBJECT-WARNINGS-PUSHING-LOCATION NIL) 

(DEFUN WARNINGS-WARM-BOOT ()
  ;; called by COMPILER:COMPILER-WARM-BOOT to re-initialize after a crash.
  ;; 10/8/86 DNG - Original.
  (SETQ FILE-WARNINGS-DATUM		NIL
	FILE-WARNINGS-PATHNAME		NIL
	FILE-WARNINGS-PUSHING-LOCATION	NIL
	PREMATURE-WARNINGS		NIL
	PREMATURE-WARNINGS-THIS-OBJECT	NIL
	OBJECT-WARNINGS-DATUM		NIL
        OBJECT-WARNINGS-LOCATION-FUNCTION NIL
        OBJECT-WARNINGS-OBJECT-NAME	NIL
        OBJECT-WARNINGS-PUSHING-LOCATION NIL
     ))

;At the beginning of an operation on an object,
;see if there is already an object-warnings-datum for this object,
;left around from previous operations on it.
;Also, initialize that we have had no warnings yet this time.

(DEFUN BEGIN-OBJECT-OPERATION (OBJECT-NAME LOCATION-FUNCTION &AUX (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
  ;;  9/25/86 DNG - Don't let NIL or a gensym overide a previous object name.
  (IF (OR (EQUAL OBJECT-WARNINGS-OBJECT-NAME OBJECT-NAME)
	  (NULL FILE-WARNINGS-DATUM)
	  (AND OBJECT-WARNINGS-OBJECT-NAME
	       (OR (NULL OBJECT-NAME)
		   (AND (SYMBOLP OBJECT-NAME) (NULL (SYMBOL-PACKAGE OBJECT-NAME))))))
    NIL
    (PROGN
      (SETQ OBJECT-NAME (COPY-TREE OBJECT-NAME));Avoid temp area lossage.
      (SETQ OBJECT-WARNINGS-DATUM
	    (ASSOC OBJECT-NAME (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM) :TEST #'EQUAL))
      (IF OBJECT-WARNINGS-DATUM
	(SETQ OBJECT-WARNINGS-PUSHING-LOCATION
	      (LOCF (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS-DATUM)))
	(SETQ OBJECT-WARNINGS-PUSHING-LOCATION NIL))
      (SETQ OBJECT-WARNINGS-OBJECT-NAME OBJECT-NAME)
      (SETQ OBJECT-WARNINGS-LOCATION-FUNCTION LOCATION-FUNCTION)
      (COND
	(PREMATURE-WARNINGS
	 (PRINT-OBJECT-WARNINGS-HEADER *STANDARD-OUTPUT* OBJECT-NAME
				       (FILE-WARNINGS-OPERATION FILE-WARNINGS-DATUM))
	 (DOLIST (W (REVERSE PREMATURE-WARNINGS))
	   (APPLY 'RECORD-WARNING W))
	 (RECORD-AND-PRINT-WARNING 'PREMATURE-WARNING-MARKER () ()
				   (IF (STRINGP OBJECT-NAME)
				     "The problems described above were encountered processing ~A."
				     "The problems described above were in data preceding the definition of ~S.")
				   OBJECT-NAME)))
      (COND
	(PREMATURE-WARNINGS-THIS-OBJECT
	 (UNLESS PREMATURE-WARNINGS
	   (PRINT-OBJECT-WARNINGS-HEADER *STANDARD-OUTPUT* OBJECT-NAME
					 (FILE-WARNINGS-OPERATION FILE-WARNINGS-DATUM)))
	 (DOLIST (W (REVERSE PREMATURE-WARNINGS-THIS-OBJECT))
	   (APPLY 'RECORD-WARNING W))
	 ;; This need not be a warning at all,
	 ;; since printing the warnings from the data base
	 ;; will look just right with nothing here.
	 (FORMAT T
		 (IF (STRINGP OBJECT-NAME)
		   "~% The problems described above were encountered processing ~A."
		   (IF PREMATURE-WARNINGS
		     "~% Some of the problems apply to the definition of ~S."
		     "~% The problems described above apply to the definition of ~S."))
		 OBJECT-NAME)))
      (SETQ PREMATURE-WARNINGS NIL
	    PREMATURE-WARNINGS-THIS-OBJECT NIL)
      T))) 


(DEFUN PRINT-OBJECT-WARNINGS-HEADER (STREAM OBJECT OPERATION)
  (IF (AND (NOT (STRINGP OBJECT)) (SEND STREAM :OPERATION-HANDLED-P :ITEM))
    (PROGN
      (TERPRI STREAM)
      (SEND STREAM :ITEM 'FUNCTION-NAME OBJECT "<< While ~A ~S >>"
	 (GET OPERATION 'NAME-AS-PRESENT-PARTICIPLE) OBJECT))
    (FORMAT STREAM (IF (STRINGP OBJECT)
		     "~%<< While ~A ~A >>"
		     "~%<< While ~A ~S >>")
	    (GET OPERATION 'NAME-AS-PRESENT-PARTICIPLE) OBJECT))) 


(DEFUN DISPOSE-OF-WARNINGS-AFTER-LAST-OBJECT ()
  (IF (OR PREMATURE-WARNINGS PREMATURE-WARNINGS-THIS-OBJECT)
    (OBJECT-OPERATION-WITH-WARNINGS
     ((STRING-APPEND "the end of the data") 'ZWEI:GO-TO-END-OF-FILE-POSSIBILITY)))) 

;At the end of an object operation, get rid of any warnings
;that were left over from previous operations on this object.
;Furthermore, if there are now no warnings for this object,
;delete the object from the list for this file.
;In that case we must update file-warnings-pushing-location,
;since chances are it is the link that was deleted from the list.

(DEFUN END-OBJECT-OPERATION ()
  (COND
    (OBJECT-WARNINGS-DATUM
     (IF OBJECT-WARNINGS-PUSHING-LOCATION
       (SETF (CDR OBJECT-WARNINGS-PUSHING-LOCATION) NIL))
     (OR (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS-DATUM)
	(PROGN
	  (SETF (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM)
		(DELETE OBJECT-WARNINGS-DATUM
			(THE LIST (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM)) :TEST #'EQ))
	  (IF (EQ (CAR FILE-WARNINGS-PUSHING-LOCATION) OBJECT-WARNINGS-DATUM)
	    (DO ((L (LOCF (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM)) (CDR L)))
		((EQ (CADR L) (CADR FILE-WARNINGS-PUSHING-LOCATION))
		 (SETQ FILE-WARNINGS-PUSHING-LOCATION L))))))))
  ;; Flush any warnings about INTERNALs of this object
  ;; that were not seen during this run.
  (DOLIST (OBJW (CDR FILE-WARNINGS-PUSHING-LOCATION))
    (AND (INTERNAL-OBJECT-OF (CAR OBJW) OBJECT-WARNINGS-OBJECT-NAME)
       (SETF (CDR FILE-WARNINGS-PUSHING-LOCATION)
	     (DELETE OBJW (THE LIST (CDR FILE-WARNINGS-PUSHING-LOCATION)) :TEST #'EQ))))) 


(DEFUN INTERNAL-OBJECT-OF (MAYBE-INTERNAL MAYBE-CONTAINS-IT)
  (AND (CONSP MAYBE-INTERNAL) (EQ (CAR MAYBE-INTERNAL) :INTERNAL)
     (OR (EQUAL (CADR MAYBE-INTERNAL) MAYBE-CONTAINS-IT)
	(INTERNAL-OBJECT-OF (CADR MAYBE-INTERNAL) MAYBE-CONTAINS-IT)))) 

;Record a warning and print it too.  For an object's first warning,
;print the object's name as well.

(DEFUN RECORD-AND-PRINT-WARNING (TYPE SEVERITY LOCATION-INFO FORMAT-STRING &REST FORMAT-ARGS)
  "Enter a warning in the warnings data base, and print the warning too.
See RECORD-WARNING for calling information."
  (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA));Stream may cons
    (OR (NULL OBJECT-WARNINGS-OBJECT-NAME)
       (NEQ OBJECT-WARNINGS-PUSHING-LOCATION
	    (LOCF (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS-DATUM)))
       (PRINT-OBJECT-WARNINGS-HEADER *STANDARD-OUTPUT* OBJECT-WARNINGS-OBJECT-NAME
				     (FILE-WARNINGS-OPERATION FILE-WARNINGS-DATUM)))
    (TERPRI)
    (WRITE-CHAR #\SPACE)
    (LET ((*PRINT-LEVEL* WARNINGS-PRINLEVEL)
	  (*PRINT-LENGTH* WARNINGS-PRINLENGTH))
      (APPLY 'GLOBAL:FORMAT T FORMAT-STRING FORMAT-ARGS))
    (APPLY 'RECORD-WARNING TYPE SEVERITY LOCATION-INFO FORMAT-STRING FORMAT-ARGS))) 


(DEFUN MAYBE-PRINT-OBJECT-WARNINGS-HEADER ()
  "If there is an object to record warnings on but no warnings yet, print <<While mumbling FOO>>."
  (OR (NULL OBJECT-WARNINGS-OBJECT-NAME)
     (NEQ OBJECT-WARNINGS-PUSHING-LOCATION
	  (LOCF (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS-DATUM)))
     (PRINT-OBJECT-WARNINGS-HEADER *STANDARD-OUTPUT* OBJECT-WARNINGS-OBJECT-NAME
				   (FILE-WARNINGS-OPERATION FILE-WARNINGS-DATUM)))) 

;Record a warning on the current object in the current file.

(DEFUN RECORD-WARNING (TYPE SEVERITY LOCATION-INFO FORMAT-STRING &REST FORMAT-ARGS &AUX
  (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
  "Enter a warning in the warnings data base.
The file and object should have been specified by using the macros
FILE-OPERATION-WITH-WARNINGS and OBJECT-OPERATION-WITH-WARNINGS.
TYPE and SEVERITY are keywords with no standard meanings.
FORMAT-STRING and FORMAT-ARGS are suitable for handing to FORMAT to print the warning."
  (IF (NULL OBJECT-WARNINGS-OBJECT-NAME)
    (PUSH (MAKE-WARNING TYPE SEVERITY LOCATION-INFO FORMAT-STRING (COPY-LIST FORMAT-ARGS))
       PREMATURE-WARNINGS)
    ;; Make sure we have ab object-warnings-datum for this object.
    (PROGN
      (OR OBJECT-WARNINGS-DATUM
	 (SETQ OBJECT-WARNINGS-DATUM
	       (MAKE-OBJECT-WARNINGS OBJECT-WARNINGS-OBJECT-NAME
				     OBJECT-WARNINGS-LOCATION-FUNCTION)
	       OBJECT-WARNINGS-PUSHING-LOCATION
	       (LOCF (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS-DATUM))))
      ;; The first time we push a warning on an object,
      ;; make sure this object is in the front half of the file's object alist
      ;; (the half that will be kept after this file operation).
      (OR
       (NEQ OBJECT-WARNINGS-PUSHING-LOCATION
	    (LOCF (OBJECT-WARNINGS-WARNINGS OBJECT-WARNINGS-DATUM)))
       (PROGN
	;; Delete it from the second half if it is there.
	(SETF (CDR FILE-WARNINGS-PUSHING-LOCATION)
	      (DELETE OBJECT-WARNINGS-DATUM (THE LIST (CDR FILE-WARNINGS-PUSHING-LOCATION))
		      :TEST #'EQ))
	;; If not present now, add to end of front half.
	(OR
	 (MEMBER OBJECT-WARNINGS-DATUM (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM) :TEST
		 #'EQ)
	 (PROGN
	   (PUSH OBJECT-WARNINGS-DATUM (CDR FILE-WARNINGS-PUSHING-LOCATION))
	   (POP FILE-WARNINGS-PUSHING-LOCATION)))))
      ;; Now push on this warning.
      (LET ((WARNING
	     (MAKE-WARNING TYPE SEVERITY LOCATION-INFO FORMAT-STRING (COPY-LIST FORMAT-ARGS))))
	(PUSH WARNING (CDR OBJECT-WARNINGS-PUSHING-LOCATION))
	(POP OBJECT-WARNINGS-PUSHING-LOCATION))))) 

;Filter all the warnings for a particular file, each according to the predicate
;associated with the operation.  Thus, :compile warnings are filtered by
;the definition of (:property :compile warnings-filtering-predicate).

(DEFUN FILTER-WARNINGS (GENERIC-PATHNAME)
  "Discard obsolete warnings for specified file from the data base."
  (DOLIST (OP (FILE-WARNINGS-OPERATIONS GENERIC-PATHNAME))
    (LET ((PRED (GET OP 'WARNINGS-FILTERING-PREDICATE)))
      (IF PRED
	(FILTER-OPERATION-WARNINGS GENERIC-PATHNAME OP PRED))))) 

;Discard any warnings for specified pathname and operation that do not match the predicate.

(DEFUN FILTER-OPERATION-WARNINGS (GENERIC-PATHNAME OPERATION PREDICATE)
  (LET ((FILE-WARNINGS-DATUM (EXAMINE-FILE-WARNINGS GENERIC-PATHNAME OPERATION)))
    (DOLIST (OBJW (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM))
     ;; Any warnings which are about previously undefined functions that are now defined,
     ;; delete from the list of warnings about this object.
      (DOLIST (WARN (OBJECT-WARNINGS-WARNINGS OBJW))
	(OR (FUNCALL PREDICATE WARN)
	   (SETF (OBJECT-WARNINGS-WARNINGS OBJW)
		 (DELETE WARN (THE LIST (OBJECT-WARNINGS-WARNINGS OBJW)) :TEST #'EQ))))
      ;; If this object now has no warnings, flush it from the file.
      (OR (OBJECT-WARNINGS-WARNINGS OBJW)
	 (SETF (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM)
	       (DELETE OBJW (THE LIST (FILE-WARNINGS-OBJECT-ALIST FILE-WARNINGS-DATUM)) :TEST
		       #'EQ)))))) 

;This predicate rejects warnings about formerly undefined functions
; which are no longer undefined.

(DEFUN (:PROPERTY :COMPILE WARNINGS-FILTERING-PREDICATE) (WARN)
  (NOT
   (AND (EQ (WARNING-TYPE WARN) 'COMPILER:UNDEFINED-FUNCTION-USED)
      (COMPILER:COMPILATION-DEFINEDP (CAR (WARNING-FORMAT-ARGS WARN)))))) 


(DEFUN PRINT-WARNINGS (PATHNAMES STREAM)
  (DOLIST (FILE (OR PATHNAMES (WARNINGS-PATHNAMES)))
    (PRINT-FILE-WARNINGS FILE STREAM))) 


(DEFUN PRINT-FILE-WARNINGS (PATHNAME &OPTIONAL (STREAM *STANDARD-OUTPUT*))
  "Output warnings data base for one file to a stream, in machine-readable form."
  (IF (STRINGP PATHNAME)
    (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME)))
  (FORMAT STREAM "~&;-*-Mode: Lisp; Package: User; Base: 10. -*-")
  (FORMAT STREAM "~%(SI:RELOAD-FILE-WARNINGS~%  '~S~%  '(" PATHNAME)
  (LET ((GENERIC-PATHNAME (IF (SYMBOLP PATHNAME)
			    PATHNAME
			    (SEND PATHNAME :GENERIC-PATHNAME)))
	(*PACKAGE* PKG-USER-PACKAGE) (*PRINT-BASE* 10) (*READ-BASE* 10)
	(*READTABLE* INITIAL-READTABLE) FILE-VARS FILE-VALS (FIRST-OPERATION T));T for the first operation in the operation-alist.
	;; Get the file's property bindings, but use them only
	;; when we construct the string which is the text of the warning.
    (MULTIPLE-VALUE-SETQ (FILE-VARS FILE-VALS)
      (AND (NOT (SYMBOLP GENERIC-PATHNAME)) (FS:FILE-ATTRIBUTE-BINDINGS GENERIC-PATHNAME)))
    (FILTER-WARNINGS GENERIC-PATHNAME)
    (DOLIST (ALIST-ELT (FILE-WARNINGS-OPERATION-ALIST GENERIC-PATHNAME))
      (IF FIRST-OPERATION
	(SETQ FIRST-OPERATION NIL)
	(FORMAT STREAM "~%    "))
      (FORMAT STREAM "(~S NIL" (CAR ALIST-ELT))
      (DOLIST (OBJW (FILE-WARNINGS-OBJECT-ALIST ALIST-ELT))
	(APPLY 'GLOBAL:FORMAT STREAM "~%     (~S ~S ~S" OBJW)
	(DOLIST (W (OBJECT-WARNINGS-WARNINGS OBJW))
	  (MULTIPLE-VALUE-BIND (NIL ERRORP)
	    (CATCH-ERROR (LET ((PRINT-READABLY T))
			   (PRINT W 'NULL-STREAM)))
	    (IF ERRORP
	      (FORMAT STREAM "~%      (~S ~S ~S \"~~A\" ~S)" (FIRST W) (SECOND W)
		      (THIRD W)
		      ;; Instead of outputting the warning's format-string and args,
		      ;; run them through format now.  Avoid problems if there is an
		      ;; object in the args that can't print readably.
		      (PROGV FILE-VARS
			     FILE-VALS
			(APPLY 'GLOBAL:FORMAT NIL (FOURTH W) (NTHCDR 4 W))))
	      ;; If we can print the list itself so it will read back, do so.
	      (FORMAT STREAM "~%      ~S" W))))
	(WRITE-CHAR #\) STREAM))
      (WRITE-CHAR #\) STREAM)))
  (FORMAT STREAM "))~%")) 


(DEFUN RELOAD-FILE-WARNINGS (PATHNAME OPERATION-ALIST)
  (SET-FILE-WARNINGS-OPERATION-ALIST
   (IF (SYMBOLP PATHNAME)
     PATHNAME
     (FUNCALL PATHNAME :GENERIC-PATHNAME))
   OPERATION-ALIST)) 


(DEFUN DUMP-WARNINGS (OUTPUT-FILE-PATHNAME &REST WARNING-FILE-PATHNAMES)
  "Write warnings data base to a file.  Read the file back with LOAD."
  (WITH-OPEN-FILE (STREAM OUTPUT-FILE-PATHNAME :characters t :direction :OUTput)
    (PRINT-WARNINGS WARNING-FILE-PATHNAMES STREAM)
    (CLOSE STREAM)))