diff --git a/code/error.lisp b/code/error.lisp index a3bfce1988cff13c1ff3227f9edac8b83b20e214..4343dabae701dc522a2ba79bc435497ab5335978 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -1,11 +1,11 @@ -;;; -*- Package: conditions; Log: code.log -*- +;; -*- Package: conditions; Log: code.log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.47 1998/04/20 11:32:50 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.48 1998/07/13 17:44:41 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -435,6 +435,9 @@ ;;;; Condition reporting: +;;; 7/13/98 BUG? CPL is not sorted and results here depend on order of +;;; superclasses in define-condition call! + (defun %print-condition (s stream d) (declare (ignore d)) (if *print-escape* @@ -815,48 +818,8 @@ ;;;; Condition definitions. -;;; 4/18/98 pw wants to make format-control and format-arguments -;;; slots in the condition class so this facility is available -;;; for all conditions internally -- however, that presents an -;;; un-nice bootstrap problem. So, for now, lets have -;;; serious-condition-xxx so they are easy to grep and get the -;;; new stuff working, then change to just condition-format-control etc. -;;; -;;; On the other hand, we have these two classes serious-condition -;;; and simple-condition so that default report schemes can be different -;;; if desired. - -(defun serious-condition-printer (condition stream) - (apply #'format stream (serious-condition-format-control condition) - (serious-condition-format-arguments condition))) - -;;; The CLHS 9.1.3.1.5 says that the name of the containing function -;;; should generally not be mentioned in report printers assuming that -;;; the debugger will make that info available when appropriate. I (pw) -;;; do so here because many CMUCL error conditions were previously signaled -;;; using (error "format-string" (format-args..)) and thus invoking -;;; the simple-error system. Now that we are changing to providing -;;; the correct condition type, using this default reporter retains -;;; the familiar behavior. It is a candidate for change some day. -;;; Perhaps better would be do define subtypes of file-error and -;;; package-error with their own :report functions as is done in -;;; other places (debug-int format ...) - -(defun print-serious-condition (condition stream) - (format stream "~&~@<Error in function ~S: ~3i~:_~?~:>" - (condition-function-name condition) - (serious-condition-format-control condition) - (serious-condition-format-arguments condition))) - -(define-condition serious-condition (condition) - ((format-control :reader serious-condition-format-control - :initarg :format-control - :initform "") - (format-arguments :reader serious-condition-format-arguments - :initarg :format-arguments - :initform '())) - (:report print-serious-condition)) +(define-condition serious-condition (condition)()) (define-condition error (serious-condition) ()) diff --git a/code/filesys.lisp b/code/filesys.lisp index 5fd49228c850f19b51b1049987d7e608e00e381f..d3029276f942a6729a1cbe91df9aaec74bebe945 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.50 1998/05/05 00:14:35 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.51 1998/07/13 17:44:42 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -28,6 +28,11 @@ file-writable unix-namestring)) (in-package "LISP") +;;; A condition type of type FILE-ERROR that uses the simple-error +;;; reporting format. + +(define-condition simple-file-error (simple-condition file-error)()) + ;;;; Unix pathname host support. @@ -664,12 +669,12 @@ An error of type file-error is signalled if no such file exists, or the pathname is wild." (if (wild-pathname-p pathname) - (error 'file-error + (error 'simple-file-error :format-control "Bad place for a wild pathname." :pathname pathname) (let ((result (probe-file pathname))) (unless result - (error 'file-error + (error 'simple-file-error :pathname pathname :format-control "The file ~S does not exist." :format-arguments (list (namestring pathname)))) @@ -683,7 +688,7 @@ "Return a pathname which is the truename of the file if it exists, NIL otherwise. An error of type file-error is signaled if pathname is wild." (if (wild-pathname-p pathname) - (error 'file-error + (error 'simple-file-error :pathname pathname :format-control "Bad place for a wild pathname.") (let ((namestring (unix-namestring pathname t))) @@ -708,7 +713,7 @@ (new-name (merge-pathnames new-name original)) (new-namestring (unix-namestring new-name nil))) (unless new-namestring - (error 'file-error + (error 'simple-file-error :pathname new-name :format-control "~S can't be created." :format-arguments (list new-name))) @@ -716,7 +721,7 @@ (unix:unix-rename original-namestring new-namestring) (unless res - (error 'file-error + (error 'simple-file-error :pathname new-name :format-control "Failed to rename ~A to ~A: ~A" :format-arguments (list original new-name @@ -735,14 +740,14 @@ (when (streamp file) (close file :abort t)) (unless namestring - (error 'file-error + (error 'simple-file-error :pathname file :format-control "~S doesn't exist." :format-arguments (list file))) (multiple-value-bind (res err) (unix:unix-unlink namestring) (unless res - (error 'file-error + (error 'simple-file-error :pathname namestring :format-control "Could not delete ~A: ~A." :format-arguments (list namestring @@ -766,7 +771,7 @@ "Return file's creation date, or NIL if it doesn't exist. An error of type file-error is signaled if file is a wild pathname" (if (wild-pathname-p file) - (error 'file-error + (error 'simple-file-error :pathname file :format-control "Bad place for a wild pathname.") (let ((name (unix-namestring file t))) @@ -785,12 +790,12 @@ determined. Signals an error of type file-error if file doesn't exist, or file is a wild pathname." (if (wild-pathname-p file) - (error 'file-error + (error 'simple-file-error :pathname file "Bad place for a wild pathname.") (let ((name (unix-namestring (pathname file) t))) (unless name - (error 'file-error + (error 'simple-file-error :pathname file :format-control "~S doesn't exist." :format-arguments (list file))) @@ -1216,7 +1221,7 @@ pathname)) (created-p nil)) (when (wild-pathname-p pathname) - (error 'file-error + (error 'simple-file-error :format-control "Bad place for a wild pathname." :pathname pathspec)) (enumerate-search-list (pathname pathname) @@ -1233,7 +1238,7 @@ namestring)) (unix:unix-mkdir namestring mode) (unless (probe-file namestring) - (error 'file-error + (error 'simple-file-error :pathname pathspec :format-control "Can't create directory ~A." :format-arguments (list namestring))) diff --git a/code/package.lisp b/code/package.lisp index 975f5e74dfd628de5f3e600c5b6086a618553d77..e8f6628c334d8e116b71357c571ba5d7535a62f8 100644 --- a/code/package.lisp +++ b/code/package.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.48 1998/05/15 11:43:24 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.49 1998/07/13 17:44:42 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -38,6 +38,9 @@ "The list of packages to use by default of no :USE argument is supplied to MAKE-PACKAGE or other package creation forms.") +;;; INTERNAL conditions +(define-condition simple-package-error (simple-condition package-error)()) +(define-condition simple-program-error (simple-condition program-error)()) (defstruct (package (:constructor internal-make-package) @@ -774,7 +777,7 @@ :internal-symbols (or size 10) :external-symbols (length exports)))))) (unless (string= (the string (package-name package)) name) - (error 'package-error + (error 'simple-package-error :package name :format-control "~A is a nick-name for the package ~A" :format-arguments (list name (package-name name)))) @@ -835,7 +838,7 @@ symbol) (t (with-simple-restart (continue "INTERN it.") - (error 'package-error + (error 'simple-package-error :package package :format-control "~A does not contain a symbol ~A" :format-arguments (list (package-name package) name))) @@ -935,7 +938,7 @@ (let ((package (find-package name))) (unless package (with-simple-restart (continue "Make this package.") - (error 'package-error + (error 'simple-package-error :package name :format-control "The package named ~S doesn't exist." :format-arguments (list name))) @@ -972,7 +975,7 @@ (find-package package-or-name)))) (cond ((not package) (with-simple-restart (continue "Return NIL") - (error 'package-error + (error 'simple-package-error :package package-or-name :format-control "No package of name ~S." :format-arguments (list package-or-name))) @@ -983,7 +986,7 @@ (when use-list (with-simple-restart (continue "Remove dependency in other packages.") - (error 'package-error + (error 'simple-package-error :package package :format-control "Package ~S is used by package(s):~% ~S" @@ -1221,7 +1224,7 @@ (when cset (restart-case (error - 'package-error + 'simple-package-error :package package :format-control "Exporting these symbols from the ~A package:~%~S~%~ @@ -1249,7 +1252,7 @@ (with-simple-restart (continue "Import these symbols into the ~A package." (package-%name package)) - (error 'package-error + (error 'simple-package-error :package package :format-control "These symbols are not accessible in the ~A package:~%~S" @@ -1278,7 +1281,7 @@ (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((or (not w) (not (eq s sym))) - (error 'package-error + (error 'simple-package-error :package package :format-control "~S is not accessible in the ~A package." :format-arguments (list sym (package-%name package)))) @@ -1317,7 +1320,7 @@ (when cset (with-simple-restart (continue "Import these symbols with Shadowing-Import.") - (error 'package-error + (error 'simple-package-error :package package :format-control "Importing these symbols into the ~A package ~