;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for Lambda-Diag version 16.1
;;; Reason:
;;;  (lam:salvage-editor) no longer worked because parts of LAM didn't
;;;  actually follow forwarding pointers if messages about them were suppressed.
;;;  Lots of debugging messages regarding forwarding were NOT suppressed, but not
;;;  all of them.  Always follow the pointers and suppress messages....
;;; Written 1-Jun-88 18:47:21 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 2
;;; with Experimental System 124.15, Experimental Local-File 74.0, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.0, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8.


(proclaim '(special lam:dtp-indexed-forward))
(setq lam:dtp-rplacd-forward global:dtp-rplacd-forward)

; From modified file DJ: L.LAMBDA-DIAG; PRINT-UINST.LISP#42 at 1-Jun-88 19:25:48
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; PRINT-UINST  "

(DEFUN LAM-MEM-READ (ADDR &optional inhibit-forwarding-messages)
    (DO ((X (QF-MEM-READ ADDR) (QF-MEM-READ ADDR))
	 (DTP))
	(NIL)
      (SETQ DTP (QF-DATA-TYPE X))
      (COND ((= DTP DTP-BODY-FORWARD)
	     (LET ((OFFSET (- (QF-POINTER ADDR) (QF-POINTER X))))
	       (SETQ X (+ (QF-MEM-READ X) OFFSET))))
	    ((OR (= DTP DTP-HEADER-FORWARD)
		 (= DTP DTP-ONE-Q-FORWARD)
		 (= DTP DTP-GC-FORWARD)
		 (= DTP DTP-EXTERNAL-VALUE-CELL-POINTER)
		 (= dtp dtp-rplacd-forward))
	     (unless inhibit-forwarding-messages
	       (format t "!~s " (nth dtp q-data-types)))) ;loop
            (T (RETURN X)))
      (SETQ ADDR X)))

))

; From modified file DJ: L.LAMBDA-DIAG; LAMQF.LISP#58 at 1-Jun-88 19:32:17
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; LAMQF  "

(DEFUN QF-MEM-READ-TRANSPORT (ADR &optional inhibit-forwarding-messages)
  "Return contents of memory address ADR as a bignum, swapping or forwarding if nec."
  (LET (DATA)
    (DECLARE (FIXNUM DATA))
    (SETQ DATA (QF-VIRTUAL-MEM-READ ADR))
    (COND ((< DATA 0)
	   (QF-SWAP-IN ADR)
	   (SETQ DATA (QF-VIRTUAL-MEM-READ ADR))))
    (AND (< DATA 0)
	 (ERROR 'QF-MEM-READ-INACCESSIBLE ADR 'FAIL-ACT))
    (SELECT (QF-DATA-TYPE DATA)
      ((DTP-GC-FORWARD DTP-ONE-Q-FORWARD DTP-HEADER-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER
		       dtp-rplacd-forward)
       (unless inhibit-forwarding-messages
	 (format t " ~s " (nth (qf-data-type data) q-data-types)))
       (QF-MEM-READ-TRANSPORT DATA inhibit-forwarding-messages))
      (DTP-BODY-FORWARD
       (unless inhibit-forwarding-messages
	 (format t " BODY-FORWARD "))
       (QF-MEM-READ-TRANSPORT (+ (QF-POINTER (- ADR DATA))
				 (QF-MEM-READ DATA))
			      inhibit-forwarding-messages))
      (T DATA))))

))

; From modified file DJ: L.LAMBDA-DIAG; LAMQF.LISP#58 at 1-Jun-88 19:35:51
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; LAMQF  "

