LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031581. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "ADDRESS" :DIRECTORY ("REL3-SOURCE" "MAIL-DAEMON") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758714948. :AUTHOR "REL3" :LENGTH-IN-BYTES 37364. :LENGTH-IN-BLOCKS 37. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        ;;;-*- Mode:Common-Lisp; Package:MAIL; Base:10 -*-;;;                           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.(defun PARSED-STRING (parser &optional including-current-token)  (let* ((end (if including-current-token  (parse-point parser)  (token-start parser))) (string (allocate-xstring (- (parse-mark parser) end))))    (copy-array-portion (parse-string parser) (parse-mark parser) endstring 0 (length string))))(defun GET-NEXT-TOKEN (parser &optional (deallocate-old t))    (setf (token-start parser) (parse-point parser))  (when (and deallocate-old (stringp (current-token parser)))    (deallocate-xstring (current-token parser)))  (loop    (multiple-value-bind (token token-type end-index whitespace-p)(parse-next-token (parse-string parser) (parse-point parser) (parse-to parser))      (setf (leading-whitespace-p parser) whitespace-p)      (cond ((eq token-type :comment)     (let ((comments (parsed-comments parser)))       (setf (parsed-comments parser)     (xstring-append comments (if (null comments) #\Space "") token #\Space)))     (deallocate-xstring token)     (setf (parse-point parser) end-index))    (t     (setf (parse-point parser) end-index)     (return        (setf (current-token parser) token)       (setf (current-token-type parser) token-type)))))))(defun SET-PARSE-MARK (parser)  (setf (parse-mark parser) (parse-point parser)))(defmacro NEXT-CHAR (char string index limit);;;Side effects galore.  Set CHAR to contents of INDEX+1 in STRING or nil if;;;INDEX+1 >= LIMIT.  CHAR and INDEX are modified and must be setf'able.  `(setf ,char (and (< (incf ,index) ,limit)    (char ,string ,index))))(defun PARSE-NEXT-TOKEN (string &optional (from 0) to no-token-string)  "Return token string, token type, and ending index, of token in STRING.If NO-TOKEN-STRING is non-nil, just return the type and ending index.If token preceeded by whitespace, a fourth value of T is returned."  (unless to    (setq to (length string)))  (let* ((index (or from 0)) (whitespace nil) start end char token-type token fixup)    (if (>= index to)(return-from parse-next-token "End-Of-Line" :eof to)      (setq char (char string index)))    (loop      while (member char *white-space-characters*)      do      (setq whitespace t)      (next-char char string index to)      unless char      do (return-from parse-next-token "End-Of-Line" :eof to))    (setq start index)        (cond ((eql char #\")   (setq token-type :quoted-string)   (loop     (next-char char string index to)     (cond ((eql char #\");normal termination    (incf index)    (return))   ((and char (not (eql char #\\))));not end of line or quote   (t    (when (eql char #\\)      (unless (next-char char string index to)(setq end (1- index))));drop quote char if at end of string.    (unless char      (setq fixup "\"")      (return))))))        ((eql char #\[)   (setq token-type :domain-literal)   (loop     (next-char char string index to)     (cond ((eql char #\]);normal termination    (incf index)    (return))   ((and char (not (eql char #\\))));not end of line or quote   (t    (when (eql char #\\)      (unless (next-char char string index to)(setq end (1- index))));drop quote char if at end of string.    (unless char      (setq fixup "]")      (return))))))      ((eql char #\()    (setq token-type :comment)    (let ((open-count 1))      (loop(next-char char string index to)(cond ((eql char #\));normal termination if last close       (decf open-count)       (when (= 0 open-count) (incf index) (return)))      ((eql char #\();nested comment       (incf open-count))      ((and char (not (eql char #\\))));not end of line or quote      (t       (when (eql char #\\) (unless (next-char char string index to)   (setq end (1- index))));drop quote char if at end of string.       (unless char (setq fixup ")") (loop for i from 1 below open-count       do (setq fixup (string-append fixup ")"))) (return)))))))      ((member char *specials*)       (setq token-type char)       (setq token char)       (incf index))            (t       (setq token-type :atom)       (loop (next-char char string index to) (when (or (null char)   (member char *specials*)   (member char *white-space-characters*)   (< 0 (char-code char) 31)); ctrl-char ?(return)))))    (when (and (not no-token-string) (null token))      (setq end (or end index))      (setq token (allocate-xstring (+ (length fixup) (- end start)) 2))      (copy-array-portion string start end token 0 (- end start))      (setf (fill-pointer token) (- end start))      (when fixup(setq token (xstring-append token fixup))))    (values token token-type index whitespace)))(defun PARSE-PHRASE (parser)    (let ((phrase (parse-word parser)))    (when phrase      (loopfor word = (parse-word parser)when (null word) return phrasedo(setq phrase (xstring-append phrase #\Space word))(deallocate-xstring word)))))(defun PARSE-WORD (parser)    (let ((token-type (current-token-type parser)))    (when (or (eq token-type :atom)      (eq token-type :quoted-string))      (prog1(current-token parser)(get-next-token parser nil)))))(defun PARSE-DOMAIN-LITERAL (parser)    (when (eq (current-token-type parser) :domain-literal)    (prog1      (current-token parser)      (get-next-token parser nil))));;;;;; ADDRESS PARSING;;;(defun PARSE-ALL-ADDRESSES (address-string &optional (from 0) to errorp address-type)    (cond ((typep address-string 'address) (list address-string))((or (null address-string)     (and (not (stringp address-string))  (not (symbolp address-string)))) ;; Let parse-address generate the error (parse-address address-string from to errorp address-type))(t (using-resource (parser rfc822-parser (string address-string) from to)   (loop     until (eq (current-token-type parser) :eof)     collect (parse-address parser from to errorp address-type)     ;;skip past delimiter     do (get-next-token parser))))))(defun PARSE-ADDRESS (address &optional (from 0) to errorp address-type trailing-junk-allowed)  "Parse ADDRESS starting at FROM, and return an address object.  IfERRORP is non-nil, signal MAIL:PARSE-ERROR if an illegal address isparsed, otherwise return an address of type bad-address.  ADDRESS-TYPEmay specify that a particular type of address be returned such as:BASIC-ADDRESS, :NAMED-ADDRESS, :ROUTE-ADDRESS, :GROUP-ADDRESS,:MAILBOX, or :ADDRESS.  The last two are syntactic catagories specifiedin RFC822 -- :ADDRESS is anything but a route-address and :MAILBOX iseither a basic-address or a named-address."    (let ((parser nil)(my-parser-p nil))    (unwind-protect (condition-case-if (not errorp) (condition)    (block nil      (cond ((typep address 'address)     address)    ((typep address 'rfc822-parser)     (setq parser address)     (setq from (token-start parser)))    ((or (null address) (and (not (stringp address))      (not (symbolp address))))     (ferror 'parse-error "Cannot parse ~S as a mail address." address))    (t     (setq parser (allocate-resource 'rfc822-parser (string address) from to))     (setq my-parser-p t)))      (parse-address-internal parser address-type (and trailing-junk-allowed :trailing-junk-allowed)))  (parse-error   (make-instance 'bad-address  :basic-string (if (null parser) ""  (subseq (parse-string parser) from (token-start parser)))  :comments (if (null parser) ""      (parsed-comments parser))  :error-report-string (send condition :report-string))))      (when parser(if my-parser-p    (deallocate-resource 'rfc822-parser parser)  (setf (parsed-comments parser) nil))))))(defun PARSE-ADDRESS-INTERNAL (parser &optional address-type delimiter)    (let ((real-address-type (parse-address-start parser delimiter)))        ;; Check if caller expecting a particular type but found something that cannot be coerced.    (when address-type      (when (and (eq real-address-type :group-address);got a group (neq address-type :group-address);but caller not expecting one (neq address-type :address))(parse-address-error parser delimiter     "Group address (containing a \":\") not allowed.  Expecting ~S type." address-type))      (when (and (eq address-type :group-address);caller wants a group (neq real-address-type :group-address));but didn't find one(parse-address-error parser nil "Group address expected but found ~S type." real-address-type)))        (let (name route local-part domain address-list comments)      (case real-address-type(:basic-address  (setq local-part (parse-address-local-part parser))  (when (eql (current-token-type parser) #\@)    (when (null local-part)      (parse-address-error parser delimiter "Invalid address: no local part preceeding \"@\""))    (get-next-token parser)    (setq domain (parse-address-domain parser t #\@))))((:named-address :route-address :naked-route-address) (when (eq real-address-type :named-address)   (setq name (parse-address-personal-name parser))) (if (eq real-address-type :naked-route-address)     (setq real-address-type :route-address)   (get-next-token parser));skip < unless "naked" (setq route (parse-address-route parser)) (setq local-part (parse-address-local-part parser route #\:)) (when (eql (current-token-type parser) #\@)   (when (null local-part)     (parse-address-error parser delimiter "Invalid address: no local part preceeding \"@\""))   (get-next-token parser)   (setq domain (parse-address-domain parser))) (if (eql (current-token-type parser) #\>)     (get-next-token parser)   (if (and (neq (current-token-type parser) :eof);forgive if at end    (not (eql (current-token-type parser) #\,)))       (parse-address-error parser delimiter "Invalid route address: Expected \">\" following domain"))))(:group-address  (setq name (parse-phrase parser))  (get-next-token parser);skip :  (loop    until (or (eql (current-token-type parser) #\;) (eq (current-token-type parser) :eof))    for addr = (parse-address-internal parser :mailbox #\;)    when addr do (push-end addr address-list)    do    (get-next-token parser))  (get-next-token parser)))            (setq comments (parsed-comments parser))      (let ((token-type (current-token-type parser)))(unless (or (eq token-type :eof) (eql token-type #\,) (eql token-type delimiter)    (eq delimiter :trailing-junk-allowed))  ;;(setq trailing-junk (rest-of-address parser delimiter t))  (parse-address-error parser delimiter "Invalid address; terminated by ~S when expecting a ~A"       (string (current-token parser))       (if delimiter (string delimiter) "\",\" or End-Of-Line"))))      ;; Figure out what kind of address to return      (if (null address-type)  (setq address-type real-address-type)(if (or (eq address-type :mailbox) (eq address-type :address))    (if (eq real-address-type :route-address)(setq address-type :named-address)      (setq address-type real-address-type))))      (multiple-value-bind (address new-address-p)  (cond ((eq address-type :named-address) (get-named-address name route local-part domain comments))((eq address-type :route-address) (get-route-address route local-part domain comments))((eq address-type :group-address) (get-group-address name address-list comments))(t  (get-basic-address local-part domain comments)))(unless new-address-p  (deallocate-xstring name domain comments)  (apply #'deallocate-xstring local-part)  (when route    (apply #'deallocate-xstring route)))address))))(defun PARSE-ADDRESS-START (parser &optional delimiter)      (let ((mark (token-start parser));Save index of start of current tokenaddress-type)    (loop      with first = t and prev-token-type      for token = (current-token parser)      for token-type = (current-token-type parser)      do      (case token-type    ((:atom :quoted-string)     (when (and (eq token-type :atom)(or (eq prev-token-type :atom)    (eq prev-token-type :quoted-string))(equalp token "at"))       (setq address-type :basic-address)       (return)))    (#\@     (if first (setq address-type :naked-route-address);Allow leading @ and convert to route address       (setq address-type :basic-address))     (return))    (#\<     (setq address-type (if first :route-address :named-address))     (return))    (#\.     )    (#\%     (setq address-type :basic-address))    (#\:     (if first (parse-address-error parser delimiter "Invalid address.  \":\" not allowed at start of address."))     (setq address-type :group-address)     (return))    (t     (unless (or (eq token-type :eof) (eql token-type #\,) (eql token-type delimiter))       (if first   (parse-address-error parser delimiter "Invalid token at start of address.  ~S not allowed." token) (parse-address-error parser delimiter "Invalid address.  ~S not allowed." (string token))))     (when (null address-type)       (setq address-type :basic-address))     (return)))      (setq first nil)      (setq prev-token-type token-type)      (get-next-token parser))    ;; return parser to state at which we were entered    (setf (parse-point parser) mark)    (get-next-token parser)    address-type)) (defun PARSE-ADDRESS-ROUTE (parser)    (when (eql (current-token-type parser) #\@)    (get-next-token parser)    (let (route)      (loop    for domain = (or (parse-address-domain parser) (parse-address-error parser #\: "Invalid route: expected domain following \"@\""))do (push-end domain route)while (eql (current-token-type parser) #\,)do(get-next-token parser)(unless (eql (current-token-type parser) #\@)  (parse-address-error parser #\: "Invalid route: Expected \"@\" following \",\" but got ~S"       (string (current-token parser))))(get-next-token parser))            (unless (eql (current-token-type parser) #\:)(parse-address-error parser #\: "Invalid route: Expected \":\" to terminate route but got ~S"     (string (current-token parser))))      (get-next-token parser)      route)))(defun PARSE-ADDRESS-LOCAL-PART (parser &optional errorp prev-token)    (let ((local-part (parse-word parser)))    (when local-part      (setq local-part (list local-part))      (loopdo(when (and (eq (current-token-type parser) :atom)   (equalp (current-token parser) "at"))  (setf (current-token-type parser) #\@)  (setf (current-token parser) #\@))for word = (parse-word parser)do(if word    (push word local-part)  (let ((token (current-token-type parser)))    (cond ((or (eql token #\.) (eql token #\%))   (push token local-part)   (get-next-token parser))  (t    (return)))))))    (when (and (null local-part) errorp)      (parse-address-error parser nil "Invalid address: missing local part following ~S") (string prev-token))    (nreverse local-part)))(defun PARSE-ADDRESS-PERSONAL-NAME (parser)    (let ((name (parse-word parser))(must-quote nil))    (when name      (loopfor lwsp = (leading-whitespace-p parser)for word = (parse-word parser)do(cond (word       (setq name (xstring-append name (if lwsp #\Space "") word))       (deallocate-xstring word))      ((eql (current-token parser) #\.)       (setq must-quote t)       (setq name (xstring-append name (if lwsp " ." ".")))       (get-next-token parser))      (t       (return))))      (when must-quote(let ((qname (xstring-append nil #\" name #\")))  (deallocate-xstring name)  (setq name qname)))      name)))(defun PARSE-ADDRESS-DOMAIN (parser &optional errorp prev-token)    (let ((domain (parse-address-sub-domain parser)))    (when domain      (loopunless (eql (current-token-type parser) #\.)return nildo (get-next-token parser)for dom = (parse-address-sub-domain parser)do(unless dom  (parse-address-error parser nil "Invalid domain: no sub-domain following \".\""))(setq domain (xstring-append domain #\. dom))(deallocate-xstring dom)))    (when (and errorp (null domain))      (parse-address-error parser nil "Invalid address: no domain following ~S" (string prev-token)))    domain))(defun PARSE-ADDRESS-SUB-DOMAIN (parser)  (let ((token-type (current-token-type parser)))    (if (or (eq token-type :domain-literal)    (eq token-type :atom))(prog1  (current-token parser)  (get-next-token parser nil)))))(defun PARSE-ADDRESS-ERROR (parser special-delimiter format-string &optional &rest format-args)  (rest-of-address parser special-delimiter)  (apply 'ferror 'parse-error format-string format-args))(defun REST-OF-ADDRESS (parser &optional special-delimiter return-copy)  ;; Gobble up the rest of an address after getting a parse error.  (let (string)    (loop      with first = t      for token = (current-token parser)      for token-type = (current-token-type parser)      until (eq token-type :eof)      do      ;; Following these tokens, nothing can hide a comma      (when (or (eq token-type special-delimiter)(member token-type '(#\> #\; #\:)))(setq special-delimiter nil))      until (and (null special-delimiter) (eql token-type #\,))      do      (when return-copy(setq string (xstring-append string token)))      ;; Don't deallocate token the first time... caller may have saved a pointer to it      (get-next-token parser (not first))      (setq first nil))    string));;;;;; ESSENTIAL ADDRESS METHODS AND FUNTIONS;;;(defmethod (ADDRESS :ROUTE) ()  nil)(defmethod (ADDRESS :LOCAL-PART) ()  nil)(defmethod (ADDRESS :DOMAIN) ()  nil)(defmethod (ADDRESS :NAME) ()  nil)(defun GET-BASIC-ADDRESS (local-part domain &optional comments)  (get-address-object 'basic-address      :local-part local-part :domain domain      :comments comments))(defun GET-ROUTE-ADDRESS (route local-part domain &optional comments)  (get-address-object 'route-address      :route route :local-part local-part :domain domain      :comments comments))(defun GET-NAMED-ADDRESS (name route local-part domain &optional comments)  (get-address-object 'named-address      :name name :route route :local-part local-part :domain domain      :comments comments))(defun GET-GROUP-ADDRESS (name address-list &optional comments)  (get-address-object 'group-address      :name name :address-list address-list      :comments comments))(defun GET-ADDRESS-OBJECT (&rest address-descriptor)  (declare (arglist flavor-type init-plist))  (or (gethash address-descriptor *address-hash-table*)      (values (setf (gethash (copy-list address-descriptor) *address-hash-table*)    (apply #'make-instance (car address-descriptor) (cdr address-descriptor)))      t)))(defun GET-NULL-ADDRESS ()  (get-route-address nil nil nil))(defun GET-NEW-ADDRESS (type name route local-part domain &optional comments address-list)    (or    (and type ;; caller specified type, assume caller knows what its doing. (case type   ((:mailbox :address)    (if (or name route)(get-named-address name route local-part domain comments)(get-basic-address local-part domain comments)))   (:basic-address    (get-basic-address local-part domain comments))   (:route-address    (get-route-address route local-part domain comments))   (:named-address    (get-named-address name route local-part domain comments))   (:group-address    (get-group-address name address-list comments))))    ;; unspecified or unknown type -- DWIM    (cond ((and route (null name))   (get-route-address route local-part domain comments))  ((or route (and name (null address-list)))   (get-named-address name route local-part domain comments))  ((or local-part domain)   (get-basic-address local-part domain comments))  (address-list   (get-group-address name address-list))  (t   (get-basic-address local-part domain comments)))))(defmethod (ADDRESS :NEW-ADDRESS) (&key &allow-other-keys)  (declare (arglist &key type name route local-part domain comments address-list))  self)(defmethod (BASIC-ADDRESS :NEW-ADDRESS) (&key type       name       route       ((:local-part new-local-part) nil new-local-part-p)       ((:domain new-domain) nil new-domain-p)       ((:comments new-comments) nil new-comments-p)       address-list)  (declare (arglist &key type name route local-part domain comments address-list))    (get-new-address type   name   route   (if new-local-part-p new-local-part local-part)   (if new-domain-p new-domain domain)   (if new-comments-p new-comments comments)   address-list))    (defmethod (GROUP-ADDRESS :NEW-ADDRESS) (&key type      ((:name new-name) nil new-name-p)      route      local-part      domain      ((:comments new-comments) nil new-comments-p)      ((:address-list new-address-list) nil new-address-list-p))  (declare (arglist &key type name route local-part domain comments address-list))    (get-new-address type   (if new-name-p new-name name)   route   local-part   domain   (if new-comments-p new-comments comments)   (if new-address-list-p new-address-list nil)))(defmethod (ADDRESS :ADDRESS-STRING) ()  (or basic-string ""))(defmethod (BASIC-ADDRESS :ADDRESS-STRING) ()    (or basic-string      (if (not (consp local-part))  (setq basic-string "")(let ((string (allocate-xstring 10)))  (setq string (apply #'xstring-append string local-part))  (if domain      (setq string (xstring-append string #\@ domain)))  (setq basic-string string)))))(defmethod (ROUTE-ADDRESS :ADDRESS-STRING) ()    (or basic-string      (if (not (consp local-part))  "";route addresses can be null (for SMTP return paths)(let ((string (allocate-xstring 10)))  (do ((domain-tail route (cdr domain-tail)))      ((null domain-tail))    (setq string (xstring-append string "@" (car domain-tail) (if (cdr domain-tail)     #\, #\:))))  (setq string (apply #'xstring-append string local-part))  (when domain    (setq string (xstring-append string #\@ domain)))  (setq basic-string string)))))(defmethod (GROUP-ADDRESS :ADDRESS-STRING) ()  (or basic-string       (setq basic-string (string-append name #\: #\;))))(defmethod (ADDRESS :STRING-FOR-PRINTING) ()  (send self :address-string))(defmethod (ADDRESS :STRING-FOR-MESSAGE)  ()  (or message-string      (setq message-string (string-append (send self :address-string) (or comments "")))))(defmethod (ROUTE-ADDRESS :STRING-FOR-MESSAGE) ()  (or message-string      (setq message-string    (string-append #\< (send self :address-string) #\>   (or comments "")))))(defmethod (NAMED-ADDRESS :STRING-FOR-MESSAGE) ()  (or message-string      (setq message-string    (string-append (or name "\"\"") " <" (send self :address-string) #\>   (or comments "")))))(defmethod (ADDRESS :STRING-FOR-MAIL-SERVER) ()  (send self :address-string))(defmethod (ROUTE-ADDRESS :STRING-FOR-MAIL-SERVER) ()  (if (null route)      (send self :address-string)    (or (get self :string-for-mail-server)(setf (get self :string-for-mail-server)      (string-append #\< (send self :address-string) #\>)))))(defmethod (ADDRESS :LOCAL-PART-STRING) ()  "")(defmethod (BASIC-ADDRESS :LOCAL-PART-STRING) ()    (or (get self :local-part-string)      (setf (get self :local-part-string)    (if (not (consp local-part))""      (apply #'string-append local-part)))))(defmethod (ADDRESS :LOCAL-PART-AS-DIRECTORY) ()  nil)(defmethod (BASIC-ADDRESS :LOCAL-PART-AS-DIRECTORY) ()    (or (get self :local-part-as-directory)      (setf (get self :local-part-as-directory)    (if (not (consp local-part))nil      (remove-if #'characterp local-part)))))(defmethod (ADDRESS :DESTINATION-DOMAIN) ()  nil)(defmethod (BASIC-ADDRESS :DESTINATION-DOMAIN) ()  domain)(defmethod (ROUTE-ADDRESS :DESTINATION-DOMAIN) ()  (or (car route) domain))(defmethod (ADDRESS :UUCP-ADDRESS-P) ()  nil)(defmethod (BASIC-ADDRESS :UUCP-ADDRESS-P) ()  (and (null domain)       (null (send self :send-if-handles :route))       (find #\! (the vector (send self :local-part-string)))));;;;;; The remaining methods are related to mail delivery, address translation,;;; verification, etc.(defmethod (ADDRESS :ACCEPT-P) ()  ;; For servers to use in deciding whether to accept an address.  ;; Acts just like :verify except obeys the :non-local-addresses value  ;; of the reject-mail host option.  ;; This does *not* heed the use-primary-mail-servers  ;; option, which is intended only for decisions about mail  ;; submitted by a user, not by a server.  (cond ((and (eq (reject-mail) :non-local-addresses)      (not (send self :local-p))) (setf (get self :rejection-report-string) "This machine only accepts local mail.  Cannot forward.") nil)((not (send self :verify)) (setf (get self :rejection-report-string) (send self :verification-report-string)) nil)(t t)))(defmethod (ADDRESS :REJECTION-REPORT-STRING) ()  (get self :rejection-report-string))(defmethod (ADDRESS :SET-DELIVERY-STATUS) (disposition &optional arg report-string)    (setf (get self :last-delivery-disposition) disposition)  (setf (get self :last-delivery-report) report-string)  (when (typep arg 'si:basic-host)    (setf (get self :last-delivery-host) arg))  (when *interactive-delivery-in-progress*    (print-address-disposition t self disposition arg report-string)))(defmethod (ADDRESS :DELIVERY-STATUS) ()  (values    (get self :last-delivery-disposition)    (get self :last-delivery-report)    (get self :last-delivery-host)))(defmethod (ADDRESS :DOMAIN-AS-NAMESPACE) ()  nil)(defmethod (BASIC-ADDRESS :DOMAIN-AS-NAMESPACE) ()  (and domain       (null (send self :route))       (name:find-known-namespace domain)))(defmethod (ADDRESS :LOCAL-P) ()  nil)(defmethod (BASIC-ADDRESS :LOCAL-P) ()  (and     (eq si:local-host(send self :destination-host))    (not (find #\! (the vector (send self :local-part-string))))))(defmethod (ADDRESS :DESTINATION-HOST) ()  nil)(defmethod (BASIC-ADDRESS :DESTINATION-HOST) ()  "Determine the host to send this address to.  Handlestop level domains, local-domains, and gateway host.  Does not deal withuucp gateway or the use-primary-gateway options.  Thoseare dealt with by :host-for-queue"    (let* ((dest (send self :destination-domain)) (host (and dest (parse-mail-domain dest))))    (cond ((null dest)   (setq host si:local-host))  ((and (null host)(find #\. (the string dest)))   (let* ((top-servers (top-level-mail-domain-servers))  domain-server)     (when (and (consp top-servers)(consp (first top-servers)))       (setq domain-server     (rassoc dest top-servers     :test #'(lambda (dest domain-list)       (loop with dest-length = (length dest) for served-domain in domain-list for served-domain-length = (length (string served-domain)) when (and (>= dest-length served-domain-length)   (string-equal dest (string served-domain) :start1 (- dest-length served-domain-length))   (or (= dest-length served-domain-length)       (eql #\. (char dest (- dest-length served-domain-length 1))))) return t)))))     (when domain-server       (setq host (si:parse-host (string (car domain-server)) t))))))    (when host      (if (eq host si:local-host)  host(setq host (or (send host :send-if-handles :host)       host))(let ((gateway (mail-gateway-host host)))  (if (and gateway (neq gateway si:local-host))      gateway    host))))))(defmethod (ADDRESS :CANONICAL-ADDRESS) ()  self)(defmethod (BASIC-ADDRESS :CANONICAL-ADDRESS) ()    (let (new)    (cond (domain   (setq new (canonical-domain domain))   (if (null new)       self     (send self :new-address :domain new)))  ((not (send self :uucp-address-p))   (send self :new-address :domain (default-mail-host)))  (t   self))))(defmethod (ROUTE-ADDRESS :CANONICAL-ADDRESS) ()  (let (new)    (cond (route    (setq new (canonical-domain (car route)))    (if (null new)self      (send self :new-address :route (append (list new) (cdr route)))))  (domain    (setq new (canonical-domain domain))    (if (null new)self      (send self :new-address :domain new)))  (t    (send self :new-address :domain (default-mail-host))))))(defun CANONICAL-DOMAIN (domain)  (let* ((host (si:parse-host domain t)) (name (and host (send host :name))))    (when (and host       (not (equalp name domain)))      name)))(defmethod (ADDRESS :REMOVE-LOCAL-HOST) ()  self)(defmethod (BASIC-ADDRESS :REMOVE-LOCAL-HOST) ()    (let ((new-route (send self :send-if-handles :route))(new-domain domain)(changed nil))    (loop      for hop in new-route      while (eq (parse-mail-domain hop) si:local-host)      do      (pop new-route)      (setq changed t))    (when (and (null new-route) domain       (eq (parse-mail-domain domain) si:local-host))      (setq changed t)      (setq new-domain nil))    (cond ((not changed)   self)  ((or new-route new-domain)   (send self :new-address :route new-route :domain new-domain))  (t   ;; Address is now local (no route or domain), check if it is percent-routed.   (let ((right-percent (position #\% local-part :from-end t)))     (if (and right-percent      (> (length local-part) (1+ right-percent))) (send self :new-address       :local-part (firstn right-percent local-part)       :domain (apply #'string-append (nthcdr (1+ right-percent) local-part)))       (send self :new-address :route nil :domain nil)))))))(defmethod (ADDRESS :ADD-LOCAL-HOST) ()  self)(defmethod (BASIC-ADDRESS :ADD-LOCAL-HOST) ()  (send self :new-address :type :route-address :route (list (send si:local-host :name))))(defmethod (ROUTE-ADDRESS :ADD-LOCAL-HOST) ()  (send self :new-address :type :route-address :route (cons (send si:local-host :name) (copy-list route))))(defmethod (ADDRESS :EXPAND-MAILING-LIST) (&optional ignore)  self)(defmethod (BASIC-ADDRESS :EXPAND-MAILING-LIST) (&optional local-only)  (let ((expansion (expand-address self local-only)))    (if (null expansion)self      (delete-duplicates expansion :test #'address-equal))))(defun EXPAND-ADDRESS (address &optional local-only exclude-list (max-recursion 6))  (declare (list exclude-list))    (let (namespace address-list expansion final-expansion)    (declare (list address-list))    (when (> (decf max-recursion) 0)      (setq namespace (send address :domain-as-namespace))            (when (or namespace (send address :local-p))(setq address-list (or (expand-local-mailing-list (send address :local-part-as-directory))       (and (not local-only)    (expand-ns-mailing-list (send address :local-part-string) namespace))))(when address-list   (push address exclude-list)  (dolist (member address-list)    (unless (find member exclude-list :test #'address-equal)      (multiple-value-setq(expansion exclude-list)(expand-address member local-only exclude-list max-recursion))      (if (null expansion)  (push member final-expansion)  (push member exclude-list)  (setq final-expansion (nconc expansion final-expansion))))))))        (values final-expansion exclude-list)))(defmethod (ADDRESS :FORWARDING-ADDRESS) ()  self)(defmethod (BASIC-ADDRESS :FORWARDING-ADDRESS) ()    (let ((namespace (send self :domain-as-namespace))(string (send self :local-part-string))forwarding)    (cond   ((and (null namespace)  (not (send self :local-p)))     self)    ((equalp "POSTMASTER" string)     (postmaster-address))    ((setq forwarding (ns-user-mail-address string namespace))     (parse-address forwarding 0 nil nil :mailbox))    (t      self))))(defmethod (ADDRESS :TRANSLATE) (&key expand forward canonical strip-local)    (let ((translation self))    (when strip-local      (setq translation (send translation :remove-local-host)))    (when expand      (setq translation (send translation :expand-mailing-list)))    (unless (consp translation)      (when forward(setq translation (send translation :forwarding-address)))      (when canonical(setq translation (send translation :canonical-address))))    translation))(defmethod (ADDRESS :HOST-FOR-QUEUE) ()  nil)(defmethod (BASIC-ADDRESS :HOST-FOR-QUEUE) (&optional (interactive *interactive-delivery-in-progress*))  "Determine the host to deliver this address to.  Any necessary processing of theaddress should already be done (canonical, verify, stripped, expanded, etc.)  Returnan host object, :SERVER (deliver to a primary server), :UUCP (deliver to a UUCPgateway), or NIL (undeliverable)."    (let* ((host (send self :destination-host)) use-primary)        (cond ((send self :uucp-address-p)   :uucp)    ((and host (send host :local-host-p))   si:local-host)  ;; Check whether to use a server.   ((progn      (setq use-primary (use-primary-mail-servers))     (or (eq use-primary :always) (and (not interactive)      (eq use-primary :after-first-attempt)) (and (null host)      (eq use-primary :unknown-addresses))))   :server)  (t   host))))(defmethod (ADDRESS :VERIFICATION-REPORT-STRING) ()  (get self :verification-report-string))(defmethod (GROUP-ADDRESS :VERIFY) ()  ;; This is never called in a context where  ;; a group address is acceptable.  A group must be  ;; translated into its component addresses first and  ;; the components verified.  (values (setf (get self :verification-status) nil)  (setf (get self :verification-report-string) "Cannot verify group address.")))(defmethod (BAD-ADDRESS :VERIFY) ()  (setf (get self :verification-report-string) error-report-string)  (setf (get self :verification-status) nil)  (values nil error-report-string))(defmethod (BASIC-ADDRESS :VERIFY) ()    (let* ((host (send self :destination-host)) (namespace (send self :domain-as-namespace)) (local-part-string (send self :local-part-string)) (ok t) report)        (cond (namespace    (cond ((expand-ns-mailing-list local-part-string namespace t)   (setq report "Namespace mailing list OK."))  ((ns-user-mail-address local-part-string namespace)   (setq report "Namespace user OK."))  (t    (setq report (format nil "User unknown in ~A namespace." (send namespace :domain-name)))    (setq ok nil))))  ((eq host si:local-host)   (cond ((send self :uucp-address-p)  (if (uucp-gateway-hosts)      (setq report "UUCP address OK.  Will forward to gateway.")    (setq report "No UUCP gateway defined for this site.")    (setq ok nil))) ((expand-local-mailing-list (send self :local-part-as-directory) t)  (setq report "Local mailing list OK.")) ((expand-ns-mailing-list (send self :local-part-string) nil t)  (setq report "Namespace mailing list OK.")) ((ns-user-mail-address local-part-string nil)  (setq report "Namespace user OK.")) ((probe-file (send (make-pathname :host si:local-host   :directory (send self :local-part-as-directory)   :type :directory)    :directory-pathname-as-file))  (setq report "Local user OK.")) ((equalp local-part-string "POSTMASTER")  (setq report "Postmaster OK.")) (t   (setq report "User unknown.")   (setq ok nil))))  (host   (if (or (send host :send-if-handles :mail-host-p)   (mail-gateway-host host))       (setq report "Host OK.")     (setq report "No mail service defined for host and no gateway provided.")     (setq ok nil)))  (t    (setq report "Unknown host.")    (setq ok nil)))    (setf (get self :verification-report-string) report)    (setf (get self :verification-status) ok)    (values ok    report)))(defun ADDRESS-EQUAL (addr1 addr2)  ;;? Need and address-equalp function to delve into more fuzzy equalities  ;;This will at least ignore comments, personal names, whitespace, and case.  (if (eq addr1 addr2)      t    (equalp (send addr1 :address-string)    (send addr2 :address-string))))(defun PARSE-AND-VERIFY-ADDRESS (address &optional (from 0) to errorp)  "Parses address, Removes local host from address and verifies that address is accessible"  (let ((address (parse-address address from to errorp)))    (when (and address (not (bad-address-p address)))      (if (send address :verify)  address))))ond ((and (> n 0) (<= n (array-active-length s))) (values (read-from-string (zlc:string (zlc:aref s (1- n))))))(t nil)))(defun zlc:ascii (n)  "Obsolete Maclisp function to turn character code number N into a symbol.The symbol's pname has one character, the one with code N."  (let* ((%inhibit-read-only t) (default-cons-area p-n-string) (str (zlc:string n)) (sym (intern str)))    (unless (eq str (symbol-name sym))      (return-array (prog1 str (setq str nil))))    sym))(defun zlc:readch (&rest read-ar