[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp

[Frode Vatvedt Fjeld]

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))))