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@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 ,@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*))) - ,@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 () ,@body))) - `(,go-tag (return-from ,block-name - (let ((,var ,var-name)) - ,@body)))))) - specs)))))) - (t (error "Too many no-error clauses."))))) - -(defmacro ignore-errors (&body body) - `(handler-case (progn ,@body) - (error (c) (values nil c))))
(defun warn (datum &rest arguments) (declare (dynamic-extent arguments))