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

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv6786

Modified Files:
	conditions.lisp 
Log Message:
Moved condition-related macros from conditions.lisp to more-macros.lisp.

Date: Tue Apr  6 10:05:18 2004
Author: ffjeld

Index: movitz/losp/muerte/conditions.lisp
diff -u movitz/losp/muerte/conditions.lisp:1.3 movitz/losp/muerte/conditions.lisp:1.4
--- movitz/losp/muerte/conditions.lisp:1.3	Fri Mar 12 06:47:41 2004
+++ movitz/losp/muerte/conditions.lisp	Tue Apr  6 10:05:18 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov 20 15:47:04 2002
 ;;;;                
-;;;; $Id: conditions.lisp,v 1.3 2004/03/12 11:47:41 ffjeld Exp $
+;;;; $Id: conditions.lisp,v 1.4 2004/04/06 14:05:18 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,7 +19,6 @@
 
 (in-package muerte)
 
-(defvar *active-condition-handlers* nil)
 (defparameter *break-on-signals* nil)
 
 (defparameter *debugger-function* nil)
@@ -134,81 +133,6 @@
   (declare (dynamic-extent slot-initializations))
   (apply 'make-instance type slot-initializations))
 
-(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))))
 
 (defun warn (datum &rest arguments)
   (declare (dynamic-extent arguments))