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