;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 121.7 ;;; Reason: ;;; Make SIGNAL-PROCEED-CASE work with proceed types (the keys ;;; of the clauses) that are not symbols, numbers, or characters. ;;; Make ASSERT work with PLACE expressions that not just variables. ;;; For both macros, the buggy cases already worked in the evaluator, ;;; but not in compiled code, where EQness is not always preserved. ;;; (RpK) ;;; Written 15-Jan-87 18:16:00 by PHILIPP at site LMI Cambridge ;;; while running on Curley from band 2 ;;; with Experimental System 121.6, Experimental Lambda-Diag 15.0, Experimental ZMail 70.1, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental TCP-Kernel 41.0, Experimental TCP-User 64.0, Experimental TCP-Server 47.0, Experimental DOE-Macsyma 22.0, microcode 1730, SDU Boot Tape 3.14, SDU ROM 103. ; From modified file DJ: L.DEBUGGER; EHF.LISP#290 at 15-Jan-87 18:16:02 #8R EH#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "EH"))) (COMPILER::PATCH-SOURCE-FILE "SYS: DEBUGGER; EHF  " (defflavor failed-assertion (places proceed-type-place-alist) (error) :inittable-instance-variables :gettable-instance-variables) ;;; >>> Needed for system versions up to and including 121 (defmethod (failed-assertion :after :init) (plist) (declare (ignore plist)) (unless (variable-boundp proceed-type-place-alist) (setq proceed-type-place-alist (pairlis places places)))) (defmethod (failed-assertion :or :document-proceed-type) (proceed-type stream ignore) (let ((entry (assq proceed-type proceed-type-place-alist))) (when entry (format stream "Try again, setting ~S. You type an expression for it." (cdr entry)) t))) (defmethod (failed-assertion :or :proceed-asking-user) (proceed-type continuation read-object-function) (let ((entry (assq proceed-type proceed-type-place-alist))) (when entry (funcall continuation proceed-type (funcall read-object-function :eval-read "Form to be evaluated and used as replacement value for ~S:~%" (cdr entry))) t))) )) ; From modified file DJ: L.DEBUGGER; ERRMAC.LISP#24 at 15-Jan-87 18:16:30 #10R EH#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "EH"))) (COMPILER::PATCH-SOURCE-FILE "SYS: DEBUGGER; ERRMAC  " (defun compilation-eq-safe-p (thing) "Returns T of THING, appearing in two different places in code, will be EQ among all those places after the code is compiled." (typep thing '(or number symbol null character))) (defun make-proceed-clauses (clauses) "Make clauses that will match with proceed types which can be non-atoms. This should be used for macros which allow non-atomic proceed-types, and use a CASE statement for handling the proceed types with the clauses. The proceed types are returned in order of their appearance in CLAUSES." (declare (values new-clauses proceed-types)) (let ((new-clauses '()) (proceed-types '())) (flet ((new-case (case) (if (compilation-eq-safe-p case) case (gensym)))) (dolist (clause clauses) (let ((cases (car clause))) (typecase cases (cons (let ((new-cases (mapcar #'new-case cases))) (setq proceed-types (append proceed-types new-cases)) (push (cons new-cases (cdr clause)) new-clauses))) (t (let ((new-case (new-case cases))) (setq proceed-types (nconc proceed-types (ncons new-case))) (push (cons new-case (cdr clause)) new-clauses))))))) (values (nreverse new-clauses) proceed-types))) ;;>> If you don't know what this macro does, if you can't read the documentation, ;;>> if you don't have any idea of what the error system is how it works, don't go ;;>> changing this macro. (defmacro signal-proceed-case ((variables . signal-args) &body clauses) "Signal a condition and provide a CASE for proceed-types in case it is handled. The SIGNAL-ARGS are evaluated and passed to SIGNAL. That is how the condition is signaled. The VARIABLES are bound to all but the first of the values returned by SIGNAL. The first value is used to select one of the CLAUSES with a CASE. The selected clause is executed and its values are returned. SIGNAL is called with a :PROCEED-TYPES argument constructed by examining the cars of the CLAUSES. If the condition is not handled, SIGNAL returns NIL. If there is a clause for NIL, it is run. Otherwise, SIGNAL-PROCEED-CASE returns NIL." (let ((proceed-type-variable (gensym)) (proceed-types-in-signal-args)) (multiple-value-bind (new-clauses proceed-types) (make-proceed-clauses clauses) (do ((sa (cdr signal-args) (cddr sa))) ((null sa)) (if (si:member-equal (car sa) '(':proceed-types :proceed-types)) (setq proceed-types-in-signal-args (cdr sa)))) `(multiple-value-bind (,proceed-type-variable . ,variables) (signal (make-condition ,@signal-args) :proceed-types ,(if proceed-types-in-signal-args (car proceed-types-in-signal-args) `',(delq nil proceed-types))) ,proceed-type-variable ,@(if (null new-clauses) variables) (case ,proceed-type-variable . ,new-clauses))))) ;;;; ASSERT, CHECK-TYPE, CHECK-ARG ;;>> This one could deal with some improvement. ;;>> (more particularly, the failed-assertion condition needs a :retry proceed type) (defmacro assert (test-form &optional places (format-string "Assertion failed.") &rest args) "Signals an error if TEST-FORM evals to NIL. PLACES are SETF'able things that the user should be able to change when proceeding. Typically they are things used in TEST-FORM. Each one becomes a proceed-type which means to set that place. FORMAT-STRING and ARGS are passed to FORMAT to make the error message." (declare (arglist test-form &optional places format-string &rest args)) (if (null places) `(or ,test-form (error 'eh::failed-assertion :places () :format-string ,format-string :format-args (list . ,args))) ;; Need this to deal with non-variable place forms (the most useful kind...) (multiple-value-bind (new-clauses proceed-types) (make-proceed-clauses (mapcar (lambda (place) `((,place) (setf ,place .value.))) places)) `(do () (,test-form) (signal-proceed-case ((.value.) 'eh::failed-assertion :places ',places :proceed-types ',proceed-types :proceed-type-place-alist ',(pairlis proceed-types places) :format-string ,format-string :format-args (list . ,args)) ,@new-clauses))))) ))