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*))) ! ,@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*))) ! ,@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))))