(DEFUN QF-CDR (LMOB &optional inhibit-forwarding-messages)
   (LET ((TYPE (QF-DATA-TYPE LMOB))(L LMOB))
     (SELECT TYPE
	(DTP-LOCATIVE
	 (QF-CAR LMOB))
	((DTP-LIST DTP-CLOSURE DTP-ENTITY)	;once included DTP-STACK-CLOSURE
	 (LET ((CDRC (QF-CDR-CODE
		      (DO ((X (QF-MEM-READ LMOB) (QF-MEM-READ L)))
			  (NIL)
			(SELECT (QF-DATA-TYPE X)
			   ((DTP-HEADER-FORWARD DTP-GC-FORWARD DTP-RPLACD-FORWARD)
			    (unless inhibit-forwarding-messages
			      (format t " ~s " (nth (qf-data-type x) q-data-types)))
			    (SETQ L X))
			   (OTHERWISE (RETURN X)))))))
	   (LET ((X (SELECT CDRC
		       (cdr-normal (QF-MEM-READ (1+ L)))	;FULL CONS
		       (cdr-error (ERROR '|CDR-ERROR encountered - QF-CDR| LMOB 'FAIL-ACT))
		       (cdr-nil QF-NIL)			;CDR NIL
		       (cdr-next (1+ L))
		       (OTHERWISE (ERROR '|Lose big -- QF-CDR|)))))
	     (DO ((X X (QF-MEM-READ X))
		  (ADR L X))
		 (NIL)
	       (SELECT (QF-DATA-TYPE X)
		  ((DTP-HEADER-FORWARD DTP-GC-FORWARD dtp-rplacd-forward
		    DTP-ONE-Q-FORWARD DTP-EXTERNAL-VALUE-CELL-POINTER)
		   (unless inhibit-forwarding-messages
		     (format t " ~s " (nth (qf-data-type x) q-data-types)))
		   NIL)
		  (DTP-BODY-FORWARD
		    (unless inhibit-forwarding-messages
		      (format t " BODY-FORWARD "))
		    (LET ((OFFSET (- (QF-POINTER ADR) (QF-POINTER X))))
		      (SETQ X (+ (QF-MEM-READ X) OFFSET))))
		  (OTHERWISE (RETURN (QF-TYPED-POINTER X))))))))
	(DTP-SYMBOL
	  (cond ((and (= type dtp-symbol)
		      (zerop (qf-pointer lmob)))
		 lmob)
		(t
		 (ferror nil "non-NIL symbol -- QF-CDR: ~s" LMOB))))
	(dtp-gc-forward
	  (unless inhibit-forwarding-messages
	    (format t " GC-FORWARD "))
	  (qf-cdr (qf-typed-pointer (qf-mem-read-transport lmob inhibit-forwarding-messages))))
	(OTHERWISE
	  (ferror nil "Neither a cons nor a locative -- QF-CDR: ~s" LMOB)))))

))

; From modified file DJ: L.LAMBDA-DIAG; PRINT-UINST.LISP#42 at 1-Jun-88 20:16:00
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; PRINT-UINST  "

(DEFUN LAM-Q-PRINT-STRING (ADR &OPTIONAL (STREAM STANDARD-OUTPUT) inhibit-forwarding-messages)
  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER ADR) DTP-ARRAY-POINTER) inhibit-forwarding-messages)
  (DO ((LEN (COND (QF-ARRAY-HAS-LEADER-P
		   (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))
		  (T QF-ARRAY-LENGTH)))
       (ADR QF-ARRAY-DATA-ORIGIN)
       (I 0 (1+ I))
       (CH)
       (WD))
      ((OR (>= I LEN) (= I LAM-Q-PRINT-STRING-MAXL))
       (AND (< I LEN) (PRINC '/././. STREAM))
       NIL)
    (DECLARE (FIXNUM LEN ADR I WD))
    (COND ((ZEROP (LOGAND 3 I))	;Get next word
	   (SETQ WD (QF-MEM-READ ADR)
		 ADR (1+ ADR))))
    (SETQ CH (LOGAND 377 WD)
	  WD (ASH WD -8))
    (TYO CH STREAM)))

))

; From modified file DJ: L.LAMBDA-DIAG; LAMQF.LISP#58 at 1-Jun-88 20:22:53
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; LAMQF  "

(DEFUN QF-CAR (LMOB &optional inhibit-forwarding-messages)
  (LET ((TYPE (QF-DATA-TYPE LMOB)))
    (cond ((or (= TYPE DTP-LIST)
	       (= TYPE DTP-LOCATIVE)
	       (= TYPE DTP-CLOSURE)
;	       (= type dtp-stack-closure)
	       (= TYPE DTP-ENTITY))
	   (QF-TYPED-POINTER (QF-MEM-READ-TRANSPORT LMOB inhibit-forwarding-messages)))
	  ((and (= type dtp-symbol)
		(zerop (qf-pointer lmob)))
	   lmob)
	  ((= type dtp-gc-forward)
	   (unless inhibit-forwarding-messages
	     (format t " GC-FORWARD "))
	   (qf-car (qf-typed-pointer (qf-mem-read-transport lmob inhibit-forwarding-messages))
		   inhibit-forwarding-messages))
	  (t
	   (ferror nil "Neither a cons nor a locative -- QF-CAR: ~s" LMOB)))))

))

; From modified file DJ: L.LAMBDA-DIAG; LAMQF.LISP#58 at 1-Jun-88 20:27:12
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; LAMQF  "

