Skip to content
Snippets Groups Projects
Commit 06be8c9a authored by pw's avatar pw
Browse files

Backout a previous hack of adding format-{control|arguments} protocol

to serious-condition. Instead, have new internal condition types
simple-package-error, simple-file-error and simple-program-error
which inherit from simple-condition and respective error condition,
thus picking up the format protocol from simple-condition.

Noted a probable bug in that the CPL for conditions is not sorted
which results in the found report method being dependent
on the order of super-classes specified in the call to define-condition.
parent 5339b590
No related branches found
No related tags found
No related merge requests found
;;; -*- 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) ())
......
......@@ -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)))
......
......@@ -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 ~
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment