diff -uNr TEST.gcl/gcl/clcs/condition-definitions.lisp agcl/agcl/clcs/condition-definitions.lisp --- TEST.gcl/gcl/clcs/condition-definitions.lisp Mon Oct 14 07:24:42 2002 +++ agcl/agcl/clcs/condition-definitions.lisp Fri Nov 8 19:17:47 2002 @@ -1,410 +1,156 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(IN-PACKAGE "CONDITIONS") +(in-package "CONDITIONS") (eval-when (compile load eval) -(pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions - *features*) -) +(pushnew :clos-conditions *features*)) -(eval-when (compile load eval) -(when (and (member :clos-conditions *features*) - (member :defstruct-conditions *features*)) - (dolist (sym '(simple-condition-format-string simple-condition-format-arguments - type-error-datum type-error-expected-type - case-failure-name case-failure-possibilities - stream-error-stream file-error-pathname package-error-package - cell-error-name arithmetic-error-operation - internal-error-function-name)) - (when (fboundp sym) (fmakunbound sym))) - (setq *features* (remove :defstruct-conditions *features*))) -) - -(DEFINE-CONDITION WARNING (CONDITION) - ()) +(define-condition warning (condition) ()) -(DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) - ()) +(define-condition serious-condition (condition) ()) -(DEFINE-CONDITION ERROR (SERIOUS-CONDITION) - ()) - -(DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) - (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) - (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) - -(DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) - #-(or clos pcl) - (FORMAT-STRING (FORMAT-ARGUMENTS '())) - #+(or clos pcl) - ((FORMAT-STRING :type string - :initarg :FORMAT-STRING - :reader SIMPLE-CONDITION-FORMAT-STRING) - (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS - :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS - :initform '())) - #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-) - (:REPORT SIMPLE-CONDITION-PRINTER)) - -(DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING) - #-(or clos pcl) - (FORMAT-STRING (FORMAT-ARGUMENTS '())) - #+(or clos pcl) - () - #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-) - #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) +(define-condition error (serious-condition) ()) -(DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION ERROR) - #-(or clos pcl) - (FORMAT-STRING (FORMAT-ARGUMENTS '())) - #+(or clos pcl) - () - #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-) - #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) - -(DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) - -(DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) - -(DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) +(defun simple-condition-printer (condition stream) + (apply #'format stream (simple-condition-format-string condition) + (simple-condition-format-arguments condition))) -(DEFINE-CONDITION TYPE-ERROR (ERROR) - #-(or clos pcl) - (DATUM EXPECTED-TYPE) - #+(or clos pcl) - ((DATUM :initarg :DATUM - :reader TYPE-ERROR-DATUM) - (EXPECTED-TYPE :initarg :EXPECTED-TYPE - :reader TYPE-ERROR-EXPECTED-TYPE)) +(define-condition simple-condition (condition) + ((format-string :type string + :initarg :format-string + :accessor simple-condition-format-string) + (format-arguments :initarg :format-arguments + :accessor simple-condition-format-arguments)) + (:report simple-condition-printer)) + +(define-condition simple-warning (simple-condition warning) ()) + +(define-condition simple-error (simple-condition error) ()) + + +(define-condition storage-condition (serious-condition) ()) +(define-condition simple-storage-condition (simple-condition storage-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))))) + (type-error-datum condition) + (type-error-expected-type condition))))) -(DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR) - #-(or clos pcl) - (FORMAT-STRING (FORMAT-ARGUMENTS '())) - #+(or clos pcl) - () - #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-) - #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) - -(DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) - #-(or clos pcl) - (NAME POSSIBILITIES) - #+(or clos pcl) - ((NAME :initarg :NAME - :reader CASE-FAILURE-NAME) - (POSSIBILITIES :initarg :POSSIBILITIES - :reader CASE-FAILURE-POSSIBILITIES)) - (:REPORT - (LAMBDA (CONDITION STREAM) - (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S." - (TYPE-ERROR-DATUM CONDITION) - (CASE-FAILURE-NAME CONDITION) - (CASE-FAILURE-POSSIBILITIES CONDITION))))) +(define-condition simple-type-error (simple-condition type-error) ()) -(DEFINE-CONDITION PROGRAM-ERROR (ERROR) +(define-condition program-error (error) ()) +(define-condition simple-program-error (simple-error program-error) ()) -(DEFINE-CONDITION CONTROL-ERROR (ERROR) - ()) +; (:report simple-condition-printer)) -(DEFINE-CONDITION STREAM-ERROR (ERROR) - #-(or clos pcl) - (STREAM) - #+(or clos pcl) - ((STREAM :initarg :STREAM - :reader STREAM-ERROR-STREAM))) +(define-condition control-error (error) ()) +(define-condition simple-control-error (simple-error control-error) + ()) +; (:report simple-condition-printer)) -(DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) +(define-condition stream-error (error) + ((stream :initarg :stream + :accessor stream-error-stream))) +(define-condition simple-stream-error (simple-error stream-error) () - (:REPORT (LAMBDA (CONDITION STREAM) - (FORMAT STREAM "Unexpected end of file on ~S." - (STREAM-ERROR-STREAM CONDITION))))) - -(DEFINE-CONDITION FILE-ERROR (ERROR) - #-(or clos pcl) - (PATHNAME) - #+(or clos pcl) - ((PATHNAME :initarg :PATHNAME - :reader FILE-ERROR-PATHNAME))) - -(DEFINE-CONDITION PACKAGE-ERROR (ERROR) - #-(or clos pcl) - (PACKAGE) - #+(or clos pcl) - ((PACKAGE :initarg :PACKAGE - :reader PACKAGE-ERROR-PACKAGE) - (MESSAGE :initarg :MESSAGE - :reader PACKAGE-ERROR-MESSAGE)) - (:report - (lambda (condition stream) - (format stream "A package error occurred on ~S: ~S." - (PACKAGE-ERROR-PACKAGE CONDITION) - (PACKAGE-ERROR-MESSAGE CONDITION))))) - - -(DEFINE-CONDITION CELL-ERROR (ERROR) - #-(or clos pcl) - (NAME) - #+(or clos pcl) - ((NAME :initarg :NAME - :reader CELL-ERROR-NAME))) + (:report stream-error-reporter)) -(DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR) - () - (:REPORT (LAMBDA (CONDITION STREAM) - (FORMAT STREAM "The variable ~S is unbound." - (CELL-ERROR-NAME CONDITION))))) - -(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) +(defun stream-error-reporter (condition stream) + (format stream "A STREAM-ERROR ocured on ~S." (stream-error-stream condition)) + (apply #'format stream (simple-condition-format-string condition) + (simple-condition-format-arguments condition))) + + +(define-condition end-of-file (stream-error) () - (:REPORT (LAMBDA (CONDITION STREAM) - (FORMAT STREAM "The function ~S is undefined." - (CELL-ERROR-NAME CONDITION))))) - -(DEFINE-CONDITION ARITHMETIC-ERROR (ERROR) - #-(or clos pcl) - (OPERATION OPERANDS) - #+(or clos pcl) - ((OPERATION :initarg :OPERATION - :reader ARITHMETIC-ERROR-OPERATION))) + (:report (lambda (condition stream) + (format stream "unexpected end of file on ~s." + (stream-error-stream condition))))) -(DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) - ()) +(define-condition file-error (error) + ((pathname :initarg :pathname + :accessor file-error-pathname)) + (:report (lambda (condition stream) + (format stream "A file-error occurred on ~S." + (file-error-pathname condition))))) +(define-condition simple-file-error (simple-error file-error) ()) + +(define-condition package-error (error) + ((package :initarg :package + :accessor package-error-package))) +(define-condition simple-package-error (simple-error package-error) ()) -(DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) - ()) -(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) - ()) +(define-condition cell-error (error) + ((name :initarg :name + :accessor cell-error-name)) + (:report (lambda (condition stream) + (format stream "Cannot access ~S." + (cell-error-name condition))))) -(DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () - (:REPORT "Abort failed.")) +(define-condition unbound-variable (cell-error) () + (:report (lambda (condition stream) + (format stream "The variable ~S is unbound." + (cell-error-name condition))))) + +(define-condition undefined-function (cell-error) () + (:report (lambda (condition stream) + (format stream "The function ~S is undefined." + (cell-error-name condition))))) -#+kcl -(progn -(define-condition internal-error ( error) - #-(or clos pcl) - ((function-name nil)) - #+(or clos pcl) - ((function-name :initarg :function-name - :reader internal-error-function-name - :initform 'nil)) +(define-condition arithmetic-error (error) + ((operation :initarg :operation + :accessor arithmetic-error-operation) + (operands :initarg :operands + :type list + :accessor arithmetic-error-operands)) (:report (lambda (condition stream) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - #+(or clos pcl)(call-next-method)))) - -(defun internal-simple-error-printer (condition stream) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - (apply #'format stream (simple-condition-format-string condition) - (simple-condition-format-arguments condition))) + (format stream "~A operation with operands ~A is an error" + (arithmetic-error-operation condition) + (arithmetic-error-operands condition))))) -(define-condition internal-simple-error - (internal-error #+(or clos pcl) simple-condition) - #-(or clos pcl) - ((function-name nil) format-string (format-arguments '())) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-simple-error-) - (:report internal-simple-error-printer)) +(define-condition division-by-zero (arithmetic-error) + ((operation :initarg :operation + :initform 'division + :reader arithmetic-error-operation))) -(define-condition internal-type-error - (#+(or clos pcl) internal-error type-error) - #-(or clos pcl) - ((function-name nil)) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-type-error-) - #-(or clos pcl)(:report (lambda (condition stream) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - (format stream "~S is not of type ~S." - (type-error-datum condition) - (type-error-expected-type condition))))) - -(define-condition internal-package-error - (#+(or clos pcl) internal-error package-error) - #-(or clos pcl) - ((function-name nil)) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-package-error-) - #-(or clos pcl)(:report (lambda (condition stream) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - (format stream "A package error occurred on ~S: ~S." - (package-error-package condition) - (package-error-message condition))))) - -(define-condition internal-simple-program-error - (#+(or clos pcl) internal-simple-error program-error) - #-(or clos pcl) - ((function-name nil) format-string (format-arguments '())) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-simple-program-error-) - #-(or clos pcl)(:report internal-simple-error-printer)) +(define-condition floating-point-overflow (arithmetic-error) ()) -(define-condition internal-simple-control-error - (#+(or clos pcl) internal-simple-error control-error) - #-(or clos pcl) - ((function-name nil) format-string (format-arguments '())) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-simple-control-error-) - #-(or clos pcl)(:report internal-simple-error-printer)) +(define-condition floating-point-underflow (arithmetic-error) ()) -(define-condition internal-unbound-variable - (#+(or clos pcl) internal-error unbound-variable) - #-(or clos pcl) - ((function-name nil)) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-unbound-variable-) - #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - (FORMAT STREAM "The variable ~S is unbound." - (CELL-ERROR-NAME CONDITION))))) - -(define-condition internal-undefined-function - (#+(or clos pcl) internal-error undefined-function) - #-(or clos pcl) - ((function-name nil)) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-undefined-function-) - #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - (FORMAT STREAM "The function ~S is undefined." - (CELL-ERROR-NAME CONDITION))))) - -(define-condition internal-end-of-file - (#+(or clos pcl) internal-error end-of-file) - #-(or clos pcl) - ((function-name nil)) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-end-of-file-) - #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) - (when (internal-error-function-name condition) - (format stream "Error in ~S [or a callee]: " - (internal-error-function-name condition))) - (FORMAT STREAM "Unexpected end of file on ~S." - (STREAM-ERROR-STREAM CONDITION))))) - -(define-condition internal-simple-file-error - (#+(or clos pcl) internal-simple-error file-error) - #-(or clos pcl) - ((function-name nil) format-string (format-arguments '())) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-simple-file-error-) - #-(or clos pcl)(:report internal-simple-error-printer)) +(define-condition unbound-slot (cell-error) + ((instance :initarg :instance + :accessor unbound-slot-instance))) -(define-condition internal-simple-stream-error - (#+(or clos pcl) internal-simple-error stream-error) - #-(or clos pcl) - ((function-name nil) format-string (format-arguments '())) - #+(or clos pcl) - () - #-(or clos pcl)(:conc-name %%internal-simple-stream-error-) - #-(or clos pcl)(:report internal-simple-error-printer)) +(define-condition floating-point-inexact (arithmetic-error) ()) -#-(or pcl clos) -(defun internal-error-function-name (condition) - (etypecase condition - (internal-error - (%%internal-error-function-name condition)) - (internal-simple-error - (%%internal-simple-error-function-name condition)) - (internal-type-error - (%%internal-type-error-function-name condition)) - (internal-simple-program-error - (%%internal-simple-program-error-function-name condition)) - (internal-simple-control-error - (%%internal-simple-control-error-function-name condition)) - (internal-unbound-variable - (%%internal-unbound-variable-function-name condition)) - (internal-undefined-function - (%%internal-undefined-function-function-name condition)) - (internal-end-of-file - (%%internal-end-of-file-function-name condition)) - (internal-simple-file-error - (%%internal-simple-file-error-function-name condition)) - (internal-simple-stream-error - (%%internal-simple-stream-error-function-name condition)))) -) - -#-(or clos pcl) -(progn - -(DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) - (ETYPECASE CONDITION - (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) - (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-STRING CONDITION)) - (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) - (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-STRING CONDITION)) - #+kcl(internal-simple-error - (%%internal-simple-error-format-string condition)) - #+kcl(internal-simple-program-error - (%%internal-simple-program-error-format-string condition)) - #+kcl(internal-simple-control-error - (%%internal-simple-control-error-format-string condition)) - #+kcl(internal-simple-file-error - (%%internal-simple-file-error-format-string condition)) - #+kcl(internal-simple-stream-error - (%%internal-simple-stream-error-format-string condition)))) - -(DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) - (ETYPECASE CONDITION - (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) - (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) - (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) - (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) - #+kcl(internal-simple-error - (%%internal-simple-error-format-arguments condition)) - #+kcl(internal-simple-program-error - (%%internal-simple-program-error-format-arguments condition)) - #+kcl(internal-simple-control-error - (%%internal-simple-control-error-format-arguments condition)) - #+kcl(internal-simple-file-error - (%%internal-simple-file-error-format-arguments condition)) - #+kcl(internal-simple-stream-error - (%%internal-simple-stream-error-format-arguments condition)))) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) -(defun simple-condition-class-p (type) - (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR - #+kcl internal-simple-error - #+kcl internal-simple-program-error - #+kcl internal-simple-control-error - #+kcl internal-simple-file-error - #+kcl internal-simple-stream-error))) -) +(define-condition print-not-readable (error) + ((object :initarg :object + :accessor print-not-readable-object))) + +(define-condition style-warning (warning) ()) + +(define-condition parse-error (error) ()) +(define-condition simple-parse-error (simple-error parse-error) ()) + +(define-condition reader-error (parse-error stream-error) ()) +(define-condition simple-reader-error (simple-error reader-error) ()) -#+(or clos pcl) -(progn (defvar *simple-condition-class* (find-class 'simple-condition)) -(defun simple-condition-class-p (TYPE) - (when (symbolp TYPE) - (setq TYPE (find-class TYPE))) - (and (typep TYPE 'standard-class) +(defun simple-condition-class-p (type) + (when (symbolp type) + (setq type (find-class type))) + (and (typep type 'standard-class) (member *simple-condition-class* - (#+pcl pcl::class-precedence-list - #-pcl clos::class-precedence-list - type)))) -) + (pcl::class-precedence-list type)))) diff -uNr TEST.gcl/gcl/clcs/condition-precom.lisp agcl/agcl/clcs/condition-precom.lisp --- TEST.gcl/gcl/clcs/condition-precom.lisp Mon Dec 6 23:43:55 1999 +++ agcl/agcl/clcs/condition-precom.lisp Tue Nov 5 15:16:37 2002 @@ -1,50 +1,36 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) +(in-package "CONDITIONS" :USE '("LISP" "PCL")) -#-(or lucid excl genera) (progn - -#+pcl -(eval-when (compile load eval) -(defun exercise-condition-classes () - (let ((gfuns nil)) - (dolist (name '(make-instance - initialize-instance - shared-initialize - print-object)) - (push (pcl::gdefinition name) gfuns)) - (labels ((do-class (class) - (dolist (gfun (pcl::specializer-generic-functions class)) - (pushnew gfun gfuns)) - (dolist (dsub (pcl::class-direct-subclasses class)) - (do-class dsub)))) - (do-class (find-class 'condition))) - (mapc #'pcl::exercise-generic-function gfuns)) - nil) -) - -#+pcl -(progn -(eval-when (compile) -(exercise-condition-classes) -) - -(pcl::precompile-random-code-segments clcs) - -(eval-when (load eval) -(exercise-condition-classes) -) -) - -#+kcl (install-clcs-symbols) - -) + (eval-when (compile load eval) + (defun exercise-condition-classes () + (let ((gfuns nil)) + (dolist (name '(make-instance + initialize-instance + shared-initialize + print-object)) + (push (pcl::gdefinition name) gfuns)) + (labels ((do-class (class) + (dolist (gfun (pcl::specializer-generic-functions class)) + (pushnew gfun gfuns)) + (dolist (dsub (pcl::class-direct-subclasses class)) + (do-class dsub)))) + (do-class (find-class 'condition))) + (mapc #'pcl::exercise-generic-function gfuns)) + nil)) + (progn + (eval-when (compile) + (exercise-condition-classes)) + (pcl::precompile-random-code-segments clcs) + (eval-when (load eval) + (exercise-condition-classes))) + (install-clcs-symbols)) (defun dsys::retry-operation (function retry-string) (loop (with-simple-restart (retry retry-string) - (return-from dsys::retry-operation - (funcall function))))) + (return-from dsys::retry-operation + (funcall function))))) (defun dsys::operate-on-module (module initial-state system-operation) (if (null dsys::*retry-operation-list*) diff -uNr TEST.gcl/gcl/clcs/conditions.lisp agcl/agcl/clcs/conditions.lisp --- TEST.gcl/gcl/clcs/conditions.lisp Mon Dec 6 23:43:55 1999 +++ agcl/agcl/clcs/conditions.lisp Wed Nov 6 22:18:02 2002 @@ -1,171 +1,36 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) +(in-package "CONDITIONS" :use '("LISP" "PCL")) + -#+kcl (eval-when (compile load eval) (when (fboundp 'remove-clcs-symbols) - (remove-clcs-symbols)) -) - -;DEFINE-CONDITION -;MAKE-CONDITION -;condition printing -;(define-condition CONDITION ...) -;CONDITIONP -;CONDITION-CLASS-P -;SIMPLE-CONDITION-P -;SIMPLE-CONDITION-CLASS-P - -#-(or clos pcl) -(progn -(DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH) - DEPTH ;ignored - (COND (*PRINT-ESCAPE* - (FORMAT STREAM "#<~S.~D>" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION))) - (T - (CONDITION-REPORT CONDITION STREAM)))) - -(DEFSTRUCT (CONDITION :CONC-NAME - (:CONSTRUCTOR |Constructor for CONDITION|) - (:PREDICATE NIL) - (:PRINT-FUNCTION CONDITION-PRINT)) - (-DUMMY-SLOT- NIL)) - -(EVAL-WHEN (EVAL COMPILE LOAD) - -(DEFMACRO PARENT-TYPE (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE)) -(DEFMACRO SLOTS (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS)) -(DEFMACRO CONC-NAME (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME)) -(DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION)) -(DEFMACRO MAKE-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION)) - -);NEHW-LAVE - -(DEFUN CONDITION-REPORT (CONDITION STREAM) - (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE))) - ((NOT TYPE) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF CONDITION))) - (LET ((REPORTER (REPORT-FUNCTION TYPE))) - (WHEN REPORTER - (FUNCALL REPORTER CONDITION STREAM) - (RETURN NIL))))) - -(SETF (MAKE-FUNCTION 'CONDITION) '|Constructor for CONDITION|) - -(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) - (LET ((FN (MAKE-FUNCTION TYPE))) - (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR - :DATUM TYPE - :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION) - :FORMAT-STRING "Not a condition type: ~S" - :FORMAT-ARGUMENTS (LIST TYPE))) - (T (APPLY FN SLOT-INITIALIZATIONS))))) - -(EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time - -(DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE) - (LET ((NEW '()) (USED '())) - (DOLIST (SLOT SLOTS) - (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE) - (PUSH SLOT USED) - (PUSH SLOT NEW))) - (VALUES NEW USED))) - -(DEFUN SLOT-USED-P (SLOT-NAME TYPE) - (COND ((EQ TYPE 'CONDITION) NIL) - ((NOT TYPE) (ERROR "The type ~S does not inherit from CONDITION." TYPE)) - ((ASSOC SLOT-NAME (SLOTS TYPE))) - (T - (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE))))) - -);NEHW-LAVE - -(DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS) - (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT - (INTERN (FORMAT NIL "Constructor for ~S" NAME))))) - (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC) - (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC)) - SLOT-SPECS))) - (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS) - (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE) - (LET ((CONC-NAME-P NIL) - (CONC-NAME NIL) - (REPORT-FUNCTION NIL) - (DOCUMENTATION NIL)) - (DO ((O OPTIONS (CDR O))) - ((NULL O)) - (LET ((OPTION (CAR O))) - (CASE (CAR OPTION) ;Should be ECASE - (:CONC-NAME (SETQ CONC-NAME-P T) - (SETQ CONC-NAME (CADR OPTION))) - (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION)) - `(LAMBDA (CONDITION STREAM) - (DECLARE (IGNORE CONDITION)) - (WRITE-STRING ,(CADR OPTION) STREAM)) - (CADR OPTION)))) - (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION))) - (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option." - "Invalid DEFINE-CONDITION option: ~S" OPTION))))) - (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" NAME) *PACKAGE*))) - ;; The following three forms are compile-time side-effects. For now, they affect - ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, - ;; and CONC-NAME, the compiler could easily make them local. - (SETF (PARENT-TYPE NAME) PARENT-TYPE) - (SETF (SLOTS NAME) SLOTS) - (SETF (CONC-NAME NAME) CONC-NAME) - ;; Finally, the expansion ... - `(PROGN (DEFSTRUCT (,NAME - (:CONSTRUCTOR ,CONSTRUCTOR) - (:PREDICATE NIL) - (:COPIER NIL) - (:PRINT-FUNCTION CONDITION-PRINT) - (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS) - (:CONC-NAME ,CONC-NAME)) - ,@NEW-SLOTS) - (SETF (DOCUMENTATION ',NAME 'TYPE) ',DOCUMENTATION) - (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE) - (SETF (SLOTS ',NAME) ',SLOTS) - (SETF (CONC-NAME ',NAME) ',CONC-NAME) - (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION)) - (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR) - ',NAME)))))) - -(defun conditionp (object) - (typep object 'condition)) - -(defun condition-class-p (object) - (and (symbolp object) - (MAKE-FUNCTION object))) - -) + (remove-clcs-symbols))) - - -#+(or clos pcl) (progn (eval-when (compile load eval) -(defvar *condition-class-list* nil) ; list of (class-name initarg1 type1...) -) + (defvar *condition-class-list* nil)) ; list of (class-name initarg1 type1...) + -(DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS) - (let* ((REPORT-FUNCTION nil) - (DOCUMENTATION nil)) - (DO ((O OPTIONS (CDR O))) - ((NULL O)) - (LET ((OPTION (CAR O))) - (CASE (CAR OPTION) - (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION)) - `(LAMBDA (CONDITION STREAM) - (DECLARE (IGNORE CONDITION)) - (WRITE-STRING ,(CADR OPTION) STREAM)) - (CADR OPTION)))) - (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION))) - (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option." - "Invalid DEFINE-CONDITION option: ~S" OPTION))))) +(defmacro define-condition (name parent-list slot-specs &rest options) + (let* ((report-function nil) + (documentation nil)) + (do ((o options (cdr o))) + ((null o)) + (let ((option (car o))) + (case (car option) + (:report (setq report-function (if (stringp (cadr option)) + `(lambda (condition stream) + (declare (ignore condition)) + (write-string ,(cadr option) stream)) + (cadr option)))) + (:documentation (setq documentation (cadr option))) + (otherwise (cerror "Ignore this DEFINE-CONDITION option." + "Invalid DEFINE-CONDITION option: ~S" option))))) `(progn (eval-when (compile) - #+pcl (setq pcl::*defclass-times* '(compile load eval))) + (setq pcl::*defclass-times* '(compile load eval))) (defclass ,name ,parent-list ,slot-specs) (eval-when (compile load eval) @@ -177,54 +42,48 @@ (cons ia (or (getf (cdr slot-spec) ':type) t)))))) - SLOT-SPECS)) + slot-specs)) *condition-class-list*) - #+kcl (setf (get ',name #+akcl 'si::s-data #-akcl 'si::is-a-structure) nil) + (setf (get ',name 'si::s-data) nil) (setf (get ',name 'documentation) ',documentation)) - ,@(when REPORT-FUNCTION - `((DEFMETHOD PRINT-OBJECT ((X ,NAME) STREAM) - (IF *PRINT-ESCAPE* - (CALL-NEXT-METHOD) - (,REPORT-FUNCTION X STREAM))))) - ',NAME))) + ,@(when report-function + `((defmethod print-object ((x ,name) stream) + (if *print-escape* + (call-next-method) + (,report-function x stream))))) + ',name))) (eval-when (compile load eval) -(define-condition condition () - ()) + (define-condition condition () + ()) -#+pcl -(when (fboundp 'pcl::proclaim-incompatible-superclasses) - (mapc - #'pcl::proclaim-incompatible-superclasses - '((condition pcl::metaobject)))) -) + (when (fboundp 'pcl::proclaim-incompatible-superclasses) + (mapc + #'pcl::proclaim-incompatible-superclasses + '((condition pcl::metaobject))))) (defun conditionp (object) (typep object 'condition)) -(DEFMETHOD PRINT-OBJECT ((X condition) STREAM) - (IF *PRINT-ESCAPE* - (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x)) - (FORMAT STREAM "The condition ~A occurred." (TYPE-OF x)))) +(defmethod print-object ((x condition) stream) + (if *print-escape* + (format stream "#<~S.~D>" (class-name (class-of x)) (unique-id x)) + (format stream "The condition ~A occurred." (class-name (class-of x))))) (defvar *condition-class* (find-class 'condition)) -(defun condition-class-p (TYPE) - (when (symbolp TYPE) - (setq TYPE (find-class TYPE))) - (and (typep TYPE 'standard-class) +(defun condition-class-p (type) + (when (symbolp type) + (setq type (find-class type))) + (and (typep type 'standard-class) (member *condition-class* - (#+pcl pcl::class-precedence-list - #-pcl clos::class-precedence-list - type)))) - -(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) - (unless (condition-class-p TYPE) - (ERROR 'SIMPLE-TYPE-ERROR - :DATUM TYPE - :EXPECTED-TYPE '(SATISFIES condition-class-p) - :FORMAT-STRING "Not a condition type: ~S" - :FORMAT-ARGUMENTS (LIST TYPE))) - (apply #'make-instance TYPE SLOT-INITIALIZATIONS)) + (pcl::class-precedence-list type)))) -) +(defun make-condition (type &rest slot-initializations) + (unless (condition-class-p type) + (error 'simple-type-error + :datum type + :expected-type '(satisfies condition-class-p) + :format-string "Not a condition type: ~S" + :format-arguments (list type))) + (apply #'make-instance type slot-initializations))) diff -uNr TEST.gcl/gcl/clcs/debugger.lisp agcl/agcl/clcs/debugger.lisp --- TEST.gcl/gcl/clcs/debugger.lisp Mon Dec 6 23:43:55 1999 +++ agcl/agcl/clcs/debugger.lisp Tue Nov 5 15:16:37 2002 @@ -2,142 +2,140 @@ (in-package "CONDITIONS") -(DEFVAR *DEBUG-LEVEL* 0) -(DEFVAR *DEBUG-ABORT* NIL) -(DEFVAR *DEBUG-CONTINUE* NIL) -(DEFVAR *DEBUG-CONDITION* NIL) -(DEFVAR *DEBUG-RESTARTS* NIL) -(DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0) -(DEFVAR *DEBUG-EVAL* 'EVAL) -(DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES))) - -(DEFMACRO DEBUG-COMMAND (X) `(GET ,X 'DEBUG-COMMAND)) -(DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT)) - -(DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY) - `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY)) - (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL)) - ',NAME)) - -(DEFUN READ-DEBUG-COMMAND () - (FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*) - (COND ((CHAR= (PEEK-CHAR T) #\:) - (READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number. - (WITH-INPUT-FROM-STRING (STREAM (READ-LINE)) - (LET ((EOF (LIST NIL))) - (DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD"))) - (READ STREAM NIL EOF)) - (READ STREAM NIL EOF)) - (L '() (CONS FORM L))) - ((EQ FORM EOF) (NREVERSE L)))))) - (T - (LIST :EVAL (READ))))) +(defvar *debug-level* 0) +(defvar *debug-abort* nil) +(defvar *debug-continue* nil) +(defvar *debug-condition* nil) +(defvar *debug-restarts* nil) +(defvar *number-of-debug-restarts* 0) +(defvar *debug-eval* 'eval) +(defvar *debug-print* #'(lambda (values) (format t "~&~{~S~^,~%~}" values))) + +(defmacro debug-command (x) `(get ,x 'debug-command)) +(defmacro debug-command-argument-count (x) `(get ,x 'debug-command-argument-count)) + +(defmacro define-debug-command (name bvl &rest body) + `(progn (setf (debug-command ',name) #'(lambda ,bvl ,@body)) + (setf (debug-command-argument-count ',name) ,(length bvl)) + ',name)) + +(defun read-debug-command () + (format t "~&Debug ~D> " *debug-level*) + (cond ((char= (peek-char t) #\:) + (read-char) ;eat the ":" so that ":1l" reliably reads a number. + (with-input-from-string (stream (read-line)) + (let ((eof (list nil))) + (do ((form (let ((*package* (find-package "KEYWORD"))) + (read stream nil eof)) + (read stream nil eof)) + (l '() (cons form l))) + ((eq form eof) (nreverse l)))))) + (t + (list :eval (read))))) -(DEFINE-DEBUG-COMMAND :EVAL (FORM) - (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM)))) +(define-debug-command :eval (form) + (funcall *debug-print* (multiple-value-list (funcall *debug-eval* form)))) -(DEFINE-DEBUG-COMMAND :ABORT () - (IF *DEBUG-ABORT* - (INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*) - (FORMAT T "~&There is no way to abort.~%"))) - -(DEFINE-DEBUG-COMMAND :CONTINUE () - (IF *DEBUG-CONTINUE* - (INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*) - (FORMAT T "~&There is no way to continue.~%"))) +(define-debug-command :abort () + (if *debug-abort* + (invoke-restart-interactively *debug-abort*) + (format t "~&There is no way to abort.~%"))) + +(define-debug-command :continue () + (if *debug-continue* + (invoke-restart-interactively *debug-continue*) + (format t "~&There is no way to continue.~%"))) -(DEFINE-DEBUG-COMMAND :ERROR () - (FORMAT T "~&~A~%" *DEBUG-CONDITION*)) +(define-debug-command :error () + (format t "~&~A~%" *debug-condition*)) -(DEFINE-DEBUG-COMMAND :HELP () - (FORMAT T "~&You are in a portable debugger.~ +(define-debug-command :help () + (format T "~&You are in a portable debugger.~ ~%Type a debugger command or a form to evaluate.~ ~%Commands are:~%") - (SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16) - (FORMAT T "~& :EVAL form Evaluate a form.~ + (show-restarts *debug-restarts* *number-of-debug-restarts* 16) + (format t "~& :EVAL form Evaluate a form.~ ~% :HELP Show this text.~%") - (IF *DEBUG-ABORT* (FORMAT T "~& :ABORT Exit by ABORT.~%")) - (IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE Exit by CONTINUE.~%")) - (FORMAT T "~& :ERROR Reprint error message.~%")) - - + (if *debug-abort* (format t "~& :ABORT Exit by ABORT.~%")) + (if *debug-continue* (format t "~& :CONTINUE Exit by CONTINUE.~%")) + (format t "~& :ERROR Reprint error message.~%")) (defvar *debug-command-prefix* ":") -(DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*) - (MAX *NUMBER-OF-DEBUG-RESTARTS*) - TARGET-COLUMN) - (UNLESS MAX (SETQ MAX (LENGTH RESTARTS))) - (WHEN RESTARTS - (DO ((W (IF TARGET-COLUMN - (- TARGET-COLUMN 3) - (CEILING (LOG MAX 10)))) - (P RESTARTS (CDR P)) - (I 0 (1+ I))) - ((OR (NOT P) (= I MAX))) - (FORMAT T "~& ~A~A " +(defun show-restarts (&optional (restarts *debug-restarts*) + (max *number-of-debug-restarts*) + target-column) + (unless max (setq max (length restarts))) + (when restarts + (do ((w (if target-column + (- target-column 3) + (ceiling (log max 10)))) + (p restarts (cdr p)) + (i 0 (1+ i))) + ((or (not p) (= i max))) + (format t "~& ~A~A " *debug-command-prefix* - (LET ((S (FORMAT NIL "~D" (+ I 1)))) - (WITH-OUTPUT-TO-STRING (STR) - (FORMAT STR "~A" S) - (DOTIMES (I (- W (LENGTH S))) - (WRITE-CHAR #\Space STR))))) - (IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) ")) - (IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) ")) - (FORMAT T "~A" (CAR P)) - (FORMAT T "~%")))) - -(defvar *DEBUGGER-HOOK* nil) -(defvar *debugger-function* 'STANDARD-DEBUGGER) - -(DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS) - (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG))) - (WHEN *DEBUGGER-HOOK* - (LET ((HOOK *DEBUGGER-HOOK*) - (*DEBUGGER-HOOK* NIL)) - (FUNCALL HOOK CONDITION HOOK))) - (funcall *debugger-function* CONDITION))) - -(DEFUN STANDARD-DEBUGGER (CONDITION) - (LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) - (*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) - (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) - (*DEBUG-ABORT* (FIND-RESTART 'ABORT)) - (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) - (IF (OR (NOT *DEBUG-CONTINUE*) - (NOT (EQ *DEBUG-CONTINUE* C))) - C NIL)) - (LET ((C (IF *DEBUG-RESTARTS* - (FIRST *DEBUG-RESTARTS*) NIL))) - (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) - (*DEBUG-CONDITION* CONDITION)) - (FORMAT T "~&~A~%" CONDITION) - (SHOW-RESTARTS) - (DO ((COMMAND (READ-DEBUG-COMMAND) - (READ-DEBUG-COMMAND))) - (NIL) - (EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*)))) - -(DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL) - (WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL) - (COND ((NOT CMD)) - ((INTEGERP CMD) - (COND ((AND (PLUSP CMD) - (< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) - (LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*))) - (IF ARGS - (APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS)) - (INVOKE-RESTART-INTERACTIVELY RESTART)))) - (T - (FORMAT T "~&No such restart.")))) - (T - (LET ((FN (DEBUG-COMMAND CMD))) - (IF FN - (COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))) - (FORMAT T "~&Too ~:[few~;many~] arguments to ~A." - (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)) - CMD)) - (T - (APPLY FN ARGS))) - (FORMAT T "~&~S is not a debugger command.~%" CMD))))))) + (let ((s (format nil "~D" (+ i 1)))) + (with-output-to-string (str) + (format str "~A" s) + (dotimes (i (- w (length s))) + (write-char #\Space str))))) + (if (eq (car p) *debug-abort*) (format t "(Abort) ")) + (if (eq (car p) *debug-continue*) (format t "(Continue) ")) + (format t "~A" (car p)) + (format t "~%")))) + +(defvar *debugger-hook* nil) +(defvar *debugger-function* 'standard-debugger) + +(defun invoke-debugger (&optional (datum "Debug") &rest arguments) + (let ((condition (coerce-to-condition datum arguments 'simple-condition 'debug))) + (when *debugger-hook* + (let ((hook *debugger-hook*) + (*debugger-hook* nil)) + (funcall hook condition hook))) + (funcall *debugger-function* condition))) + +(defun standard-debugger (condition) + (let* ((*debug-level* (1+ *debug-level*)) + (*debug-restarts* (compute-restarts)) + (*number-of-debug-restarts* (length *debug-restarts*)) + (*debug-abort* (find-restart 'abort)) + (*debug-continue* (or (let ((c (find-restart 'continue))) + (if (or (not *debug-continue*) + (not (eq *debug-continue* c))) + c nil)) + (let ((c (if *debug-restarts* + (first *debug-restarts*) nil))) + (if (not (eq c *debug-abort*)) c nil)))) + (*debug-condition* condition)) + (format t "~&~A~%" condition) + (show-restarts) + (do ((command (read-debug-command) + (read-debug-command))) + (nil) + (execute-debugger-command (car command) (cdr command) *debug-level*)))) + +(defun execute-debugger-command (cmd args level) + (with-simple-restart (abort "Return to debug level ~D." level) + (cond ((not cmd)) + ((integerp cmd) + (cond ((and (plusp cmd) + (< cmd (+ *number-of-debug-restarts* 1))) + (let ((restart (nth (- cmd 1) *debug-restarts*))) + (if args + (apply #'invoke-restart restart (mapcar *debug-eval* args)) + (invoke-restart-interactively restart)))) + (t + (format t "~&No such restart.")))) + (t + (let ((fn (debug-command cmd))) + (if fn + (cond ((not (= (length args) (debug-command-argument-count cmd))) + (format t "~&Too ~:[few~;many~] arguments to ~A." + (> (length args) (debug-command-argument-count cmd)) + cmd)) + (t + (apply fn args))) + (format t "~&~S is not a debugger command.~%" cmd))))))) diff -uNr TEST.gcl/gcl/clcs/handler.lisp agcl/agcl/clcs/handler.lisp --- TEST.gcl/gcl/clcs/handler.lisp Wed Oct 23 02:16:07 2002 +++ agcl/agcl/clcs/handler.lisp Mon Nov 4 18:32:03 2002 @@ -1,138 +1,135 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(IN-PACKAGE "CONDITIONS") +(in-package "CONDITIONS") -(DEFVAR *HANDLER-CLUSTERS* NIL) +(defvar *handler-clusters* nil) -(DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS) - (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS) - (ERROR "Ill-formed handler bindings.")) - `(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X))) - BINDINGS)) - *HANDLER-CLUSTERS*))) - ,@FORMS)) - -(DEFVAR *BREAK-ON-SIGNALS* NIL) - -(DEFUN SIGNAL (DATUM &REST ARGUMENTS) - (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL)) - (*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*)) - (IF (TYPEP CONDITION *BREAK-ON-SIGNALS*) - (BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*." - CONDITION)) - (LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN)) - (LET ((CLUSTER (POP *HANDLER-CLUSTERS*))) - (DOLIST (HANDLER CLUSTER) - (WHEN (TYPEP CONDITION (CAR HANDLER)) - (FUNCALL (CDR HANDLER) CONDITION) - (RETURN NIL) ;? - )))) - NIL)) +(defmacro handler-bind (bindings &body forms) + (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) + (error "ill-formed handler bindings.")) + `(let ((*handler-clusters* (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) + bindings)) + *handler-clusters*))) + ,@forms)) + +(defvar *break-on-signals* nil) + +(defun signal (datum &rest arguments) + (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal)) + (*handler-clusters* *handler-clusters*)) + (if (typep condition *break-on-signals*) + (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." + condition)) + (loop (if (not *handler-clusters*) (return)) + (let ((cluster (pop *handler-clusters*))) + (dolist (handler cluster) + (when (typep condition (car handler)) + (funcall (cdr handler) condition) + (return nil))))) nil)) ;;; COERCE-TO-CONDITION ;;; Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the ;;; hairy argument conventions into a single argument that's directly usable ;;; by all the other routines. -(DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME) - #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS)) - (COND ((CONDITIONP DATUM) - (IF ARGUMENTS - (CERROR "Ignore the additional arguments." - 'SIMPLE-TYPE-ERROR - :DATUM ARGUMENTS - :EXPECTED-TYPE 'NULL - :FORMAT-STRING "You may not supply additional arguments ~ +(defun coerce-to-condition (datum arguments default-type function-name) + (cond ((conditionp datum) + (if arguments + (cerror "Ignore the additional arguments." + 'simple-type-error + :datum arguments + :expected-type 'null + :format-string "You may not supply additional arguments ~ when giving ~S to ~S." - :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME))) - DATUM) - ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM)) - (APPLY #'MAKE-CONDITION DATUM ARGUMENTS)) - ((STRINGP DATUM) - (MAKE-CONDITION DEFAULT-TYPE - :FORMAT-STRING DATUM - :FORMAT-ARGUMENTS ARGUMENTS)) - (T - (ERROR 'SIMPLE-TYPE-ERROR - :DATUM DATUM - :EXPECTED-TYPE '(OR SYMBOL STRING) - :FORMAT-STRING "Bad argument to ~S: ~S" - :FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM))))) - -(DEFUN ERROR (DATUM &REST ARGUMENTS) - (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR))) - (SIGNAL CONDITION) - (INVOKE-DEBUGGER CONDITION))) - -(DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS) - (WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS)) - (APPLY #'ERROR DATUM ARGUMENTS)) - NIL) - -(DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS) - (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.") - (INVOKE-DEBUGGER - (MAKE-CONDITION 'SIMPLE-CONDITION - :FORMAT-STRING FORMAT-STRING - :FORMAT-ARGUMENTS FORMAT-ARGUMENTS))) - NIL) - -(DEFUN WARN (DATUM &REST ARGUMENTS) - (LET ((CONDITION - (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN))) - (CHECK-TYPE CONDITION WARNING "a warning condition") - (IF *BREAK-ON-WARNINGS* - (BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*." - CONDITION)) - (RESTART-CASE (SIGNAL CONDITION) - (MUFFLE-WARNING () - :REPORT "Skip warning." - (RETURN-FROM WARN NIL))) - (FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION) - NIL)) - -(DEFMACRO HANDLER-CASE (FORM &REST CASES) - (LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES))) - (IF NO-ERROR-CLAUSE - (LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN")) - (ERROR-RETURN (MAKE-SYMBOL "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 CASES))))))) - (LET ((TAG (GENSYM)) - (VAR (GENSYM)) - (ANNOTATED-CASES (MAPCAR #'(LAMBDA (CASE) (CONS (GENSYM) CASE)) - CASES))) - `(BLOCK ,TAG - (LET ((,VAR NIL)) - ,VAR ;ignorable - (TAGBODY - (HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE) - (LIST (CADR ANNOTATED-CASE) - `#'(LAMBDA (TEMP) - ,@(IF (CADDR ANNOTATED-CASE) - `((SETQ ,VAR TEMP))) - (GO ,(CAR ANNOTATED-CASE))))) - ANNOTATED-CASES) - (RETURN-FROM ,TAG ,FORM)) - ,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE) - (LIST (CAR ANNOTATED-CASE) - (LET ((BODY (CDDDR ANNOTATED-CASE))) - `(RETURN-FROM ,TAG - ,(COND ((CADDR ANNOTATED-CASE) - `(LET ((,(CAADDR ANNOTATED-CASE) - ,VAR)) - ,@BODY)) - ((NOT (CDR BODY)) - (CAR BODY)) - (T - `(PROGN ,@BODY))))))) - ANNOTATED-CASES)))))))) - -(DEFMACRO IGNORE-ERRORS (&REST FORMS) - `(HANDLER-CASE (PROGN ,@FORMS) - (ERROR (CONDITION) (VALUES NIL CONDITION)))) + :format-arguments (list datum function-name)) + datum)) + ((or (symbolp datum) (condition-class-p datum)) + (apply #'make-condition datum arguments)) + ((stringp datum) + (make-condition default-type + :format-string datum + :format-arguments arguments)) + (t + (error 'simple-type-error + :datum datum + :expected-type '(or symbol string) + :format-string "Bad argument to ~S: ~S" + :format-arguments (list function-name datum))))) + +(defun error (datum &rest arguments) + (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) + (signal condition) + (invoke-debugger condition))) + +(defun cerror (continue-string datum &rest arguments) + (with-simple-restart (continue "~a" (apply #'format nil continue-string arguments)) + (apply #'error datum arguments)) + nil) + +(defun break (&optional (format-string "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (invoke-debugger + (make-condition 'simple-condition + :format-string format-string + :format-arguments format-arguments))) + nil) + +(defun warn (datum &rest arguments) + (let ((condition + (coerce-to-condition datum arguments 'simple-warning 'warn))) + (check-type condition warning "a warning condition") + (if *break-on-warnings* + (break "~A~%Break entered because of *BREAK-ON-WARNINGS*." + condition)) + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (format *error-output* "~&Warning:~%~A~%" condition) + nil)) + +(defmacro handler-case (form &rest cases) + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (make-symbol "NORMAL-RETURN")) + (error-return (make-symbol "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 cases))))))) + (let ((tag (gensym)) + (var (gensym)) + (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case)) + cases))) + `(block ,tag + (let ((,var nil)) + ,var ;ignorable + (tagbody + (handler-bind ,(mapcar #'(lambda (annotated-case) + (list (cadr annotated-case) + `#'(lambda (temp) + ,@(if (caddr annotated-case) + `((setq ,var temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag ,form)) + ,@(mapcan #'(lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from ,tag + ,(cond ((caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body)) + ((not (cdr body)) + (car body)) + (t + `(progn ,@body))))))) + annotated-cases)))))))) + +(defmacro ignore-errors (&rest forms) + `(handler-case (progn ,@forms) + (error (condition) (values nil condition)))) diff -uNr TEST.gcl/gcl/clcs/kcl-cond.lisp agcl/agcl/clcs/kcl-cond.lisp --- TEST.gcl/gcl/clcs/kcl-cond.lisp Sat Oct 19 05:42:05 2002 +++ agcl/agcl/clcs/kcl-cond.lisp Tue Nov 5 15:35:30 2002 @@ -4,147 +4,71 @@ (defvar *internal-error-table* (make-hash-table :test 'equal)) -;(defmacro find-internal-error-data (error-name error-format-string) -; `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) (defmacro find-internal-error-data (error-name) `(gethash (list ,error-name) *internal-error-table*)) -;(defun clcs-universal-error-handler (error-name correctable function-name -; continue-format-string error-format-string -; &rest args) -; (if correctable -; (with-simple-restart -; (continue "~a" (apply #'format nil continue-format-string args)) -; (error 'internal-simple-error -; :function-name function-name -; :format-string error-format-string -; :format-arguments args)) -; (let ((e-d (find-internal-error-data error-name error-format-string))) -; (if e-d -; (let ((condition-name (car e-d))) -; (apply #'error condition-name -; :function-name function-name -; (let ((k-a (mapcan #'list (cdr e-d) args))) -; (if (simple-condition-class-p condition-name) -; (list* :format-string error-format-string -; :format-arguments args -; k-a) -; k-a)))) -; (error 'internal-simple-error :function-name function-name -; :format-string error-format-string :format-arguments args))))) - (defun clcs-universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args) + (declare (ignore function-name)) (let ((e-d (find-internal-error-data error-name))) - (if e-d - (let ((condition-name (car e-d))) - (if correctable - (with-simple-restart - (continue "~a" (apply #'format nil continue-format-string args)) - (apply #'error condition-name - :function-name function-name - (let ((k-a (mapcan #'list (cdr e-d) args))) - (if (simple-condition-class-p condition-name) - (list* :format-string error-format-string - :format-arguments args - k-a) - k-a)))) - (apply #'error condition-name - :function-name function-name - (let ((k-a (mapcan #'list (cdr e-d) args))) - (if (simple-condition-class-p condition-name) - (list* :format-string error-format-string - :format-arguments args - k-a) - k-a))))) - (error 'internal-simple-error :function-name function-name - :format-string error-format-string :format-arguments args)))) - -(defun set-internal-error (error-keyword error-format condition-name - &rest keyword-list) -; (setf (find-internal-error-data error-keyword error-format) - (setf (find-internal-error-data error-keyword) + (when e-d + (progn + (when (keywordp (car e-d)) + (setf e-d (cdr e-d))) + (let ((condition-name (car e-d))) + (if correctable + (with-simple-restart + (continue "~a" (apply #'format nil continue-format-string args)) + (apply #'error condition-name + (let ((k-a (mapcan #'list (cdr e-d) args))) + (if (simple-condition-class-p condition-name) + (list* :format-string error-format-string + :format-arguments args + k-a) + k-a)))) + (apply #'error condition-name + (let ((k-a (mapcan #'list (cdr e-d) args))) + (if (simple-condition-class-p condition-name) + (list* :format-string error-format-string + :format-arguments args + k-a) + k-a))))))) + (error "Error in error-handler: (universal-error-handler ~s ~s ~s ~s ~s ~s)" + error-name correctable function-name continue-format-string error-format-string args))) + +(defun set-internal-error (condition-name &rest keyword-list) + (setf (find-internal-error-data condition-name) (cons condition-name keyword-list))) (defun initialize-internal-error-table () (declare (special *internal-error-list*)) (clrhash *internal-error-table*) (dolist (error-data *internal-error-list*) - (apply #'set-internal-error (cdr error-data)))) + (apply #'set-internal-error error-data))) (defparameter *internal-error-list* - '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S." - internal-type-error :datum :expected-type) - ("FEpackage_error" :package-error "A package error occurred on ~S: ~S." - internal-package-error :package :message) ; || |top - base| - ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." - internal-simple-program-error) ; || |top - base| -; ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." -; internal-simple-control-error) ; || |args| - ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." - internal-simple-program-error) ; || |top - base| -; ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." -; internal-simple-control-error) ; || |args| - ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." - internal-simple-program-error) ; || - ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." - internal-simple-program-error) ; || |key| - ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." - internal-unbound-variable :name) ; |sym| - ("FEundefined_function" :undefined-function "The function ~S is undefined." - internal-undefined-function :name) - ("FEinvalid_function" :invalid-function "~S is invalid as a function." - internal-type-error) ; |obj| - ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ -but only ~R ~:*~[were~;was~:;were~] supplied." - internal-simple-program-error) ; || |n| |top - base| -; ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ -;but ~R ~:*~[were~;was~:;were~] supplied." -; internal-simple-program-error) ; || |n| |top - base| - ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." - internal-simple-control-error) - ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." - internal-simple-control-error) - ("keyword_value_mismatch" :error "Keywords and values do not match." - internal-simple-program-error) ;?? - ("not_a_keyword" :error "~S is not a keyword." - internal-simple-program-error) ;?? - ("illegal_declare" :invalid-form "~S is an illegal declaration form." - internal-simple-program-error) - ("not_a_symbol" :invalid-variable "~S is not a symbol." - internal-simple-error) ;?? - ("not_a_variable" :invalid-variable "~S is not a variable." - internal-simple-program-error) - ("illegal_index" :error "~S is an illegal index to ~S." - internal-simple-error) - ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" - internal-simple-control-error) - ("end_of_stream" :error "Unexpected end of ~S." - internal-end-of-file :stream) - ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." - internal-simple-control-error) - ("open_stream" :error "The file ~A already exists." - internal-simple-file-error :pathname) - ("open_stream" :error "Cannot append to the file ~A." - internal-simple-file-error :pathname) - ("open_stream" :error "~S is an illegal IF-EXISTS option." - internal-simple-control-error) - ("close_stream" :error "Cannot close the standard output." - internal-simple-stream-error) ; no stream here!! - ("close_stream" :error "Cannot close the standard input." - internal-simple-stream-error) ; no stream here!! - ("too_long_file_name" :error "~S is a too long file name." - internal-simple-file-error :pathname) - ("cannot_open" :error "Cannot open the file ~A." - internal-simple-file-error :pathname) - ("cannot_create" :error "Cannot create the file ~A." - internal-simple-file-error :pathname) - ("cannot_read" :error "Cannot read the stream ~S." - internal-simple-stream-error :stream) - ("cannot_write" :error "Cannot write to the stream ~S." - internal-simple-stream-error :stream) - )) + '((division-by-zero :operands) + (type-error :datum :expected-type) + (end-of-file :stream) + (unbound-slot :instance) + (print-not-readable :object) + (arithmetic-error :operation :operands) + (unbound-variable :name) + (undefined-function :name) + (cell-error :name) + (package-error :package) + (file-error :pathname) + (simple-type-error :format-string :format-arguments) + (simple-error :format-string :format-arguments) + (stream-error :stream) + (:simple-stream-error conditions::simple-stream-error) + (:simple-package-error conditions::simple-package-error) + (:simple-storage-condition conditions::simple-storage-condition) + (:simple-program-error conditions::simple-program-error) + (:simple-control-error conditions::simple-control-error) + (:simple-parse-error conditions::simple-parse-error) + (:simple-reader-error conditions::simple-reader-error))) (initialize-internal-error-table) @@ -178,14 +102,12 @@ cond)))) (eval-when (compile load eval) - -(defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties - (setf (symbol-function symbol) (symbol-function symbol))) - -(reset-function 'si::error-set) -(reset-function 'load) -(reset-function 'open) -) + (defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties + (setf (symbol-function symbol) (symbol-function symbol))) + + (reset-function 'si::error-set) + (reset-function 'load) + (reset-function 'open)) (setq compiler::*compiler-break-enable* t) diff -uNr TEST.gcl/gcl/clcs/macros.lisp agcl/agcl/clcs/macros.lisp --- TEST.gcl/gcl/clcs/macros.lisp Tue Oct 22 23:42:04 2002 +++ agcl/agcl/clcs/macros.lisp Tue Nov 5 15:16:37 2002 @@ -1,178 +1,177 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(IN-PACKAGE "CONDITIONS") +(in-package "conditions") -(EVAL-WHEN (EVAL COMPILE LOAD) +(eval-when (eval compile load) -(DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P) - (DO ((L '()) - (C CASES (CDR C))) - ((NULL C) (NREVERSE L)) - (LET ((KEYS (CAAR C))) - (COND ((ATOM KEYS) - (COND ((NULL KEYS)) - ((MEMBER KEYS '(OTHERWISE T)) - (IF (NOT (MEMBER MACRO-NAME '( ECASE CCASE ETYPECASE CTYPECASE))) - (ERROR "OTHERWISE is not allowed in ~S expressions." MACRO-NAME)) - (PUSH (LIST KEYS) L)) - (T (PUSH KEYS L)))) - (LIST-IS-ATOM-P - (PUSH KEYS L)) - (T (DOLIST (KEY KEYS) (PUSH KEY L))))))) -);NEHW-LAVE - -;(DEFUN ESCAPE-SPECIAL-CASES (CASES) -; (DO ((L '()) -; (C CASES (CDR C))) -; ((NULL C) (NREVERSE L)) -; (LET ((KEYS (CAAR C))) -; (COND ((ATOM KEYS) -; (COND ((NULL KEYS)) -; ((MEMBER KEYS '(OTHERWISE T)) -; (PUSH (CONS (LIST KEYS) (CDR (CAR C))) L)) -; (T (PUSH (CONS KEYS (CDR (CAR C))) L)))) -; (T -; (PUSH (CONS KEYS (CDR (CAR C))) L)))))) - -(DEFUN ESCAPE-SPECIAL-CASES-REPLACE (CASES) - (DO ((C CASES (CDR C))) - ((NULL C) CASES) - (LET ((KEYS (CAAR C))) - (IF (MEMBER KEYS '(OTHERWISE T)) - (RPLACA (CAR C) (LIST KEYS)))))) - -(DEFMACRO ECASE (KEYFORM &REST CASES) - (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL)) - (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES)) - (VAR (GENSYM))) - `(LET ((,VAR ,KEYFORM)) - (CASE ,VAR - ,@NCASES - (OTHERWISE - (ERROR 'CASE-FAILURE :NAME 'ECASE - :DATUM ,VAR - :EXPECTED-TYPE '(MEMBER ,@KEYS) - :POSSIBILITIES ',KEYS)))))) - -(DEFMACRO CCASE (KEYPLACE &REST CASES) - (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL)) - (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES)) - (TAG1 (GENSYM)) - (TAG2 (GENSYM))) - `(BLOCK ,TAG1 - (TAGBODY ,TAG2 - (RETURN-FROM ,TAG1 - (CASE ,KEYPLACE - ,@NCASES - (OTHERWISE - (RESTART-CASE (ERROR 'CASE-FAILURE - :NAME 'CCASE - :DATUM ,KEYPLACE - :EXPECTED-TYPE '(MEMBER ,@KEYS) - :POSSIBILITIES ',KEYS) - (STORE-VALUE (VALUE) - :REPORT (LAMBDA (STREAM) - (FORMAT STREAM "Supply a new value of ~S." - ',KEYPLACE)) - :INTERACTIVE READ-EVALUATED-FORM - (SETF ,KEYPLACE VALUE) - (GO ,TAG2)))))))))) - -(DEFMACRO ETYPECASE (KEYFORM &REST CASES) - (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T)) - (VAR (GENSYM))) - `(LET ((,VAR ,KEYFORM)) - (TYPECASE ,VAR - ,@CASES - (OTHERWISE - (ERROR 'CASE-FAILURE :NAME 'ETYPECASE - :DATUM ,VAR - :EXPECTED-TYPE '(OR ,@TYPES) - :POSSIBILITIES ',TYPES)))))) - -(DEFMACRO CTYPECASE (KEYPLACE &REST CASES) - (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T)) - (TAG1 (GENSYM)) - (TAG2 (GENSYM))) - `(BLOCK ,TAG1 - (TAGBODY ,TAG2 - (RETURN-FROM ,TAG1 - (TYPECASE ,KEYPLACE - ,@CASES - (OTHERWISE - (RESTART-CASE (ERROR 'CASE-FAILURE - :NAME 'CTYPECASE - :DATUM ,KEYPLACE - :EXPECTED-TYPE '(OR ,@TYPES) - :POSSIBILITIES ',TYPES) - (STORE-VALUE (VALUE) - :REPORT (LAMBDA (STREAM) - (FORMAT STREAM "Supply a new value of ~S." - ',KEYPLACE)) - :INTERACTIVE READ-EVALUATED-FORM - (SETF ,KEYPLACE VALUE) - (GO ,TAG2)))))))))) - -(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 accumulate-cases (macro-name cases list-is-atom-p) + (do ((l '()) + (c cases (cdr c))) + ((null c) (nreverse l)) + (let ((keys (caar c))) + (cond ((atom keys) + (cond ((null keys)) + ((member keys '(otherwise t)) + (if (not (member macro-name '( ecase ccase etypecase ctypecase))) + (error "OTHERWISE is not allowed in ~S expressions." macro-name)) + (push (list keys) l)) + (t (push keys l)))) + (list-is-atom-p + (push keys l)) + (t (dolist (key keys) (push key l)))))))) + +;(defun escape-special-cases (cases) +; (do ((l '()) +; (c cases (cdr c))) +; ((null c) (nreverse l)) +; (let ((keys (caar c))) +; (cond ((atom keys) +; (cond ((null keys)) +; ((member keys '(otherwise t)) +; (push (cons (list keys) (cdr (car c))) l)) +; (t (push (cons keys (cdr (car c))) l)))) +; (t +; (push (cons keys (cdr (car c))) l)))))) + +(defun escape-special-cases-replace (cases) + (do ((c cases (cdr c))) + ((null c) cases) + (let ((keys (caar c))) + (if (member keys '(otherwise t)) + (rplaca (car c) (list keys)))))) + +(defmacro ecase (keyform &rest cases) + (let ((keys (accumulate-cases 'ecase cases nil)) + (ncases (escape-special-cases-replace cases)) + (var (gensym))) + `(let ((,var ,keyform)) + (case ,var + ,@ncases + (otherwise + (error 'case-failure :name 'ecase + :datum ,var + :expected-type '(member ,@keys) + :possibilities ',keys)))))) + +(defmacro ccase (keyplace &rest cases) + (let ((keys (accumulate-cases 'ccase cases nil)) + (ncases (escape-special-cases-replace cases)) + (tag1 (gensym)) + (tag2 (gensym))) + `(block ,tag1 + (tagbody ,tag2 + (return-from ,tag1 + (case ,keyplace + ,@ncases + (otherwise + (restart-case (error 'case-failure + :name 'ccase + :datum ,keyplace + :expected-type '(member ,@keys) + :possibilities ',keys) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value of ~S." + ',keyplace)) + :interactive read-evaluated-form + (setf ,keyplace value) + (go ,tag2)))))))))) + +(defmacro etypecase (keyform &rest cases) + (let ((types (accumulate-cases 'etypecase cases t)) + (var (gensym))) + `(let ((,var ,keyform)) + (typecase ,var + ,@cases + (otherwise + (error 'case-failure :name 'etypecase + :datum ,var + :expected-type '(or ,@types) + :possibilities ',types)))))) + +(defmacro ctypecase (keyplace &rest cases) + (let ((types (accumulate-cases 'ctypecase cases t)) + (tag1 (gensym)) + (tag2 (gensym))) + `(block ,tag1 + (tagbody ,tag2 + (return-from ,tag1 + (typecase ,keyplace + ,@cases + (otherwise + (restart-case (error 'case-failure + :name 'ctypecase + :datum ,keyplace + :expected-type '(or ,@types) + :possibilities ',types) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value of ~S." + ',keyplace)) + :interactive read-evaluated-form + (setf ,keyplace value) + (go ,tag2)))))))))) + +(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.~ +(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))) - -(DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION) - (ERROR 'SIMPLE-TYPE-ERROR - :DATUM ASSERTION - :EXPECTED-TYPE NIL ; This needs some work in next revision. -kmp - :FORMAT-STRING "The assertion ~S failed." - :FORMAT-ARGUMENTS (LIST ASSERTION))) - -(DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS) - (LET ((TAG (GENSYM))) - `(TAGBODY ,TAG - (UNLESS ,TEST-FORM - (RESTART-CASE ,(IF DATUM - `(ERROR ,DATUM ,@ARGUMENTS) - `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM)) - (CONTINUE () - :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM)) - ,@(MAPCAR #'(LAMBDA (PLACE) - `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE))) - PLACES) - (GO ,TAG))))))) - -(DEFUN READ-EVALUATED-FORM () - (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%") - (LIST (EVAL (READ *QUERY-IO*)))) - -(DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING) - (LET ((TAG1 (GENSYM)) - (TAG2 (GENSYM))) - `(BLOCK ,TAG1 - (TAGBODY ,TAG2 - (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL)) - (RESTART-CASE ,(IF TYPE-STRING - `(ERROR "The value of ~S is ~S, ~ + 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))) + +(defun simple-assertion-failure (assertion) + (error 'simple-type-error + :datum assertion + :expected-type nil ; this needs some work in next revision. -kmp + :format-string "The assertion ~S failed." + :format-arguments (list assertion))) + +(defmacro assert (test-form &optional places datum &rest arguments) + (let ((tag (gensym))) + `(tagbody ,tag + (unless ,test-form + (restart-case ,(if datum + `(error ,datum ,@arguments) + `(simple-assertion-failure ',test-form)) + (continue () + :report (lambda (stream) (assert-report ',places stream)) + ,@(mapcar #'(lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places) + (go ,tag))))))) + +(defun read-evaluated-form () + (format *query-io* "~&Type a form to be evaluated:~%") + (list (eval (read *query-io*)))) + +(defmacro check-type (place type &optional type-string) + (let ((tag1 (gensym)) + (tag2 (gensym))) + `(block ,tag1 + (tagbody ,tag2 + (if (typep ,place ',type) (return-from ,tag1 nil)) + (restart-case ,(if type-string + `(error "The value of ~S is ~S, ~ which is not ~A." - ',PLACE ,PLACE ,TYPE-STRING) - `(ERROR "The value of ~S is ~S, ~ + ',place ,place ,type-string) + `(error "The value of ~S is ~S, ~ which is not of type ~S." - ',PLACE ,PLACE ',TYPE)) - (STORE-VALUE (VALUE) - :REPORT (LAMBDA (STREAM) - (FORMAT STREAM "Supply a new value of ~S." - ',PLACE)) - :INTERACTIVE READ-EVALUATED-FORM - (SETF ,PLACE VALUE) - (GO ,TAG2))))))) + ',place ,place ',type)) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value of ~S." + ',place)) + :interactive read-evaluated-form + (setf ,place value) + (go ,tag2))))))) diff -uNr TEST.gcl/gcl/clcs/package.lisp agcl/agcl/clcs/package.lisp --- TEST.gcl/gcl/clcs/package.lisp Wed Oct 9 05:46:33 2002 +++ agcl/agcl/clcs/package.lisp Tue Nov 5 20:19:42 2002 @@ -12,36 +12,36 @@ ;;; file will define a bunch of functions which work like a condition system. Redefining ;;; existing condition systems is beyond the goal of this implementation attempt. -(MAKE-PACKAGE "CONDITIONS" :USE '("LISP" #+lucid "LUCID-COMMON-LISP")) -(IN-PACKAGE "CONDITIONS" :USE '("LISP" #+lucid "LUCID-COMMON-LISP")) +;(make-package "CONDITIONS" :use '("LISP")) +(in-package "CONDITIONS" :use '("LISP")) #-(or lucid excl genera cmu ) -(SHADOW '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE - CTYPECASE ECASE CCASE)) +(shadow '(break error cerror warn check-type assert etypecase + ctypecase ecase ccase)) #+gcl -(EXPORT '(;; Shadowed symbols - BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE - CTYPECASE ECASE CCASE)) +(export '(;; shadowed symbols + break error cerror warn check-type assert etypecase + ctypecase ecase ccase)) -(EXPORT '(;; New symbols - *BREAK-ON-SIGNALS* *DEBUGGER-HOOK* SIGNAL - HANDLER-CASE HANDLER-BIND IGNORE-ERRORS DEFINE-CONDITION MAKE-CONDITION - WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND RESTART-NAME - RESTART-NAME FIND-RESTART COMPUTE-RESTARTS INVOKE-RESTART - INVOKE-RESTART-INTERACTIVELY ABORT CONTINUE MUFFLE-WARNING - STORE-VALUE USE-VALUE INVOKE-DEBUGGER RESTART CONDITION - WARNING SERIOUS-CONDITION SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-ERROR - SIMPLE-CONDITION-FORMAT-STRING SIMPLE-CONDITION-FORMAT-ARGUMENTS - STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED TYPE-ERROR - TYPE-ERROR-DATUM TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR - PROGRAM-ERROR CONTROL-ERROR STREAM-ERROR STREAM-ERROR-STREAM - END-OF-FILE FILE-ERROR FILE-ERROR-PATHNAME CELL-ERROR - UNBOUND-VARIABLE UNDEFINED-FUNCTION ARITHMETIC-ERROR - ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS - PACKAGE-ERROR PACKAGE-ERROR-PACKAGE - DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW)) +(export '(;; new symbols + *break-on-signals* *debugger-hook* signal + handler-case handler-bind ignore-errors define-condition make-condition + with-simple-restart restart-case restart-bind restart-name + restart-name find-restart compute-restarts invoke-restart + invoke-restart-interactively abort continue muffle-warning + store-value use-value invoke-debugger restart condition + warning serious-condition simple-condition simple-warning simple-error + simple-condition-format-string simple-condition-format-arguments + storage-condition stack-overflow storage-exhausted type-error + type-error-datum type-error-expected-type simple-type-error + program-error control-error stream-error stream-error-stream + end-of-file file-error file-error-pathname cell-error + unbound-variable undefined-function arithmetic-error + arithmetic-error-operation arithmetic-error-operands + package-error package-error-package + division-by-zero floating-point-overflow floating-point-underflow)) -(DEFVAR *THIS-PACKAGE* (FIND-PACKAGE "CONDITIONS")) +(defvar *this-package* (find-package "CONDITIONS")) diff -uNr TEST.gcl/gcl/clcs/precom.lisp agcl/agcl/clcs/precom.lisp --- TEST.gcl/gcl/clcs/precom.lisp Mon Dec 6 23:43:55 1999 +++ agcl/agcl/clcs/precom.lisp Tue Nov 5 15:16:37 2002 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) +(in-package "CONDITIONS" :use '("LISP" "PCL")) #+pcl (pcl::precompile-random-code-segments clcs) diff -uNr TEST.gcl/gcl/clcs/restart.lisp agcl/agcl/clcs/restart.lisp --- TEST.gcl/gcl/clcs/restart.lisp Fri Oct 25 00:10:45 2002 +++ agcl/agcl/clcs/restart.lisp Fri Nov 8 19:18:01 2002 @@ -1,212 +1,254 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- -(IN-PACKAGE "CONDITIONS") +(in-package "CONDITIONS") ;;; Unique Ids -(DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE)) -(DEFVAR *UNIQUE-ID-COUNT* -1) +(defvar *unique-id-table* (make-hash-table)) +(defvar *unique-id-count* -1) -(DEFUN UNIQUE-ID (OBJ) +(defun unique-id (obj) "Generates a unique integer ID for its argument." - (OR (GETHASH OBJ *UNIQUE-ID-TABLE*) - (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*)))) + (or (gethash obj *unique-id-table*) + (setf (gethash obj *unique-id-table*) (incf *unique-id-count*)))) ;;; Miscellaneous Utilities -(EVAL-WHEN (EVAL COMPILE LOAD) +(eval-when (eval compile load) -(DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS) - (DO ((L LIST (CDDR L)) - (K '() (LIST* (CADR L) (CAR L) K))) - ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS))) - (VALUES (NREVERSE K) L)))) - -(DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS) - (LET ((TEMP (MEMBER '&REST NAMES))) - (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is ~:[missing~;misplaced~]." TEMP)) - (LET ((KEY-VARS (LDIFF NAMES TEMP)) - (KEY-VAR (OR KEYWORDS-VAR (GENSYM))) - (REST-VAR (CADR TEMP))) - (LET ((KEYWORDS (MAPCAR #'(LAMBDA (X) (INTERN (STRING X) (FIND-PACKAGE "KEYWORD"))) - KEY-VARS))) - `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR) - (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS) - (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD))) - KEY-VARS KEYWORDS) - ,@FORMS)))))) - -);NEHW-LAVE + (defun parse-keyword-pairs (list keys) + (do ((l list (cddr l)) + (k '() (list* (cadr l) (car l) k))) + ((or (null l) (not (member (car l) keys))) + (values (nreverse k) l)))) + + (defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms) + (let ((temp (member '&rest names))) + (unless (= (length temp) 2) (error "&REST keyword is ~:[missing~;misplaced~]." temp)) + (let ((key-vars (ldiff names temp)) + (key-var (or keywords-var (gensym))) + (rest-var (cadr temp))) + (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD"))) + key-vars))) + `(multiple-value-bind (,key-var ,rest-var) + (parse-keyword-pairs ,expression ',keywords) + (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword))) + key-vars keywords) + ,@forms))))))) ;;; Restarts -(DEFVAR *RESTART-CLUSTERS* '()) +(defvar *restart-clusters* '()) -; FIXME add condition support -(DEFUN COMPUTE-RESTARTS (&optional condition) - #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts)) - #-kcl (mapcan #'copy-list *RESTART-CLUSTERS*)) - -(DEFUN RESTART-PRINT (RESTART STREAM DEPTH) - (DECLARE (IGNORE DEPTH)) - (IF *PRINT-ESCAPE* - (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART)) - (RESTART-REPORT RESTART STREAM))) - -(DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT)) - NAME - FUNCTION - REPORT-FUNCTION - INTERACTIVE-FUNCTION) +;added support for optional condition arg - prw 7.11.2002 +(defun compute-restarts (&optional condition) + (if condition + (nconc (remove-if-not #'(lambda (restart) + (funcall (restart-test-function restart) condition)) + (mapcan #'copy-list *restart-clusters*)) + (remove-if-not #'(lambda (restart) + (funcall (restart-test-function restart) condition)) + (kcl-top-restarts))) + (nconc (mapcan #'copy-list *restart-clusters*) (kcl-top-restarts)))) + -#+kcl -(progn -(defvar *kcl-top-restarts* nil) +(defun restart-print (restart stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<~S.~D>" (type-of restart) (unique-id restart)) + (restart-report restart stream))) + +(defstruct (restart (:print-function restart-print)) + name + function + report-function + (test-function #'(lambda (c) (declare (ignore c)) t)) ;by default a restart applies to any condition + interactive-function) -(defun make-kcl-top-restart (quit-tag) - (make-restart :name 'abort - :function #'(lambda () (throw (car (list quit-tag)) quit-tag)) - :report-function - #'(lambda (stream) - (let ((b-l (if (eq quit-tag si::*quit-tag*) - si::*break-level* +(progn + (defvar *kcl-top-restarts* nil) + + (defun make-kcl-top-restart (quit-tag) + (make-restart :name 'abort + :function #'(lambda () (throw (car (list quit-tag)) quit-tag)) + :report-function + #'(lambda (stream) + (let ((b-l (if (eq quit-tag si::*quit-tag*) + si::*break-level* (car (or (find quit-tag si::*quit-tags* :key #'cdr) '(:not-found)))))) - (cond ((eq b-l :not-found) - (format stream "Return to ? level.")) - ((null b-l) - (format stream "Return to top level.")) - (t - (format stream "Return to break level ~D." - (length b-l)))))) - :interactive-function nil)) - -(defun find-kcl-top-restart (quit-tag) - (cdr (or (assoc quit-tag *kcl-top-restarts*) - (car (push (cons quit-tag (make-kcl-top-restart quit-tag)) - *kcl-top-restarts*))))) - -(defun kcl-top-restarts () - (let* ((old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e)))) - si::*quit-tags*)) - (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags)) - (restarts (mapcar #'find-kcl-top-restart tags))) - (setq *kcl-top-restarts* (mapcar #'cons tags restarts)) - restarts)) -) - -(DEFUN RESTART-REPORT (RESTART STREAM) - (FUNCALL (OR (RESTART-REPORT-FUNCTION RESTART) - (LET ((NAME (RESTART-NAME RESTART))) - #'(LAMBDA (STREAM) - (IF NAME (FORMAT STREAM "~S" NAME) - (FORMAT STREAM "~S" RESTART))))) - STREAM)) - -(DEFMACRO RESTART-BIND (BINDINGS &BODY FORMS) - `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING) - `(MAKE-RESTART - :NAME ',(CAR BINDING) - :FUNCTION ,(CADR BINDING) - ,@(CDDR BINDING))) - BINDINGS)) - *RESTART-CLUSTERS*))) - ,@FORMS)) - -(DEFUN FIND-RESTART (NAME &optional condition) -;FIXME add condition support - (declare (ignore condition)) - (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*) - (DOLIST (RESTART RESTART-CLUSTER) - (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) - (RETURN-FROM FIND-RESTART RESTART)))) - #+kcl - (let ((RESTART-CLUSTER (kcl-top-restarts))) - (DOLIST (RESTART RESTART-CLUSTER) - (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) - (RETURN-FROM FIND-RESTART RESTART))))) + (cond ((eq b-l :not-found) + (format stream "Return to ? level.")) + ((null b-l) + (format stream "Return to top level.")) + (t + (format stream "Return to break level ~D." + (length b-l)))))) + :interactive-function nil + :test-function #'(lambda (condition) + (member (find-class 'error) + (class-precedence-list (class-of condition)) + :test #'eq)))) + + (defun find-kcl-top-restart (quit-tag) + (cdr (or (assoc quit-tag *kcl-top-restarts*) + (car (push (cons quit-tag (make-kcl-top-restart quit-tag)) + *kcl-top-restarts*))))) + + (defun kcl-top-restarts () + (let* ((old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e)))) + si::*quit-tags*)) + (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags)) + (restarts (mapcar #'find-kcl-top-restart tags))) + (setq *kcl-top-restarts* (mapcar #'cons tags restarts)) + restarts))) + +(defun restart-report (restart stream) + (funcall (or (restart-report-function restart) + (let ((name (restart-name restart))) + #'(lambda (stream) + (if name (format stream "~S" name) + (format stream "~S" restart))))) + stream)) + +(defmacro restart-bind (bindings &body forms) + `(let ((*restart-clusters* (cons (list ,@(mapcar #'(lambda (binding) + `(make-restart + :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) + ,@forms)) + +(defun find-restart (name &optional condition) +;added support for condition argument - prw 7.11.2002 + (dolist (restart-cluster *restart-clusters*) + (dolist (restart restart-cluster) + (when (and (if condition (funcall (restart-test-function restart) condition) t) + (or (eq restart name) + (eq (restart-name restart) name))) + (return-from find-restart restart)))) + (let ((restart-cluster (kcl-top-restarts))) + (dolist (restart restart-cluster) + (when (and (if condition (funcall (restart-test-function restart) condition) t) + (or (eq restart name) + (eq (restart-name restart) name))) + (return-from find-restart restart))))) -(DEFUN INVOKE-RESTART (RESTART &REST VALUES) - (LET ((REAL-RESTART (OR (FIND-RESTART RESTART) - (ERROR "Restart ~S is not active." RESTART)))) - (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES))) - -(DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART) - (LET ((REAL-RESTART (OR (FIND-RESTART RESTART) - (ERROR "Restart ~S is not active." RESTART)))) - (APPLY (RESTART-FUNCTION REAL-RESTART) - (LET ((INTERACTIVE-FUNCTION - (RESTART-INTERACTIVE-FUNCTION REAL-RESTART))) - (IF INTERACTIVE-FUNCTION - (FUNCALL INTERACTIVE-FUNCTION) +(defun invoke-restart (restart &rest values) + (let ((real-restart (or (find-restart restart) + (error "Restart ~S is not active." restart)))) + (apply (restart-function real-restart) values))) + +(defun invoke-restart-interactively (restart) + (let ((real-restart (or (find-restart restart) + (error "Restart ~S is not active." restart)))) + (apply (restart-function real-restart) + (let ((interactive-function + (restart-interactive-function real-restart))) + (if interactive-function + (funcall interactive-function) '()))))) -(DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES) - (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE) - (LET ((RESULT '())) - (WHEN REPORT - (SETQ RESULT (LIST* (IF (STRINGP REPORT) - `#'(LAMBDA (STREAM) - (WRITE-STRING ,REPORT STREAM)) - `#',REPORT) - :REPORT-FUNCTION - RESULT))) - (WHEN INTERACTIVE - (SETQ RESULT (LIST* `#',INTERACTIVE - :INTERACTIVE-FUNCTION - RESULT))) - (NREVERSE RESULT)))) - (LET ((BLOCK-TAG (GENSYM)) - (TEMP-VAR (GENSYM)) - (DATA - (MAPCAR #'(LAMBDA (CLAUSE) - (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS) - (CDDR CLAUSE)) - (LIST (CAR CLAUSE) ;Name=0 - (GENSYM) ;Tag=1 - (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2 - :INTERACTIVE INTERACTIVE) - (CADR CLAUSE) ;BVL=3 - FORMS))) ;Body=4 - CLAUSES))) - `(BLOCK ,BLOCK-TAG - (LET ((,TEMP-VAR NIL)) - (TAGBODY - (RESTART-BIND - ,(MAPCAR #'(LAMBDA (DATUM) - (LET ((NAME (NTH 0 DATUM)) - (TAG (NTH 1 DATUM)) - (KEYS (NTH 2 DATUM))) - `(,NAME #'(LAMBDA (&REST TEMP) - #+LISPM (SETQ TEMP (COPY-LIST TEMP)) - (SETQ ,TEMP-VAR TEMP) - (GO ,TAG)) - ,@KEYS))) - DATA) - (RETURN-FROM ,BLOCK-TAG ,EXPRESSION)) - ,@(MAPCAN #'(LAMBDA (DATUM) - (LET ((TAG (NTH 1 DATUM)) - (BVL (NTH 3 DATUM)) - (BODY (NTH 4 DATUM))) - (LIST TAG - `(RETURN-FROM ,BLOCK-TAG - (APPLY #'(LAMBDA ,BVL ,@BODY) - ,TEMP-VAR))))) - DATA))))))) - -(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 ABORT () (INVOKE-RESTART 'ABORT) - (ERROR 'ABORT-FAILURE)) -(DEFUN CONTINUE () (INVOKE-RESTART 'CONTINUE)) -(DEFUN MUFFLE-WARNING () (INVOKE-RESTART 'MUFFLE-WARNING)) -(DEFUN STORE-VALUE (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE)) -(DEFUN USE-VALUE (VALUE) (INVOKE-RESTART 'USE-VALUE VALUE)) +(defmacro restart-case (expression &body clauses) + (flet ((transform-keywords (&key report interactive) + (let ((result '())) + (when report + (setq result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setq result (list* `#',interactive + :interactive-function + result))) + (nreverse result)))) + (let ((block-tag (gensym)) + (temp-var (gensym)) + (data + (mapcar #'(lambda (clause) + (with-keyword-pairs ((report interactive &rest forms) + (cddr clause)) + (list (car clause) ;name=0 + (gensym) ;tag=1 + (transform-keywords :report report ;keywords=2 + :interactive interactive) + (cadr clause) ;bvl=3 + forms))) ;body=4 + clauses))) + `(block ,block-tag + (let ((,temp-var nil)) + (tagbody + (restart-bind + ,(mapcar #'(lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + #+lispm (setq temp (copy-list temp)) + (setq ,temp-var temp) + (go ,tag)) + ,@keys))) + data) + (return-from ,block-tag ,expression)) + ,@(mapcan #'(lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply #'(lambda ,bvl ,@body) + ,temp-var))))) + data))))))) + +(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)))) + +;added support for optional condition arg - prw 7.11.2002 +;abort and muffle-warning signal an error of type 'control-error +;if the restart for the specified condition can not be found. CLHS 9.2 +;the others return nil in that case. +(defun abort (&optional condition) + (let ((restart (find-restart 'abort condition))) + (if restart + (invoke-restart restart) + (error 'clcs::simple-control-error + :format-string "The ABORT restart for ~S could not be found." + :format-arguments (list (if condition condition 'unspecified-condition)))))) + +(defun continue (&optional condition) + (let ((restart (find-restart 'continue condition))) + (if restart + (invoke-restart restart) + nil))) + +(defun muffle-warning (&optional condition) + (let ((restart (find-restart 'muffle-warning condition))) + (if restart + (invoke-restart restart) + (error 'clcs::simple-control-error + :format-string "The MUFFLE-WARNING restart for ~S could not be found." + :format-arguments (list (if condition condition 'unspecified-condition)))))) + +(defun store-value (value &optional condition) + (let ((restart (find-restart 'store-value condition))) + (if restart + (invoke-restart restart value) + nil))) + + +(defun use-value (value &optional condition) + (let ((restart (find-restart 'use-value condition))) + (if restart + (invoke-restart restart value) + nil))) diff -uNr TEST.gcl/gcl/clcs/top-patches.lisp agcl/agcl/clcs/top-patches.lisp --- TEST.gcl/gcl/clcs/top-patches.lisp Mon Dec 6 23:43:55 1999 +++ agcl/agcl/clcs/top-patches.lisp Tue Nov 5 15:16:37 2002 @@ -13,33 +13,33 @@ (defvar *abort-restarts* nil) (defmacro with-clcs-break-level-bindings (&body forms) - `(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) - (debug-level *DEBUG-LEVEL*) - (*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) - (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) - (*DEBUG-ABORT* (FIND-RESTART 'ABORT)) - (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) - (IF (OR (NOT *DEBUG-CONTINUE*) - (NOT (EQ *DEBUG-CONTINUE* C))) - C NIL)) - (LET ((C (IF *DEBUG-RESTARTS* - (FIRST *DEBUG-RESTARTS*) NIL))) - (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) - (*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*)) + `(let* ((*debug-level* (1+ *debug-level*)) + (debug-level *debug-level*) + (*debug-restarts* (compute-restarts)) + (*number-of-debug-restarts* (length *debug-restarts*)) + (*debug-abort* (find-restart 'abort)) + (*debug-continue* (or (let ((c (find-restart 'continue))) + (if (or (not *debug-continue*) + (not (eq *debug-continue* c))) + c nil)) + (let ((c (if *debug-restarts* + (first *debug-restarts*) nil))) + (if (not (eq c *debug-abort*)) c nil)))) + (*debug-condition* (if (conditionp at) at *debug-condition*)) (*abort-restarts* (let ((abort-list nil)) - (dolist (restart *DEBUG-RESTARTS*) + (dolist (restart *debug-restarts*) (when (eq 'abort (restart-name restart)) (push restart abort-list))) (nreverse abort-list)))) ,@forms)) (defun clcs-break-level-invoke-restart (-) - (COND ((AND (PLUSP -) - (< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) - (LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*))) - (INVOKE-RESTART-INTERACTIVELY RESTART))) - (T - (FORMAT T "~&No such restart.")))) + (cond ((and (plusp -) + (< - (+ *number-of-debug-restarts* 1))) + (let ((restart (nth (- - 1) *debug-restarts*))) + (invoke-restart-interactively restart))) + (t + (format t "~&No such restart.")))) ;; From akcl-1-530, changes marked with ;*** (defun clcs-break-level (at &optional env) @@ -178,5 +178,4 @@ :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1 ") - (values) - ) + (values))