[PATCH] Improved error detection and reporting in RESTART-BIND

[Spiros Bousbouras]

If you do

(restart-bind ((locutus (function cdr) :report-function "23"))
    (error "This is an error"))

you get

    Excessive debugger depth! Probable infinite recursion!
    Quitting process: #<process TOP-LEVEL>.

and ECL exits. This isn't very useful. One can find various similar examples.
After the patch one would get

{
Condition of type: SIMPLE-ERROR
Macro RESTART-BIND :  "23" is not a function object

Available restarts:

1. (RESTART-TOPLEVEL) Go back to Top-Level REPL.

Broken at SI:BYTECODES. [Evaluation of: (RESTART-BIND ((LOCUTUS #'CDR :REPORT-FUNCTION "23")) (ERROR "This is an error"))] In: #<process TOP-LEVEL>.
}

which is better. The new RESTART-BIND does improved error detection and
reporting in other situations too.

The patch follows below. You go to directory
ecl-16.1.3/src/clos/  and , assuming you have saved the patch with the filename
patch , you do
    patch -F 0 --verbose --posix conditions.lsp patch

.This assumes GNU patch , otherwise skip the   --verbose --posix    part.

I didn't make an entry in  ecl-16.1.3/CHANGELOG  because I'm not sure what the
required format is. The file indicates near the top that it is for version
16.1.3 .So where should one mention changes which might appear in a newer
version ?

@=====================================================================================

*** conditions.lsp	Fri Jul 19 19:37:53 2019
--- conditions.lsp.new	Fri Jul 19 19:39:05 2019
***************
*** 99,118 ****
               for n in (if (atom names) (list names) names)
               for f = (simple-handler-function tag i)
               collect (cons n f))
            *handler-clusters*)))
  
! (defmacro restart-bind (bindings &body forms)
!   `(let ((*restart-clusters*
!           (cons (list ,@(mapcar #'(lambda (binding)
!                                     `(make-restart
!                                       :NAME     ',(car binding)
!                                       :FUNCTION ,(cadr binding)
!                                       ,@(cddr binding)))
!                                 bindings))
!                 *restart-clusters*)))
!      , at forms))
  
  (defun find-restart (name &optional condition)
    (dolist (restart (compute-restarts condition))
      (when (or (eq restart name) (eq (restart-name restart) name))
        (return-from find-restart restart))))
--- 99,159 ----
               for n in (if (atom names) (list names) names)
               for f = (simple-handler-function tag i)
               collect (cons n f))
            *handler-clusters*)))
  
! (defun restart-bind-check-binding
!         (name foo &rest rest
!          &aux int-foo rep-foo test-foo
!               (err-mes (format nil "Macro ~S :" 'restart-bind)))
!     (unless (symbolp name) (error "~a ~s is not a symbol" err-mes name))
!     (unless (functionp foo) (error "~a ~s is not a function object" err-mes foo))
!     (do     ((br rest (cddr br)))
!             ((eq br nil) (make-restart :name name :function foo
!                                        :report-function rep-foo
!                                        :interactive-function int-foo
!                                        :test-function (if test-foo test-foo
!                                                                    (constantly t))))
!          (let    ((key (first br)) (obj (second br)))
!              (unless (functionp obj)
!                  (error "~a  ~s is not a function object" err-mes obj))
!              (cond ((eq key :interactive-function)
!                         (when int-foo
!                             (error "~a ~s given more than once"
!                                    err-mes :interactive-function))
!                         (setq int-foo obj))
!                    ((eq key :report-function)
!                        (when rep-foo
!                            (error "~a ~s given more than once"
!                                   err-mes :report-function))
!                        (setq rep-foo obj))
!                    ((eq key :test-function)
!                        (when test-foo
!                            (error "~a ~s given more than once"
!                                   err-mes :test-function))
!                        (setq test-foo obj))
!                    (t (error "~a Inappropriate keyword ~s" err-mes key))))))
! 
! (defmacro restart-bind (bindings &body forms
!                            &aux (new (list 'list)) (tail new) fb eta
!                                 (err-mes (format nil "Macro ~S :" 'restart-bind)))
!     (dolist (b bindings)
!         (unless (listp b) (error "~a ~s is not a list" err-mes b))
!         (setq fb (first b))
!         (unless (symbolp fb) (error "~a ~s is not a symbol" err-mes fb))
!         (unless (second b) (error "~a ~s does not have a function argument"
!                                   err-mes b))
!         (setq eta (list 'restart-bind-check-binding `(quote ,fb) (second b)))
!         (do    ((l (cddr b) (cdr l))
!                 (t2 (cddr eta) (cdr t2)))
!                ((eql nil l))
!             (rplacd t2 (list (first l))))
!         (rplacd tail (list eta))
!         (setq tail (cdr tail)))
!     `(let   ((*restart-clusters* (cons ,new *restart-clusters*)))
!          , at forms))
! 
  
  (defun find-restart (name &optional condition)
    (dolist (restart (compute-restarts condition))
      (when (or (eq restart name) (eq (restart-name restart) name))
        (return-from find-restart restart))))