[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue Apr 6 14:05:23 UTC 2004
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv20256
Modified Files:
more-macros.lisp
Log Message:
Moved condition-related macros from conditions.lisp to more-macros.lisp.
Date: Tue Apr 6 10:05:23 2004
Author: ffjeld
Index: movitz/losp/muerte/more-macros.lisp
diff -u movitz/losp/muerte/more-macros.lisp:1.4 movitz/losp/muerte/more-macros.lisp:1.5
--- movitz/losp/muerte/more-macros.lisp:1.4 Thu Mar 25 20:50:32 2004
+++ movitz/losp/muerte/more-macros.lisp Tue Apr 6 10:05:23 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Fri Jun 7 15:05:57 2002
;;;;
-;;;; $Id: more-macros.lisp,v 1.4 2004/03/26 01:50:32 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.5 2004/04/06 14:05:23 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -216,3 +216,79 @@
+
+(defmacro handler-bind (bindings &body forms)
+ (if (null bindings)
+ `(progn , at forms)
+ (labels ((make-handler (binding)
+ (destructuring-bind (type handler)
+ binding
+ (cond
+ #+ignore
+ ((and (listp handler)
+ (eq 'lambda (first handler))
+ (= 1 (length (second handler))))
+ `(cons t (lambda (x)
+ (when (typep x ',type)
+ (let ((,(first (second handler)) x))
+ ,@(cddr handler)))
+ nil)))
+ #+ignore
+ ((and (listp handler)
+ (eq 'function (first handler))
+ (listp (second handler))
+ (eq 'lambda (first (second handler)))
+ (= 1 (length (second (second handler)))))
+ (make-handler (list type (second handler))))
+ (t `(cons ',type ,handler))))))
+ `(let ((*active-condition-handlers*
+ (cons (list ,@(mapcar #'make-handler #+ignore (lambda (binding)
+ `(cons ',(first binding)
+ ,(second binding)))
+ bindings))
+ *active-condition-handlers*)))
+ , at forms))))
+
+(defmacro handler-case (expression &rest clauses)
+ (multiple-value-bind (normal-clauses no-error-clauses)
+ (loop for clause in clauses
+ if (eq :no-error (car clause))
+ collect clause into no-error-clauses
+ else collect clause into normal-clauses
+ finally (return (values normal-clauses no-error-clauses)))
+ (case (length no-error-clauses)
+ (0 (let ((block-name (gensym "handler-case-block-"))
+ (var-name (gensym "handler-case-var-"))
+ (temp-name (gensym "handler-case-temp-var-"))
+ (specs (mapcar (lambda (clause)
+ (list clause (gensym "handler-case-clause-tag-")))
+ normal-clauses)))
+ `(block ,block-name
+ (let (,var-name)
+ (tagbody
+ (handler-bind ,(mapcar (lambda (clause-spec)
+ (let* ((clause (first clause-spec))
+ (go-tag (second clause-spec))
+ (typespec (first clause)))
+ `(,typespec (lambda (,temp-name)
+ (setq ,var-name ,temp-name)
+ (go ,go-tag)))))
+ specs)
+ (return-from ,block-name ,expression))
+ ,@(mapcan (lambda (clause-spec)
+ (let* ((clause (first clause-spec))
+ (go-tag (second clause-spec))
+ (var (first (second clause)))
+ (body (cddr clause)))
+ (if (not var)
+ `(,go-tag (return-from ,block-name
+ (let () , at body)))
+ `(,go-tag (return-from ,block-name
+ (let ((,var ,var-name))
+ , at body))))))
+ specs))))))
+ (t (error "Too many no-error clauses.")))))
+
+(defmacro ignore-errors (&body body)
+ `(handler-case (progn , at body)
+ (error (c) (values nil c))))
More information about the Movitz-cvs
mailing list