;;; KLUDGE: we PROCLAIM these special here so that we can use restart
;;; macros in the compiler before the DEFVARs are compiled.
-(sb!xc:proclaim
- '(special *handler-clusters* *restart-clusters* *condition-restarts*))
+;;;
+;;; For an explanation of these data structures, see DEFVARs in
+;;; target-error.lisp.
+(sb!xc:proclaim '(special *handler-clusters* *restart-clusters*))
(defmacro-mundanely with-condition-restarts
(condition-form restarts-form &body body)
RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.
This allows FIND-RESTART, etc., to recognize restarts that are not related
to the error currently being debugged. See also RESTART-CASE."
- (let ((n-cond (gensym)))
- `(let ((*condition-restarts*
- (cons (let ((,n-cond ,condition-form))
- (cons ,n-cond
- (append ,restarts-form
- (cdr (assoc ,n-cond *condition-restarts*)))))
- *condition-restarts*)))
- ,@body)))
+ (once-only ((restarts restarts-form))
+ (with-unique-names (restart)
+ ;; FIXME: check the need for interrupt-safety.
+ `(unwind-protect
+ (progn
+ (dolist (,restart ,restarts)
+ (push ,condition-form
+ (restart-associated-conditions ,restart)))
+ ,@body)
+ (dolist (,restart ,restarts)
+ (pop (restart-associated-conditions ,restart)))))))
(defmacro-mundanely restart-bind (bindings &body forms)
#!+sb-doc
- "Executes forms in a dynamic context where the given restart bindings are
- in effect. Users probably want to use RESTART-CASE. When clauses contain
- the same restart name, FIND-RESTART will find the first such clause."
- `(let ((*restart-clusters*
- (cons (list
- ,@(mapcar (lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
- report function: ~S"
- binding))
- `(make-restart :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
- *restart-clusters*)))
- ,@forms))
+ "(RESTART-BIND ({(case-name function {keyword value}*)}*) forms)
+ Executes forms in a dynamic context where the given bindings are in
+ effect. Users probably want to use RESTART-CASE. A case-name of NIL
+ indicates an anonymous restart. When bindings contain the same
+ restart name, FIND-RESTART will find the first such binding."
+ (flet ((parse-binding (binding)
+ (unless (>= (length binding) 2)
+ (error "ill-formed restart binding: ~S" binding))
+ (destructuring-bind (name function
+ &key interactive-function
+ test-function
+ report-function)
+ binding
+ (unless (or name report-function)
+ (warn "Unnamed restart does not have a report function: ~
+ ~S" binding))
+ `(make-restart ',name ,function
+ ,report-function
+ ,interactive-function
+ ,@(and test-function
+ `(,test-function))))))
+ `(let ((*restart-clusters*
+ (cons (list ,@(mapcar #'parse-binding bindings))
+ *restart-clusters*)))
+ ,@forms)))
;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
;;; appropriate. Gross, but it's what the book seems to say...
(return (values result form))))
result)))))
(parse-clause (clause)
- (unless (and (listp clause ) (>= (length clause) 2)
+ (unless (and (listp clause) (>= (length clause) 2)
(listp (second clause)))
(error "ill-formed ~S clause, no lambda-list:~% ~S"
'restart-case clause))
(parse-keywords-and-body body)
(list name (sb!xc:gensym "TAG") keywords lambda-list body))))
(make-binding (clause-data)
- (destructuring-bind (name tag keywords &rest rest) clause-data
- (declare (ignore rest))
- `(,name #'(lambda (&rest temp)
- (setq ,temp-var temp)
- (go ,tag))
- ,@keywords)))
+ (destructuring-bind (name tag keywords lambda-list body) clause-data
+ (declare (ignore body))
+ `(,name
+ (lambda ,(cond ((null lambda-list)
+ ())
+ ((and (null (cdr lambda-list))
+ (not (member (car lambda-list)
+ '(&optional &key &aux))))
+ '(temp))
+ (t
+ '(&rest temp)))
+ ,@(when lambda-list `((setq ,temp-var temp)))
+ (locally (declare (optimize (safety 0)))
+ (go ,tag)))
+ ,@keywords)))
(make-apply-and-return (clause-data)
(destructuring-bind (name tag keywords lambda-list body) clause-data
(declare (ignore name keywords))
`(,tag (return-from ,block-tag
- (apply (lambda ,lambda-list ,@body) ,temp-var))))))
+ ,(cond ((null lambda-list)
+ `(progn ,@body))
+ ((and (null (cdr lambda-list))
+ (not (member (car lambda-list)
+ '(&optional &key &aux))))
+ `(funcall (lambda ,lambda-list ,@body) ,temp-var))
+ (t
+ `(apply (lambda ,lambda-list ,@body) ,temp-var))))))))
(let ((clauses-data (mapcar #'parse-clause clauses)))
`(block ,block-tag
(let ((,temp-var nil))