diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 64bab9c885e0468d557302f303ab87912c3c1f59..69ac4021f446112af4877021fca4849c30a63e1f 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.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/defstruct.lisp,v 1.61 1998/03/21 08:11:53 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.62 1998/04/20 11:32:50 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -564,7 +564,9 @@ spec)) spec)) (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) - (error "Duplicate slot name ~S." name)) + (error 'program-error + :format-control "Duplicate slot name ~S." + :format-arguments (list name))) (setf (dsd-%name islot) (string name)) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) diff --git a/code/error.lisp b/code/error.lisp index a10c32e08f39680b9f89932007f00df72c8016f9..a3bfce1988cff13c1ff3227f9edac8b83b20e214 100644 --- a/code/error.lisp +++ b/code/error.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/error.lisp,v 1.46 1997/02/05 16:15:41 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.47 1998/04/20 11:32:50 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -815,8 +815,48 @@ ;;;; 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) ()) @@ -845,6 +885,8 @@ (simple-condition-format-arguments condition))) (define-condition simple-error (simple-condition error) () + ;; This is the condition type used by error and cerror when + ;; a format-control string is supplied as the first argument. (:report print-simple-error)) (define-condition storage-condition (serious-condition) ()) @@ -883,9 +925,9 @@ (define-condition program-error (error) ()) -(define-condition parse-error (error) ()) -(define-condition control-error (simple-error) ()) -(define-condition stream-error (error) +(define-condition parse-error (error) ()) +(define-condition control-error (error) ()) +(define-condition stream-error (error) ((stream :reader stream-error-stream :initarg :stream))) (define-condition end-of-file (stream-error) () diff --git a/code/filesys.lisp b/code/filesys.lisp index 2d1c14158ccbbe9935cf1ebeb162d696c4be1010..6aad47383d6521b25fccf607b2b3bd6a3c180206 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.46 1998/03/01 21:46:05 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.47 1998/04/20 11:32:51 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -661,11 +661,19 @@ ;;; (defun truename (pathname) "Return the pathname for the actual file described by the pathname - An error is signalled if no such file exists." - (let ((result (probe-file pathname))) - (unless result - (error "The file ~S does not exist." (namestring pathname))) - result)) + 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 + :format-control "Bad place for a wild pathname." + :pathname pathname) + (let ((result (probe-file pathname))) + (unless result + (error 'file-error + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list (namestring pathname)))) + result))) ;;; Probe-File -- Public ;;; @@ -673,15 +681,19 @@ ;;; (defun probe-file (pathname) "Return a pathname which is the truename of the file if it exists, NIL - otherwise." - (let ((namestring (unix-namestring pathname t))) - (when (and namestring (unix:unix-file-kind namestring)) - (let ((truename (unix:unix-resolve-links - (unix:unix-maybe-prepend-current-directory - namestring)))) - (when truename - (let ((*ignore-wildcards* t)) - (pathname (unix:unix-simplify-pathname truename)))))))) + otherwise. An error of type file-error is signaled if pathname is wild." + (if (wild-pathname-p pathname) + (error 'file-error + :pathname pathname + :format-control "Bad place for a wild pathname.") + (let ((namestring (unix-namestring pathname t))) + (when (and namestring (unix:unix-file-kind namestring)) + (let ((truename (unix:unix-resolve-links + (unix:unix-maybe-prepend-current-directory + namestring)))) + (when truename + (let ((*ignore-wildcards* t)) + (pathname (unix:unix-simplify-pathname truename))))))))) ;;;; Other random operations. @@ -696,13 +708,19 @@ (new-name (merge-pathnames new-name original)) (new-namestring (unix-namestring new-name nil))) (unless new-namestring - (error "~S can't be created." new-name)) + (error 'file-error + :pathname new-name + :format-control "~S can't be created." + :format-arguments (list new-name))) (multiple-value-bind (res error) (unix:unix-rename original-namestring new-namestring) (unless res - (error "Failed to rename ~A to ~A: ~A" - original new-name (unix:get-unix-error-msg error))) + (error 'file-error + :pathname new-name + :format-control "Failed to rename ~A to ~A: ~A" + :format-arguments (list original new-name + (unix:get-unix-error-msg error)))) (when (streamp file) (file-name file new-namestring)) (values new-name original (truename new-name))))) @@ -717,13 +735,18 @@ (when (streamp file) (close file :abort t)) (unless namestring - (error "~S doesn't exist." file)) + (error '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 "Could not delete ~A: ~A." - namestring - (unix:get-unix-error-msg err))))) + (error 'file-error + :pathname namestring + :format-control "Could not delete ~A: ~A." + :format-arguments (list namestring + (unix:get-unix-error-msg err)))))) t) @@ -740,29 +763,41 @@ ;;; File-Write-Date -- Public ;;; (defun file-write-date (file) - "Return file's creation date, or NIL if it doesn't exist." - (let ((name (unix-namestring file t))) - (when name - (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime)))))) + "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 + :pathname file + :format-control "Bad place for a wild pathname.") + (let ((name (unix-namestring file t))) + (when name + (multiple-value-bind + (res dev ino mode nlink uid gid rdev size atime mtime) + (unix:unix-stat name) + (declare (ignore dev ino mode nlink uid gid rdev size atime)) + (when res + (+ unix-to-universal-time mtime))))))) ;;; File-Author -- Public ;;; (defun file-author (file) "Returns the file author as a string, or nil if the author cannot be - determined. Signals an error if file doesn't exist." - (let ((name (unix-namestring (pathname file) t))) - (unless name - (error "~S doesn't exist." file)) - (multiple-value-bind (winp dev ino mode nlink uid) - (unix:unix-stat name) - (declare (ignore dev ino mode nlink)) - (if winp (lookup-login-name uid))))) - + 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 + :pathname file + "Bad place for a wild pathname.") + (let ((name (unix-namestring (pathname file) t))) + (unless name + (error 'file-error + :pathname file + :format-control "~S doesn't exist." + :format-arguments (list file))) + (multiple-value-bind (winp dev ino mode nlink uid) + (unix:unix-stat name) + (declare (ignore dev ino mode nlink)) + (if winp (lookup-login-name uid)))))) ;;;; DIRECTORY. @@ -1181,7 +1216,9 @@ pathname)) (created-p nil)) (when (wild-pathname-p pathname) - (error (make-condition 'file-error :pathname pathspec))) + (error 'file-error + :format-control "Bad place for a wild pathname." + :pathname pathspec)) (enumerate-search-list (pathname pathname) (let ((dir (pathname-directory pathname))) (loop for i from 1 upto (length dir) @@ -1196,8 +1233,10 @@ namestring)) (unix:unix-mkdir namestring mode) (unless (probe-file namestring) - (error (make-condition 'file-error - :pathname pathspec))) + (error 'file-error + :pathname pathspec + :format-control "Can't create directory ~A." + :format-arguments (list namestring)))) (setf created-p t))))) ;; Only the first path in a search-list is considered. (return (values pathname created-p)))))) diff --git a/code/package.lisp b/code/package.lisp index 4445aed36867e213603ca50c128b0c79869ca304..1ffdd556c7ecb679c9cbebd0964a9fca49f42752 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.41 1998/03/01 21:46:13 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.42 1998/04/20 11:32:52 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -507,18 +507,24 @@ (:internal `(let ((,symbols (package-internal-symbols (car ,',packages)))) - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols)))) + (when ,symbols + (setf ,',vector (package-hashtable-table ,symbols)) + (setf ,',hash-vector (package-hashtable-hash ,symbols))))) (:external `(let ((,symbols (package-external-symbols (car ,',packages)))) - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols)))) + (when ,symbols + (setf ,',vector (package-hashtable-table ,symbols)) + (setf ,',hash-vector + (package-hashtable-hash ,symbols))))) (:inherited - `(let ((,symbols (package-external-symbols - (car ,',package-use-list)))) - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols)))))))) + `(let ((,symbols (and ,',package-use-list + (package-external-symbols + (car ,',package-use-list))))) + (when ,symbols + (setf ,',vector (package-hashtable-table ,symbols)) + (setf ,',hash-vector + (package-hashtable-hash ,symbols))))))))) (,end-test-macro (this-kind) `,(let ((next-kind (cadr (member this-kind ',ordered-types)))) @@ -529,12 +535,16 @@ (,',init-macro ,(car ',ordered-types))))))) (when ,packages ,(when (null symbol-types) - (error "Must supply at least one of :internal, :external, or ~ - :inherited.")) + (error 'program-error + :format-control + "Must supply at least one of :internal, :external, or ~ + :inherited.")) ,(dolist (symbol symbol-types) (unless (member symbol '(:internal :external :inherited)) - (error "~S is not one of :internal, :external, or :inherited." - symbol))) + (error 'program-error + :format-control + "~S is not one of :internal, :external, or :inherited." + :format-argument symbol))) (,init-macro ,(car ordered-types)) (flet ((,real-symbol-p (number) (> number 1))) @@ -592,7 +602,6 @@ (t (,',init-macro :inherited) (setf ,',counter nil))))))))))))) ,@body))))))) - ;;;; DEFPACKAGE: @@ -608,7 +617,7 @@ (:INTERN {symbol-name}*) (:EXPORT {symbol-name}*) (:DOCUMENTATION doc-string) - All options except :SIZE can be used multiple times." + All options except :SIZE and :DOCUMENTATION can be used multiple times." (let ((nicknames nil) (size nil) (shadows nil) @@ -623,20 +632,25 @@ (doc nil)) (dolist (option options) (unless (consp option) - (error "Bogus DEFPACKAGE option: ~S" option)) + (error 'program-error + :format-control "Bogus DEFPACKAGE option: ~S" + :format-arguments (list option))) (case (car option) (:nicknames (let ((new (stringify-names (cdr option) "package"))) (setf nicknames (append-unique new nicknames :nicknames)))) (:size (cond (size - (error "Can't specify :SIZE twice.")) + (error 'program-error + :format-control "Can't specify :SIZE twice.")) ((and (consp (cdr option)) (typep (second option) 'unsigned-byte)) (setf size (second option))) (t - (error "Bogus :SIZE, must be a positive integer: ~S" - (second option))))) + (error + 'program-error + :format-control "Bogus :SIZE, must be a positive integer: ~S" + :format-arguments (list (second option)))))) (:shadow (let ((new (stringify-names (cdr option) "symbol"))) (setf incomming (append-unique new incomming :shadow)) @@ -674,9 +688,14 @@ (setf outgoing (append-unique new outgoing :export)) (setf exports (append exports new)))) (:documentation + (when doc + (error 'program-error + :format-control "Can't specify :DOCUMENTATION twice.")) (setf doc (coerce (second option) 'simple-string))) (t - (error "Bogus DEFPACKAGE option: ~S" option)))) + (error 'program-error + :format-control "Bogus DEFPACKAGE option: ~S" + :format-arguments (list option))))) `(eval-when (compile load eval) (%defpackage ,(stringify-name package "package") ',nicknames ',size ',shadows ',shadowing-imports ',(if use-p use :default) @@ -719,8 +738,10 @@ :internal-symbols (or size 10) :external-symbols (length exports)))))) (unless (string= (the string (package-name package)) name) - (error "~A is a nick-name for the package ~A" - name (package-name name))) + (error 'package-error + :package name + :format-control "~A is a nick-name for the package ~A" + :format-arguments (list name (package-name name)))) (enter-new-nicknames package nicknames) ;; Shadows and Shadowing-imports. (let ((old-shadows (package-%shadowing-symbols package))) @@ -825,6 +846,7 @@ estimates for the number of internal and external symbols which will ultimately be present in the package." (when (find-package name) + ;; @@@ this is supposed to be a correctable error @@@ (error "A package named ~S already exists" name)) (let* ((name (package-namify name)) (package (internal-make-package @@ -1140,9 +1162,15 @@ (pushnew p cpackages)))))) (when cset (restart-case - (error "Exporting these symbols from the ~A package:~%~S~%~ - results in name conflicts with these packages:~%~{~A ~}" - (package-%name package) cset (mapcar #'package-%name cpackages)) + (error + 'package-error + :package package + :format-control + "Exporting these symbols from the ~A package:~%~S~%~ + results in name conflicts with these packages:~%~{~A ~}" + :format-arguments + (list (package-%name package) cset + (mapcar #'package-%name cpackages))) (unintern-conflicting-symbols () :report "Unintern conflicting symbols." (dolist (p cpackages) @@ -1186,8 +1214,10 @@ (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 "~S is not accessible in the ~A package." - sym (package-%name package))) + (error 'package-error + :package package + :format-control "~S is not accessible in the ~A package." + :format-arguments (list sym (package-%name package)))) ((eq w :external) (pushnew sym syms))))) (let ((internal (package-internal-symbols package))