(DEFUN QF-ARRAY-SETUP (Q &optional inhibit-forwarding-messages)
  (PROG (N)
    (OR (= (QF-DATA-TYPE Q) DTP-ARRAY-POINTER)
	(FERROR NIL "Data type of supposed array is ~s, not DTP-ARRAY-POINTER"
		(QF-DATA-TYPE Q)))
A   (SETQ QF-ARRAY-HEADER-ADDRESS (QF-POINTER Q))
    (SETQ QF-ARRAY-HEADER (QF-MEM-READ QF-ARRAY-HEADER-ADDRESS))
    (SETQ N (QF-DATA-TYPE QF-ARRAY-HEADER))
    (COND ((= N DTP-ARRAY-HEADER))
	  ((OR (= N DTP-HEADER-FORWARD) (= N DTP-GC-FORWARD))
	   (unless inhibit-forwarding-messages
	     (format t " ~s " (nth (qf-data-type qf-array-header) q-data-types)))
	   (SETQ Q QF-ARRAY-HEADER)
	   (GO A))
	  (T
	   (FERROR NIL "Data type of supposed array header is ~s, not DTP-ARRAY-HEADER"
		   N)))
    (SETQ QF-ARRAY-DISPLACED-P (= 1 (LDB %%ARRAY-DISPLACED-BIT
							QF-ARRAY-HEADER)))
    (SETQ QF-ARRAY-HAS-LEADER-P (= 1 (LDB %%ARRAY-LEADER-BIT QF-ARRAY-HEADER)))
    (SETQ QF-ARRAY-NUMBER-DIMS (LDB %%ARRAY-NUMBER-DIMENSIONS QF-ARRAY-HEADER))
    (SETQ QF-ARRAY-DATA-ORIGIN (+ QF-ARRAY-NUMBER-DIMS QF-ARRAY-HEADER-ADDRESS))
    (COND ((= 0 (LDB %%ARRAY-LONG-LENGTH-FLAG QF-ARRAY-HEADER))
	   (SETQ QF-ARRAY-LENGTH (LDB %%ARRAY-INDEX-LENGTH-IF-SHORT
						     QF-ARRAY-HEADER)))
	  (T
	   (SETQ QF-ARRAY-DATA-ORIGIN (1+ QF-ARRAY-DATA-ORIGIN))
	   (SETQ QF-ARRAY-LENGTH (QF-POINTER (QF-MEM-READ (1+ QF-ARRAY-HEADER-ADDRESS))))))
  ))

))

; From modified file DJ: L.LAMBDA-DIAG; LAMQF.LISP#58 at 1-Jun-88 20:29:38
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; LAMQF  "

(DEFUN QF-ARRAY-LEADER (Q I &optional inhibit-forwarding-messages)
  (QF-ARRAY-SETUP Q inhibit-forwarding-messages)
  (OR QF-ARRAY-HAS-LEADER-P (ERROR '|NO ARRAY LEADER - QF-ARRAY-LEADER| Q 'FAIL-ACT))
  (OR (< I (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 1))))
      (ERROR '|ARRAY LEADER INDEX OUT OF BOUNDS - QF-ARRAY-LEADER| Q 'FAIL-ACT))
  (QF-TYPED-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS I 2))))

))

; From modified file DJ: L.LAMBDA-DIAG; SALVAG.LISP#21 at 1-Jun-88 20:30:35
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; SALVAG  "

