From 0f383318a079bd0c7bb23c909f30771b1c20b29c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 31 Jul 2008 09:33:25 +0200 Subject: Add Sacla to the repository. --- Sacla/condition.lisp | 437 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 437 insertions(+) create mode 100644 Sacla/condition.lisp (limited to 'Sacla/condition.lisp') diff --git a/Sacla/condition.lisp b/Sacla/condition.lisp new file mode 100644 index 0000000..d7ec782 --- /dev/null +++ b/Sacla/condition.lisp @@ -0,0 +1,437 @@ +;; Copyright (C) 2002-2004, Yuji Minejima +;; ALL RIGHTS RESERVED. +;; +;; $Id: condition.lisp,v 1.11 2004/08/19 06:26:06 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + + +;; 9.1.1 Condition Types +;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm +;; CONDITION is defined in clos.lisp. +(define-condition warning () ()) +(define-condition style-warning (warning) ()) +(define-condition serious-condition () ()) +(define-condition storage-condition (serious-condition) ()) +(define-condition error (serious-condition) ()) +(define-condition type-error (error) + ((datum :initarg :datum :accessor type-error-datum) + (expected-type :initarg :expected-type :accessor type-error-expected-type)) + (:report (lambda (condition stream) + (format stream "~S is not of type ~S" + (type-error-datum condition) + (type-error-expected-type condition))))) +(define-condition package-error (error) + ((package :initarg :package :accessor package-error-package))) +(define-condition control-error (error) ()) +(define-condition print-not-readable (error) + ((object :initarg :object :accessor print-not-readable-object))) +(define-condition program-error (error) ()) +(define-condition file-error (error) + ((pathname :initarg :pathname :accessor file-error-pathname))) +(define-condition stream-error (error) + ((stream :initarg :stream :accessor stream-error-stream))) +(define-condition end-of-file (stream-error) ()) +(define-condition parse-error (error) ()) +(define-condition reader-error (parse-error stream-error) ()) +(define-condition cell-error (error) + ((name :initarg :name :accessor cell-error-name))) +(define-condition unbound-variable (cell-error) ()) +(define-condition undefined-function (cell-error) ()) +(define-condition unbound-slot (cell-error) + ((instance :initarg :incetance :accessor unbound-slot-instance))) +(define-condition arithmetic-error (error) + ((operation :initarg :operation :accessor arithmetic-error-operation) + (operands :initarg :operands :accessor arithmetic-error-operands))) +(define-condition division-by-zero (arithmetic-error) ()) +(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-underflow (arithmetic-error) ()) +(define-condition simple-condition (condition) + ((format-control :initarg :format-control + :accessor simple-condition-format-control) + (format-arguments :initarg :format-arguments + :accessor simple-condition-format-arguments)) + (:report (lambda (condition stream) + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))))) +(define-condition simple-warning (simple-condition warning) ()) +(define-condition simple-error (simple-condition error) ()) +(define-condition simple-type-error (simple-condition type-error) ()) +;; non standard +(define-condition simple-program-error (simple-condition program-error) ()) + + + +;; utilities +(defun existing-condition-name-p (object) + (and (symbolp object) (subtypep object 'condition))) +(deftype condition-designator () + '(or string condition (satisfies existing-condition-name-p))) +(defun condition (datum arguments + &optional (default-simple-condition 'simple-condition)) + (typecase datum + (condition (when arguments + (error 'type-error :datum arguments :expected-type 'null)) + datum) + (string (make-condition default-simple-condition + :format-control + (concatenate 'string *message-prefix* datum) + :format-arguments arguments)) + ((satisfies existing-condition-name-p) + (apply #'make-condition datum arguments)) + (t (error 'type-error :datum datum :expected-type 'condition-designator)))) + + + +;; 9.1.4 Handling Conditions +;; http://www.lispworks.com/reference/HyperSpec/Body/09_ad.htm +(defvar *handler-clusters* '()) +(defmacro handler-bind (bindings &body forms) + ;; binding::= (type handler) + ;; type --- a type specifier. + ;; handler --- a form; evaluated to produce a handler-function. + `(let ((*handler-clusters* + (cons (list ,@(mapcar #'(lambda (binding) + (destructuring-bind (type handler) binding + `(cons ',type ,handler))) + bindings)) + *handler-clusters*))) + ,@forms)) + +(defun handler-case-bindings-and-body (block-tag condition-variable + handler-case-clauses) + (loop for clause in handler-case-clauses + for (typespec (var) . rest) = clause + for clause-tag = (gensym) + collect `(,typespec #'(lambda (temp) + ,(if var + `(setq ,condition-variable temp) + '(declare (ignore temp))) + (go ,clause-tag))) + into bindings + append `(,clause-tag (return-from ,block-tag + (let ,(when var `((,var ,condition-variable))) + ,@rest))) + into body + finally (return (values bindings body)))) + +(defmacro handler-case (form &rest clauses) + (let ((no-error-clause (assoc ':no-error clauses))) + (if no-error-clause + (let ((normal-return (gensym "NORMAL-RETURN-")) + (error-return (gensym "ERROR-RETURN-"))) + `(block ,error-return + (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause clauses))))))) + (let ((block-tag (gensym)) + (condition (gensym))) + (multiple-value-bind (bindings body) + (handler-case-bindings-and-body block-tag condition clauses) + `(block ,block-tag + (let ((,condition nil)) + (declare (ignorable ,condition)) + (tagbody + (handler-bind ,bindings + (return-from ,block-tag ,form)) + ,@body)))))))) + +(defmacro ignore-errors (&body body) + `(handler-case (progn ,@body) + (error (condition) (values nil condition)))) + + + +;; 9.1.4.2 Restarts +;; http://www.lispworks.com/reference/HyperSpec/Body/09_adb.htm +(defstruct (restart (:print-object print-restart)) + (name nil :type symbol) + (function (required-argument) :type function) + report-function + interactive-function + (test-function #'(lambda (condition) (declare (ignore condition)) t))) +(defun print-restart (restart stream) + (format stream "#<~A restart (sacla)>" (restart-name restart))) + +(defvar *restart-clusters* 'nil) +(defmacro restart-bind (restart-specs &body forms) + "Execute FORMS in a dynamic environment where specified restarts are ~ + in effect." + ;; restart-spec::= (name function {key-val-pair}*) + ;; key-val-pair::= :interactive-function interactive-function | + ;; :report-function report-function | + ;; :test-function test-function + (flet ((make-restart-form (spec) + (destructuring-bind (name function . initargs) spec + `(make-restart :name ',name :function ,function ,@initargs)))) + `(let ((*restart-clusters* (cons (list ,@(mapcar #'make-restart-form + restart-specs)) + *restart-clusters*))) + ,@forms))) + +(defvar *condition-restarts* 'nil) +(defmacro with-condition-restarts (condition-form restarts-form &body forms) + "Execute FORMS in an environment where restarts are associated with ~ + a condition." + `(let ((*condition-restarts* (acons ,condition-form ,restarts-form + *condition-restarts*))) + ,@forms)) + +(defmacro with-restarts (restarts-form form &environment env) + "Associate a condition to be signaled by FORM with restarts of RESTARTS-FORM." + (flet ((signaling-form-p (form) + (and (consp form) (member (car form) '(cerror error signal warn))))) + (let ((form (macroexpand form env))) + (if (not (signaling-form-p form)) + form + (let* ((condition (gensym)) + (signaler (car form)) + (datum (if (eq signaler 'cerror) (third form) (second form))) + (args (if (eq signaler 'cerror) (cdddr form) (cddr form))) + (default-condition (ecase signaler + ((cerror error) 'simple-error) + (warning 'simple-warning) + (signal 'simple-condition)))) + `(let ((,condition (condition ,datum ',args ',default-condition))) + (with-condition-restarts ,condition + ,restarts-form + ,(if (eq signaler 'cerror) + `(cerror ,(second form) ,condition) + `(,signaler ,condition))))))))) + +(defun restart-case-bindings-and-body (block-tag args-var restart-case-clauses) + ;; restart-case-clause::= (case-name lambda-list + ;; [[:interactive interactive-expression | :report report-expression | + ;; :test test-expression]] declaration* form*) + (loop for clause in restart-case-clauses + for (case-name lambda-list . tail) = clause + for clause-tag = (gensym) + for initargs = + (loop for plist on tail by #'cddr + for (key value) = plist + and names = '(:interactive :report :test) then (remove key names) + if (member key names) + if (eq key :interactive) + append `(:interactive-function #',value) + else if (eq key :report) + append `(:report-function + #',(if (not (stringp value)) + value + `(lambda (stream) + (write-string ,value stream)))) + else if (eq key :test) append `(:test-function #',value) + else do (loop-finish) + finally (setq tail plist)) + collect `(,case-name + #'(lambda (&rest rest) (setq ,args-var rest) (go ,clause-tag)) + ,@initargs) into bindings + append `(,clause-tag + (return-from ,block-tag + (apply #'(lambda ,lambda-list ,@tail) ,args-var))) into body + finally (return (values bindings body)))) + +(defmacro restart-case (restartable-form &body clauses) + "Eval RESTARTABLE-FORM in an environment with restarts specified by CLAUSES." + (let ((block-tag (gensym)) + (args (gensym))) + (multiple-value-bind (bindings body) + (restart-case-bindings-and-body block-tag args clauses) + `(block ,block-tag + (let ((,args nil)) + (declare (ignorable ,args)) + (tagbody + (restart-bind ,bindings + (return-from ,block-tag + (with-restarts (first *restart-clusters*) ,restartable-form))) + ,@body)))))) + +(defmacro with-simple-restart ((restart-name format-string &rest format-arguments) + &body forms) + `(restart-case (progn ,@forms) + (,restart-name () + :report (lambda (stream) (format stream ,format-string ,@format-arguments)) + (values nil t)))) + +(defun compute-restarts (&optional condition) + "Compute a list of the restarts which are currently active." + (let ((visibles nil) + (ignorables nil)) + (dolist (assoc *condition-restarts*) + (if (eq (car assoc) condition) + (setq visibles (append (cdr assoc) visibles)) + (setq ignorables (append (cdr assoc) ignorables)))) + (flet ((visible-p (restart) + (and (or (null condition) + (member restart visibles) + (not (member restart ignorables))) + (funcall (restart-test-function restart) condition)))) + (loop for restart in (mapcan #'copy-list *restart-clusters*) + if (visible-p restart) collect restart)))) + +(defun find-restart (id &optional condition) + "Search for a particular restart in the current dynamic environment." + (if (restart-p id) + (if (funcall (restart-test-function id) condition) + id + nil) + (find id (compute-restarts condition) :key #'restart-name))) + +(defun restart (designator) + (or (find-restart designator) + (error "Restart ~S is not active." designator))) + +(defun invoke-restart (restart-designator &rest values) + (let ((restart (restart restart-designator))) + (apply (restart-function restart) values))) + +(defun invoke-restart-interactively (restart-designator) + (let* ((restart (restart restart-designator)) + (interactive-function (restart-interactive-function restart))) + (apply (restart-function restart) (if interactive-function + (funcall interactive-function) + '())))) + +(defun abort (&optional condition) + (let ((restart (find-restart 'abort condition))) + (when restart + (invoke-restart 'abort)) + (error 'control-error))) + +(defun muffle-warning (&optional condition) + (let ((restart (find-restart 'muffle-warning condition))) + (when restart + (invoke-restart 'muffle-warning)) + (error 'control-error))) + +(defun continue (&optional condition) + (let ((restart (find-restart 'continue condition))) + (when restart + (invoke-restart restart)))) + +(defun store-value (value &optional condition) + (let ((restart (find-restart 'store-value condition))) + (when restart + (invoke-restart 'store-value value)))) + +(defun use-value (value &optional condition) + (let ((restart (find-restart 'use-value condition))) + (when restart + (invoke-restart 'use-value value)))) + + + +(defvar *break-on-signals* 'nil) +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ((*debugger-hook* nil)) + (invoke-debugger (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments)))) + nil) +(defun signal (datum &rest arguments) + (let ((condition (condition datum arguments)) + (*handler-clusters* *handler-clusters*)) + (when (typep condition *break-on-signals*) + (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition)) + (loop while *handler-clusters* + do (dolist (handler (pop *handler-clusters*)) + (when (typep condition (car handler)) + (funcall (cdr handler) condition)))) + nil)) + +(defun error (datum &rest arguments) + (let ((condition (condition datum arguments 'simple-error))) + (signal condition) + (invoke-debugger condition))) + +(defun cerror (continue-format-control datum &rest arguments) + (restart-case (error (condition datum arguments 'simple-error)) + (continue () + :report (lambda (stream) + (apply #'format stream continue-format-control arguments)))) + nil) + +(defmacro check-type (place typespec &optional string) + (declare (ignorable string)) + `(loop + until (typep ,place ',typespec) + do (restart-case (error 'type-error :datum ,place :expected-type ',typespec) + (store-value (value) + :report (lambda (stream) (store-value-report stream ',place)) + :interactive store-value-interactive + (setf ,place value))))) + +(defun warn (datum &rest arguments) + (let ((condition (condition datum arguments 'simple-warning))) + (check-type condition warning) + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (format *error-output* "~&Warning:~%~A~%" condition) + nil)) + + + +(defun assert-report (names stream) + (format stream "Retry assertion") + (if names + (format stream " with new value~P for ~{~S~^, ~}." (length names) names) + (format stream "."))) +(defun assert-prompt (name value) + (cond ((y-or-n-p "The old value of ~S is ~S.~%~ + Do you want to supply a new value? " + name value) + (format *query-io* "~&Type a form to be evaluated:~%") + (flet ((read-it () (eval (read *query-io*)))) + (if (symbolp name) ;help user debug lexical variables + (progv (list name) (list value) (read-it)) + (read-it)))) + (t value))) +(defmacro assert (test-form &optional places datum-form &rest argument-forms) + `(loop + (when ,test-form (return nil)) + (restart-case (error ,@(if datum-form + `(,datum-form ,@argument-forms) + `("The assertion ~S failed." ',test-form))) + (continue () + :report (lambda (stream) (assert-report ',places stream)) + ,@(mapcar #'(lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places))))) + +;;Function INVOKE-DEBUGGER +;;Variable *DEBUGGER-HOOK* +;; +;;Defined in clos.lisp +;; Macro DEFINE-CONDITION +;; Function MAKE-CONDITION +;; Function INVALID-METHOD-ERROR +;; Function METHOD-COMBINATION-ERROR -- cgit v1.2.3