;;; -*- Mode:Common-Lisp; Package:Yes-Way; Base:10 -*-

;;; **********************************************************************
;;; Copyright (c) 1990 Stanford University.
;;; This code was written by James Rice.
;;; Copyright is held by Stanford University except where code has been
;;; modified from TI source code.  In these cases TI code is marked with
;;; a suitable comment.

;;; All Stanford Copyright code is in the public domain.  This code may be
;;; distributed and used without restriction as long as this copyright
;;; notice is included and no fee is charged.  This can be thought of as
;;; being equivalent to the Free Software Foundation's Copyleft policy.

;;; TI source code may only be distributed to users who hold valid TI
;;; software licenses.

;;; The development of this software was assisted by the following grants:
;;; Biomedical Research Technology Program of the National Institutes
;;; of Health under grant RR-00785
;;; Information Systems Technologies office of the Defense Advanced
;;; Research Projects Agency under contract N00039-86-C0033.

;;; **********************************************************************

(defmacro stream-safely ((stream &optional (error-val nil)) &body body)
"Executes body with a condition handler that looks for tcp errors.
If an error occurs then Stream is closed and the user is notified,
returning error-val.
"
  `(condition-bind
     ((ip:tcp-error 'imap-stream-error-handler ,stream)
      (sys:deallocate-non-resource-entry 'imap-stream-error-handler ,stream)
     )
     (let ((result (catch 'imap-stream-close
		     (if (send ,stream :Open-P)
			 (progn ,@body)
			 (ferror 'close-worthy-error "~S is closed." ,stream)
		     )
		   )
	   )
	  )
          (if (equal result :imap-stream-error)
	      ,error-val
	      result
	  )
     )
   )
)

(defmacro with-close-errors-handled ((mailstream) &body body)
"Executes body with a condition handler that looks for errors when closing
an imap stream.  If an error occurs then MailStream is cleaned up.
"
  `(condition-bind ((ip:tcp-error 'close-error-handler ,mailstream))
     (Without-Recursion ()
       (let ((result (catch 'close-error
		       (with-timeout (10 :Close-Error) ,@body)
		     )
	     )
	    )
	    (if (equal result :close-error)
		(send ,mailstream :clean-up-after-close)
		result
	    )
       )
     )
   )
)

(defmacro with-carriage-return ((&optional (window '*query-io*)) &body body)
"Executes Body by throwing a carriage return before the body is executed.
This shows the user that the machine is thinking.
"
 `(let ((real-window (if (typep ,window 'Yw-Prompt-Window)
			 ,window
			 (send ,window :Prompt-Window)
		     )
	)
       )
       (let ((rhb (symeval-in-instance real-window 'tv:rubout-handler-buffer)))
;	    (setf (tv:rhb-scan-pointer rhb) 0)
; (prin1 (list (tv:rhb-scan-pointer rhb) (tv:rhb-fill-pointer rhb)))
	    (setf (tv:rhb-scan-pointer rhb) (tv:rhb-fill-pointer rhb))
  	    (clean-up-rh real-window)
       )
     ,@body
  )
)

(defmacro With-Close-Worthy-Errors-Handled
	  ((mailstream &optional (error-val nil)) &body body)
"Executes body with a condition handler that looks for errors that are severe
enough for us to want to close MailStream.  If such an error occurs the stream
gets closed and error-val is returned.
"
  `(condition-bind
        ((close-worthy-error 'close-worthy-error-handler ,mailstream))
     (let ((result (catch 'close-worthy-error ,@body)))
	  (if (equal result :close-worthy-error)
	      ,error-val
	      result
	  )
     )
   )
)

(defun safe-lexpr-send (to message &rest args)
"Like Lexpr-send only it makes sure that the last arg is really a list."
  (if (and (not args) (consp message))
      (progn (setq args (rest message))
	     (setq message (first message))
      )
      nil
  )
  (if (not (listp (first (last args))))
      (ferror nil "Lexpr-send being called on a non-list for its last arg.")
      nil
  )
  (lexpr-send to message (append (butlast args) (first (last args))))
)

(defmacro inside-zmacs ((frame &optional (window nil)) &body body)
"Executes Body in an environment which makes it think that it is being
called from within Zmacs.  All Zmacs specials are bound to some suitable value.
"
 `(let ((.frame. ,frame)
	(.window. ,window)
	(.values. nil)
       )
       (declare (unspecial .frame. .window. .values.))
       (let-if .window.
	       ((zwei:*window* .window.))
	       (funcall (send .frame. :editor-closure)
			#'(lambda ()
			    (setq .values. (multiple-value-list (progn ,@body)))
			  )
	       )
       )
       (values-list .values.)
  )
)

(defmacro inside-all-zmacs (&body body)
"Executes Body successively in the environments of all of the existing zmacs
frames.
"
 `(loop for win in Zwei::*All-Zmacs-Windows* do
	(Inside-Zmacs ((send win :Superior)) ,@body)
  )
)

(defmacro undefimmediate-command
	  (defname lambda-list (&rest command-list) &rest ignore)
"Undefines an immediate command defined by defimmediate-command."
 `(progn ,(if (consp defname)
	     `(undefmethod ,defname ,lambda-list)
	     `(undefun ,defname)
	  )
	  (let ((com-name ',(if (consp defname) (second defname) defname)))
	       (mapcar #'(lambda (x)
			   (if (member com-name (symbol-value x) :Test #'equalp)
			       (progn (set x (remove com-name (symbol-value x)))
				      (Build-All-Command-Tables)
			       )
			       nil
			   )
			 )
		       ',command-list
	       )
	  )
	  ',defname
  )  
)

(defmacro undefnonimmediate-command
	  (defname lambda-list (&rest command-list) &rest ignore)
"Undefines a nonimmediate command defined by defnonimmediate-command."
  `(undefimmediate-command ,defname ,lambda-list (,@command-list))
)

(defflavor Yw-Command
	   ()
	   (ucl:command)
  (:Documentation "The flavor of command used by the Mailer.")
)

(defmethod (yw-command :Print-Self) (stream &rest ignore)
  (format stream "#<~S ~S ~D>" (type-of self) (send self :name)
	  (sys:%pointer self)
  )
)

(defflavor Yw-Immediate-Command
	   ()
	   (Yw-Command)
  (:Documentation "The flavor of command used by the Mailer.")
)

(defflavor Yw-Non-Immediate-Command
	   ()
	   (Yw-Command)
  (:Documentation "The flavor of command used by the Mailer.")
)

(defmacro defimmediate-command
	  (defname lambda-list (&rest command-list) keywords &body body)
"Defines a command for the mailer called DefName.  Command-list is the list
of the command list names that this command is to be added to.  Keywords
is the list of decommmand magic things like :names and :keys.
  An immediate command is a command that is executed as soon as it has been
completed, as opposed to a non-immediate command, which is not executed until
a newline is typed.  Immediate commands should finish with a (continuation ...).
"
 `(let ((command
	  (defcommand ,defname ,lambda-list
	    ',(append (eval keywords) '(:Command-Flavor Yw-Immediate-Command))
	    (let ((*command-stack*
		    (cons (first ucl:command-history)
			  (if (boundp '*command-stack*)
			      *command-stack*
			      nil
			  )
		    )
		  )
		 )
	         (declare (special *command-stack*))
		 ,@body
	    )
	  )
	)
       )
       (setf (get command :immediate-p) t)
       (let ((com-name ',(if (consp defname) (second defname) defname)))
	    (mapcar #'(lambda (x)
			(if (member com-name (symbol-value x) :Test #'equalp)
			    nil
			    (set x (cons com-name (symbol-value x)))
			)
		      )
		    ',command-list
	    )
       )
       command
  )
)

(if (boundp 'zwei:*section-defining-items*)
    (let ((string (string-append "(" (symbol-name 'Defimmediate-Command))))
	 (pushnew (list (length string) string :Always-Method)
		  zwei:*section-defining-items* :test #'equalp
	 )
    )
    nil
)


(if (boundp 'eh:*source-code-debuggable-forms*)
    (pushnew '(Defimmediate-Command eh:make-method-name 5)
	     eh:*source-code-debuggable-forms*
    )
    nil
)

(defmacro defnonimmediate-command
	  (defname lambda-list (&rest command-list) keywords &body body)
"Defines a command for the mailer called DefName.  Command-list is the list
of the command list names that this command is to be added to.  Keywords
is the list of decommmand magic things like :names and :keys.
  An immediate command is a command that is executed as soon as it has been
completed, as opposed to a non-immediate command, which is not executed until
a newline is typed.
"
 `(let ((command
	  (defcommand ,defname ,lambda-list
	    ',(append (eval keywords)
		      '(:Command-Flavor Yw-Non-Immediate-Command)
	      )
	    (let ((*command-stack*
		    (cons (send self :Command-Entry)
			  (if (boundp '*command-stack*)
			      *command-stack*
			      nil
			  )
		    )
		  )
		 )
	         (declare (special *command-stack*))
		 ,@body
		 (send prompt-window :Clear-Input)
	    )
	  )
	)
       )
       (setf (get command :immediate-p) nil)
       (let ((com-name ',(if (consp defname) (second defname) defname)))
	    (mapcar #'(lambda (x)
			(if (member com-name (symbol-value x) :Test #'equalp)
			    nil
			    (set x (cons com-name (symbol-value x)))
			)
		      )
		    ',command-list
	    )
       )
       command
  )
)

(if (boundp 'zwei:*section-defining-items*)
    (let ((string (string-append "(" (symbol-name 'Defnonimmediate-Command))))
	 (pushnew (list (length string) string :Always-Method)
		  zwei:*section-defining-items* :test #'equalp
	 )
    )
    nil
)

(if (boundp 'eh:*source-code-debuggable-forms*)
    (pushnew '(Defnonimmediate-Command eh:make-method-name 5)
	     eh:*source-code-debuggable-forms*
    )
    nil
)

(defmacro defcommand-short-form (for-command short-form)
"Defines a shortform for a command.  This allows you to get the read
command to be executed by just typing R.  Syntax is:
  (defcommand-short-form (mail-control-window :Read-Sequence) \"R\")
"
 `(let ((command (ucl:get-command ',(cons :Method for-command))))
       (if command
	   (setf (get command :short-forms)
		 (fs:cons-new ,short-form (get command :short-forms)
			      :Test #'string-equal
		 )
	   )
	   (ferror nil "There is no command called ~S" ',for-command)
       )
       (values ',for-command ,short-form command)
  )
)

(defmacro undefcommand-short-form (for-command short-form)
"Undefines a short form command declared using defcommand-short-form."
 `(let ((command (ucl:get-command ',(cons :Method for-command))))
       (if command
	   (setf (get command :short-forms)
		 (remove ,short-form (get command :short-forms)
			 :Test #'string-equal
		 )
	   )
	   (ferror nil "There is no command called ~S" ',for-command)
       )
       (values ',for-command ,short-form command)
  )
)


(if (boundp 'zwei:*section-defining-items*)
    (let ((string (string-append "(" (symbol-name 'Defcommand-Short-form))))
	 (pushnew (list (length string) string :Always-Method)
		  zwei:*section-defining-items* :test #'equalp
	 )
    )
    nil
)



(defmacro defmacro-command
	  (name (&key (names (string-capitalize (symbol-name name)))
		      description documentation keys
		)
	   &body value-string
	  )
"Declares a macro command.  A macro command is a command that has the effect
of typing an arbitrary amount of user input to the prompt window.  This can,
therefore embody an arbitrary number of typed commands.
  Name - is the name to give to the command.  This names the method for the
       command and, by default names the printed/typed representation of the
       command.
  Documentation - is like documentation for defcommand.
  Description - is like description for defcommand.
  Keys - is like the :keys option to defcommand.  Thus, if you want your
         macrocommand to be invoked by a keystroke then you should put in
         an entry such as (#\H-S).
  Value-string - is a string which denotes the text that you would have
                 typed.

Worked Example:
  (defmacro-command interesting-command (:Keys (#\M-I))
    \"Head from acuff
     Read >
    \"
  )

This will create a command called Interesting Command with a keystroke short
form = M-I, which will get the headers from Acuff and read the most recent
message.  If you don't want to give the command a name (so that it does not
polute the existing command names) then your should specify :names nil.
"
  (declare (arglist command-name
		    (&key (names \""Command-Name"\") description documentation
			  keys
		    )
		    value-string
	   )
  )
  (let ((name-spec `(:Names ,names
                     :Documentation ,documentation
		     :Description ,description
		     :Keys ,keys
		    )
        )
	(command-name
	  `(mail-control-window ,(intern (symbol-name name) 'keyword))
	)
       )
      `(progn (defnonimmediate-command ,command-name
		() (*All-Top-Level-Command-Names*)
		 ',name-spec
		(continuation
		  (apply-macro-command-string ',value-string *mailer*)
		)
	      )
	      (def ,name)
	      (defparent ,(cons :Method command-name) ,name)
	      (Build-Top-Level-Command-Table)
	      ',name
       )
  )
)

(defmacro undefmacro-command (name &rest ignore)
"Undefines a macro command declared using defmacro-command."
  (let ((command-name
	  `(mail-control-window ,(intern (symbol-name name) 'keyword))
	)
       )
      `(progn (undefnonimmediate-command ,command-name () () nil)
	      ',name
       )
  )
)

(defmacro without-recursion ((&optional recurse-value nil) &body body)
"Executes body in a manner that makes sure that it will not be entered
 recursively.
"
  (let ((tag (gensym "WITHOUT-RECURSION-"))) 
      `(if (and (boundp ',tag) (locally (declare (special ,tag)) ,tag))
	   ,recurse-value
	   (let ((,tag t))
	        (declare (special ,tag))
		,@body
	   )
       )
  )
)

(defmacro With-These-Command-Tables
	  ((new-tables &optional (new-p t)) application &body body)
"Executes Body in a ucl environment which has New-Tables as its active
 command tables.  If new-p then these replace any existing command tables.
"
  `(letf (((symeval-in-instance ,application
	    'ucl:active-command-tables)
	    (if ,new-p
		,new-tables
	       (append ,new-tables
			(symeval-in-instance ,application
					     'ucl:active-command-tables
			)
	       )
	    )
	  )
	 )
	 ,@body
   )
)

(defmacro Without-universal-command-Tables (application &body body)
"Executes Body in a ucl environment which has the universal commands removed."
  `(letf (((symeval-in-instance ,application
	    'ucl:system-command-tables)
	    (remove 'ucl:universal-commands
		    (symeval-in-instance ,application
					 'ucl:active-command-tables
		    )
	    )
	  )
	 )
	 ,@body
   )
)

(defmacro with-whitespace-as-eof (&body body)
"Executes Body in an environment in which a whitespace char will indicate
EOF to the reader.
"
  `(let ((*eof-chars*
	   (if (boundp '*eof-chars*)
	       (append (locally (declare (special *eof-chars*)) *eof-chars*)
		       *whitespace-chars*
	       )
	       *whitespace-chars*
	   )
	 )
	 (was-already-eof (and (boundp '*eof-found*) *eof-found*))
	)
        (declare (special *eof-chars*))
	(unwind-protect (progn ,@body)
	  (if was-already-eof
	      nil
	      (if (and (boundp '*eof-found*) *eof-found*
		       (member *eof-found* *whitespace-chars* :Test #'char=)
		  )
		  (setq *eof-found* nil)
		  nil
	      )
	  )
	)
   )
)

(defmacro with-nl-as-eof (&body body)
"Executes Body in an environment in which a newline char will indicate
EOF to the reader.
"
  `(let ((*eof-chars*
	   (if (boundp '*eof-chars*)
	       (append (locally (declare (special *eof-chars*)) *eof-chars*)
		       '(#\newline)
	       )
	       '(#\newline)
	   )
	 )
	 (was-already-eof (and (boundp '*eof-found*) *eof-found*))
	)
        (declare (special *eof-chars*))
	(unwind-protect (progn ,@body)
	  (if was-already-eof
	      nil
	      (if (and (boundp '*eof-found*) *eof-found*
		       (char= #\newline *eof-found*)
		  )
		  (setq *eof-found* nil)
		  nil
	      )
	  )
	)
   )
)

(defmacro with-paren-as-eof (paren-char &body body)
"Executes Body in an environment in which a ) char will indicate
EOF to the reader.
"
  `(let ((*eof-chars*
	   (if (boundp '*eof-chars*)
	       (append (locally (declare (special *eof-chars*))
				(set-difference
				  *eof-chars*
				  (mapcar #'second *parenthesis-chars*)
				)
		       )
		       (rest (assoc ,paren-char *parenthesis-chars*))
	       )
	       (rest (assoc ,paren-char *parenthesis-chars*))
	   )
	 )
	)
        (declare (special *eof-chars*))
	,@body
   )
)

(defmacro with-non-space-whitespace-as-eof (&body body)
"Executes Body in an environment in which any whitespace char except #\space
will indicate EOF to the reader.
"
  `(let ((*eof-chars*
	   (if (boundp '*eof-chars*)
	       (remove #\space
		 (append (locally (declare (special *eof-chars*)) *eof-chars*)
		         *whitespace-chars*
		 )
	       )
	       (remove #\space *whitespace-chars*)
	   )
	 )
	 (was-already-eof (and (boundp '*eof-found*) *eof-found*))
	)
        (declare (special *eof-chars*))
	(unwind-protect (progn ,@body)
	  (if was-already-eof
	      nil
	      (if (and (boundp '*eof-found*) *eof-found*
		       (member *eof-found* (remove #\space *whitespace-chars*)
			       :Test #'char=
		       )
		  )
		  (setq *eof-found* nil)
		  nil
	      )
	  )
	)
   )
)

(defmacro without-whitespace-as-eof (&body body)
"Executes Body in an environment in which whitespace chars will not indicate
an EOF to the reader.
"
  `(let ((*eof-chars*
	   (if (boundp '*eof-chars*)
	       (set-difference *eof-chars* *whitespace-chars*)
	       nil
	   )
	 )
	)
        (declare (special *eof-chars*))
	,@body
   )
)

(defmacro with-different-command-tables ((new-tables) &body body)
"Executes Body in a ucl environment which has New-Tables as its active
 command tables.
"
  `(locally (declare (special *Mailer*))
	    (letf (((symeval-in-instance *Mailer* 'ucl:active-command-tables)
		    ,new-tables
		   )
		  )
		  (let ((*throw-out-on-rubout* t))
		       (declare (special *throw-out-on-rubout*))
		       ,@body
		  )
	    )
   )
)

(defmacro with-extra-command-tables ((new-tables) &body body)
"Executes Body in a ucl environment which has New-Tables as active
 command tables as well as any previous ones.
"
  `(locally (declare (special *Mailer*))
	    (letf (((symeval-in-instance *Mailer* 'ucl:active-command-tables)
		    (append ,new-tables (send *Mailer* :Active-Command-Tables))
		   )
		  )
		  (let ((*throw-out-on-rubout* t))
		       (declare (special *throw-out-on-rubout*))
		       ,@body
		  )
	    )
   )
)

(defmacro continuation (&body body)
"Throws out a continuation for a command."
  `(throw :Top-Level-Command
	  (closure '(self si:self-mapping-table)
		   #'(lambda () (progn ,@body))
	  )
   )
)

(defmacro defparent (thing parent)
"Declares that Parent is the Parent of thing.  Used by M-."
  `(si:function-spec-putprop ',thing ',parent 'si:function-parent)
)

(defun good-package (package)
"Given a package, finds a good package in which to intern some new symbol.
This will be the YW package if the user is trying to intern into the lisp or
keyword packages.
"
  (if (member package (mapcar #'find-package '(keyword lisp)))
      (find-package 'yw)
      package
  )
)

(defmacro defcommand-table (name short-doc long-doc)
"Declares a new command table called Name.  Short-doc and Long-doc are
 doc strings given to the command table build code.
"
  (let ((*name (intern (string-append "*" (symbol-name name) "-COMMAND-TABLE*")
		       (good-package (symbol-package name))
	       )
	)
	(*all-name (intern (string-append "*ALL-" (symbol-name name)
					  "-COMMAND-NAMES*"
			   )
			   (good-package (symbol-package name))
	           )
	)
	(all-name (intern (string-append "ALL-" (symbol-name name)
					  "-COMMAND-NAMES"
			  )
			  (good-package (symbol-package name))
	          )
	)
	(build-name (intern (string-append "BUILD-" (symbol-name name)
					  "-COMMAND-TABLE"
			  )
			  (good-package (symbol-package name))
	            )
	)
       )
      `(progn (defvar ,*name :Unbound
		       ,(string-append "The command table for "
				       (string-capitalize (symbol-name name))
			)
	      )
	      (pushnew ',*name *all-mailer-command-tables*)
	      (si:function-spec-putprop ',*name ',name 'si:function-parent)
	      (defvar ,*all-name nil
		      ,(string-append
			 "All of the commands to be built into the "
			 (string-capitalize (symbol-name *name))
			 " command table for "
			 (string-capitalize (symbol-name name))
		       )
	      )
	      (si:function-spec-putprop ',*all-name ',name 'si:function-parent)
	      (defun ,all-name ()
	       ,(format nil "Returns all of the commands that are built into ~
			     the ~A command table for ~A"
			(string-capitalize (symbol-name *name))
			(string-capitalize (symbol-name name))
	        )
		(declare (si:function-parent ,name))
		,*all-name
	      )
	      (defun ,build-name ()
	       ,(format nil "Builds the command table ~A for ~A"
			(string-capitalize (symbol-name *name))
			(string-capitalize (symbol-name name))
	        )
		(declare (si:function-parent ,name))
		(build-command-table ',*name 'mail-control-window
		  (,all-name)
		  :Init-Options
		  '(:Name ,short-doc :Documentation ,long-doc)
		)
		',name
	      )
	      (pushnew ',build-name *all-command-table-builders*)
	      ',name
       )
  )
)

(defun check-for-do-it (function-spec class in)
"Makes sure that there is a :do-it clause in the body In, which is a body
of an advise of class specified by Class.
"
  (if (and (equal class :Around) (eq in (subst :Foo :Do-It in)))
      (compiler:warn :advice-missing-do-it :probable-error
		     "Advice on ~S missing a :do-it" function-spec 
      )
      nil
  )
  in
)

(defmacro destructuring-symbol-macrolet
	  (pattern data &body body &environment env)
"Like destructuring-bind only generates symbol macros for the pattern
variables.  E.g.
  (destructuring-symbol-macrolet (ignore docs &rest body) l
    (setq docs (mutate-docs docs)
  )
"
  (let ((expansion
	  (macroexpand `(destructuring-bind ,pattern ,data ,@body) env)
	)
       )
       (cons 'symbol-macrolet* (rest expansion))
  )
)

(defun symbol-macrolet*-1 (bindings body)
  (if bindings
      (if (string-equal "IGNORE" (string (first (first bindings))))
	  (symbol-macrolet*-1 (rest bindings) body)
	 `(symbol-macrolet (,(first bindings))
	    ,(symbol-macrolet*-1 (rest bindings) body)
	  )
      )
      (cons 'progn body)
  )
)

(defmacro symbol-macrolet* ((&rest bindings) &body body)
  "Is to symbol-macrolet as let* is to let."
  (symbol-macrolet*-1 bindings body)
)

(defmacro Defadvise
	  (function-spec (name &optional (class :Around) (position nil))
	   (&rest args) &body forms
	  )
"Just like advise only it gets M-. right and makes sure that it's compiled.
Destructuring-symbol-macrolets Arglist to the arglist.  Uses
the arglist of function-to-advise if none is provided.  Note:  this means that
you can do things like (setq <an-arg-name> <a-new-value>) and that value
will be passed along to the function named function-spec.
"
  (Check-For-Do-It function-spec class
   `(let ((compiler:compile-encapsulations-flag t))
	 (declare (special compiler:compile-encapsulations-flag))
	 (advise ,function-spec ,class ,name ,position
	  ,@(if (or args (arglist function-spec))
	       `((Destructuring-Symbol-Macrolet
		   ,(or args (arglist function-spec)) arglist
		   (locally ,@forms)
		 )
		)
	       `((locally ,@forms))
	    )
	 )
    )
  )
)

(if (boundp 'eh:*source-code-debuggable-forms*)
    (pushnew '(Defadvise second 4 eh:advise-putprop)
	     eh:*source-code-debuggable-forms*
    )
    nil
)


(defmacro Defadvise-Within
     (function-to-advise
      (within-function-spec name &optional (class :Around) (position nil))
      (&rest args) &body forms
     )
"Just like advise-within only it gets M-. right and makes sure that it's
 compiled.  Destructuring-symbol-macrolets Arglist to the arglist.  Uses
the arglist of function-to-advise if none is provided.  Note:  this means that
you can do things like (setq <an-arg-name> <a-new-value>) and that value
will be passed along to the function named function-spec.
"
  (Check-For-Do-It function-to-advise class
   `(let ((compiler:compile-encapsulations-flag t))
	 (declare (special compiler:compile-encapsulations-flag))
	 (advise-within ,within-function-spec ,function-to-advise
			,class ,name ,position
	  ,@(if (or args (arglist function-to-advise))
	       `((Destructuring-Symbol-Macrolet
		   ,(or args (arglist function-to-advise)) arglist
		   (locally ,@forms)
		 )
		)
	       `((locally ,forms))
	    )
	 )
    )
  )
)

(if (boundp 'eh:*source-code-debuggable-forms*)
    (pushnew '(Defadvise-within second 4)
	     eh:*source-code-debuggable-forms*
    )
    nil
)

(defmacro Defadvise-Dynamically-Within
     (function-to-advise
      (within-function-spec name &optional (class :Around) (position nil))
      (&rest args) &body forms
     )
"Just like defadvise-within only it works for any call to function-to-advise
that is called dynamically within a call to within-function-spec.
Destructuring-symbol-macrolets Arglist to the arglist.  Uses
the arglist of function-to-advise if none is provided.
"
  (let ((special-name
	  (intern (format nil "DYNAMICALLY-WITHIN-~A-~A-~A"
			  within-function-spec function-to-advise name
		  )
		  *package*
	  )
	)
       )
       (Check-For-Do-It function-to-advise class
	`(let ((compiler:compile-encapsulations-flag t))
	      (declare (special compiler:compile-encapsulations-flag))
	      (proclaim '(special ,special-name))
	      (advise ,within-function-spec :Around ,special-name nil
		(let ((,special-name t)) :Do-It)
	      )
	      (advise ,function-to-advise ,class ,name ,position
		(if (and (boundp ',special-name) ,special-name)
		   ,(if (or args (arglist function-to-advise))
		       `(Destructuring-Symbol-Macrolet
			  ,(or args (arglist function-to-advise)) arglist
			  (locally ,@forms)
			)
		       `(locally ,forms)
		    )
		    :Do-It
		)
	      )
	      ',function-to-advise
	 )
       )
  )
)

(if (boundp 'eh:*source-code-debuggable-forms*)
    (pushnew '(Defadvise-Dynamically-Within second 4)
	     eh:*source-code-debuggable-forms*
    )
    nil
)

(defmacro Looping-Through-Command-Tables
	  ((var-name &optional (all-p nil) (system-p t)) &body body)
"Loops through all of your command tables so that Var-name denotes a
 command-table.  If All-p then all command tables are processed.  If system-p
 then system command tables are processed.  Body is executed in the
 environment of var-name being the command table.
"
  (declare (special ucl:special-command-tables ucl:active-command-tables
		    ucl:all-command-tables ucl:system-command-tables))
  `(prog ((groups ',(if all-p
		       '(ucl:special-command-tables
			 ucl:all-command-tables
			 ucl:system-command-tables
			)
			(if system-p
			   '(ucl:special-command-tables
			     ucl:active-command-tables
			     ucl:system-command-tables
			    )
			   '(ucl:special-command-tables
			     ucl:active-command-tables
			    )
			)
		    )
	  )
	  group
	  ucl:command-table
	 )
      group-loop
	 (unless groups (return nil))
	 (setq group (symbol-value (pop groups)))
	 (unless group ;; Group may start out NIL, like NIL active-comtabs
	   ;; in Lisp Listener
	   (go group-loop))
      table-loop
	 (setq ucl:command-table (symbol-value (pop group)))
	 (unless ucl:command-table
	   (go group-loop))
	 (let ((,var-name ucl:command-table)) ,@body)
	 (go table-loop))
)

(defmacro Looping-Through-Commands
	  ((command-name &optional (in-table nil)) &body body)
"Loops through all of your commands in command table in-table so that
 Var-name denotes a command.  If All-p then all command tables are
 processed.  If system-p then system command tables are processed. 
 Body is executed in the environment of var-name being the command.
"
  (if in-table
     `(let ((.table. ,in-table))
	   (let ((.commands. (send .table. :Commands)))
	        (loop for .index.
		      from 0
		      to (- (array-active-length .commands.) 1)
		      for ,command-name = (aref .commands. .index.)
		      do ,@body
		)
	   )
      )
     `(Looping-Through-Command-Tables (ucl:command-table nil)
	(looping-through-commands (,command-name ucl:command-table)
	  ,@body
	)
      )
  )
)


(defun get-filter-representation (filter-name)
"Given the name of a filter (user name) gets the name of the variable that
we use to hold the specification of that filter.
"
  (intern (string-append #\* (get-string filter-name) #\*) :Yw)
  
)

(defmacro Get-Filter-Printed-Representation (filter-name)
"Given the user name of a filter returns the printed representation of that
filter.
"
  `(get (Get-Filter-Representation ,filter-name) :Printed-Representation)
)

(defmacro deffilter
	  (name (&key (printed-representation
		        (let ((*print-case* :Capitalize))
			     (format nil "~A" name)
		        )
		      )
	              (documentation "")
		      (description (string-append documentation " "))
		      (applicable-if
			#'(lambda (name stream) (ignore name stream) t)
		      )
		)
	        &body filter-expression
	  )
  (declare (arglist name (&key printed-representation documentation
			       description applicable-if
			 )
		    filter-expression
	   )
  )
"Declares a user defined named filter called Name.
 Printed-Representation - is the the thing that you type/gets printed on
   completion.
 documentation and description are just like for defcommand.
 Filter-expression - is the expression used to denote the filter predicate.
   this is can be expressed in one of two forms:
   a) a string, which denotes the sequence expression that you would type to a
      mail window such as \"Unseen And (To Rice Or Cc Rice)\"
   b) a lisp-ese expression in terms of message sequence keywords.
      For instance to specify a filter to denote \"From acuff And To Rice\"
      called To-Me you would use the declaration:
        (deffilter to-me () (and (from acuff) (to rice)))
 Applicable-If - is a function of two arguments which determines whether this
   filter is applicable in this context.  The arguments are the name of the
   mailstream and the mailstream.
"
  (if (> (length filter-expression) 1)
      (ferror nil "Illegal filter expression ~S.  This must be a single form."
	      filter-expression
      )
      nil
  )
  (let ((*name (get-filter-representation name))
        (key-name (intern (symbol-name name) :Keyword))
       )
      `(progn (defparameter
		,*name
		',(parse-filter-expression (first filter-expression))
		,@(if (not (equal "" documentation)) (list documentation) nil)
	      )
	      (setf (get ',*name :Applicable-If) ,applicable-if)
              (setf (get-filter-printed-representation ',name)
                   ,printed-representation
              )
	      (defparent ,*name ,name)
	      (Defimmediate-command (mail-control-window ,key-name)
		      () (*All-Message-Sequence-Command-Names*)
	       '(:Names ,printed-representation
		 :Description ,description
		 :Documentation '(,documentation
				  *message-sequence-documentation*
				 )
		)
	       (if (not (funcall (get ',*name :Applicable-If)
				 (and current-mailbox
				      (send current-mailbox :Mailbox)
				 )
				 current-mailbox
			)
		   )
		   (parse-error ,(format nil "filter \"~A\" is not applicable."
					 printed-representation
				 )
		   )
		   nil
	       )
	       (Throw :Sequence
		      (apply-filter ,*name ,printed-representation
				    self current-mailbox
		      )
	       )
	      )
	      (defparent ,key-name ,name)
	      (Build-Message-Sequence-Command-Table)
	      (values ',name ',*name ',key-name)
      )
  )
)

(defmacro undeffilter (name &body ignore)
"Undefines a filter defined using deffilter."
 `(Undefimmediate-Command
    (mail-control-window ,(intern (symbol-name name) :Keyword)) () ()
  )
)

(defmacro with-maybe-reopening-mail-file ((file-name stream) &body body)
"Executes Body in an environment that will switch the mailbox that Stream points
to to that denoted by the defined dummy mailbox name if File-name names a
mailbox that is currently open on some stream.
"
 `(let ((host (second (multiple-value-list
			(mailbox-and-host-from-mailbox-name
			  (send ,stream :Mailbox)
			)
		      )
	      )
	)
	(body-function #'(lambda () ,@body))
       )
       (let ((name-from-path
	       (if (canonical-mailbox-name-p ,file-name)
		   (mailbox-and-host-from-mailbox-name
		     (decanonicalize-mailbox-name ,file-name host)
		   )
		   (let ((temp-path
			   (fs:make-pathname :defaults ,file-name :Host host)
			 )
			)
			(string-append
			  (pathname-name temp-path)
			  (if (equal :unspecific (pathname-type temp-path))
			      ""
			      (string-append "." (pathname-type temp-path))
			  )
			)
		   )
	       )
	     )
	    )
	    (with-maybe-reopening-mail-file-1
	      ,stream name-from-path body-function
	    )
       )
  )
)


;(defmacro with-more-p-enabled ((sheet) &body body)
; `(letf (((tv:sheet-more-flag ,sheet) 1)) ,@body)
;)

(defmacro with-more-p-enabled ((sheet) &body body)
"Executes Body with more-p set in sheet."
 `(let ((.old. (send ,sheet :More-P)))
       (unwind-protect (progn (send ,sheet :Set-More-P t) ,@body)
	 (send ,sheet :Set-More-P .old.)
       )
  )
)

(defmacro do-descriptors
	  ((message mailbox &optional (when t) (loop-keyword 'do)) &body body)
"Iterates over the messages in mailbox binding Message to the current message.
When When is true it loop-keyword-s Body."
 `(let ((.mailbox. ,mailbox))
       (loop for .index. from 1 to (send .mailbox. :Messagecnt)
	     for ,message = (descriptor-of .index. .mailbox.)
	     when ,when ,loop-keyword ,@body
       )
  )
)

(defmacro do-summary-windows
	  ((window mailbox
	    &optional (when '(send window :Exposed-P)) (loop-keyword 'do)
	   )
	   &body body
	  )
"Iterates over the summary windows associated with mailbox binding Window
 to the current window.  When When is true it loop-keyword-s Body."
  `(let ((.mailbox. ,mailbox))
       (loop for ,window in (send .mailbox. :Associated-Windows)
	     when ,when ,loop-keyword ,@body
       )
  )
)

(defmacro with-address-database-locked ((lock-p) &body body)
"Locks the address database for the duration of Body."
 `(locally (declare (special *address-database-lock*))
	   (flet ((_body-function_ () ,@body))
	     (if ,lock-p
		 (with-lock ((IMAP.Lock-Location *address-database-lock*)
			     :Whostate "Wait for Addr D/B Lock"
			     :Norecursive
			    )
		   (_body-function_)
		 )
		 (_body-function_)
	     )
	   )
  )
)

(defmacro with-rule-base-locked ((lock-p) &body body)
"Locks the address database for the duration of Body."
 `(locally (declare (special *address-database-lock*))
	   (flet ((_body-function_ () ,@body))
	     (if ,lock-p
		 (with-lock ((IMAP.Lock-Location *rule-base-lock*)
			     :Whostate "Wait for Addr D/B Lock"
			     :Norecursive
			    )
		   (_body-function_)
		 )
		 (_body-function_)
	     )
	   )
  )
)

(defmacro with-mailbox-locked ((mailbox) &body body)
"Locks the mailbox for the duration of Body."
 `(with-lock ((IMAP.Lock-Location (GETSTREAMPROP ,mailbox :IMAPLock))
	      :Whostate "Wait for mailbox lock"
	     )
    ,@body
  )
)

;-------------------------------------------------------------------------------

;;; Patches 

ucl:
(DEFUN ucl:my-general-error-handler (condition-instance tag)
  "This defines a query loop used by the UCL to keep users out of the error handler (unless
they want in)."
  (LET (condition-handled?)
    (SETQ condition-handled?
          (MULTIPLE-VALUE-LIST
           (SIGNAL-CONDITION condition-instance eh::*condition-proceed-types* nil nil t)))
    (COND
      (condition-handled?)
      ((MEMBER :fquery (SEND condition-instance :condition-names) :test #'EQ) nil)
      ((CONDITION-TYPEP condition-instance 'system:abort)
       (THROW tag nil))
      ((OR (SEND condition-instance :dangerous-condition-p)
           (SEND condition-instance :debugging-condition-p))
       nil)
      ;;; change here by JPR.  I have no idea why sometimes we need a catch-all
      ;;; here.
      (yw:*just-warn-for-errors*
       (catch-all (format *query-io* "~A" (SEND condition-instance :report-string))))
      ((catch-all (tv::mouse-confirm (SEND condition-instance :report-string)
                          "Click mouse here to debug, move mouse outside to ignore"))
       nil)
      (t (THROW tag nil)))))

ucl:
(defmacro ucl:my-ignore-errors-query-loop (&body body)
  "Execute the body as if it were surrounded by do forever.  If an error occurs within
the body, the user is queried whether or not to go into the error handler.  If the user
declines to go into the error handler, or the user aborts from the error handler,
control is passed to the loop."
  (let ((tag (gensym)))
      `(flet ((.body. () ,@body))
             (if (not yw:*use-ucl-error-catching-stuff-p*)
		 (loop do (.body.))
		 (loop do
		       (catch ',tag
			 (condition-bind
			   ((global:error 'ucl:my-general-error-handler ',tag))
			   (values (.body.) ()))))))))


ucl:
(defmacro ucl:my-ignore-errors-query (&body body)
  "If an error occurs within the body, the user is queried whether or not to go
into the error handler. "
  (let ((tag (gensym)))
      `(flet ((.body. () ,@body))
             (if (not yw:*use-ucl-error-catching-stuff-p*)
		 (progn (.body.))
		 (catch ',tag
		   (condition-bind
		     ((global:error 'ucl:my-general-error-handler ',tag))
		     (values (.body.) ())))))))


(defsubst yw:dbg (&optional (value :not-supplied))
  (with-standard-io-environment
    (if (equal value :not-supplied)
	(cleh:break)
	(let ((*debug-value* value))
	     (declare (special *debug-value*))
	     (cleh:break)
	     *debug-value*
	)
    )
  )
)

(if (= 6 (sys:get-system-version))
    (progn ;(deff yw:dbg #'cleh:break)
	   (setf (get 'yw:dbg 'compiler:style-checker)
		 (get 'cleh:break 'compiler:style-checker)
	   )
    )
    nil
)

;-------------------------------------------------------------------------------

(defmacro with-all-mailstream-locks (&body body)
  "Executes body having grabbed the lock for every mailstream."
 `(with-all-mailstream-locks-1 *all-open-imap-streams* #'(lambda () ,@body))
)

(defmacro With-Daemons-Reset-And-Arrested
	  ((&optional (delay-before-imperative
			*default-delay-before-imperative-reset-of-daemons*
		       )
	   )
	   &body body
	  )
"Executes Body with the daemon processes arrested.  It resets the deamons too."
  `(unwind-protect
       (progn (reset-daemons :Reset -3 ,delay-before-imperative)
	      (clear-all-mailstream-locks)
	      ,@body
       )
     (unarrest-daemons :Reset -3)
   )
)

(defmacro defunwind-trace (fspec)
"Traces a function specified by fspec so that a trace message is generated
on function exit, even if we throw out.
"
  (let ((name (sys:unencapsulate-function-spec fspec 'trace)))
       (let ((sym (make-symbol
		   (if (symbolp name) (symbol-name name) (prin1-to-string name))
		  )
	     )
	    )
	   `(defadvise ,fspec (:unwind-trace) ()
	      (let ((,sym (if (boundp ',sym) (+ 1 ,sym) 1)))
		   (declare (special ,sym))
		   (let-if (not (member ',fspec (trace)))
			   ((sys:trace-level (+ 1 sys:trace-level)))
		     (unwind-protect
			 :Do-It
		       (let ((sys:values nil)
			     (sys:arglist nil)
			    )
			    (declare (special sys:values sys:arglist))
			    (sys:trace-print
			      ,sym 'sys:exit-unwind ',fspec nil nil nil
			    )
		       )
		     )
		   )
	      )
	    )
      )
  )
)


;-------------------------------------------------------------------------------


(defmacro Maybe-With-Metering
	  ((predicate file without-interrupts-p &rest report-keys) &body body)
"Executes body maybe withg metering switched on.  Predicate is a predicate
to determine whether to switch on metering.  File is the output file for
the metering report.  When without-interrupts-p is true then the metering
runs without interrupts.  Report-keys are keyword args to pass to
sys:submeter-report.
"
  `(if ,predicate
       (multiple-value-prog1
	 (unwind-protect
	     (progn (sys:submeter-initialize :Items (list sys:current-process))
		    (sys:submeter-enable)
		    (if ,without-interrupts-p
			(without-interrupts (progn ,@body))
			(progn ,@body)
		    )
	     )
	   (sys:submeter-disable)
	 )
	 (with-open-file (*standard-output* ,file :Direction :Output)
	   (sys:submeter-report ,@report-keys)
	 )
       )
       (progn ,@body)
   )
)


(defmacro defrh-watch (fspec)
"Whatches the rubout handler behaviour in the function fspec."
 `(defadvise ,fspec (:rhb-watch) ()
    (tv:Watch-Rh ',fspec)
    (unwind-protect :Do-It (tv:Watch-Rh ',fspec t) (sleep 0.5))
  )
)

(defmacro Do-Messages
	  ((cache-entry-name mailstream messages-form cache-name) &body body)
"Executes Body in an environment for which Cache-Entry-Name is bound to each
message cache entry in the messages denoted by Message-form.  The returned value
of the expressions in Body is set into the cache slot named by cache-name.
"
 `(let ((.mailstream. ,mailstream))
       (let ((.array. (getstreamprop .MailStream. :MessageArray)))
	    (declare (unspecial .array.))
	    (loop for .number. in (list-if-not ,messages-form) do
		  (locally (declare (unspecial .array. .number.))
			   (let ((,cache-entry-name
				  (map-elt .array. .number. .mailstream.)
				 )
				)
				(declare (unspecial ,cache-entry-name))
				(let ((.value. ,@body))
				     (declare (unspecial .value.))
				     (setf (,cache-name ,cache-entry-name)
					   .value.
				     )
				)
			   )
		  )
	    )
       )
  )
)

;-------------------------------------------------------------------------------

;;; Macros used in the imap parser for speed purposes.

(defmacro ensure-line-read-in (&optional (force-p nil))
"Makes sure thatb a line has been read in."
  (declare (optimize (speed 3) (safety 0)))
 `(if (or ,force-p (not current-line))
      (progn (setq current-line (send *stream* :Line-In))
	     (setq line-index 0)
      )
      nil
  )
)

(defmacro skip-imap-whitespace (&optional (line 'current-line))
"Skips whitespace.  If current-line is supplied then whitespace is skipped
in this line.
"
 `(loop while (char= (aref ,line line-index) #\space)
	do (setq line-index (+ 1 line-index))
  )
)

(defmacro Maybe-Discard-Line
    (&optional (force-p nil) (length-of-current-line '(length current-line)))
"Checks to see whether the line index has exceeded the length of the current
line.  If it has then we mark things so that another line will be read in later.
"
 `(if (or ,force-p (>= line-index ,length-of-current-line))
      (progn (setq current-line nil)
	     (setq line-index 0)
	     t
      )
      nil
  )
)

(defmacro current-char (&optional (line-known-to-be-read-in-p nil))
"The char at the current input point (like peek).  If we already know that
a line has been read in then we can simply peek into the current line,
otherwise we must check for the line line.
"
  `(progn ,(if line-known-to-be-read-in-p nil '(ensure-line-read-in))
	  (aref current-line line-index)
   )
)

(defmacro inc-char (&optional (length-of-current-line '(length current-line)))
"Increments the char we are looking at.  If the length of the current line
 is supplied then we use this to save having to look it up again.
"
 `(progn (setq line-index (+ 1 line-index))
	 (Maybe-Discard-Line nil ,length-of-current-line)
  )
)