LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030423. :SYSTEM-TYPE :LOGICAL :VERSION 3. :TYPE "LISP" :NAME "WARN" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758303227. :AUTHOR "REL3" :LENGTH-IN-BYTES 23824. :LENGTH-IN-BLOCKS 24. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ;-*- Mode:Common-Lisp; Package:SI; Base:10. -*-;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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,1987 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) ;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 operationfor 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-DATUMNILFILE-WARNINGS-PATHNAMENILFILE-WARNINGS-PUSHING-LOCATIONNILPREMATURE-WARNINGSNILPREMATURE-WARNINGS-THIS-OBJECTNILOBJECT-WARNINGS-DATUMNIL        OBJECT-WARNINGS-LOCATION-FUNCTION NIL        OBJECT-WARNINGS-OBJECT-NAMENIL        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 macrosFILE-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))) exp) all-functions-to-check-for :test #'eq)(pushnew (cadr exp) all-functions))      exp)))(defun (:property cond cw-handler) (exp)  (if cw-return-expansion-flag      (cons 'cond (mapcar 'cw-clause (cdr exp)))    (mapc 'cw-clause (cdr exp))))(defprop if cw-eval-args cw-handler)(defprop multiple-value cw-multiple-value cw-handler)(defprop multiple-value-setq cw-multiple-value cw-handler)(defprop multiple-value-call cw-eval-args cw-handler)(defprop multiple-value-prog1 cw-eval-args cw-handler)(defun cw-multiple-value (exp)  ;;  1/28/87 DNG - Add call to COPY-LIST because ALL-VARIABLES is destructively modified by CW-LET.  (when (consp (cadr exp))    (setq all-variables (nunion all-variables (copy-list (cadr exp)) :test #'eq))