LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031587. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "DEFINITIONS" :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 2758715853. :AUTHOR "REL3" :LENGTH-IN-BYTES 23968. :LENGTH-IN-BLOCKS 24. :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.;;;;;; MAILER DEFINITIONS;;;;;;;;; PARSER;;;(defparameter *SPECIALS* '(#\( #\) #\< #\> #\@ #\, #\; #\: #\\ #\" #\. #\[ #\] #\%)  "A list of rfc822 special characters")(defconstant *WHITE-SPACE-CHARACTERS* '(#\Tab #\Space #\Return) "A list of linear whitespace characters")(defflavor PARSE-ERROR () (eh:ferror))(defsignal PARSE-ERROR parse-error () "Error parsing RFC822 header")(compile-flavor-methods parse-error) (defstruct (RFC822-PARSER (:conc-name nil))  parse-string;String being parsed by this parser  parse-to;Index of last char to be parsed  parse-point;Index into parse-string of end of last token parsed  parse-mark;Marker (used at higher level)  token-start;Index into parse-string of start of current token  current-token;Most recent token parsed  current-token-type;Type of ^  parsed-comments;String of all comments parsed (appended together)  leading-whitespace-p;T if current token was preceeded by white space)(defresource RFC822-PARSER (string &optional (from 0) to)  :constructor (make-rfc822-parser)  :initializer (parse-init object string from to)  :matcher (true))(defun PARSE-INIT (parser string &optional (from 0) to)  (setf (parse-string parser) string)  (setf (parse-to parser) (or to (length string)))  (setf (parse-point parser) from)  (setf (parse-mark parser) from)  (setf (token-start parser) from)  (setf (current-token parser) nil)  (setf (current-token-type parser) nil)  (setf (parsed-comments parser) nil)  (setf (leading-whitespace-p parser) nil)  (get-next-token parser));;;;;; ADDRESS ;;;(defflavor ADDRESS    ((comments nil)    (basic-string nil)    (message-string nil))    (si:property-list-mixin)  :abstract-flavor  (:gettable-instance-variables comments)  :initable-instance-variables)(defflavor GROUP-ADDRESS   ((name "")    (address-list))   (address)  :gettable-instance-variables  :initable-instance-variables  (:default-init-plist :allow-other-keys t))  (defflavor BASIC-ADDRESS   ((local-part nil)    (domain nil))   (address)  :gettable-instance-variables  :initable-instance-variables  (:default-init-plist :allow-other-keys t))(defflavor ROUTE-ADDRESS   ((route nil))   (basic-address)  :gettable-instance-variables  :initable-instance-variables  (:default-init-plist :allow-other-keys t))(defflavor NAMED-ADDRESS   ((name nil))   (route-address)  :gettable-instance-variables  :initable-instance-variables  (:default-init-plist :allow-other-keys t))(defflavor BAD-ADDRESS   (error-report-string)   (address)  :gettable-instance-variables  :initable-instance-variables  (:default-init-plist :allow-other-keys t))(defmethod (ADDRESS :PRINT-SELF) (stream depth slashify)  (declare (ignore depth))  (if slashify      (format stream "#<~S ~S ~O>"      (type-of self) (send self :address-string) (sys:%pointer self))      (princ (send self :address-string) stream)))(defmethod (GROUP-ADDRESS :AFTER :DESCRIBE) ()  (format t "~2%ADDRESS-LIST:~%")  (dolist (address address-list)    (describe address)))(defun MAILBOX-P (address)  (or (and (typep address 'basic-address)   (not (typep address 'route-address)))      (typep address 'named-address)))(defun NAMED-ADDRESS-P (address)  (typep address 'named-address))(defun ROUTE-ADDRESS-P (address)  (and (typep address 'route-address)       (not (typep address 'named-address))))(defun BASIC-ADDRESS-P (address)  (and (typep address 'basic-address)       (not (typep address 'route-address))))(defun ADDRESS-P (address)  (typep address 'address))(defun GROUP-ADDRESS-P (address)  (typep address 'group-address))(defun BAD-ADDRESS-P (address)  (typep address 'bad-address))(defun NULL-ADDRESS-P (address)  (cond ((typep address 'basic-address) (not (consp (send address :local-part))))((typep address 'group-address) (null (send :address :name)))(t nil)));;;;;; HEADER;;;(defflavor HEADER    ((type)    (string))   (si:property-list-mixin)  :abstract-flavor  :outside-accessible-instance-variables  (:accessor-prefix header-)  :gettable-instance-variables  :initable-instance-variables)(defflavor BASIC-HEADER   (body)   (header)  :outside-accessible-instance-variables  (:accessor-prefix header-)  :gettable-instance-variables  :initable-instance-variables)(defflavor ADDRESS-HEADER   ((address-list))   (header)  :outside-accessible-instance-variables  (:accessor-prefix header-)  :gettable-instance-variables  :initable-instance-variables)(defun BAD-HEADER-P (header)  (and (typep header 'header)       (eq (send header :type) :bad-header)))(defmethod (ADDRESS-HEADER :AFTER :DESCRIBE) ()  (format t "~%ADDRESS-LIST:~2%")  (dolist (address address-list)    (describe address)))(defmethod (HEADER :PRINT-SELF) (stream depth slashify)  (declare (ignore depth))  (if slashify      (format stream "#<~A ~S ~O>"      (type-of self) (send self :string-for-message) (sys:%pointer self))      (princ (send self :string-for-message) stream)));;;;;; MAIL MESSAGE;;;(defflavor MESSAGE   (    (return-path nil);Address of originator.    (address-list '());List of recipients yet to be delivered    (original-address-list '());The original addresses before expansion    (disposed-address-list '());List of addresses that have been delivered or disposed of in some way    (error-return-list '());List of addresses and error responses that need to be returned    (subject);Subject of message (needed for DECNET's so-called mail protocol)    (expanded-p nil);T when addresses have been aliased and mailing lists expanded    (date-received);Universal time when this message was received on this machine    (tick-received);Tick when this message was received (value from (TIME))    (first-notification-sent nil);T when first notification of delivery problem has been returned    (text nil);Text of the message, either a string or pathname.    (queue-path nil);Queue file pathname or nil if message has not be saved to disk    (modified-p nil);T when message has been modified since written to disk    (origin);Host from which message was received -- may be a string    (loop-detected-p);T if server detects that this message is looping on the network    ;;(error-history '()) ;Record of past failures to deliver message.    (lock nil);Lock for modification    )   (si:output-stream)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables  :outside-accessible-instance-variables  (:accessor-prefix message-))(defmethod (message :REUSE) ()  (when (stringp text)    (deallocate-xstring text))  (setq return-path niladdress-list niloriginal-address-list nildisposed-address-list nilerror-return-list nilsubject nilexpanded-p nildate-received niltick-received niltext nilqueue-path nilmodified-p nilorigin nilloop-detected-p nillock nil))(defun REUSE-MESSAGE (object &rest init-plist)  ;; Initialize a message being reused;  init-plist is like what MAKE-INSTANCE would allow.  (loop     for (kwd value) on init-plist by #'cddr    do    (send object :set kwd value)))(defresource MESSAGE (&rest message-init-plist)  :constructor (apply #'make-instance 'message message-init-plist)  :initializer (apply #'reuse-message object message-init-plist)  :matcher (true))(defsubst DEALLOCATE-MESSAGE (message-object)  ;; This is required so that the xstring sometimes used to hold the  ;; message text can be deallocated too (defresource does not allow  ;; one to provide a "de-initializer" function  (send message-object :reuse)  (deallocate-resource 'message message-object))(defsubst ALLOCATE-MESSAGE (&rest message-init-plist)  ;; Just for consistency  (apply #'allocate-resource 'message message-init-plist));;;;;; MAIL QUEUE;;;(defflavor MAIL-QUEUE   ((message-list);List of messages waiting to be sent    (host-queue-list);List of host queues with messages waiting    (enabled-p)    (lock nil));Lock for modification   ()  :gettable-instance-variables  :settable-instance-variables)(defmethod (MAIL-QUEUE :REUSE) ()  (setq message-list nil)  (setq host-queue-list nil))(defresource TEMP-MAIL-QUEUE ()  :constructor (make-instance 'mail-queue)  :initializer (send object :reuse)  :matcher (true)  :initial-copies 1)(defstruct HOST-QUEUE  "A queue of messages/addresses for a particular host."  contact;The host to receive messages in this queue; or a symbol indicating special treatment  message-alist;Alist of ((msg addr ...) ...); Each means deliver ADDRs from MSG to this host.  last-attempt;Time of last attempted delivery  last-error;Last fatal error to occur accessing this host  new-item-p;T if this queue has something new since the last queue run.  delivery-in-progress-p;T if attempting delivery right now.  lock;Lock for modification)(defflavor SMTP-MAIL-SERVICE   ((host:name :smtp)     (host:desirability .25))   (host:service-implementation-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables)(defflavor CHAOS-MAIL-SERVICE   ((host:name :mail)     (host:desirability .75))   (host:service-implementation-mixin)  :gettable-instance-variables  :settable-instance-variables  :initable-instance-variables);;(defflavor CHAOS-SMTP-MAIL-SERVICE;;   ((host:name :chaos-smtp) ;;    (host:desirability .25));;   (host:service-implementation-mixin);;  :gettable-instance-variables;;  :settable-instance-variables;;  :initable-instance-variables)(host:define-service-implementation 'smtp-mail-service)(host:define-service-implementation 'chaos-mail-service);;For Rel2 compat;;(host:define-service-implementation 'chaos-smtp-service);;(host:define-logical-contact-name "SMTP" '((:tcp 25)));;(host:define-logical-contact-name "CHAOS-SMTP" '((:chaos "SMTP")))(host:define-logical-contact-name "SMTP" '((:chaos "SMTP") (:tcp 25)))(host:define-logical-contact-name "MAIL" '((:chaos "MAIL")))(defresource DELIVERY-PROCESS ()  :constructor (make-process "Mail Delivery"     :warm-boot-action 'si:process-warm-boot-reset     :priority -6     :special-pdl-size 2048.     :regular-pdl-size 6656.)  :initializer (process-disable object)  :matcher (not (member object (the list si:all-processes) :test #'eq)))(defvar *DELIVERY-PROCESS* nil)(defvar *MAIL-QUEUE* (make-instance 'mail-queue))(defvar *MAIL-DAEMON* nil)(defvar *TRY-ALL-MAIL-SERVICES* t)(defvar *MAILER-DIRECTORY* '("MAILER"))(defvar *WAKEUP-MAILER* nil)(defsubst MAILER-DIRECTORY ()  (make-pathname :host si:local-host :directory *mailer-directory* :name :wild :type :wild :version :newest))(defvar *CHECK-ROUTING-INTERVAL* (* 4 60 60)  "Time (in seconds) between checking whether queued messagesneed re-routing based on new name server data.")(defvar *INBOX-PROBE-LIST* nil  "List of pathnames to probe for new mail")(defvar *ADDRESS-HEADER-TYPES* '(:from :to :cc :bcc :reply-to :sender :resent-from :resent-sender :resent-to :resent-cc :resent-bcc))(defvar *MAILBOX-HEADER-TYPES* '(:from :sender :resent-from :resent-sender))(defvar *DESTINATION-HEADER-TYPES* '(:to :resent-to :cc :resent-cc :bcc :resent-bcc)  "A list of destination addr types")(defvar *HEADERS-NOT-COPIED-TO-FINAL-MESSAGE* '(:bcc :resent-bcc :fcc)  "A list of headers that are not directly copied to the message that is sent")(defvar *MAX-MESSAGE-NETWORK-HOPS* 30)(defvar *READ-TIMEOUT* (* 10 (* 60 60)))(defvar *INTERACTIVE-DELIVERY-IN-PROGRESS* nil)(defvar *MAIL-SERVER-PROCESS-LIST* nil)(defvar *SMTP-PORT-NUMBER* 25.)(defvar *INITIAL-MESSAGE-TIMEOUT-HOURS* 36)(defvar *FINAL-MESSAGE-TIMEOUT-HOURS* (* 4 24))(defvar *XSTRING-RESOURCE* (make-array 200 :fill-pointer 0 :initial-element nil))(defsubst XSTRINGP (object)  (and (stringp object)       (array-has-leader-p object)))(defun ALLOCATE-XSTRING (size &optional (max-delta 10))    (let (xstring asize)    (without-interrupts      (dotimes (i (length *xstring-resource*)  (make-array size :element-type 'string-char :fill-pointer 0))(setq xstring (aref *xstring-resource* i))(when xstring  (setq asize (array-dimension xstring 0))  (when (and (>= asize size)     (<= (- asize size) max-delta))    (setf (aref *xstring-resource* i) nil)    (setf (fill-pointer xstring) 0)    (return xstring)))))))(defun DEALLOCATE-XSTRING (&rest strings)  (let ((start 0))    (dolist (string strings)      (when (xstringp string)(without-interrupts   (loop    for i from start below (length *xstring-resource*)    when (null (aref *xstring-resource* i))    do (setf (aref *xstring-resource* i) string)       (return)    finally    (vector-push-extend string *xstring-resource* 100)))))))(defmacro USING-XSTRING ((var size &optional (max-delta 4)) &body body)  `(let ((,var nil))     (unwind-protect (progn    (setq ,var (allocate-xstring ,size ,max-delta))   . ,body)       (deallocate-xstring ,var))))(defun XSTRING-APPEND (into-string &rest strings)  "Much like string-nconc but neither creates garbage or preservesEQness. INTO-STRING must be NIL or a string from the xstring resource.If STRINGS will fit into INTO-STRING without causing an arrayadjustment, then just modify and return it.  Otherwise, allocate alarger xstring, copy into-string to the new string, return into-stringto the xstring resource, then modify and return the new string.  Thusthe return value from this function MUST be used because the objectpassed may not be the object returned (and may even be later reused)."    (if (null strings)      (or into-string (allocate-xstring 0))      (let ((rest-length (loop for s in strings       sum (length (string s)))))(when (null into-string)  (setq into-string (allocate-xstring rest-length)))(let* ((into-length (length into-string))       (into-size (array-dimension into-string 0))       (final-length (+ into-length rest-length))       from-string-length)  (when (> final-length into-size)    (let ((new-string (allocate-xstring (+ final-length (ceiling final-length 2)))))      (copy-array-contents into-string new-string)      (setf (fill-pointer new-string) into-length)      (deallocate-xstring into-string)      (setq into-string new-string)))  (dolist (from-string strings)    (cond ((characterp from-string)   (setf (char into-string into-length) from-string)   (incf into-length))  (t   (setq from-string (string from-string))   (setq from-string-length (length from-string))   (copy-array-portion from-string 0 from-string-length       into-string into-length (incf into-length from-string-length))))    (setf (fill-pointer into-string) into-length)))into-string)))(defun XSUBSTRING (string from &optional to into-string)  "Return a copied substring of STRING from FROM to TO allocated from the xstringresource.  If INTO-STRING is supplied, it is assumed to be an xstring toappend the substring to -- a different string may still be returned if theresult will not fit into INTO-STRING."    (unless from (setq from 0))  (unless to (setq to (length string)))  (if (>= from to)      (or into-string (allocate-xstring 0))    (cond ((null into-string)   (let* ((result-length (- to from))  (xstring (allocate-xstring result-length)))     (setf (fill-pointer xstring) result-length)     (copy-array-portion string from to xstring 0 result-length)     xstring))  (t    (let* ((into-length (length into-string))   (result-length (+ into-length (- to from))))      (when (> result-length (array-dimension into-string 0))(let ((new-xstring (allocate-xstring (+ result-length (ceiling result-length 2)))))  (copy-array-contents into-string new-xstring)  (deallocate-xstring into-string)  (setq into-string new-xstring)))      (setf (fill-pointer into-string) result-length)      (copy-array-portion string from to into-string into-length result-length)      into-string)))))(defun CLEAR-XSTRINGS ()  (dotimes (i (length *xstring-resource*))    (setf (aref *xstring-resource* i) nil)))(defvar *ADDRESS-HASH-TABLE* (make-hash-table :test #'equal      :size 500      :rehash-size 200))(defun CLEAR-RESOURCES ()  (clrhash *address-hash-table*)  (clear-xstrings)  (clear-resource 'rfc822-parser nil nil)  (clear-resource 'temp-mail-queue nil nil)  (clear-resource 'message nil nil));; This exists only to avoid a package search when interning things(defvar *UTILITY-PACKAGE* (find-package "KEYWORD"))(defun READ-LINE-WITH-TIMEOUT (stream &optional (eof-error-p t) eof-value copy-p)  "Read line from stream, ferror if it takes longer than mail:*read-timeout* 60'th of a second"    (when (eq (send stream :send-if-handles :network-type) :chaos)    (let ((peek    (process-wait-with-timeout "Net Input" *read-timeout*       #'(lambda (stream)   (condition-call (condition)       (let ((char (read-char-no-hang stream nil :eof))) (when (or (characterp char) (eq char :eof))   char))     ((not (send condition :dangerous-condition-p))      condition)))              stream)))      ;;(format t "~&PEEK => ~S" peek)      ;;(when (eq peek :eof);;(multiple-value-bind (line eof)    ;;(send stream :line-in copy-p)  ;;(format t "   LINE => ~S   EOF => ~S" line eof)))      (cond ((errorp peek)     (signal-condition peek))    ((eq peek :eof)     (if eof-error-p (ferror 'sys:end-of-file "End of file on ~S" stream)       (return-from read-line-with-timeout eof-value t)))    ((null peek)     (ferror 'read-time-out "Read from stream ~A timed out" stream))    (t     (unread-char peek stream)))))  (multiple-value-bind (line eof)      (send stream :line-in copy-p)    ;;(format t "   LINE => ~S   EOF => ~S" line eof)    ;; Convert :line-in return values to read-line style    (cond ((and eof (zerop (length line)))   (if eof-error-p       (ferror 'sys:end-of-file "End of file on ~S" stream)     (values eof-value t)))  (eof   (values line t))  (t   (values line nil)))))#|(defun READ-LINE-WITH-TIMEOUT (stream &optional (eof-error-p t) eof-value copy-p)  "Read line from stream, ferror if it takes longer than mail:*read-timeout* 60'th of a second"    (multiple-value-bind (line eof)      (send stream :line-in copy-p)    ;; Convert return values to read-line style    (cond ((and eof (zerop (length line)))   (if eof-error-p       (ferror 'sys:end-of-file "End of file on ~S" stream)     (values eof-value t)))  (eof    (values line t))  (t    (values line nil)))))|#(defun STREAM-COPY-UNTIL-EOF-WITH-TIMEOUT (from-stream to-stream)  "Copy from-stream to to-stream using read-line-with-timeout"    (loop      (multiple-value-bind (line eof)  (read-line-with-timeout from-stream nil nil)(when line  (send to-stream :line-out line))(when (or (null line) eof)  (send to-stream :send-if-handles :force-output)  (send to-stream :send-if-handles :eof)  (return)))))(defsubst STRING-BLANK-P (string)  (dotimes (x (length string) t)    (when (not (member (char string x) *white-space-characters*))      (return nil))))(defsubst SHORT-HOST-STRING (host)  (cond ((typep host 'si:basic-host) (send host :name))((stringp host) host)(t "UNKNOWN")))(defvar *DEBUG-MAILER* nil)(defvar *DEBUG-TYPES* '(:mailer :chaos-mail-server :smtp-server :mail-queue :smtp-client :chaos-mail-client))(defun HANDLE-CONDITION-P (condition &rest not-these-conditions)  (and (not (send condition :debugging-condition-p))       (not (send condition :dangerous-condition-p))       (if not-these-conditions   (not (condition-typep condition (cons 'or not-these-conditions))) (not (condition-typep condition 'sys:abort)))))(defun IGNORED-NETWORK-CONDITION-P (condition)  (condition-typep condition   '(or sys:network-errorsys:end-of-fileread-time-outchaos-mail-client-errorsmtp-client-errorchaos-mail-server-errorsmtp-server-error)))       (defun SANITIZE-STRING (string)  "For sending error reports over network.  Ensure string is not too longand contains no newlines."  (if (and (< (length string) 256)   (not (find #\Newline (the string string))))      string    (setq string (subseq string 0 (min (length string) 256)))    (nsubstitute #\Space #\Newline (the string string))))(defvar *MAILER-LOG-PATHNAME* "LM:MAILER;LOG.TEXT"  "Standard pathname used for log output.")(defvar *LOG-OUTPUT* nil  "Stream used for log output.  Usually set to a MAIL:LOG-STREAM instance.")(defvar *LOG-ENABLED* t  "Controls the amount of log data produced by the Mailer.  Possiblevalues are: NIL for no logging, T to log only important events, :ALL tolog everthing, or a list containing any of the following: :MAIL-QUEUE:DELIVERY :CHAOS-MAIL-CLIENT :CHAOS-MAIL-SERVER :SMTP-MAIL-CLIENT:SMTP-MAIL-SERVER.  The defaut is T.")(defvar *LOG-SESSION* 0  "A number to identify the log output of different processes.  Eachprocess that produces log output should INCF and bind this.")(defmacro MAYBE-LOG ((catagory) &body body)  `(when (and *log-enabled* *log-output*      (or (eq *log-enabled* :all)  (and (consp *log-enabled*) (member ,catagory (the list *log-enabled*) :test #'eq))))     . ,body))(defmacro LOG-DEBUG (catagory format-string &rest format-args)  "Log a debug message if logging enabled for CATAGORY."  `(maybe-log (,catagory)     (log-output ,catagory ,format-string ,@format-args)))(defmacro LOG-EVENT (catagory format-string &rest format-args)  "Log an important event unless logging completely disabled."  `(when (and *log-enabled* *log-output*)     (log-output ,catagory ,format-string ,@format-args)))(defun LOG-OUTPUT (catagory format-string &rest format-args)  (when *log-output*    (send *log-output* :send-if-handles :set-more-p nil)    (fresh-line *log-output*)    (time:print-current-time *log-output*)    (format *log-output* " ~3D~@[ ~S~]  " *log-session* catagory)    (apply #'format *log-output* format-string format-args)))(defsubst FORCE-LOG-OUTPUT ()  (when *log-output*    (send *log-output* :send-if-handles :force-output)))(defflavor LOG-STREAM   ((pathname);Pathname for output    (versions-kept 6);Max # versions of output file to keep    (new-version-hour 12);Hour of day to create new version    (next-new-version-time);Time that next new version will be created    (output-lock);Lock for doing output    (buffer);Current buffer used to store output    (buffer-index 0);Current index into BUFFER    (old-buffer);Spare buffer to use while output in progress    (old-buffer-index)    (buffer-size 8192);Size of each buffer    (overflow-p);T when BUFFER has overflown before being output    (bytes-lost));Record of how many bytes of log info lost after BUFFER overflew  (si:buffered-output-stream)  :gettable-instance-variables  (:required-init-keywords :pathname)  (:initable-instance-variables pathname versions-kept buffer-size new-version-hour))erver)(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 l