(DEFUN SALVAGE-EDITOR-FILE-NAME (BUFFER &AUX BUFFER-NAME FILE-NAME)
  (DECLARE (RETURN-LIST BUFFER-NAME FILE-NAME))
  (SETQ BUFFER-NAME (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
		      (LAM-Q-PRINT-STRING
			(GET-SLOT-OR-IV BUFFER 'ZWEI:BUFFER-NAME 'ZWEI:NAME)
			standard-output
			t)))
  (OR (LET ((FILE-ID (GET-SLOT-OR-IV BUFFER 'ZWEI:BUFFER-FILE-ID 'ZWEI:FILE-ID)))
	(LAM-Q-NULL FILE-ID))
      (LET* ((PATHNAME (GET-SLOT-OR-IV BUFFER 'ZWEI:BUFFER-PATHNAME 'ZWEI:PATHNAME))
	     (NAME (GET-INSTANCE-VARIABLE PATHNAME 'FS:STRING-FOR-PRINTING)))
	(IF (LAM-Q-NULL NAME)
	    (SETQ FILE-NAME BUFFER-NAME)	;Best we can do if no string cached yet
	    (SETQ FILE-NAME (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
			      (LAM-Q-PRINT-STRING NAME standard-output t))))))
  (VALUES BUFFER-NAME FILE-NAME))

))

; From modified file DJ: L.LAMBDA-DIAG; SALVAG.LISP#21 at 1-Jun-88 20:31:05
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; SALVAG  "

(DEFUN SALVAGE-ZMAIL ()
  "Save the mail files in the ZMAIL editor in the other machine, through the debugging cables.
Asks, about each buffer that is modified, whether to save it."
  (LET ((ZM-WINDOW (QF-TYPED-POINTER (LAM-MEM-READ (1+ (QF-POINTER
							(QF-SYMBOL 'ZWEI:*ZMAIL-WINDOW*)))
						   t))))
    (LET ((MF-LIST (OR (GET-INSTANCE-VARIABLE ZM-WINDOW 'ZWEI:*ZMAIL-BUFFER-LIST* T)
		       (GET-INSTANCE-VARIABLE ZM-WINDOW 'ZWEI:*MAIL-FILE-LIST*))))
      (DO ((LIST MF-LIST (QF-CDR LIST t))
	   MAIL-FILE)
	  ((LAM-Q-NULL LIST))
	(SETQ MAIL-FILE (QF-CAR LIST t))
	(LET ((INTERVAL (GET-INSTANCE-VARIABLE MAIL-FILE 'ZWEI:INTERVAL T)))
	  (AND (NOT (NULL INTERVAL))
	       (LET ((NODE-TICK (QF-AR-OR-IR-1 INTERVAL
					       (GET-DEFSTRUCT-INDEX 'ZWEI:NODE-TICK)))
		     (MAIL-FILE-TICK (GET-INSTANCE-VARIABLE MAIL-FILE 'ZWEI:TICK)))
		 (> (LOGLDB %%Q-POINTER NODE-TICK) (LOGLDB %%Q-POINTER MAIL-FILE-TICK)))
	       (LET ((MAIL-FILE-NAME (LET* ((PATHNAME (GET-INSTANCE-VARIABLE
							MAIL-FILE 'ZWEI:PATHNAME))
					    (NAME (GET-INSTANCE-VARIABLE
						    PATHNAME 'FS:STRING-FOR-PRINTING)))
				       (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
					 (LAM-Q-PRINT-STRING
					   (IF (LAM-Q-NULL NAME)
					       (GET-INSTANCE-VARIABLE
						 MAIL-FILE 'ZWEI:NAME)
					     NAME)
					   standard-output
					   t)))))
		 (AND (FQUERY NIL "Save mail file ~A? " MAIL-FILE-NAME)
		      (SALVAGE-INTERVAL INTERVAL MAIL-FILE-NAME)))))))
    (LET ((DRAFT-LIST (GET-INSTANCE-VARIABLE ZM-WINDOW 'ZWEI:*DRAFT-LIST*)))
      (DO ((LIST DRAFT-LIST (QF-CDR LIST t))
	   DRAFT-MSG)
	  ((LAM-Q-NULL LIST))
	(SETQ DRAFT-MSG (QF-CAR LIST t))
	(COND ((LAM-Q-NULL (GET-SLOT-OR-IV DRAFT-MSG 'ZWEI:DRAFT-MSG-SENT-P 'ZWEI:SENT-P))
	       (LET ((PATHNAME (GET-SLOT-OR-IV DRAFT-MSG 'ZWEI:DRAFT-MSG-PATHNAME
					       'ZWEI:PATHNAME))
		     (SUMMARY-STRING
		       (GET-SLOT-OR-IV DRAFT-MSG 'ZWEI:DRAFT-MSG-SUMMARY-STRING
				       'ZWEI:SUMMARY-STRING)))
		 (IF (LAM-Q-NULL PATHNAME)
		     (SETQ PATHNAME NIL)
		     (SETQ PATHNAME (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
				      (LAM-Q-PRINT-STRING
					(GET-INSTANCE-VARIABLE
					  PATHNAME 'FS:STRING-FOR-PRINTING)
					standard-output
					t))))
		 (SETQ SUMMARY-STRING (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
					(LAM-Q-PRINT-STRING SUMMARY-STRING standard-output t)))
		 (COND ((FQUERY NIL "Save ~A~@[ on ~A~]? " SUMMARY-STRING PATHNAME)
			(COND ((NULL PATHNAME)
			       (FORMAT QUERY-IO "~&Write ~A to file: " SUMMARY-STRING)
			       (SETQ PATHNAME (READLINE QUERY-IO))))
			(SALVAGE-INTERVAL DRAFT-MSG PATHNAME))))))))))

))

; From modified file DJ: L.LAMBDA-DIAG; SALVAG.LISP#21 at 1-Jun-88 20:32:26
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; SALVAG  "

(DEFUN SALVAGE-INTERVAL (BUFFER FILE-NAME)
  (LET ((STRING-CODE (LDB %%ARRAY-TYPE-FIELD ART-STRING))
	(FAT-STRING-CODE (LDB %%ARRAY-TYPE-FIELD ART-FAT-STRING)))
    (WITH-OPEN-STREAM (STREAM (OPEN-SOME-FILE FILE-NAME '(:OUT)))

      (DO ((LINE-NEXT (GET-DEFSTRUCT-INDEX 'ZWEI:LINE-NEXT 'ARRAY-LEADER))       
	   (LINE (QF-CAR (LAM-REFERENCE-INSTANCE BUFFER 'ZWEI:FIRST-BP) t)
		 (QF-ARRAY-LEADER LINE LINE-NEXT t))
	   (LIMIT (QF-CAR (LAM-REFERENCE-INSTANCE BUFFER 'ZWEI:LAST-BP) t)))
	  (NIL)
	(COND (LINE				;CAN BE NIL IF IT BOMBS ON THE LOSER
						; AND HE RETURNS NIL FROM EH
	       (SALVAGE-LINE LINE STREAM)
	       (SEND STREAM :TYO #\NEWLINE)))
	(COND ((OR (NULL LINE) (= LINE LIMIT))
	       (CLOSE STREAM)
	       (FORMAT T "~&Written: ~A~%" (SEND STREAM :TRUENAME))
	       (RETURN NIL)))) )
  ))

))

; From modified file DJ: L.LAMBDA-DIAG; SALVAG.LISP#21 at 1-Jun-88 20:32:36
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; SALVAG  "

(DEFUN SALVAGE-LINE (LINE STREAM)
  (LET ((ARRAY-TYPE-CODE
	  (LDB %%ARRAY-TYPE-FIELD (LAM-MEM-READ (LOGLDB %%Q-POINTER LINE)
						t))))
    (COND ((= ARRAY-TYPE-CODE STRING-CODE)
	   (LET ((LAM-Q-PRINT-STRING-MAXL 177777))
	     (LAM-Q-PRINT-STRING LINE STREAM t)))
	  ((= ARRAY-TYPE-CODE FAT-STRING-CODE)
	   (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER LINE) DTP-ARRAY-POINTER) t)
	   (DO ((LEN (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))
		(ADR QF-ARRAY-DATA-ORIGIN)
		(I 0 (1+ I))
		(CH) (WD)
		(FONT-FLAG 0)
		(FNT))
	       (( I LEN)
		(OR (ZEROP LEN) (ZEROP FONT-FLAG)
		    (SEND STREAM :STRING-OUT "0")))
	     (COND ((ZEROP (LOGAND 1 I))	;Get next word
		    (SETQ WD (QF-MEM-READ ADR)
			  ADR (1+ ADR))))
	     (SETQ CH (LOGAND 177777 WD)
		   WD (ASH WD -16.))
	     (SETQ FNT (LSH CH -8))
	     (COND (( FNT FONT-FLAG)
		    (SEND STREAM :TYO #/)
		    (SEND STREAM :TYO (+ #/0 FNT))
		    (SETQ FONT-FLAG FNT)))
	     (SEND STREAM :TYO (LOGAND CH #o377)))))))

))

; From modified file DJ: L.LAMBDA-DIAG; SALVAG.LISP#21 at 1-Jun-88 20:32:50
#8R LAMBDA#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "LAMBDA")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: LAMBDA-DIAG; SALVAG  "

(DEFUN SALVAGE-WARNINGS-OF-PATHNAME (GENERIC-PATHNAME STREAM)
  (when (= (qf-data-type generic-pathname) dtp-instance)
    (let ((wl (qf-cdr
		(qf-assq (qf-symbol ':compile)
			 (qf-get-from-alternating-list
			   (get-instance-variable generic-pathname 'si:property-list)
			   (qf-symbol ':warnings))) t)))
      (when (not (lam-q-null (qf-cdr wl t)))
	(let ((NAME (GET-INSTANCE-VARIABLE GENERIC-PATHNAME 'FS:STRING-FOR-PRINTING)))
	  (FORMAT STREAM "~&Warnings for ")
	  (IF (LAM-Q-NULL NAME)
	      (PRIN1 (QF-PATHNAME-STRING-FOR-PRINTING GENERIC-PATHNAME))
	    (LAM-Q-PRINT-STRING NAME stream t))
	  (format stream "~%compiler warnings list: ")
	  (lam-q-print-toplev wl))))))

))