;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
;;; Patch file for ZMail version 38.3
;;; Reason: Fix some toplevel comtabs
;;; Written 12/17/81 15:40:28 by MMcM,
;;; while running on Lisp Machine Sixteen from band 6
;;; with System 78.18, ZMail 38.2, Experimental Macsyma 22.0, microcode 836.

; From buffer ZFIX
#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))


(SETF
 (COMTAB-INDIRECT-TO (SYMEVAL-IN-INSTANCE (SYMEVAL-IN-INSTANCE *ZMAIL-WINDOW*
							      '*UNIVERSE-DEFINITION-FRAME*)
					 '*MODE-COMTAB*))
*STANDALONE-COMTAB*
)

(SETF
 (COMTAB-INDIRECT-TO (SYMEVAL-IN-INSTANCE (SYMEVAL-IN-INSTANCE *ZMAIL-WINDOW*
							      '*FILTER-WINDOW*)
					 '*MODE-COMTAB*))
*STANDALONE-COMTAB*
)

)

; From file COMNDS > ZMAIL; AI:
#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))

(DEFUN EXPUNGE-MAIL-FILE (MAIL-FILE &OPTIONAL (DELETED-MSGS T)
				    &AUX ARRAY INFS (*INTERVAL* *INTERVAL*))
  (COND ((MAIL-FILE-DISK-P MAIL-FILE)
	 (SETQ *INTERVAL* (DISK-MAIL-FILE-INTERVAL MAIL-FILE))
	 (SETQ INFS (LOCF (NODE-INFERIORS *INTERVAL*)))
	 (FOREGROUND-BACKGROUND-FINISH MAIL-FILE)
	 (MAIL-FILE-DELETE-EXPIRED MAIL-FILE *DELETE-EXPIRED-MSGS*)
	 (AND *QUERY-BEFORE-EXPUNGE*
	      (MAIL-FILE-EXPUNGE-QUERY MAIL-FILE))))
  (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE))
  (DO ((NMSGS (ARRAY-ACTIVE-LENGTH ARRAY))
       (I 0 (1+ I))
       (J 0)
       (MSG))
      (( I NMSGS)
       (SETF (ARRAY-LEADER ARRAY 0) J)
       (COND ((AND (PLUSP J) (MAIL-FILE-DISK-P MAIL-FILE))
	      ;; Kludge for babyl, make the last line of the file correct maybe.
	      (FUNCALL MAIL-FILE ':UPDATE-MSG-END (AREF ARRAY (1- J))))
	     ((AND (ZEROP J) (NOT (MAIL-FILE-DISK-P MAIL-FILE)))
	      ;; A temporary mail file goes away when it becomes empty.
	      (FUNCALL MAIL-FILE ':KILL))))
    ;; For speed, this does not call MSG-GET, which would parse the
    ;; message if need be.  If the message has never been parsed, it
    ;; probably isn't deleted.  Likewise, below it cannot be recent.
    (COND ((OR (EQ (MSG-PARSED-P (SETQ MSG (AREF ARRAY I))) ':KILLED)
	       (AND DELETED-MSGS (GET (LOCF (MSG-STATUS MSG)) 'DELETED)))
	   (MSG-POINT-PDL-PURGE MSG (AND (NOT (EQ MAIL-FILE (MSG-MAIL-FILE MSG)))
					 MAIL-FILE))
	   (AND (EQ MAIL-FILE (MSG-MAIL-FILE MSG))
		(LET ((REAL-INT (MSG-REAL-INTERVAL MSG)))
		  (FLUSH-BP (INTERVAL-FIRST-BP REAL-INT))
		  (FLUSH-BP (INTERVAL-LAST-BP REAL-INT))
		  (LET ((INT (MSG-INTERVAL MSG)))
		    (FLUSH-BP (INTERVAL-FIRST-BP INT))
		    (FLUSH-BP (INTERVAL-LAST-BP INT)))
		  (DELETE-INTERVAL REAL-INT)
		  (SETF (MSG-PARSED-P MSG) ':KILLED)
		  (IF (EQ REAL-INT (CADR INFS))
		      (RPLACD INFS (CDDR INFS))
		      (FERROR NIL "Node inferiors messed up, please report to BUG-ZMAIL")))))
	  (T
	   (COND ((EQ MAIL-FILE (MSG-MAIL-FILE MSG))
		  (AND (REMPROP (LOCF (MSG-STATUS MSG)) 'RECENT)
		       (SETF (MSG-TICK MSG) (TICK)))
		  (SETQ INFS (CDR INFS))))
	   (OR (= I J) (ASET MSG ARRAY J))
	   (SETQ J (1+ J)))))
  (COND ((EQ MAIL-FILE *MAIL-FILE*)
	 (FUNCALL *SUMMARY-WINDOW* ':NEED-FULL-REDISPLAY)
	 (ZMAIL-SELECT-MSG (COND ((ZEROP (ARRAY-ACTIVE-LENGTH ARRAY)) NIL)
				 ((OR (EQ (MSG-PARSED-P *MSG*) ':KILLED)
				      (MSG-GET *MSG* 'DELETED))
				  0)
				 (T *MSG*))
			   T NIL))))

)

; From file DEFS > ZMAIL; AI:
#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))

(DEFMACRO USING-OVERLYING-WINDOW (&BODY BODY)
  `(UNWIND-PROTECT
     (PROGN
       (FUNCALL *OVERLYING-WINDOW* ':DELETE-TEXT)
       (FUNCALL *OVERLYING-WINDOW* ':SELECT NIL)
       (LET ((TERMINAL-IO *OVERLYING-WINDOW*)
	     (STANDARD-INPUT SI:SYN-TERMINAL-IO)
	     (STANDARD-OUTPUT SI:SYN-TERMINAL-IO)
	     (QUERY-IO SI:SYN-TERMINAL-IO))
	 . ,BODY))
;     (FUNCALL *ZMAIL-WINDOW* ':DEEXPOSE NIL ':NOOP)
     (FUNCALL *OVERLYING-WINDOW* ':DEACTIVATE)
     (FUNCALL *ZMAIL-WINDOW* ':SELECT NIL)))

)

; From file PROFIL > ZMAIL; AI:
#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))

;;; Quick processing of a set of messages
(DEFUN PROCESS-FILTER (FILTER &REST OPTIONS &AUX NAME NAME-BEFORE NAME-AFTER)
  (MULTIPLE-VALUE (FILTER NAME NAME-BEFORE NAME-AFTER)
    (PARSE-FILTER-SPEC FILTER))
  (USING-OVERLYING-WINDOW
    (LEXPR-FUNCALL #'PROCESS-FILTER-1 'MSG-FITS-FILTER-P FILTER
		   NAME NAME-BEFORE NAME-AFTER OPTIONS))
  (ZMAIL-SELECT-MSG *MSG* NIL NIL))

)

; From file PROFIL > ZMAIL; AI:
#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))

(DEFUN PROCESS-FILTER-1 (FILTER FILTER-ARG NAME NAME-BEFORE NAME-AFTER
				&REST OPTIONS
				&AUX (MAP-FUNCTION 'MAP-OVER-SINGLE-MAIL-FILE)
				     (MAP-ARG *MAIL-FILE*) (LAST-P T)
				     (COUNT-P ':ENGLISH) (SURVEY-P T)
				     (TYPE-P ':ASK) (DELETE-P NIL) (KEYWORDS NIL) (SAVE-P NIL)
				     (MARKING-FUNCTION NIL) (NOT-IF-MARKED-P NIL)
				     MAIL-FILE ARRAY NMSGS N-ALREADY-MARKED PRONOUN)
  (TV:DOPLIST (OPTIONS VAL KEY)
    (SELECTQ KEY
      (:MAP-FUNCTION
       (SETQ MAP-FUNCTION VAL))
      (:MAP-ARG
       (SETQ MAP-ARG VAL))
      (:COUNT-P
       (SETQ COUNT-P VAL))
      (:SURVEY-P
       (SETQ SURVEY-P VAL))
      (:TYPE-P
       (SETQ TYPE-P VAL))
      (:DELETE-P
       (SETQ DELETE-P VAL))
      (:SAVE-P
       (SETQ SAVE-P VAL))
      (:KEYWORDS
       (SETQ KEYWORDS VAL))
      (:MARKING-FUNCTION
       (SETQ MARKING-FUNCTION VAL))
      (:NOT-IF-MARKED-P
       (SETQ NOT-IF-MARKED-P VAL))
      (:LAST-P
       (SETQ LAST-P VAL))
      (OTHERWISE
       (FERROR NIL "Unknown keyword: ~S" KEY))))
  (SETQ MAIL-FILE (MAKE-MAIL-FILE 'TEMP-MAIL-FILE ':NAME NAME))
  (MAKE-MAIL-FILE-FROM-FILTER MAP-FUNCTION MAP-ARG FILTER FILTER-ARG MAIL-FILE)
  (SETQ ARRAY (MAIL-FILE-ARRAY MAIL-FILE)
	NMSGS (ARRAY-ACTIVE-LENGTH ARRAY)
	N-ALREADY-MARKED 0)
  (AND MARKING-FUNCTION
       (DO ((I 0 (1+ I))
	    (MSG))
	   (( I NMSGS))
	 (SETQ MSG (AREF ARRAY I))
	 (COND ((AND (NOT (FUNCALL MARKING-FUNCTION MSG))
		     NOT-IF-MARKED-P)		;Already done once
		(REMOVE-MSG MAIL-FILE MSG I)
		(SETQ N-ALREADY-MARKED (1+ N-ALREADY-MARKED)
		      NMSGS (1- NMSGS)
		      I (1- I))))))
  (AND COUNT-P
       (LET ((BASE (IF (EQ COUNT-P T) 10. COUNT-P)))
	 (FORMAT T "~&~: ~@[~A ~]message~P~@[ ~A~]~
		    ~:[ (not counting ~A message~:P already done)~].~%"
		 NMSGS NAME-BEFORE NMSGS NAME-AFTER
		 (ZEROP N-ALREADY-MARKED) N-ALREADY-MARKED)))
  (COND ((NOT (ZEROP NMSGS))
	 (SETQ PRONOUN (IF (= NMSGS 1) "it" "them"))
	 (COND ((OR (EQ SURVEY-P T)
		    (AND (EQ SURVEY-P ':ASK)
			 (SETQ SURVEY-P (FQUERY NIL "Survey ~A? " PRONOUN))))
		(FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
		(DO ((I 0 (1+ I))
		     (MSG) (STATUS))
		    (( I NMSGS))
		  (SETQ MSG (AREF ARRAY I)
			STATUS (ASSURE-MSG-PARSED MSG))
		  (FUNCALL STANDARD-OUTPUT ':TRUNCATED-FORMAT
			   " ~3D~C~A" (1+ I) (STATUS-LETTER STATUS) (MSG-SUMMARY-LINE MSG))
		  (FUNCALL STANDARD-OUTPUT ':TYO #\CR))))
	 (AND (OR (EQ TYPE-P T)
		  (AND (EQ TYPE-P ':ASK)
		       (SETQ TYPE-P (FQUERY NIL "Type ~A? " PRONOUN))))
	      (LET ((STREAM (MAKE-MAIL-FILE-STREAM MAIL-FILE)))
		(FUNCALL STANDARD-OUTPUT ':FRESH-LINE)
		(FUNCALL STANDARD-OUTPUT ':VIEW-STREAM STREAM T)
		(FUNCALL STANDARD-OUTPUT ':MOVE-TO-END)
		(DO ((I 0 (1+ I))
		     (LIM (FUNCALL STREAM ':CURRENT-MSG-NO)))
		    (( I LIM))
		  (MSG-PUT (AREF ARRAY I) NIL 'UNSEEN))))
	 (AND (OR (EQ DELETE-P T)
		  (AND (EQ DELETE-P ':ASK)
		       (SETQ DELETE-P (FQUERY NIL "Delete ~A? " PRONOUN))))
	      (DO I 0 (1+ I) ( I NMSGS)
		(MSG-PUT (AREF ARRAY I) T 'DELETED)))
	 (COND ((NOT DELETE-P)
		(AND KEYWORDS
		     (DO ((KEYS KEYWORDS (CDDR KEYS))
			  (KEY-P) (KEYWORDS))
			 ((NULL KEYS))
		       (SETQ KEY-P (CAR KEYS)
			     KEYWORDS (CADR KEYS))
		       (COND ((EQ KEY-P ':ASK)
			      (FORMAT T "~&Add keyword~P" (LENGTH KEYWORDS))
			      (DOLIST (KEY KEYWORDS)
				(FUNCALL STANDARD-OUTPUT ':TYO #\SP)
				(FUNCALL STANDARD-OUTPUT ':STRING-OUT
					 (OR (CAR (RASSQ KEY *KEYWORD-ALIST*))
					     (STRING KEY))))
			      (FUNCALL STANDARD-OUTPUT ':STRING-OUT "? ")
			      (SETQ KEY-P (Y-OR-N-P))))
		       (AND KEY-P
			    (DOMSGS (MSG MAIL-FILE)
				    (LET* ((OLD-KEYWORDS (MSG-GET MSG 'KEYWORDS))
					   (NEW-KEYWORDS (DO ((L KEYWORDS (CDR L))
							      (NL (REVERSE OLD-KEYWORDS)))
							     ((NULL L) (NREVERSE NL))
							   (OR (MEMQ (CAR L) NL)
							       (PUSH (CAR L) NL)))))
				      (CHANGE-MSG-KEYWORDS MSG NEW-KEYWORDS OLD-KEYWORDS))))))
		(AND (OR (EQ SAVE-P T)
			 (AND (EQ SAVE-P ':ASK)
			      (SETQ SAVE-P (FQUERY NIL "Save ~A? " PRONOUN))))
		     (SETQ *MAIL-FILE-LIST* (NCONC *MAIL-FILE-LIST* (NCONS MAIL-FILE))))))))
  (COND (LAST-P
	 (FORMAT T "~&Type any character to flush:")
	 (FUNCALL STANDARD-INPUT ':TYI))))

(DEFUN PROCESS-FILTER-ALIST (MAIL-FILE ALIST &OPTIONAL MENU-P)
  (USING-OVERLYING-WINDOW
    (PROCESS-FILTER-ALIST-1 MAIL-FILE ALIST MENU-P))
  (ZMAIL-SELECT-MSG *MSG* NIL NIL))

(DEFUN PROCESS-FILTER-ALIST-1 (MAIL-FILE ALIST &OPTIONAL MENU-P &AUX LIST MARK-P)
  (DOMSGS (MSG MAIL-FILE)
    (MSG-PUT MSG NIL 'PROCESSED))
  (IF MENU-P
      (DO ((AL ALIST (CDR AL))
	   (L NIL)
	   (FILTER) (NAME) (ITEM))
	  ((NULL AL) (SETQ LIST (NREVERSE L)))
	(SETQ FILTER (CAR AL))
	(SETQ NAME (IF (ATOM (CAR FILTER)) (STRING (CAR FILTER)) (CADR FILTER)))
	(AND (LISTP NAME) (SETQ NAME (CAR NAME)))
	(SETQ ITEM `(,NAME :VALUE ,FILTER))
	(AND (EQ (IF (ATOM (CAR FILTER)) (CAR FILTER) (CAAR FILTER)) 'NOT-PROCESSED)
	     (SETQ MARK-P T
		   ITEM (NCONC ITEM '((:FONT FONTS:HL12I)))))
	(PUSH ITEM L))
      (SETQ LIST ALIST)
      (DO ((AL ALIST (CDR AL))
	   (FILTER))
	  ((NULL AL))
	(SETQ FILTER (CAAR AL))
	(AND (EQ (IF (ATOM FILTER) FILTER (CAR FILTER)) 'NOT-PROCESSED)
	     (SETQ MARK-P T))))
  (AND MARK-P (SETQ MARK-P 'MARK-MSG-AS-PROCESSED))
  (DO ((ITEM) (FILTER) (NAME) (NAME-BEFORE) (NAME-AFTER) (FILTER-ARG))
      (NIL)
    (SETQ ITEM (IF MENU-P (TV:MENU-CHOOSE LIST) (POP LIST)))
    (AND (NULL ITEM) (RETURN T))
    (MULTIPLE-VALUE (FILTER NAME NAME-BEFORE NAME-AFTER)
      (PARSE-FILTER-SPEC (CAR ITEM)))
    (IF (EQ FILTER 'NOT-PROCESSED)
	(SETQ FILTER 'MSG-DOES-NOT-HAVE-ATTRIBUTE-P
	      FILTER-ARG 'PROCESSED)
      (PSETQ FILTER 'MSG-FITS-FILTER-P
	     FILTER-ARG FILTER))
    (LEXPR-FUNCALL #'PROCESS-FILTER-1 FILTER FILTER-ARG NAME NAME-BEFORE NAME-AFTER
		   ':MAP-ARG MAIL-FILE ':MARKING-FUNCTION MARK-P ':LAST-P (NULL LIST)
		   (CDR ITEM))
    (FORMAT T "~2&")))

)