;;;-*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;


;;; Save all files on the object machine
(DEFUN SALVAGE-EDITOR ()
  "Save the files in the editor in the other machine, through the debugging cables.
Asks, about each buffer that is modified, whether to save it."
  (PKG-BIND "LAMBDA"
    (QF-CLEAR-CACHE T)				;Make completely certain no garbage
						;in caches screws this!
    (qf-setup-pht-addr)
    (DO ((BUFFER-LIST (LAM-MEM-READ (1+ (QF-POINTER (QF-SYMBOL 'ZWEI:*ZMACS-BUFFER-LIST*))) t)
		      (QF-CDR BUFFER-LIST t))
	 BUFFER)
	((LAM-Q-NULL BUFFER-LIST))
      (SETQ BUFFER (QF-CAR BUFFER-LIST t))
      (LET ((TICK (GET-INSTANCE-VARIABLE BUFFER 'ZWEI:TICK))
	    (FILE-TICK (GET-INSTANCE-VARIABLE BUFFER 'ZWEI:FILE-TICK)))
	(if  (AND (= DTP-FIX (LOGLDB %%Q-DATA-TYPE TICK))
	     	 (= DTP-FIX (LOGLDB %%Q-DATA-TYPE FILE-TICK))
	     	 (> (LOGLDB %%Q-POINTER TICK)
	     	    (LOGLDB %%Q-POINTER FILE-TICK)))
	    (MULTIPLE-VALUE-BIND (BUFFER-NAME FILE-NAME)
		(SALVAGE-EDITOR-FILE-NAME BUFFER)
	      (tagbody
	       confirm
		  (cond (file-name
			 (case (fquery
				'(:choices (((foo "Choose a different file name") #/D #/C)
					    . #.format:y-or-n-p-choices))
				"~&Save buffer ~A~%   to file ~A ? " buffer-name file-name)
			   ((t) (go save))
			   ((foo) (go choose))
			   ((nil) (go punt))))
			((setq file-name (prompt-and-read
					   :pathname-or-nil
					   "~&Save buffer ~A in file (or  not to save it): "
					   buffer-name))
			 (go confirm))
			(t
			 (format t "(Not saving buffer ~A)" buffer-name)
			 (go punt)))
	       choose
		  (setq file-name (prompt-and-read `(:pathname :defaults ,file-name)
						   "~&   Save buffer ~A to file: "
						   buffer-name))
		  (go confirm)
	       save
		  (SALVAGE-INTERVAL BUFFER
				    FILE-NAME)
	       punt
		  ))
	  (MULTIPLE-VALUE-BIND (BUFFER-NAME FILE-NAME)
	      (SALVAGE-EDITOR-FILE-NAME BUFFER)
	    (FORMAT T "~%Buffer ~A~@[ on file ~A~] not modified "
		    BUFFER-NAME FILE-NAME)))))))

(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))

(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))))))))))

(DEFUN OPEN-SOME-FILE (INITIAL-FILE &REST KEYWORD-ARGS &AUX ACTUAL-FILE)
  "Open INITIAL-FILE, or read another filename if INITIAL-FILE's host is down.
KEYWORD-ARGS are passed to OPEN."
  (SETQ ACTUAL-FILE
	(LOOP FOR FILE = INITIAL-FILE
	      THEN (FS:MERGE-PATHNAME-DEFAULTS
		     (PROGN (FORMAT T "~%Host ~a not available."
				    (SEND HOST :NAME))
			    (FORMAT T "~%Use what pathname instead? (default = ~a) " FILE)
			    (READLINE))
		     FILE)
	      FOR HOST = (SEND (FS:PARSE-PATHNAME FILE) :HOST)
	      UNTIL (CHAOS:HOST-UP-P HOST (* 10. 60.))
	      FINALLY (RETURN FILE)))
  (APPLY #'OPEN ACTUAL-FILE KEYWORD-ARGS))

(DEFVAR STRING-CODE :UNBOUND
  "Within SALVAGE-INTERVAL, holds unshifted array type field for ART-STRINGs.")

(DEFVAR FAT-STRING-CODE :UNBOUND
  "Within SALVAGE-INTERVAL, holds unshifted array type field for ART-FAT-STRINGs.")

;;; Write out one file
(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)))) )
  ))

;  (COMMENT
;      (DO ((LINE-NEXT (GET-DEFSTRUCT-INDEX 'ZWEI:LINE-NEXT 'ARRAY-LEADER))       
;	   (LINE (QF-CAR (QF-AR-OR-IR-1 BUFFER (GET-DEFSTRUCT-INDEX 'ZWEI:INTERVAL-FIRST-BP)))
;		 (QF-ARRAY-LEADER LINE LINE-NEXT))
;	   (LIMIT (QF-CAR (QF-AR-OR-IR-1 BUFFER
;					 (GET-DEFSTRUCT-INDEX 'ZWEI:INTERVAL-LAST-BP)))))
;	  (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 #\CR)))
;	(COND ((OR (NULL LINE) (= LINE LIMIT))
;	       (CLOSE STREAM)
;	       (FORMAT T "~&Written: ~A~%" (SEND STREAM :TRUENAME))
;	       (RETURN NIL)))) )
;  )))

(DEFUN GET-DEFSTRUCT-INDEX (SYM &OPTIONAL TYPE)
  (cond ((LAM-GET-DEFSTRUCT-INDEX SYM TYPE))  ;this one really gets it from remote machine.
	(t (FERROR NIL "Unable to get defstruct index for ~S: get help!" SYM))))

(COMMENT ;this one assumes slot number the same in local and remote machines
;;; Figure out the index for array-leader or aref generated by defstruct
 (DEFUN GET-DEFSTRUCT-INDEX (SYM TYPE)
  (LET ((DEF (FSYMEVAL SYM)))
    (OR (AND (EQ (CAR DEF) 'NAMED-SUBST)
	     (EQ (CAAR (CDDDR DEF)) TYPE)
	     (CADDR (CADDDR DEF)))
	(FERROR NIL "Unable to get defstruct index for ~S: get help!" SYM)))) )

;Used when something is an array in one version and an instance in another.
(DEFUN GET-SLOT-OR-IV (OBJECT ARRAY-SLOT-ACCESSOR INSTANCE-VARIABLE)
  (LET ((SLOT (LAM-GET-DEFSTRUCT-INDEX ARRAY-SLOT-ACCESSOR 'AREF)))
    (IF (not (= (qf-data-type object) dtp-instance))
	(QF-AR-1 OBJECT SLOT)
      (GET-INSTANCE-VARIABLE OBJECT INSTANCE-VARIABLE))))

(DEFUN GET-INSTANCE-VARIABLE (FLAVOR COMPONENT &OPTIONAL NO-ERROR)
  (LET ((IDX (GET-INSTANCE-VARIABLE-INDEX FLAVOR COMPONENT NO-ERROR)))
    (AND IDX (QF-P-CONTENTS (+ (QF-POINTER FLAVOR) IDX)))))

(DEFUN QF-%P-CONTENTS-OFFSET (PTR OFFSET)
  (QF-P-CONTENTS (+ (QF-POINTER PTR) OFFSET)))

(DEFUN GET-INSTANCE-VARIABLE-INDEX (INSTANCE COMPONENT &OPTIONAL NO-ERROR)
  (LET* ((FLAVOR-DEFSTRUCT (LAM-P-CONTENTS-AS-LOCATIVE-OFFSET INSTANCE 0))
	 (BINDINGS (LAM-REF-DEFSTRUCT
		     'SI:FLAVOR-ALL-INSTANCE-VARIABLES
		     FLAVOR-DEFSTRUCT
		     'AREF))
	 (QF-COMPONENT (QF-SYMBOL COMPONENT)))
    (DO ((INDEX 1 (1+ INDEX))
	 (BINDING BINDINGS (QF-CDR BINDING t)))
	((QF-NULL BINDING)
	 (AND (NOT NO-ERROR)
	      (FERROR NIL "Unable to find binding of ~S" COMPONENT)))
      (COND ((= QF-COMPONENT
		(QF-CAR BINDING t))
	     (RETURN INDEX))))))

(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)))))))

(DEFUN SALVAGE-WARNINGS ()
  (PKG-BIND "LAMBDA"
    (QF-CLEAR-CACHE T)				;Make completely certain no garbage
						;in caches screws this!
    (QF-SETUP-PHT-ADDR)
    (DO ((GENERIC-PATHNAME-LIST
	   (LAM-MEM-READ (1+ (QF-POINTER (QF-SYMBOL 'SI:WARNINGS-PATHNAMES)))
			 t)
	   (QF-CDR GENERIC-PATHNAME-LIST t)))
	((LAM-Q-NULL GENERIC-PATHNAME-LIST))
      (SALVAGE-WARNINGS-OF-PATHNAME (QF-CAR GENERIC-PATHNAME-LIST t) *STANDARD-OUTPUT*))))

(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))))))

(DEFUN QF-PATHNAME-STRING-FOR-PRINTING (PATHNAME)
  (LET* ((HOST (GET-INSTANCE-VARIABLE PATHNAME 'FS:HOST))
	 (DIRECTORY (GET-INSTANCE-VARIABLE PATHNAME 'FS:DIRECTORY))
	;(DEVICE (GET-INSTANCE-VARIABLE PATHNAME 'FS:DEVICE))
	 (NAME (GET-INSTANCE-VARIABLE PATHNAME 'FS:NAME))
	 (TYPE (GET-INSTANCE-VARIABLE PATHNAME 'FS:TYPE))
	 (VERSION (GET-INSTANCE-VARIABLE PATHNAME 'FS:VERSION))
	 (HOST-NAME (GET-INSTANCE-VARIABLE HOST 'FS:NAME)))
;    (LAM-Q-PRINT-TOPLEV HOST-NAME)
;    (TERPRI)
;    (LAM-Q-PRINT-TOPLEV DIRECTORY)
;    (TERPRI)
;    (LAM-Q-PRINT-TOPLEV NAME)
;    (TERPRI)
;    (LAM-Q-PRINT-TOPLEV TYPE)
;    (TERPRI)
;    (LAM-Q-PRINT-TOPLEV VERSION)

    (LET* ((DIR (IF (QF-LISTP DIRECTORY) (QF-MAPCAR 'QF-STRING-OR-WILD DIRECTORY)
		  (LIST (QF-STRING-OR-WILD DIRECTORY))))
	   ;(DEV (QF-LOGICAL-DEVICE-STRING DEVICE))
	   (NAM (QF-PRINT-TO-STRING NAME))
	   (TYP (QF-STRING-OR-WILD TYPE))
	   (VER (QF-STRING-OR-WILD VERSION)))
	(FORMAT NIL "~A: ~{~A; ~}~@[~A~]~@[ ~A~]~@[ ~A~]"
	    (QF-PRINT-TO-STRING HOST-NAME)
	    DIR NAM TYP VER))))

(DEFUN QF-STRING-OR-WILD (FIELD)
  (COND ((= FIELD (QF-SYMBOL ':WILD)) "*")
	((OR (= FIELD QF-NIL)
	     (= FIELD (QF-SYMBOL ':UNSPECIFIC)))
	 NIL)
	(T 					;(FS:QUOTE-COMPONENT-STRING FIELD)
	 (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
	   (LAM-Q-PRINC-TOPLEV FIELD))
	   )))


(DEFUN QF-PRINT-TO-STRING (THING)
  (WITH-OUTPUT-TO-STRING (STANDARD-OUTPUT)
    (LAM-Q-PRINC-TOPLEV THING)))