;;; -*- Mode: Common-Lisp; Package: EH; Base: 10.; Patch-File: T -*-
;;; Patch file for EH version 6.2
;;; Reason: Fixed INVOKE-HANDLERS so that if a Common Lisp condition handler
;;; returns, then any values it returns are ignored and another handler 
;;; is sought [spr 10024].
;;; Written 06/13/89 13:24:57 by MCCREARY,
;;; while running on Jules-Verne from band LOD9
;;; With SYSTEM 6.5, VIRTUAL-MEMORY 6.1, EH 6.1, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.2, TV 6.6, DATALINK 6.0, CHAOSNET 6.0, GC 6.2, MEMORY-AUX 6.0, NVRAM 6.0,
;;;  SYSLOG 6.0, STREAMER-TAPE 6.2, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.1,
;;;  DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.1, TI-CLOS 6.5, CLEH 6.3, IP 3.46,
;;;  Experimental BUG 11.7, Experimental CLX 6.1, CLUE 6.5, X11M 6.1,  microcode 429,
;;;  Band Name: Release 6.0 + SLE 6/5

#!C
; From file CONDITION-SIGNALLING.LISP#> EH; MR-X:
#10R EH#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "EH"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: EH; CONDITION-SIGNALLING.#"


(defun invoke-handlers (condition &optional condition-names)
  "Invoke handler, if one exists for condition or one of its condition names"

  ;; A handler should be invoked, if either the condition name for the handler is nil, or
  ;; the one of the condition-names of condition is the same as one of the
  ;; condition names for the handler;
  ;; Once a handler is invoked it may or may not return.
  ;; If it returns Non-nil (the proceed type), return this value.
  ;; If it returns nil, continue searching for a handler
  ;;
  ;; 06/13/89 clm  If a Common Lisp condition handler returns, then any values
  ;;                 it returns are ignored and another handler is sought [spr 10024].
  (declare (special *condition-handlers* *condition-default-handlers*)
	   (list condition-names))
    (unless condition-names
      (setq condition-names (send condition :condition-names)))
    (or
      ;; First search for a handler in *condition-handlers*
      (do ((handler-list *condition-handlers* (cdr handler-list))
	   (h))
	  ((null handler-list) nil)
	(let (cleh-handler)      ; clm 06/13/89 - new, used to flag a cleh handler 
	  (setq h (car handler-list))
	  (cond ((cond ((null (car h)) t)
		       ((atom (car h)) 
			(member (car h) condition-names :test #'eq))
		       ;; Common LISP condition handlers use typespecs
		       ;; instead of just a list of condition names
		       ;; -- mjf/clm 7/20/88
		       ((and (find-package 'cleh)
			     (eq (caar h) 'cleh:typespec))
			(let ((*condition-handlers* (cdr handler-list)))
			  (and (typep condition (cadar h))
			       (setq cleh-handler t))))	   ; clm 06/13/89 - so I don't have to make
				                           ; the same checks later.
		       (t
			(dolist (c (car h))
			  (if (member c condition-names :test #'eq) (return t)))))
		 (let ((values
			 ;; Before invoking this handler, set current *condition-handlers*
			 ;; to include only the innermost handlers defined before this one.
			 (multiple-value-list
			   (let ((*condition-handlers* (cdr handler-list)))
			     (declare (special *condition-handlers*))
			     (apply (cadr h) condition (cddr h))))))
		   (when (and (car values)
			      (not cleh-handler))  ; clm 06/13/89 - previously did
					           ; (if (car values) (return values)), which 
					           ; wasn't correct for cleh
		     (return values)))))) )
      ;; Then search for a handler in *condition-default-handlers*
      (do ((handler-list *condition-default-handlers* (cdr handler-list))
	   (h))
	  ((null handler-list) nil)
	(setq h (car handler-list))
	(cond ((cond ((null (car h)) t)
		     ((atom (car h)) 
		      (member (car h) condition-names :test #'eq))
		     (t
		      (dolist (c (car h))
			(if (member c condition-names :test #'eq)  (return t)))))
	       (let ((values
		       ;; Before invoking this handler, set current *condition-default-handlers*
		       ;; to include only the innermost handlers defined before this one.
		       (multiple-value-list
			 (let ((*condition-default-handlers* (cdr handler-list)))
			   (declare (special *condition-default-handlers*))
			   (apply (cadr h) condition (cddr h))))))
		 (if (car values) (return values))))))))
))