From 1003741193d7fd0fb037bfddfad016bc0dd1025d Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 19 Dec 1998 15:56:19 +0000
Subject: [PATCH] Correct a program-error which should have been a
 simple-program-error. Rework some error's into simple-type-error's. Based of
 patches from Peter Van Eynde.

---
 code/defstruct.lisp | 81 +++++++++++++++++++++++++++++----------------
 1 file changed, 52 insertions(+), 29 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 06d4d3850..3555b240f 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.65 1998/07/25 23:37:39 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.66 1998/12/19 15:56:19 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -556,7 +556,7 @@
 		spec))
 	spec))
     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
-      (error 'program-error
+      (error 'simple-program-error
 	     :format-control "Duplicate slot name ~S."
 	     :format-arguments (list name)))
     (setf (dsd-%name islot) (string name))
@@ -1165,16 +1165,23 @@
 	#'(lambda (structure)
 	    (declare (optimize (speed 3) (safety 0)))
 	    (unless (typep-to-layout structure layout)
-	      (error "Structure for accessor ~S is not a ~S:~% ~S"
-		     (dsd-accessor dsd) (class-name (layout-class layout))
-		     structure))
+	      (error 'simple-type-error
+		     :datum structure
+		     :expected-type class
+		     :format-control "Structure for accessor ~S is not a ~S:~% ~S"
+		     :format-arguments (list (dsd-accessor dsd)
+					     (class-name class)
+					     structure)))
 	    (%instance-ref structure (dsd-index dsd)))
 	#'(lambda (structure)
 	    (declare (optimize (speed 3) (safety 0)))
 	    (unless (%typep structure class)
-	      (error "Structure for accessor ~S is not a ~S:~% ~S"
-		     (dsd-accessor dsd) class
-		     structure))
+	      (error 'simple-type-error
+		     :datum structure
+		     :expected-type class
+		     :format-control "Structure for accessor ~S is not a ~S:~% ~S"
+		     :format-arguments (list (dsd-accessor dsd) class
+					     structure)))
 	    (%instance-ref structure (dsd-index dsd))))))
 ;;;
 (defun structure-slot-setter (layout dsd)
@@ -1183,26 +1190,40 @@
 	#'(lambda (new-value structure)
 	    (declare (optimize (speed 3) (safety 0)))
 	    (unless (typep-to-layout structure layout)
-	      (error "Structure for setter ~S is not a ~S:~% ~S"
-		     `(setf ,(dsd-accessor dsd))
-		     (class-name (layout-class layout))
-		     structure))
+	      (error 'simple-type-error
+		     :datum structure
+		     :expected-type class
+		     :format-control "Structure for setter ~S is not a ~S:~% ~S"
+		     :format-arguments (list `(setf ,(dsd-accessor dsd))
+					     (class-name class)
+					     structure)))
 	    (unless (%typep new-value (dsd-type dsd))
-	      (error "New-Value for setter ~S is not a ~S:~% ~S."
-		     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-		     new-value))
+	      (error 'simple-type-error
+		     :datum new-value
+		     :expected-type (dsd-type dsd)
+		     :format-control "New-Value for setter ~S is not a ~S:~% ~S."
+		     :format-arguments (list `(setf ,(dsd-accessor dsd))
+					     (dsd-type dsd)
+					     new-value)))
 	    (setf (%instance-ref structure (dsd-index dsd)) new-value))
 	#'(lambda (new-value structure)
 	    (declare (optimize (speed 3) (safety 0)))
 	    (unless (%typep structure class)
-	      (error "Structure for setter ~S is not a ~S:~% ~S"
-		     `(setf ,(dsd-accessor dsd))
-		     (class-name class)
-		     structure))
+	      (error 'simple-type-error
+		     :datum structure
+		     :expected-type class
+		     :format-control "Structure for setter ~S is not a ~S:~% ~S"
+		     :format-arguments (list `(setf ,(dsd-accessor dsd))
+					     (class-name class)
+					     structure)))
 	    (unless (%typep new-value (dsd-type dsd))
-	      (error "New-Value for setter ~S is not a ~S:~% ~S."
-		     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-		     new-value))
+	      (error 'simple-type-error
+		     :datum new-value
+		     :expected-type (dsd-type dsd)
+		     :format-control "New-Value for setter ~S is not a ~S:~% ~S."
+		     :format-arguments (list `(setf ,(dsd-accessor dsd))
+					     (dsd-type dsd)
+					     new-value)))
 	    (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
 
 
@@ -1216,7 +1237,7 @@
 (defun %defstruct (info inherits)
   (declare (type defstruct-description info))
   (multiple-value-bind (class layout old-layout)
-		       (ensure-structure-class info inherits "current" "new")
+      (ensure-structure-class info inherits "current" "new")
     (cond ((not old-layout)
 	   (unless (eq (class-layout class) layout)
 	     (register-layout layout)))
@@ -1255,13 +1276,15 @@
 	      #'(lambda (structure)
 		  (declare (optimize (speed 3) (safety 0)))
 		  (unless (typep-to-layout structure layout)
-		    (error "Structure for copier is not a ~S:~% ~S"
-			   (class-name (layout-class layout))
-			   structure))
-		  (copy-structure structure)))))
-  
+		    (error 'simple-type-error
+			   :datum structure
+			   :expected-type class
+			   :format-control "Structure for copier is not a ~S:~% ~S"
+			   :format-arguments (list class structure)))
+		  (copy-structure structure))))))
+
   (when (dd-doc info)
-    (setf (documentation (dd-name info) 'type) (dd-doc info))))
+    (setf (documentation (dd-name info) 'type) (dd-doc info)))
 
   (undefined-value))
 
-- 
GitLab