mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-13 08:20:31 -07:00
Code Issues Projects Releases Packages Wiki Activity

signals: handler-bind handles only objects of type CONDITION

Browse source
This commit is contained in:
Daniel Kochmański 2026-03-06 19:17:11 +01:00
parent a87e48e88a
commit 7f43fd550e
1 changed files with 14 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

23
src/clos/conditions.lsp
View file

@ -378,21 +378,26 @@
(defmacro handler-bind (bindings &body body)
(with-gensyms (handler condition)
`(flet ((,handler (,condition)
,@(loop for (type func . rest) in bindings
when rest do
(error "Ill-formed handler bindings.")
collect `(when (typep ,condition ',type)
(funcall ,func ,condition)))))
;; We don't want to handle exceptions here, if it is expanded from
;; HANDLER-CASE and the type qualifier is T, then we end up with
;; invalid pointer, because the stack is unwound. -- jd 2026-03-04
(when (typep ,condition 'condition)
,@(loop for (type func . rest) in bindings
when rest do
(error "Ill-formed handler bindings.")
collect `(when (typep ,condition ',type)
(funcall ,func ,condition))))))
(declare (dynamic-extent (function ,handler)))
(let ((*handler-clusters* (cons (function ,handler) *handler-clusters*)))
,@body))))
(defun bind-simple-handlers (tag names)
(flet ((simple-handler (condition)
(loop for code from 1
for type in (if (atom names) (list names) names)
when (typep condition type) do
(throw tag (values code condition)))))
(when (typep condition 'condition)
(loop for code from 1
for type in (if (atom names) (list names) names)
when (typep condition type) do
(throw tag (values code condition))))))
(cons #'simple-handler *handler-clusters*)))
(defun signal (datum &rest arguments)