;;; RFC733 address parser -*- Mode:LISP; Package:ZWEI-*-
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **

;;; Lexer routines, fsm defined in ZMAIL; LEX733
(DEFVAR RFC733)

(DEFPROP ATOM LEX-SUBSTRING RFC733)
(DEFPROP AT-ATOM LEX-SUBSTRING RFC733)
(DEFPROP QUOTED-STRING LEX-QUOTED-STRING RFC733)

(DEFUN (COMMENT RFC733) (TYPE RDTBL START-STRING START-INDEX END-STRING END-INDEX
			 &AUX STRING INDEX)
  (MULTIPLE-VALUE (NIL NIL STRING INDEX)
    (LEXEME-TYI RDTBL START-STRING START-INDEX END-STRING END-INDEX))
  (DO ((TEM)) (NIL)
    (MULTIPLE-VALUE (TEM STRING INDEX)
      (READ-LEXEME RDTBL STRING INDEX END-STRING END-INDEX ':RECURSIVE))
    (SELECTQ (CAR TEM)
      (CLOSE (RETURN))
      (EOF (PARSE-ERROR "EOF in the middle of a comment"))))
  (LEX-SUBSTRING TYPE RDTBL START-STRING START-INDEX STRING INDEX))

(DEFUN RFC733-LEXER (STRING &OPTIONAL (START 0) END (ERROR-P T))
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (RDTBL-LEXER RFC733 STRING START STRING END ERROR-P))

;;; Parsing grammar itself
;;; An interval is parsed into a list of ADDRESS'es.  Each address is a plist.
;;; The indicators are:
;;; :NAME (string) - the mailbox at the particular site.
;;; :HOST (string-list) - path to the site.
;;; :PERSONAL-NAME (string) - a string that might possibly be the user's real name.
;;; :INTERVAL (`((,start-string ,start-index) (,end-string ,end-index))) - parsed area
;;;           [Note those are really bp's.]
;;; :DISTRIBUTION-LIST (string) - for Foo: mumble ;
;;; :BRACKETED-LIST (string) - for Foo <mumble, frotz> with more than 1 address
;;; :INFERIORS (addresses) - for bracketing type headers like above
;;; :POSTAL (string) - for :postal:
;;; :INCLUDE (string) - likewise for :include:

(DEFUN PARSE-ADDRESSES-INTERVAL (START-BP &OPTIONAL END-BP IN-ORDER-P &AUX LEXEMES)
  (GET-INTERVAL START-BP END-BP IN-ORDER-P)
  (SETQ LEXEMES (RDTBL-LEXER RFC733 (BP-LINE START-BP) (BP-INDEX START-BP)
			     (BP-LINE END-BP) (BP-INDEX END-BP) NIL))
  (IF (STRINGP LEXEMES)				;An error
      LEXEMES
      (PARSE-DRIVER LEXEMES (GET 'ADDRESSES 'PARSE-GRAMMAR) NIL)))

(DEFUN PARSE-ADDRESSES (STRING &OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (PARSE STRING 'ADDRESSES START END NIL))

(DEFINE-PARSE-GRAMMAR ADDRESSES
  (:LEXER RFC733-LEXER)
  (:LEXEMES LEFT-BRACKET RIGHT-BRACKET ATSIGN COMMA SEMI COLON QUOTED-STRING COMMENT
	    CLOSE AT-ATOM ATOM)
  (:PRECEDENCES (ATSIGN COLON QUOTED-STRING) ATOM WORD NOWORD PHRASE)
  (:IGNORED COMMENT)
  (:RIGHT-ASSOCIATIVE ATSIGN AT-ATOM)
  )

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESSES ADDRESSES)
			      NIL FALSE)

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESSES ADDRESSES)
			      (ADDRESS) IDENTITY)

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESSES ADDRESSES)
			      (ADDRESS COMMA ADDRESSES) ADDRESS-COMMA-ADDRESS)

;;; These functions aren't #'(lambda (...) ...)'s because that wouldn't get compiled at
;;; top level like this.
(DEFUN ADDRESS-COMMA-ADDRESS (ADDRESS IGNORE ADDRESSES)
  (NCONC ADDRESS ADDRESSES))

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESS ADDRESSES)
			      (HOST-PHRASE) LIST)

;;; Recognize comments for FOO at MIT-AI (Fred Foobar) specially
(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESS ADDRESSES)
			      (HOST-PHRASE COMMENT) HOST-PHRASE-WITH-COMMENT)

(DEFUN HOST-PHRASE-WITH-COMMENT (HOST-PHRASE COMMENT)
  (LET ((PLIST (LOCF HOST-PHRASE)))
    (LET ((STRING (SECOND COMMENT)))
      (PUTPROP PLIST (SUBSTRING STRING 1 (1- (STRING-LENGTH STRING))) ':PERSONAL-NAME))
    ;; Include comment in interval
    (SETF (SECOND (GET PLIST ':INTERVAL)) (FOURTH COMMENT)))
  (LIST HOST-PHRASE))

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESS ADDRESSES)
			      (PHRASES LEFT-BRACKET ADDRESSES RIGHT-BRACKET)
			      ADDRESSES-IN-BRACKETS)

(DEFUN ADDRESSES-IN-BRACKETS (PHRASES IGNORE ADDRESSES RIGHT-BRACKET)
  (AND PHRASES
       (IF (= (LENGTH ADDRESSES) 1)
	   ;; For just one address, treat as Fred Foobar <FOO at MIT-AI>
	   (LET ((PLIST (LOCF (CAR ADDRESSES))))
	     (PUTPROP PLIST (FIRST PHRASES) ':PERSONAL-NAME)
	     ;; Include phrases and bracket in interval
	     (LET ((INTERVAL (GET PLIST ':INTERVAL)))
	       (SETF (FIRST INTERVAL) (SECOND PHRASES))
	       (SETF (SECOND INTERVAL) (THIRD RIGHT-BRACKET))))
	   ;; Otherwise treat as a list
	   (LET* ((ADDRESS NIL)
		  (PLIST (LOCF ADDRESS)))
	     (PUTPROP PLIST (FIRST PHRASES) ':BRACKETED-LIST)
	     (SETF (THIRD PHRASES) (THIRD RIGHT-BRACKET))
	     (PUTPROP PLIST (CDR PHRASES) ':INTERVAL)
	     (PUTPROP PLIST ADDRESSES ':INFERIORS)
	     (PUSH ADDRESS ADDRESSES))))
  ADDRESSES)

;;; This is necessary because of the dual nature of COMMENT's.
;;; It makes foo (bar) <mumble at frotz> work.
(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESS ADDRESSES)
			      (ADDRESS LEFT-BRACKET ADDRESSES RIGHT-BRACKET)
			      ADDRESS-ADDRESSES-IN-BRACKETS
  (:PRECEDENCE PHRASE))

(DEFUN ADDRESS-ADDRESSES-IN-BRACKETS (ADDRESS LEFT-BRACKET ADDRESSES RIGHT-BRACKET)
  (LET ((INTERVAL (GET (LOCF (CAR ADDRESS)) ':INTERVAL)))
    (SETQ ADDRESS (CONS (STRING-INTERVAL (CAR INTERVAL) (CADR INTERVAL) T)
			INTERVAL)))
  (ADDRESSES-IN-BRACKETS ADDRESS LEFT-BRACKET ADDRESSES RIGHT-BRACKET))

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESS ADDRESSES)
			      (PHRASES COLON ADDRESSES SEMI)
			      ADDRESS-DISTRIBUTION-LIST)

(DEFUN ADDRESS-DISTRIBUTION-LIST (PHRASES IGNORE ADDRESSES SEMI)
  (AND PHRASES
       (LET* ((ADDRESS NIL)
	      (PLIST (LOCF ADDRESS)))
	 (PUTPROP PLIST (FIRST PHRASES) ':DISTRIBUTION-LIST)
	 (SETF (THIRD PHRASES) (THIRD SEMI))
	 (PUTPROP PLIST (CDR PHRASES) ':INTERVAL)
	 (PUTPROP PLIST ADDRESSES ':INFERIORS)
	 (PUSH ADDRESS ADDRESSES)))
  ADDRESSES)

(ADD-PARSE-GRAMMAR-PRODUCTION (ADDRESS ADDRESSES)
			      (COLON ATOM COLON ADDRESS)
			      COLON-ATOM-COLON-ADDRESS)

(DEFUN COLON-ATOM-COLON-ADDRESS (COLON ATOM IGNORE ADDRESS)
  (LET ((IND (INTERN (STRING-UPCASE (SECOND ATOM)) ""))
	TEM)
    (DOLIST (ADD ADDRESS)
      (AND (SETQ TEM (GETL (LOCF ADD) '(:NAME)))
	   (SETF (CAR TEM) IND))))
  (AND (= (LENGTH ADDRESS) 1)
       (LET ((INT (GET (LOCF (CAR ADDRESS)) ':INTERVAL)))
	 (SETF (FIRST INT) (THIRD COLON))))
  ADDRESS)

(ADD-PARSE-GRAMMAR-PRODUCTION (PHRASES ADDRESSES)
			      NIL FALSE
  (:PRECEDENCE NOWORD))

(ADD-PARSE-GRAMMAR-PRODUCTION (PHRASES ADDRESSES)
			      (PHRASE PHRASES) APPEND-PHRASES)

(DEFUN APPEND-PHRASES (PHRASE PHRASES)
  (COND (PHRASES
	 (SETF (FIRST PHRASE) (STRING-APPEND (FIRST PHRASE) #\SP (FIRST PHRASES)))
	 (SETF (THIRD PHRASE) (THIRD PHRASES))))
  PHRASE)

(ADD-PARSE-GRAMMAR-PRODUCTION (PHRASE ADDRESSES)
			      (WORD) IDENTITY
  (:PRECEDENCE WORD))

(ADD-PARSE-GRAMMAR-PRODUCTION (PHRASE ADDRESSES)
			      (WORD PHRASE)
			      APPEND-PHRASES
  (:PRECEDENCE WORD))

(ADD-PARSE-GRAMMAR-PRODUCTION (WORD ADDRESSES)
			      (ATOM) CDR)

(ADD-PARSE-GRAMMAR-PRODUCTION (WORD ADDRESSES)
			      (AT-ATOM) CDR
  (:PRECEDENCE ATOM))

(ADD-PARSE-GRAMMAR-PRODUCTION (WORD ADDRESSES)
			      (QUOTED-STRING) CDR)

(ADD-PARSE-GRAMMAR-PRODUCTION (HOST-PHRASE ADDRESSES)
			      (PHRASE-FOR-HOST HOST-INDICATOR)
			      ADDRESS-HOST-PHRASE)

(DEFUN ADDRESS-HOST-PHRASE (PHRASE HOST)
  (AND HOST (SETF (THIRD PHRASE) (THIRD HOST)))
  `(:NAME ,(CAR PHRASE) :HOST ,(CAR HOST) :INTERVAL ,(CDR PHRASE)))

(ADD-PARSE-GRAMMAR-PRODUCTION (PHRASE-FOR-HOST ADDRESSES)
			      (PHRASE) IDENTITY
  (:PRECEDENCE PHRASE))

;;; This is not legal 733, it makes "(BUG ZWEI) at MIT-AI" work.
(ADD-PARSE-GRAMMAR-PRODUCTION (PHRASE-FOR-HOST ADDRESSES)
			      (COMMENT) COMMENT-PHRASE-FOR-HOST)

(DEFUN COMMENT-PHRASE-FOR-HOST (COMMENT &AUX NAME INTERVAL)
  (SETF `(COMMENT ,NAME . ,INTERVAL) COMMENT)
  (AND (STRING-EQUAL NAME "(BUG " 0 0 5 5)
       (SETQ NAME (STRING-APPEND "BUG-" (SUBSTRING NAME 5 (1- (STRING-LENGTH NAME))))))
  `(,NAME . ,INTERVAL))

;;; This is not legal 733, but every tenex site in the world sends addresses without hosts.
(ADD-PARSE-GRAMMAR-PRODUCTION (HOST-INDICATOR ADDRESSES)
			      NIL FALSE)

(ADD-PARSE-GRAMMAR-PRODUCTION (HOST-INDICATOR ADDRESSES)
			      (AT-HOST HOST-INDICATOR)
			      ADDRESS-HOST-INDICATOR)

(DEFUN ADDRESS-HOST-INDICATOR (AT-HOST HOST-INDICATOR)
  (COND (HOST-INDICATOR
	 (SETF (FIRST AT-HOST) (CONS (FIRST AT-HOST) (FIRST HOST-INDICATOR)))
	 (SETF (THIRD AT-HOST) (THIRD HOST-INDICATOR)))
	(T
	 (SETF (FIRST AT-HOST) (NCONS (FIRST AT-HOST)))))
  AT-HOST)

(ADD-PARSE-GRAMMAR-PRODUCTION (AT-HOST ADDRESSES)
			      (AT WORD) ADDRESS-AT-HOST)

;;; These hooks are for canonializing all the "@"'s and host names
(DEFVAR *HOST-INTERVALS*)
(DEFVAR *ACCUMULATE-HOST-INTERVALS* NIL)

(DEFUN ADDRESS-AT-HOST (AT WORD)
  (COND (*ACCUMULATE-HOST-INTERVALS*
	 (PUSH AT *HOST-INTERVALS*)
	 (PUSH (CONS 'HOST (COPYLIST WORD)) *HOST-INTERVALS*)))
  (SETF (SECOND WORD) (THIRD AT))
  WORD)

(ADD-PARSE-GRAMMAR-PRODUCTION (AT ADDRESSES)
			      (ATSIGN) IDENTITY)

(ADD-PARSE-GRAMMAR-PRODUCTION (AT ADDRESSES)
			      (AT-ATOM) IDENTITY
  (:PRECEDENCE ATSIGN))

(BUILD-PARSE-GRAMMAR ADDRESSES)

;;; Address movement
(DEFCOM COM-FORWARD-ADDRESS "Move one or more addresses forward." (KM)
  (MOVE-BP (POINT) (OR (FORWARD-ADDRESS (POINT) *NUMERIC-ARG*) (BARF)))
  DIS-BPS)

(DEFCOM COM-BACKWARD-ADDRESS "Move one or more addresses backward." (KM)
  (MOVE-BP (POINT) (OR (FORWARD-ADDRESS (POINT) (- *NUMERIC-ARG*)) (BARF)))
  DIS-BPS)

(DEFCOM COM-KILL-ADDRESS "Kill one or more addresses forward." ()
  (KILL-COMMAND-INTERNAL #'FORWARD-ADDRESS *NUMERIC-ARG*))

(DEFCOM COM-BACKWARD-KILL-ADDRESS "Kill one or more addresses backward." ()
  (KILL-COMMAND-INTERNAL #'FORWARD-ADDRESS (- *NUMERIC-ARG*)))

(DEFCOM COM-EXCHANGE-ADDRESSES "Interchange the addresses before and after the cursor." ()
  (EXCHANGE-SUBR 'FORWARD-ADDRESS *NUMERIC-ARG*)
  DIS-TEXT)

(DEFCOM COM-MARK-ADDRESS "Set mark one or more addresses from point." (SM)
  (LET (BP1 BP2)
    (SETQ BP1 (FORWARD-ADDRESS (POINT) *NUMERIC-ARG* T))
    (SETQ BP2 (FORWARD-ADDRESS BP1 (MINUS *NUMERIC-ARG*) T))
    (AND (MINUSP *NUMERIC-ARG*)
	 (SETQ BP2 (PROG1 BP1 (SETQ BP1 BP2))))
    (MOVE-BP (POINT) BP1)
    (MOVE-BP (MARK) BP2))
  DIS-BPS)

(DEFUN FORWARD-ADDRESS (BP &OPTIONAL (TIMES 1) FIXUP-P)
  (COND ((ZEROP TIMES)
	 (COPY-BP BP))
	((PLUSP TIMES)
	 (DO ((LINE (BP-LINE BP))
	      (END-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*)))
	      (START-BP) (START-ADDRESS)
	      (END-BP) (END-ADDRESS)
	      (INTERVAL))
	     (NIL)
	   (SETQ START-ADDRESS NIL
		 END-ADDRESS NIL)
	   (DOLIST (ADDRESS (ADDRESSES-STARTING-ON-LINE LINE))
	     (AND (SETQ INTERVAL (GET (LOCF ADDRESS) ':INTERVAL))
		  (NOT (BP-< (FIRST INTERVAL) BP))
		  (OR (NULL START-ADDRESS) (BP-< (FIRST INTERVAL) START-BP))
		  (SETQ START-BP (FIRST INTERVAL)
			START-ADDRESS ADDRESS)))
	   (DOLIST (ADDRESS (ADDRESSES-ENDING-ON-LINE LINE))
	     (AND (SETQ INTERVAL (GET (LOCF ADDRESS) ':INTERVAL))
		  (BP-< BP (SECOND INTERVAL))
		  (OR (NULL END-ADDRESS) (BP-< (SECOND INTERVAL) END-BP))
		  (SETQ END-BP (SECOND INTERVAL)
			END-ADDRESS ADDRESS)))
	   (COND ((AND (NULL START-ADDRESS) (NULL END-ADDRESS))
		  (AND (EQ LINE END-LINE)
		       (RETURN (AND FIXUP-P (COPY-BP (INTERVAL-LAST-BP *INTERVAL*)))))
		  (SETQ LINE (LINE-NEXT LINE)))
		 (T
		  (SETQ BP (IF (OR (NULL END-BP) (AND START-BP (BP-< START-BP END-BP)))
			       (SECOND (GET (LOCF START-ADDRESS) ':INTERVAL))
			       END-BP)
			LINE (BP-LINE BP)
			TIMES (1- TIMES))
		  (AND (ZEROP TIMES) (RETURN BP))))))
	(T
	 (DO ((LINE (BP-LINE BP))
	      (START-LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))
	      (END-BP) (END-ADDRESS)
	      (START-BP) (START-ADDRESS)
	      (INTERVAL))
	     (NIL)
	   (SETQ END-ADDRESS NIL
		 START-ADDRESS NIL)
	   (DOLIST (ADDRESS (ADDRESSES-ENDING-ON-LINE LINE))
	     (AND (SETQ INTERVAL (GET (LOCF ADDRESS) ':INTERVAL))
		  (NOT (BP-< BP (SECOND INTERVAL)))
		  (OR (NULL END-BP) (BP-< END-BP (SECOND INTERVAL)))
		  (SETQ END-BP (SECOND INTERVAL)
			END-ADDRESS ADDRESS)))
	   (DOLIST (ADDRESS (ADDRESSES-STARTING-ON-LINE LINE))
	     (AND (SETQ INTERVAL (GET (LOCF ADDRESS) ':INTERVAL))
		  (BP-< (FIRST INTERVAL) BP)
		  (OR (NULL START-BP) (BP-< START-BP (FIRST INTERVAL)))
		  (SETQ START-BP (FIRST INTERVAL)
			START-ADDRESS ADDRESS)))
	   (COND ((AND (NULL END-ADDRESS) (NULL START-ADDRESS))
		  (AND (EQ LINE START-LINE)
		       (RETURN (AND FIXUP-P (COPY-BP (INTERVAL-LAST-BP *INTERVAL*)))))
		  (SETQ LINE (LINE-PREVIOUS LINE)))
		 (T
		  (SETQ BP (IF (OR (NULL START-BP) (AND END-BP (BP-< START-BP END-BP)))
			       (FIRST (GET (LOCF END-ADDRESS) ':INTERVAL))
			       START-BP)
			LINE (BP-LINE BP)
			TIMES (1+ TIMES))
		  (AND (ZEROP TIMES) (RETURN BP))))))))

(DEFUN ADDRESSES-STARTING-ON-LINE (LINE &AUX PLIST TEM)
  (SETQ PLIST (LOCF (LINE-CONTENTS-PLIST LINE)))
  (IF (SETQ TEM (GETL PLIST '(STARTING-ADDRESSES)))
      (CADR TEM)
      (PARSE-ADDRESSES-AROUND-LINE LINE)
      (GET PLIST 'STARTING-ADDRESSES)))

(DEFUN ADDRESSES-ENDING-ON-LINE (LINE &AUX PLIST TEM)
  (SETQ PLIST (LOCF (LINE-CONTENTS-PLIST LINE)))
  (IF (SETQ TEM (GETL PLIST '(ENDING-ADDRESSES)))
      (CADR TEM)
      (PARSE-ADDRESSES-AROUND-LINE LINE)
      (GET PLIST 'ENDING-ADDRESSES)))

(DEFUN PARSE-ADDRESSES-AROUND-LINE (LINE &AUX START-LINE END-LINE)
  (DO ((FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*))))
      ((OR (EQ LINE FIRST-LINE)
	   (NOT (CONTINUATION-LINE-P LINE))))
    (SETQ LINE (LINE-PREVIOUS LINE)))
  (SETQ START-LINE LINE)
  (DO ((LAST-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*))))
      (NIL)
    (SETQ END-LINE LINE)
    (AND (EQ LINE LAST-LINE) (RETURN))
    (SETQ LINE (LINE-NEXT LINE))
    (AND (NOT (CONTINUATION-LINE-P LINE)) (RETURN)))
  (DO ((LINE START-LINE (LINE-NEXT LINE))
       (PLIST))
      (NIL)
    (SETQ PLIST (LOCF (LINE-CONTENTS-PLIST LINE)))
    (PUTPROP PLIST NIL 'STARTING-ADDRESSES)
    (PUTPROP PLIST NIL 'ENDING-ADDRESSES)
    (AND (EQ LINE END-LINE) (RETURN)))
  (LOOP FOR (TYPE ADDRESSES) ON (PARSE-ONE-HEADER START-LINE END-LINE) BY 'CDDR
	WHEN (MEMQ TYPE *ADDRESS-TYPE-HEADERS*)
	DO (DOLIST (ADDRESS ADDRESSES)
	     (LET ((INTERVAL (GET (LOCF ADDRESS) ':INTERVAL)))
	       (COND (INTERVAL
		      (LET ((START-LINE (BP-LINE (FIRST INTERVAL))))
			(PUSH ADDRESS (GET (LOCF (LINE-CONTENTS-PLIST START-LINE))
					   'STARTING-ADDRESSES)))
		      (LET ((END-LINE (BP-LINE (SECOND INTERVAL))))
			(PUSH ADDRESS (GET (LOCF (LINE-CONTENTS-PLIST END-LINE))
					   'ENDING-ADDRESSES)))))))))

(DEFUN CONTINUATION-LINE-P (LINE)
  (AND (PLUSP (LINE-LENGTH LINE))
       (MEMQ (AREF LINE 0) '(#\SP #\TAB))))

;;; Header parsing
;;; Parse headers in the given interval, returning a list
(DEFUN PARSE-HEADERS-INTERVAL (BP1 &OPTIONAL BP2 IN-ORDER-P STOP-AT-BLANK-LINE &AUX LIST)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (DO ((LINE (BP-LINE BP1) (AND (NEQ LINE LIMIT-LINE) (LINE-NEXT LINE)))
       (LAST-LINE NIL LINE)
       (LIMIT-LINE (BP-LINE BP2))
       (RETURN-P NIL)
       (BLANK-P NIL NIL)
       (START-LINE NIL))
      (NIL)
    (COND ((COND ((NULL LINE)
		  (SETQ RETURN-P T))
		 ((EQ LINE LIMIT-LINE)
		  (AND (ZEROP (BP-INDEX BP2)) (SETQ RETURN-P T))
		  T)
		 ((ZEROP (LINE-LENGTH LINE))	;Blank line
		  (AND START-LINE STOP-AT-BLANK-LINE
		       (SETQ BP2 (CREATE-BP (OR (LINE-NEXT LINE) LINE) 0)
			     RETURN-P T))
		  (SETQ BLANK-P T)
		  T)
		 ((MEMQ (AREF LINE 0) '(#\SP #\TAB))	;Continuation line
		  NIL)
		 (T
		  T))
	   ;; Are now at the start of something new
	   (AND START-LINE
		(LET ((HEADERS (PARSE-ONE-HEADER START-LINE LAST-LINE)))
		  (LOOP FOR LINE = START-LINE THEN (LINE-NEXT LINE)
			DO (PUTPROP (LOCF (LINE-CONTENTS-PLIST LINE)) HEADERS 'PARSED-HEADERS)
			UNTIL (EQ LINE LAST-LINE))
		  (LOOP FOR (TYPE PROP) ON HEADERS BY 'CDDR
			AS SUBLIST = (CAR (REMPROP (LOCF LIST) TYPE))
			DO (SETQ SUBLIST (IF SUBLIST
					     (APPEND (IF (LISTP SUBLIST) SUBLIST
							 (NCONS SUBLIST))
						     (IF (LISTP PROP) PROP (NCONS PROP)))
					     PROP)
				 LIST (NCONC LIST (LIST TYPE SUBLIST))))))
	   (SETQ START-LINE (AND (NOT BLANK-P) LINE))))
    (AND RETURN-P (RETURN NIL)))
  (VALUES LIST BP2))

;;; Parse a single line or line and continuation line(s)
(DEFUN PARSE-ONE-HEADER (START-LINE END-LINE &AUX INDEX TYPE FLAG)
  (IF (NULL (SETQ INDEX (STRING-SEARCH-CHAR #/: START-LINE)))
      '(LOSING-HEADERS "Line without a colon")
      (SETQ TYPE (INTERN (STRING-UPCASE (NSUBSTRING START-LINE 0 INDEX)) ""))
      (AND (EQ TYPE ':RE) (SETQ TYPE ':SUBJECT))
      (SETQ INDEX (OR (STRING-SEARCH-NOT-SET '(#\SP #\TAB) START-LINE (1+ INDEX))
		      (LINE-LENGTH START-LINE)))
      (COND ((MEMQ TYPE *ADDRESS-TYPE-HEADERS*)
	     (LET ((PROP (PARSE-ADDRESSES-INTERVAL (CREATE-BP START-LINE INDEX)
						   (END-OF-LINE END-LINE)
						   T)))
	       (IF (STRINGP PROP)
		   `(LOSING-HEADERS ,PROP)
		   `(,TYPE ,PROP))))
	    (T
	     (AND (NEQ START-LINE END-LINE)
		  (SETQ START-LINE (STRING-INTERVAL (CREATE-BP START-LINE INDEX)
						    (END-OF-LINE END-LINE)
						    T)
			INDEX 0
			FLAG T))
	     (COND ((MEMQ TYPE *DATE-TYPE-HEADERS*)
		    (LET ((PROP (TIME:PARSE-UNIVERSAL-TIME START-LINE INDEX
							   NIL NIL NIL NIL T NIL NIL)))
		      (IF (STRINGP PROP)
			  `(LOSING-HEADERS ,PROP)
			  `(,TYPE ,PROP))))
		   ((AND (MEMQ TYPE *SINGLE-LINE-TYPE-HEADERS*)
			 (OR FLAG (MEMQ TYPE *REFERENCE-TYPE-HEADERS*)))
		    `(,TYPE ,(LOOP FOR START-IDX = INDEX
						 THEN (STRING-SEARCH-NOT-SET '(#\SP #\TAB)
									     START-LINE
									     (+ END-IDX 2))
				   AS END-IDX = (STRING-SEARCH ",
"
							       START-LINE START-IDX)
				   COLLECT (IF (MEMQ TYPE *REFERENCE-TYPE-HEADERS*)
					       (PARSE-REFERENCE START-LINE START-IDX END-IDX)
					       (SUBSTRING START-LINE START-IDX END-IDX))
				   UNTIL (NULL END-IDX))))
		   ((EQ TYPE ':FORWARDED-TO)
		    (PARSE-COMSYS-FORWARDED-TO START-LINE INDEX))
		   (T
		    `(,TYPE ,(IF FLAG START-LINE (SUBSTRING START-LINE INDEX)))))))))

(DEFUN PROBABLE-ITS-HEADER-P (LINE &OPTIONAL (START 0) END &AUX TEM)
  (DECLARE (RETURN-LIST DATE-START FROM-ADDRESSES))
  (OR END (SETQ END (STRING-LENGTH LINE)))
  (AND (OR (NULL (SETQ TEM (STRING-SEARCH-CHAR #/: LINE START END)))
	   (> TEM (OR (STRING-SEARCH-CHAR #\SP LINE START END) END)))
       (LISTP (SETQ TEM (RFC733-LEXER LINE START (OR TEM END) NIL)))
       (LOOP WITH LEXEMES = TEM AND LAST-HAD-AT
	     UNLESS (EQ (CAAR LEXEMES) 'ATOM) RETURN NIL
	     AS ADDRESS = `(:NAME ,(CADAR LEXEMES))
	     IF (MEMQ (CAADR LEXEMES) '(ATSIGN AT-ATOM))
	     DO (OR (EQ (CAADDR LEXEMES) 'ATOM) (RETURN NIL))
		(SETQ ADDRESS (NCONC ADDRESS `(:HOST (,(SECOND (THIRD LEXEMES)))
					       :INTERVAL (,(THIRD (FIRST LEXEMES))
							  ,(FOURTH (THIRD LEXEMES)))))
		      LEXEMES (CDDDR LEXEMES)
		      LAST-HAD-AT T)
	     ELSE DO (SETQ LEXEMES (CDR LEXEMES)
			   LAST-HAD-AT NIL)
	     COLLECT ADDRESS INTO ADDRESSES
	     DO (LET ((NEXT (CAAR LEXEMES)))
		  (COND ((EQ NEXT 'COMMA))	;Continue
			((AND LAST-HAD-AT (MEMQ NEXT '(ATOM COMMENT)))
			 (RETURN (SECOND (THIRD (FIRST LEXEMES))) ADDRESSES))
			(T
			 (RETURN NIL))))
	     DO (SETQ LEXEMES (CDR LEXEMES)))))

;;; Parse an abbreviated ITS style header
(DEFUN PARSE-ITS-HEADER (LINE DATE-START END FROM-ADDRESSES &AUX LIST LOSE-P)
  (SETQ LIST `(:FROM ,FROM-ADDRESSES))
  (LET ((SENT-BY-END (+ DATE-START 11)))
    (AND (STRING-EQUAL "(Sent by " LINE 0 DATE-START 11 SENT-BY-END)
	 (LET ((BEFORE-AT-POS (STRING-SEARCH-CHAR #/@ LINE SENT-BY-END)))
	   (SETQ LIST `(,@LIST :SENDER ((,@(IF BEFORE-AT-POS
					       `(:NAME ,(SUBSTRING LINE SENT-BY-END
								   BEFORE-AT-POS)
						 :HOST (,(SUBSTRING
							   LINE (1+ BEFORE-AT-POS)
							   (SETQ DATE-START
								 (STRING-SEARCH-CHAR
								   #/) LINE BEFORE-AT-POS))))
						 )
					       `(:NAME ,(SUBSTRING
							  LINE SENT-BY-END
							  (SETQ DATE-START (STRING-SEARCH-CHAR
									     #/) LINE
									     SENT-BY-END)))))
					 :INTERVAL ((,LINE ,SENT-BY-END)
						    (,LINE ,DATE-START)))))
		 DATE-START (1+ DATE-START)))))
  (LET ((RE (STRING-SEARCH "Re: " LINE DATE-START END)))
    (LET ((TIME (TIME:PARSE-UNIVERSAL-TIME LINE DATE-START RE NIL NIL T NIL NIL NIL)))
      (IF (STRINGP TIME)
	  (SETQ LOSE-P TIME)
	  (SETQ LIST `(,@LIST :DATE ,TIME))))
    (AND RE
	 (SETQ LIST `(,@LIST
		      :SUBJECT ,(STRING-TRIM '(#\SP) (NSUBSTRING LINE (+ RE 4) END))))))
  (AND LOSE-P (SETQ LIST `(LOSING-HEADERS ,LOSE-P . ,LIST)))
  `(,@LIST ITS-HEADER-P T))

;;; Parse the head of a *MSG type message
(DEFUN PARSE-*MSG-START (START-LINE)
  (DECLARE (RETURN-LIST STATUS START-LINE))
  (DO ((LINE START-LINE (LINE-NEXT LINE))
       (STATUS NIL))
      (NIL)
    (COND ((STRING-EQUAL-START LINE ':MSG)
	   (SETQ STATUS (APPEND STATUS (LIST ':*MSG
					     (DO ((I)
						  (J 4)
						  (LIST NIL (CONS (SUBSTRING LINE I J) LIST)))
						 (NIL)
					       (OR (AND J
							(SETQ I (STRING-SEARCH-NOT-CHAR
								  #\SP LINE J)))
						   (RETURN (NREVERSE LIST)))
					       (SETQ J (STRING-SEARCH-CHAR #\SP LINE I)))))))
	  ((STRING-EQUAL-START LINE ':DISTRIB)
	   (SETQ STATUS (APPEND STATUS (LIST ':DISTRIB
					     (DO ((I)
						  (J 8 (1+ J))
						  (LIST NIL))
						 (NIL)
					       (SETQ I (STRING-SEARCH-NOT-CHAR #\SP LINE J)
						     J (STRING-SEARCH-CHAR #/, LINE I))
					       (PUSH (SUBSTRING LINE I J) LIST)
					       (OR J (RETURN (NREVERSE LIST))))))))
	  ((STRING-EQUAL-START LINE ':EXPIRES)
	   (SETQ STATUS (APPEND STATUS (LIST ':EXPIRES
					     (LET ((TIME (TIME:PARSE-UNIVERSAL-TIME
							   LINE 8 (LINE-LENGTH LINE)
							   NIL NIL T NIL NIL NIL)))
					       (IF (STRINGP TIME) -1 TIME))))))
	  (T
	   (RETURN STATUS LINE)))))

(DEFUN PARSE-COMSYS-FORWARDED-TO (STRING &OPTIONAL (START 0) END &AUX TO FROM DATE LOSE-P)
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (IF (NOT (AND (SETQ DATE (STRING-REVERSE-SEARCH " on " STRING END))
		(SETQ FROM (STRING-REVERSE-SEARCH " by " STRING DATE))))
      '(LOSING-HEADERS "Bad format Forward-to field")
      (SETQ TO (PARSE-ADDRESSES STRING START FROM)
	    FROM (PARSE-ADDRESSES STRING (+ FROM 4) DATE)
	    DATE (TIME:PARSE-UNIVERSAL-TIME STRING (+ DATE 4) END NIL NIL T NIL NIL NIL))
      (IF (SETQ LOSE-P (COND ((STRINGP TO) TO)
			     ((STRINGP FROM) FROM)
			     ((STRINGP DATE) DATE)))
	  `(LOSING-HEADERS ,LOSE-P)
	  `(:FORWARDED-TO (:TO ,TO :FROM ,FROM :DATE ,DATE)
	    :FORWARDED-TO-TO ,TO
	    :FORWARDED-TO-FROM ,FROM
	    :FORWARDED-TO-DATE ,DATE))))

(DEFUN PARSE-MSG-HEADERS (START-BP &OPTIONAL END-BP IN-ORDER-P REFORMATTED
				   &AUX (LINE (BP-LINE START-BP)) (NEWSTAT NIL) STOP-BP
				        TEM TEM1)
  (GET-INTERVAL START-BP END-BP IN-ORDER-P)
  (DO () ((NOT (LINE-BLANK-P LINE))) (SETQ LINE (LINE-NEXT LINE)))
  (AND (STRING-EQUAL-START LINE "MSG:")
       (MULTIPLE-VALUE (NEWSTAT LINE)
	 (PARSE-*MSG-START LINE)))
  (COND ((AND (NOT REFORMATTED)
	      (MULTIPLE-VALUE (TEM TEM1)
		(PROBABLE-ITS-HEADER-P LINE)))
	 (SETQ NEWSTAT (APPEND NEWSTAT
			       (PARSE-ITS-HEADER LINE TEM (LINE-LENGTH LINE) TEM1)))
	 (LET* ((START-LINE (LINE-NEXT LINE))
		(END-LINE (DO ((LINE START-LINE (LINE-NEXT LINE)))
			      ((NOT (OR (STRING-EQUAL-START LINE "To: ")
					(STRING-EQUAL-START LINE "Cc: ")))
			       LINE))))
	   (OR (EQ END-LINE START-LINE)
	       (SETQ NEWSTAT (APPEND NEWSTAT
				     (PARSE-HEADERS-INTERVAL
				       (CREATE-BP START-LINE 0)
				       (LET ((LINE (LINE-PREVIOUS END-LINE)))
					 (CREATE-BP LINE (LINE-LENGTH LINE)))
				       T))))
	   (SETQ STOP-BP (CREATE-BP END-LINE 0))))
	(T
	 (MULTIPLE-VALUE (TEM STOP-BP)
	   (PARSE-HEADERS-INTERVAL START-BP END-BP T T))
	 (SETQ NEWSTAT (APPEND NEWSTAT TEM))))
  (VALUES NEWSTAT STOP-BP))

(DEFUN STRING-EQUAL-START (STRING PATTERN &OPTIONAL (START 0))
  (OR (STRINGP PATTERN)
      (SETQ PATTERN (STRING PATTERN)))
  (%STRING-EQUAL STRING START PATTERN 0 (ARRAY-ACTIVE-LENGTH PATTERN)))

(DEFPROP :ADDRESS-LIST
	 (PRINT-ADDRESS-LIST READ-ADDRESS-LIST NIL
	  NIL NIL "Click left to enter list of addresses from the keyboard.")
	 TV:CHOOSE-VARIABLE-VALUES-KEYWORD)

(DEFUN READ-ADDRESS-LIST (STREAM &AUX ADDRESSES)
  (SETQ ADDRESSES (PARSE-ADDRESSES (READLINE STREAM)))
  (AND (STRINGP ADDRESSES) (FERROR NIL "Bad addresses: ~A" ADDRESSES))
  (LOOP FOR ADDRESSES ON ADDRESSES
	DO (REMPROP (LOCF (CAR ADDRESSES)) ':INTERVAL))
  ADDRESSES)

(DEFUN PRINT-ADDRESS-LIST (ADDRESSES STREAM)
  (LOOP FOR ADDRESS IN ADDRESSES
	WITH COMMA-P = NIL
	DO (IF COMMA-P (FUNCALL STREAM ':STRING-OUT ", ") (SETQ COMMA-P T))
	   (FUNCALL STREAM ':STRING-OUT (STRING-FROM-HEADER ADDRESS ':SHORT))))

;;; Reference parsing

;;; Parse the in-reply-to field.  This understands everything i could find in the minutes
;;; of HEADER-PEOPLE, which will serve as the network standard for now.
(DEFUN PARSE-REFERENCE (STRING &OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH STRING)))
  ;;"<80265.32584.6980 @ Darcom-hq>"
  (IF (AND (= (AREF STRING START) #/<)
	   (= (AREF STRING (1- END)) #/>))
      `(:MESSAGE-ID ,(SUBSTRING STRING START END))
      (LET (DATE FROM FROM-OK TEM TEM1)
	(COND ((NULL (SETQ START (STRING-SEARCH-NOT-SET *BLANKS* STRING START END))))
	      ;;"Your message of 21 Sep 1980 22:12 PDT"
	      ((STRING-EQUAL-START STRING "Your message of " START)
	       ;; RAND peculiarity
	       (AND (STRING-EQUAL STRING ")." (- END 2) 0 END)
		    (SETQ END (1- END)))
	       (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME STRING (+ START 16.) END
						     NIL NIL NIL NIL NIL NIL)
		     FROM-OK T))
	      ;;"Message of 12 Mar 81 at 1937 PST by Admin.MRC@SU-SCORE"
	      ((AND (STRING-EQUAL-START STRING "Message of " START)
		    (SETQ TEM (STRING-SEARCH " by " STRING START END)))
	       (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME STRING (+ START 11.) TEM
						     NIL NIL NIL NIL NIL NIL)
		     FROM (PARSE-ADDRESSES STRING (+ TEM 4) END))
	       (AND (LISTP FROM)
		    (SETQ FROM-OK T
			  FROM (SOME-PLIST (CAR FROM) '(:NAME :HOST)))))
	      ;;"Earl A. Killian's message of 23 Mar 81 03:41-EST"
	      ((AND (SETQ TEM (STRING-SEARCH " message of " STRING START END))
		    ;;"Rick Gumpertz' message ..."
		    (SETQ TEM1 (STRING-REVERSE-SEARCH-CHAR #/' STRING TEM START)))
	       (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME STRING (+ TEM 12.) END
						     NIL NIL NIL NIL NIL NIL)
		     FROM (PARSE-ADDRESSES STRING START TEM1))
	       (COND ((LISTP FROM)
		      (SETQ FROM-OK T
			    FROM (CAR FROM))
		      (IF (NULL (GET (LOCF FROM) ':HOST))
			  (SETQ FROM `(:PERSONAL-NAME ,(GET (LOCF FROM) ':NAME)))
			  (SETQ FROM (SOME-PLIST FROM '(:NAME :HOST)))))))
	      ;;"Message from Richard M. Stallman <RMS at MIT-AI>
	      ;;  of 28-May-81 2333-EDT"
	      ((AND (STRING-EQUAL-START STRING "Message from " START)
		    (SETQ TEM (STRING-REVERSE-SEARCH " of " STRING END START)))
	       (SETQ FROM (PARSE-ADDRESSES STRING (+ 13. START) TEM)
		     DATE (TIME:PARSE-UNIVERSAL-TIME STRING (+ TEM 4) END
						     NIL NIL NIL NIL NIL NIL))
	       (AND (LISTP FROM)
		    (SETQ FROM-OK T
			  FROM (SOME-PLIST (CAR FROM) '(:NAME :HOST)))))
	      ;;"The message of 27 Apr 81 13:53-EDT from Daniel L. Weinreb <DLW at MIT-AI>"
	      ((AND (STRING-EQUAL-START STRING "The message of " START)
		    (SETQ TEM (STRING-SEARCH " from " STRING START END)))
	       (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME STRING (+ START 15.) TEM
						     NIL NIL NIL NIL NIL NIL)
		     FROM (PARSE-ADDRESSES STRING (+ TEM 6) END))
	       (AND (LISTP FROM)
		    (SETQ FROM-OK T
			  FROM (SOME-PLIST (CAR FROM) '(:NAME :HOST)))))
	      ;; Anything else?
	      )
	(AND FROM-OK (NUMBERP DATE)
	     `(:DATE ,DATE . ,(AND FROM `(:FROM ,FROM)))))))

;;; Figure out what message if any was yanked into the body of this one as a reply.
(DEFUN GET-MSG-TEXT-REFERENCES (MSG &AUX REFLIST)
  (DO ((LINE (BP-LINE (MSG-START-BP MSG)) (LINE-NEXT LINE))
       (END-LINE (BP-LINE (MSG-END-BP MSG)))
       (LEN) (TEM) (TEM1) (FROM) (DATE))
      ((EQ LINE END-LINE))
    (CATCH-ERROR
      (COND ((NOT (PLUSP (SETQ LEN (LINE-LENGTH LINE)))))
	    ((MEMQ (AREF LINE 0) *BLANKS*)	;Possibly indented line
	     (LET ((START-IDX (STRING-SEARCH-NOT-SET *BLANKS* LINE)))
	       (COND ((MULTIPLE-VALUE (TEM TEM1)
			(PROBABLE-ITS-HEADER-P LINE START-IDX))
		      (SETQ TEM (PARSE-ITS-HEADER LINE TEM LEN TEM1))
		      (COND ((SETQ TEM (SOME-PLIST TEM '(:DATE :FROM)))
			     (LET* ((PLIST (LOCF TEM))
				    (TEM1 (GET PLIST ':FROM)))
			       (AND TEM1
				    (PUTPROP PLIST (SOME-PLIST (CAR TEM1) '(:NAME :HOST))
					     ':FROM)))
			     (PUSH TEM REFLIST))))
		     ((AND (SETQ TEM (STRING-SEARCH-CHAR #/: LINE START-IDX LEN))
			   (STRING-EQUAL LINE "DATE" START-IDX 0 TEM)
			   (NUMBERP (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME LINE (1+ TEM) LEN
									  NIL NIL NIL NIL NIL
									  NIL))))
		      (SETQ LINE (LINE-NEXT LINE)
			    LEN (LINE-LENGTH LINE))
		      (AND (EQ START-IDX (STRING-SEARCH-NOT-SET *BLANKS* LINE))
			   (SETQ TEM (STRING-SEARCH-CHAR #/: LINE START-IDX LEN))
			   (STRING-EQUAL LINE "FROM" START-IDX 0 TEM)
			   (LISTP (SETQ TEM (PARSE-ADDRESSES LINE (1+ TEM) LEN)))
			   (PUSH `(:DATE ,DATE :FROM ,(SOME-PLIST (CAR TEM) '(:NAME :HOST)))
				 REFLIST))))))
	    ((COND ;; Good old MSG
		   ((AND (STRING-EQUAL-START LINE "In response to the message sent ")
			 (SETQ TEM (STRING-SEARCH " from " LINE)))
		    (SETQ DATE (TIME:PARSE-UNIVERSAL-TIME LINE 32. TEM
							  NIL NIL NIL NIL NIL NIL)
			  FROM (PARSE-ADDRESSES LINE (+ TEM 6)))
		    T)
		   ;; In reply to in body of message from some weird mail system in NLS.
		   ((AND (STRING-EQUAL-START LINE "In reply to the message from ")
			 (SETQ TEM (STRING-REVERSE-SEARCH-CHAR #/, LINE LEN)))
		    (SETQ FROM (PARSE-ADDRESSES LINE 29. TEM)
			  DATE (TIME:PARSE-UNIVERSAL-TIME LINE (1+ TEM)
							  NIL NIL NIL NIL NIL NIL NIL))
		    T)
		   (T NIL))
	     (COND ((AND (LISTP FROM) (NUMBERP DATE))
		    (SETQ FROM (CAR FROM))
		    (REMPROP (LOCF FROM) ':INTERVAL)
		    (PUSH `(:DATE ,DATE :FROM ,FROM) REFLIST)))))
      NIL))
  (NREVERSE REFLIST))