From 9c701a9f04e48bc7d2dc55025cbe642050bab327 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Fri, 23 Aug 2002 18:31:06 +0000 Subject: [PATCH] Merged patches by Eric Marsden and Gerd Moellmann to improve error reporting in several places to be more specific and/or ANSI compliant. The patches have been modified to make use of the new common simple-programm-error function where applicable. --- code/defmacro.lisp | 21 ++++++++++--------- code/error.lisp | 19 ++++++++++-------- code/fd-stream.lisp | 20 +++++++++--------- code/symbol.lisp | 26 +++++++++++------------- code/type.lisp | 49 +++++++++++++++++++++++++++------------------ pcl/init.lisp | 22 ++++++++++---------- 6 files changed, 87 insertions(+), 70 deletions(-) diff --git a/code/defmacro.lisp b/code/defmacro.lisp index bb1de0f7c..144ed75da 100644 --- a/code/defmacro.lisp +++ b/code/defmacro.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/defmacro.lisp,v 1.21 2002/07/30 13:30:41 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.22 2002/08/23 18:31:04 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -93,7 +93,8 @@ ((atom list) nil) (when (eq (car list) '&whole) (return t))) (not (eq (car lambda-list) '&whole))) - (error "&Whole must appear first in ~S lambda-list." error-kind)) + (simple-program-error "&Whole must appear first in ~S lambda-list." + error-kind)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((atom rest-of-args) (cond ((null rest-of-args) nil) @@ -126,10 +127,11 @@ (defmacro-error "&WHOLE" error-kind name)))) ((eq var '&environment) (cond (env-illegal - (error "&Environment not valid with ~S." error-kind)) + (simple-program-error "&environment not valid with ~S." + error-kind)) ((not top-level) - (error "&Environment only valid at top level of ~ - lambda-list."))) + (simple-program-error + "&environment only valid at top level of lambda-list."))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setf rest-of-args (cdr rest-of-args)) (push-let-binding (car rest-of-args) env-arg-name nil) @@ -244,7 +246,7 @@ (:auxs (push-let-binding var nil nil)))) (t - (error "Non-symbol in lambda-list - ~S." var))))) + (simple-program-error "Non-symbol in lambda-list - ~S." var))))) ;; Generate code to check the number of arguments, unless dotted ;; in which case length will not work. (unless restp @@ -336,15 +338,16 @@ ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t - (error "Illegal optional variable name: ~S" value-var)))) + (simple-program-error "Illegal optional variable name: ~S" + value-var)))) (defun make-keyword (symbol) "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." (intern (symbol-name symbol) *keyword-package*)) (defun defmacro-error (problem kind name) - (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]." - problem kind name)) + (simple-program-error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]." + problem kind name)) diff --git a/code/error.lisp b/code/error.lisp index 48c631a23..e5a1f6dde 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.63 2002/08/22 22:23:29 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.64 2002/08/23 18:31:04 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -67,7 +67,7 @@ &body forms) (let ((temp (member '&rest names))) (unless (= (length temp) 2) - (error "&rest keyword is ~:[missing~;misplaced~]." temp)) + (simple-program-error "&rest keyword is ~:[missing~;misplaced~]." temp)) (let ((key-vars (ldiff names temp)) (key-var (or keywords-var (gensym))) (rest-var (cadr temp))) @@ -721,7 +721,8 @@ (do ((options (rest spec) (cddr options))) ((null options)) (unless (and (consp options) (consp (cdr options))) - (error "Malformed condition slot spec:~% ~S." spec)) + (simple-program-error "Malformed condition slot spec:~% ~S." + spec)) (let ((arg (second options))) (case (first options) (:reader (readers arg)) @@ -731,7 +732,8 @@ (writers `(setf ,arg))) (:initform (when initform-p - (error "More than one :INITFORM in:~% ~S" spec)) + (simple-program-error "More than one :INITFORM in:~% ~S" + spec)) (setq initform-p t) (setq initform arg)) (:initarg (initargs arg)) @@ -739,7 +741,8 @@ (setq allocation arg)) (:type) (t - (error "Unknown slot option:~% ~S" (first options)))))) + (simple-program-error "Unknown slot option:~% ~S" + (first options)))))) (all-readers (readers)) (all-writers (writers)) @@ -756,7 +759,7 @@ (dolist (option options) (unless (consp option) - (error "Bad option:~% ~S" option)) + (simple-program-error "Bad option:~% ~S" option)) (case (first option) (:documentation (setq documentation (second option))) (:report @@ -779,7 +782,7 @@ `#'(lambda () ,val)) default-initargs))))) (t - (error "Unknown option: ~S" (first option))))) + (simple-program-error "Unknown option: ~S" (first option))))) `(progn (eval-when (compile load eval) @@ -806,7 +809,7 @@ argument. The bindings are searched first to last in the event of a signalled condition." (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) - (error "Ill-formed handler bindings.")) + (simple-program-error "Ill-formed handler bindings.")) `(let ((*handler-clusters* (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index 415170504..73f040a03 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.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/fd-stream.lisp,v 1.60 2002/08/02 14:43:08 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.61 2002/08/23 18:31:05 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1045,9 +1045,9 @@ (declare (ignore ino nlink uid gid rdev atime mtime ctime blksize blocks)) (unless okay - (error "Error fstating ~S: ~A" - stream - (unix:get-unix-error-msg dev))) + (error 'simple-file-error + :format-control "Error fstating ~S: ~A" + :format-arguments (list stream (unix:get-unix-error-msg dev)))) (if (zerop mode) nil (truncate size (fd-stream-element-size stream))))) @@ -1371,16 +1371,18 @@ (okay (when (and output (= (logand orig-mode #o170000) #o40000)) - (error "Cannot open ~S for output: Is a directory." - namestring)) + (error 'simple-file-error + :format-control "Cannot open ~S for output: Is a directory." + :format-arguments (list namestring))) (setf mode (logand orig-mode #o777)) t) ((eql err/dev unix:enoent) nil) (t - (error "Cannot find ~S: ~A" - namestring - (unix:get-unix-error-msg err/dev)))))))) + (error 'simple-file-error + :format-control "Cannot find ~S: ~A" + :format-arguments + (list namestring (unix:get-unix-error-msg err/dev))))))))) (unless (and exists (do-old-rename namestring original)) (setf original nil) diff --git a/code/symbol.lisp b/code/symbol.lisp index 349e34f71..adf367692 100644 --- a/code/symbol.lisp +++ b/code/symbol.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/symbol.lisp,v 1.30 2002/07/22 17:05:47 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/symbol.lisp,v 1.31 2002/08/23 18:31:05 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -46,12 +46,12 @@ set to the specified new value." (declare (type symbol variable)) (cond ((null variable) - (error "Nihil ex nihil, can't set NIL.")) + (simple-program-error "Nihil ex nihil, can't set NIL.")) ((eq variable t) - (error "Veritas aeterna, can't set T.")) + (simple-program-error "Veritas aeterna, can't set T.")) ((and (boundp '*keyword-package*) (keywordp variable)) - (error "Can't set keywords.")) + (simple-program-error "Can't set keywords.")) (t (%set-symbol-value variable new-value)))) @@ -110,8 +110,8 @@ (do ((pl (symbol-plist symbol) (cddr pl))) ((atom pl) default) (cond ((atom (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) + (simple-program-error + "~S has an odd number of items in its property list." symbol)) ((eq (car pl) indicator) (return (cadr pl)))))) @@ -124,8 +124,8 @@ (list* indicator value (symbol-plist symbol))) value) (cond ((endp (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) + (simple-program-error + "~S has an odd number of items in its property list." symbol)) ((eq (car pl) indicator) (rplaca (cdr pl) value) (return value))))) @@ -142,8 +142,8 @@ (prev nil pl)) ((atom pl) nil) (cond ((atom (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) + (simple-program-error + "~S has an odd number of items in its property list." symbol)) ((eq (car pl) indicator) (cond (prev (rplacd (cdr prev) (cddr pl))) (t @@ -157,8 +157,7 @@ (do ((plist place (cddr plist))) ((null plist) default) (cond ((atom (cdr plist)) - (error "~S is a malformed property list." - place)) + (simple-program-error "~S is a malformed property list." place)) ((eq (car plist) indicator) (return (cadr plist)))))) @@ -179,8 +178,7 @@ (do ((plist place (cddr plist))) ((null plist) (values nil nil nil)) (cond ((atom (cdr plist)) - (error "~S is a malformed proprty list." - place)) + (simple-program-error "~S is a malformed property list." place)) ((memq (car plist) indicator-list) (return (values (car plist) (cadr plist) plist)))))) diff --git a/code/type.lisp b/code/type.lisp index 9861f4e6d..cc67bd01c 100644 --- a/code/type.lisp +++ b/code/type.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/type.lisp,v 1.41 2002/08/12 21:13:54 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.42 2002/08/23 18:31:05 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -340,7 +340,8 @@ (multiple-value-bind (required optional restp rest keyp keys allowp aux) (parse-lambda-list lambda-list) (when aux - (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) + (simple-program-error "&Aux in a FUNCTION or VALUES type: ~S." + lambda-list)) (setf (args-type-required result) (mapcar #'specifier-type required)) (setf (args-type-optional result) (mapcar #'specifier-type optional)) (setf (args-type-rest result) (if restp (specifier-type rest) nil)) @@ -348,10 +349,12 @@ (collect ((key-info)) (dolist (key keys) (when (or (atom key) (/= (length key) 2)) - (error "Keyword type description is not a two-list: ~S." key)) + (simple-program-error + "Keyword type description is not a two-list: ~S." key)) (let ((kwd (first key))) (when (find kwd (key-info) :key #'key-info-name) - (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) + (simple-program-error "Repeated keyword ~S in lambda list: ~S." + kwd lambda-list)) (key-info (make-key-info :name kwd :type (specifier-type (second key)))))) (setf (args-type-keywords result) (key-info))) @@ -885,7 +888,8 @@ (return-from values-specifier-type (make-unknown-type :specifier spec))) (t - (error "Bad thing to be a type specifier: ~S." spec))))))))) + (simple-program-error "Bad thing to be a type specifier: ~S." + spec))))))))) ;;; SPECIFIER-TYPE -- Interface @@ -896,7 +900,7 @@ (defun specifier-type (x) (let ((res (values-specifier-type x))) (when (values-type-p res) - (error "VALUES type illegal in this context:~% ~S" x)) + (simple-program-error "VALUES type illegal in this context:~% ~S" x)) res)) @@ -1419,7 +1423,8 @@ (make-numeric-type :complexp :complex)) (t (flet ((complex-type-error (type) - (error "Component type for Complex is not real: ~S." spec))) + (simple-program-error + "Component type for Complex is not real: ~S." spec))) (let* ((type (specifier-type spec)) (res (copy-numeric-type (cond ((numeric-type-p type) @@ -1463,7 +1468,8 @@ (and (consp ,x) (typep (car ,x) ',type) (null (cdr ,x)))) ,x) (t - (error "Bound is not *, a ~A or a list of a ~A: ~S" ',type ',type ,x)))) + (simple-program-error "Bound is not *, a ~A or a list of a ~A: ~S" + ',type ',type ,x)))) (def-type-translator integer (&optional low high) (let* ((l (check-bound low integer)) @@ -1471,7 +1477,8 @@ (h (check-bound high integer)) (hb (if (consp h) (1- (car h)) h))) (when (and hb lb (< hb lb)) - (error "Lower bound ~S is greater than upper bound ~S." l h)) + (simple-program-error + "Lower bound ~S is greater than upper bound ~S." l h)) (make-numeric-type :class 'integer :complexp :real :enumerable (not (null (and l h))) :low lb @@ -1479,7 +1486,7 @@ (deftype mod (n) (unless (and (integerp n) (> n 0)) - (error "Bad N specified for MOD type specifier: ~S." n)) + (simple-program-error "Bad N specified for MOD type specifier: ~S." n)) `(integer 0 ,(1- n))) (deftype signed-byte (&optional s) @@ -1488,14 +1495,16 @@ (let ((bound (ash 1 (1- s)))) `(integer ,(- bound) ,(1- bound)))) (t - (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + (simple-program-error + "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) (deftype unsigned-byte (&optional s) (cond ((eq s '*) '(integer 0)) ((and (integerp s) (> s 0)) `(integer 0 ,(1- (ash 1 s)))) (t - (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) + (simple-program-error + "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) (defmacro def-bounded-type (type class format) @@ -1503,7 +1512,8 @@ (let ((lb (check-bound low ,type)) (hb (check-bound high ,type))) (unless (numeric-bound-test* lb hb <= <) - (error "Lower bound ~S is not less than upper bound ~S." low high)) + (simple-program-error + "Lower bound ~S is not less than upper bound ~S." low high)) (make-numeric-type :class ',class :format ',format :low lb :high hb)))) (def-bounded-type rational rational nil) @@ -1894,22 +1904,23 @@ ((member *) dims) (integer (when (minusp dims) - (error "Arrays can't have a negative number of dimensions: ~D." dims)) + (simple-program-error + "Arrays can't have a negative number of dimensions: ~D." dims)) (when (>= dims array-rank-limit) - (error "Array type has too many dimensions: ~S." dims)) + (simple-program-error "Array type has too many dimensions: ~S." dims)) (make-list dims :initial-element '*)) (list (when (>= (length dims) array-rank-limit) - (error "Array type has too many dimensions: ~S." dims)) + (simple-program-error "Array type has too many dimensions: ~S." dims)) (dolist (dim dims) (unless (eq dim '*) (unless (and (integerp dim) (>= dim 0) (< dim array-dimension-limit)) - (error "Bad dimension in array type: ~S." dim)))) + (simple-program-error "Bad dimension in array type: ~S." dim)))) dims) (t - (error "Array dimensions is not a list, integer or *:~% ~S" - dims)))) + (simple-program-error + "Array dimensions is not a list, integer or *:~% ~S" dims)))) (def-type-translator array (&optional element-type dimensions) (specialize-array-type diff --git a/pcl/init.lisp b/pcl/init.lisp index 8306291ac..f51f811f6 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.11 1999/05/30 23:14:00 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.12 2002/08/23 18:31:06 pmai Exp $") ;;; ;;; This file defines the initialization and related protocols. ;;; @@ -49,8 +49,8 @@ (let* ((info (initialize-info class initargs)) (valid-p (initialize-info-valid-p info))) (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (error "Invalid initialization argument ~S for class ~S" - (cdr valid-p) (class-name class)))) + (simple-program-error "Invalid initialization argument ~S for class ~S" + (cdr valid-p) (class-name class)))) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance)) @@ -98,8 +98,8 @@ (info (initialize-info class initargs)) (valid-p (initialize-info-ri-valid-p info))) (when (and (consp valid-p) (eq (car valid-p) :invalid)) - (error "Invalid initialization argument ~S for class ~S" - (cdr valid-p) (class-name class)))) + (simple-program-error "Invalid initialization argument ~S for class ~S" + (cdr valid-p) (class-name class)))) (apply #'shared-initialize instance nil initargs) instance) @@ -239,9 +239,9 @@ (doplist (key val) initargs (unless (memq key legal) (if error-p - (error "Invalid initialization argument ~S for class ~S" - key - (class-name class)) + (simple-program-error + "Invalid initialization argument ~S for class ~S" + key (class-name class)) (return-from check-initargs-2-plist nil))))) t) @@ -252,9 +252,9 @@ (dolist (key initkeys) (unless (memq key legal) (if error-p - (error "Invalid initialization argument ~S for class ~S" - key - (class-name class)) + (simple-program-error + "Invalid initialization argument ~S for class ~S" + key (class-name class)) (return-from check-initargs-2-list nil))))) t) -- GitLab