bug in condition-system implementation

[Richard Mlynarik <MLY@AI.AI.MIT.EDU>]

Sigh.  The handlers in CONDITION-BIND were being evaluated in the wrong dynamic
context (they should be evaluated when the condition-bind form is `entered',
not when the handler is invoked.)

The issue came of when handlers should be evaluated up on this list some time
last year, as I recall.

CONDITION-BIND and SIGNAL should read:

(defmacro condition-bind ((&rest condition-handler-bindings) &body body)
  "Execute BODY with the specified condition handlers in effect.
Each element of CONDITION-HANDLER-BINDINGS is a list of two elements:
   (<conditions> <handler-function>).
 <conditions> is not evaluated, and should be either a condition name
  or a list of condition names.
 <handler-function> is evaluated before BODY is entered to get a function
  to call to handle the condition(s)
 When a one of the specified conditions is signalled, <handler-function>
  is called with the signalled condition as its argument (after any
  dynamically more-recent CONDITION-BIND handlers have been called and
  \"declined\" the condition.)
 <handler-function> may either \"handle\" the condition, by doing some non-local
  transfer of control (such as RETURN or THROW) or it may \"decline\" to handle
  the condition by simply returning, in which case any previously-established
  handlers are successively called. (See SIGNAL)
The first CONDITION-HANDLER-BINDING, somewhat perversely, is established last,
 the second penultimately, and so forth, so that textually earlier bindings in
 CONDITION-HANDLER-BINDINGS are called on a matching condition before
 following handlers are offered it.  (The order in which the handlers in
 CONDITION-HANDLER-BINDINGS are evaluated is unspecified: not that you should
 depend on things like that in any case!)
The values of BODY are returned."
  (check-type condition-handler-bindings list)
  (flet ((lose (&rest format)
	   #+lmi (declare (dbg:error-reporter))
           (apply #'lisp:error
		  "Error macro-expanding ~S: ~@?" 'condition-bind format)))
    (let ((handlers ()))
      (dolist (clause condition-handler-bindings)
	(unless (and (consp clause)
		     (consp (cdr clause))
		     ;; could warn about condition-names which aren't known
		     ;;  about at compile time
		     (or ;; Should the empty list of conditions be legal?
		         ;;  Warned about?
			 (null (car clause))
			 (symbolp (car clause))
			 (and (listp (car clause))
			      (every #'symbolp (car clause))))
		     (null (cddr clause)))
	  (lose "~%The form \"~S\" does not appear to be a \"binding\"~%  ~
	-- ie a list of (<condition-names-to-handle> <handler-function>)."
		clause))
	;; Be careful to evaluate the handler at the right time!
	;;  [(condition-bind ((error *error-handler*))
	;;     (let ((*error-handler* #)) ...))
	;;   must handle errors using the outer binding of *error-handler*]
   	(push (list ;; test-function
		    `#'(lambda (.condition.)
			 (declare (type condition .condition.))
			 ;; an implementation could use a more efficient form of
			 ;;  typep here, since we guarantee that .condition.
			 ;;  is always a condition
			 ;;>> Why not have the user supply a type-specifier
			 ;;>>  rather than condition/list-of-conditions?
			 ;;>> This would be more consistent with the rest of
			 ;;>>  the language (though might make such typep
			 ;;>>  optimizations less feasible.
			 (typep .condition. ,(if (listp (car clause))
						 `'(or . ,(car clause))
						 `',(car clause))))
		    ;; separate (sigh) handler-function
		    (cadr clause)
		    ;,@(cddr clause)
		    )
	      handlers))
      `(stack-consing-frobs t (*established-condition-handlers*
				,@(nreverse handlers))
	 . ,body))))

(defun signal (datum &rest args)
  "\"Signals\" a condition.
The condition which is signalled is specified by DATUM and ARGS (see below.)
\"Signalling\" involves the following steps:
 Firstly, all active condition-handlers (established by dynamically active
  CONDITION-BINDs and CONDITION-CASEs) are called in most-recently-established-
  first order.  If any of these handle the condition (by doing transferring
  control non-locally) the signalling process is terminated by that control
  transfer.
  Next, the default-handler for the condition is called, which may likewise
  decide to handle the condition and thus terminate the signalling.
  If the default handler for CONDITION declines, then the default-handlers
  for each of the parent-types of CONDITION are called in order.
  (Note that certain types of conditions, such as those based on ERROR,
  cause the debugger to be entered as their default-handler.)
 If the condition is neither handled by some dynamic handler, nor by its
  default-handlers, then SIGNAL just returns the condition signalled.

The condition to be signalled is determined as follows:
 If DATUM is a condition object, then that condition itself is used.
  In this case, it is an error for ARGS to be non-NIL.
 If DATUM is a condition-type name (defined by DEFINE-CONDITION),
  then the condition used is the result of doing
  (APPLY #'MAKE-CONDITION DATUM ARGS)
 Any other type of DATUM is an error."
  #+lmi (declare (dbg:error-reporter))
  (let ((condition
	  (etypecase datum
	    (condition datum)
;; this is useless
;	    (string (make-condition 'simple-condition
;				    :format-string datum
;				    :format-arguments args))
	    (condition-name (apply #'make-condition datum 
				   ; god damned fucking unrequested stack consing
				   #+lispm (copy-list args)
				   #-lispm args)))))
    ;; search handlers
    #-nil
    (do ((handlers *established-condition-handlers* (cdr handlers)))
	((null handlers))
      (let ((*established-condition-handlers* (cdr handlers)))
	(when (funcall (caar handlers) condition)
	  (apply (cadar handlers) condition #|(cddar handlers)|#))))
    #+nil
    (do ((handlers *established-condition-handlers* (svref handlers 2)))
	((null handlers))
      (let ((*established-condition-handlers* (svref handlers 2)))
	(when (funcall (svref handlers 0) condition)
	  (funcall (svref handlers 1) condition))))
    ;; default handler
    ;;  this is different from what KMP specified in eprop5
    (let ((*established-condition-handlers* ())) ;;>> I don't know if this is right
      #-lmnil
      (let ((descriptor (%get-condition-descriptor condition)))
	(dolist (d (condition-descriptor-descriptors descriptor))
	  (let ((h (condition-descriptor-default-handler d)))
	    (when h (funcall h condition)))))
      #+lmnil
      (si:send condition 'handle-condition-default)	;isn't method-combination wonderful?
      )
    ;; no handlers.
    condition))