diff --git a/code/array.lisp b/code/array.lisp
index 2c2743f71c7f2046a0e6a59290d8717bee5253e5..def4c73c28ed0c2607911baa36a5ff46526b065e 100644
--- a/code/array.lisp
+++ b/code/array.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/array.lisp,v 1.26 1998/03/21 08:11:48 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.28 1998/07/16 13:30:42 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -612,7 +612,12 @@
   (declare (vector vector))
   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
       (%array-fill-pointer vector)
-      (error "~S is not an array with a fill-pointer." vector)))
+      (error 'simple-type-error
+	     :datum vector
+	     :expected-type '(and vector (satisfies array-has-fill-pointer-p))
+	     :format-control
+	     "~S is not an array with a fill-pointer."
+	     :format-arguments (list vector))))
 
 (defun %set-fill-pointer (vector new)
   (declare (vector vector) (fixnum new))
@@ -621,7 +626,11 @@
 	(error "New fill pointer, ~S, is larger than the length of the vector."
 	       new)
 	(setf (%array-fill-pointer vector) new))
-      (error "~S is not an array with a fill-pointer." vector)))
+      (error 'simple-type-error
+	     :datum vector
+	     :expected-type '(and vector (satisfies array-has-fill-pointer-p))
+	     :format-control "~S is not an array with a fill-pointer."
+	     :format-arguments (list vector))))
 
 (defun vector-push (new-el array)
   "Attempts to set the element of Array designated by the fill pointer
diff --git a/code/char.lisp b/code/char.lisp
index bb8440bdcc0bd3d3f80fedf3e3c236c5f671e814..3bf82a9c1acb12b57fe590fd54e2d50a67f217c1 100644
--- a/code/char.lisp
+++ b/code/char.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/char.lisp,v 1.10 1997/09/16 17:15:26 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/char.lisp,v 1.12 1998/07/16 13:30:43 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -116,19 +116,25 @@
 
 (defun character (object)
   "Coerces its argument into a character object if possible.  Accepts
-  characters, strings and symbols of length 1, and integers."
-  (typecase object
-    (character object)
-    (char-code (code-char object))
-    (string (if (= 1 (length (the string object)))
-		(char object 0)
-		(error "String is not of length one: ~S" object)))
-    (symbol (if (= 1 (length (symbol-name object)))
-		(schar (symbol-name object) 0)
-		(error "Symbol name is not of length one: ~S" object)))
-    (t
-     (error "~S cannot be coerced to a character."))))
-
+  characters, strings and symbols of length 1."
+  (flet ((do-error (control args)
+	   (error 'simple-type-error
+		  :datum object
+		  ;;?? how to express "symbol with name of length 1"?
+		  :expected-type '(or character (string 1))
+		  :format-control control
+		  :format-arguments args)))
+    (typecase object
+      (character object)
+      (string (if (= 1 (length (the string object)))
+		  (char object 0)
+		  (do-error
+		   "String is not of length one: ~S" (list object))))
+      (symbol (if (= 1 (length (symbol-name object)))
+		  (schar (symbol-name object) 0)
+		  (do-error
+		   "Symbol name is not of length one: ~S" (list object))))
+      (t (do-error "~S cannot be coerced to a character." (list object))))))
 
 
 (defun char-name (char)
diff --git a/code/error.lisp b/code/error.lisp
index 4343dabae701dc522a2ba79bc435497ab5335978..a18a98f2dfcd6d79e8c44a66aec9a469f733aa24 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.48 1998/07/13 17:44:41 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.49 1998/07/14 18:12:15 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -19,7 +19,9 @@
 (use-package "KERNEL")
 
 (in-package "KERNEL")
-(export '(layout-invalid simple-style-warning condition-function-name))
+(export '(layout-invalid simple-style-warning condition-function-name
+			 ;;simple-program-error simple-file-error
+			 ))
 
 (in-package "LISP")
 (export '(break error warn cerror
@@ -513,13 +515,15 @@
 
 (defun make-condition (thing &rest args)
   "Make an instance of a condition object using the specified initargs."
+  ;; Note: ANSI specifies no exceptional situations in this function.
+  ;; signalling simple-type-error would not be wrong.
   (let* ((thing (if (symbolp thing)
 		    (find-class thing)
 		    thing))
 	 (class (typecase thing
 		  (condition-class thing)
 		  (class
-		   (error "~S is not a condition class."))
+		   (error "~S is not a condition class." thing))
 		  (t
 		   (error "Bad thing for class arg:~%  ~S" thing))))
 	 (res (make-condition-object args)))
@@ -902,6 +906,10 @@
 (define-condition file-error (error)
   ((pathname :reader file-error-pathname :initarg :pathname)))
 
+;;; INTERNAL
+(define-condition simple-file-error   (simple-condition file-error)())
+(define-condition simple-program-error(simple-condition program-error)())
+
 (define-condition package-error (error)
   ((package :reader package-error-package :initarg :package)))
 
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index 74a6d58fd6157a4905b102f0136b00e5b13342c3..9f958ab468d518ff81388ea5eed56a4d6a787ab0 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.43 1998/05/04 01:27:13 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.44 1998/07/14 18:12:15 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1260,7 +1260,9 @@ non-server method is also significantly more efficient for large reads.
                        :overwrite, :append, :supersede or nil
    :if-does-not-exist - one of :error, :create or nil
   See the manual for details."
-  (declare (ignore external-format))
+
+  (unless (eq external-format :default)
+    (error "Only :DEFAULT is acceptable for :EXTERNAL-FORMAT."))
 
   ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
   (setf direction
@@ -1398,9 +1400,11 @@ non-server method is also significantly more efficient for large reads.
 		   (case if-does-not-exist
 		     (:error
 		      (cerror "Return NIL."
-			      "Error opening ~S, ~A."
-			      pathname
-			      (unix:get-unix-error-msg errno)))
+			      'simple-file-error
+			      :pathname pathname
+			      :format-control "Error opening ~S, ~A."
+			      :format-arguments
+			      (list pathname (unix:get-unix-error-msg errno))))
 		     (:create
 		      (cerror "Return NIL."
 			      "Error creating ~S, path does not exist."
@@ -1409,9 +1413,11 @@ non-server method is also significantly more efficient for large reads.
 		  ((eql errno unix:eexist)
 		   (unless (eq nil if-exists)
 		     (cerror "Return NIL."
-			     "Error opening ~S, ~A."
-			     pathname
-			     (unix:get-unix-error-msg errno)))
+			     'simple-file-error
+			     :pathname pathname
+			     :format-control "Error opening ~S, ~A."
+			     :format-arguments
+			     (list pathname (unix:get-unix-error-msg errno))))
 		   (return nil))
 		  ((eql errno unix:eacces)
 		   (cerror "Try again."
diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp
index d9d89dbacbed6444ce79e7acb409db5db40eb74f..4c84ee21ae1e3994680f057adb70fd6eb6786d3c 100644
--- a/code/fdefinition.lisp
+++ b/code/fdefinition.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/fdefinition.lisp,v 1.15 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.17 1998/07/16 13:30:47 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -90,7 +90,11 @@
 		     (and (consp cdr)
 			  (symbolp (car cdr))
 			  (null (cdr cdr))))))
-    (error "Invalid function name: ~S" name))
+    (error 'simple-type-error
+	   :datum name
+	   :expected-type '(or symbol list)
+	   :format-control "Invalid function name: ~S"
+	   :format-arguments (list name)))
   (let ((fdefn (info function definition name)))
     (if (and (null fdefn) create)
 	(setf (info function definition name) (make-fdefn name))
diff --git a/code/filesys.lisp b/code/filesys.lisp
index d3029276f942a6729a1cbe91df9aaec74bebe945..cebaf13822d88bdacec003f975ad43553e271de9 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.51 1998/07/13 17:44:42 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.53 1998/07/16 13:30:47 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -28,11 +28,6 @@
 			  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.
 
diff --git a/code/load.lisp b/code/load.lisp
index ac527ac9ee8771066d2c16f51a3b63227edb9795..5089ed85739f1f6cac8c70325dd26eeed15d60c1 100644
--- a/code/load.lisp
+++ b/code/load.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/load.lisp,v 1.70 1998/05/04 01:27:14 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.72 1998/07/16 13:30:47 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -549,7 +549,10 @@
      internal-load
      (ecase if-does-not-exist
        (:error
-	(restart-case (error "~S does not exist." (namestring pathname))
+	(restart-case (error 'simple-file-error
+			     :pathname pathname
+			     :format-control "~S does not exist."
+			     :format-arguments (list (namestring pathname)))
 	  (check-again () :report "See if it exists now."
 	    (load pathname))
 	  (use-value () :report "Prompt for a new name."
diff --git a/code/macros.lisp b/code/macros.lisp
index bd03d0d05b179cef9cbd8246da2ee8a406def242..57a741007d4c8f9f0f5b4843a38d308986af9834 100644
--- a/code/macros.lisp
+++ b/code/macros.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/macros.lisp,v 1.55 1998/06/16 06:37:15 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.57 1998/07/16 13:30:48 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -824,25 +824,18 @@
 	      `(let* ,(nreverse let-list)
 		 ,setter)))))))
 
-
-
 (defmacro push (obj place &environment env)
   "Takes an object and a location holding a list.  Conses the object onto
-  the list, returning the modified list."
+  the list, returning the modified list.  OBJ is evaluated before PLACE."
   (if (symbolp place)
       `(setq ,place (cons ,obj ,place))
       (multiple-value-bind (dummies vals newval setter getter)
-			   (get-setf-method place env)
-	(do* ((d dummies (cdr d))
-	      (v vals (cdr v))
-	      (let-list nil))
-	     ((null d)
-	      (push (list (car newval) `(cons ,obj ,getter))
-		    let-list)
-	      `(let* ,(nreverse let-list)
-		 ,setter))
-	  (push (list (car d) (car v)) let-list)))))
-
+	  (get-setf-method place env)
+	(let ((g (gensym)))
+	  `(let* ((,g ,obj)
+		  ,@(mapcar #'list dummies vals)
+		  (,(car newval) (cons ,g ,getter)))
+	    ,setter)))))
 
 (defmacro pushnew (obj place &rest keys &environment env)
   "Takes an object and a location holding a list.  If the object is already
@@ -1139,6 +1132,12 @@
 ;;; RESTART-CASE allowing keyform to be set and retested.
 ;;;
 (defun case-body (name keyform cases multi-p test errorp proceedp)
+  (when (null cases)
+    (error 'simple-type-error
+	   :datum cases
+	   :expected-type 'list
+	   :format-control "~S was called without any clauses."
+	   :format-arguments (list name)))
   (let ((keyform-value (gensym))
 	(clauses ())
 	(keys ()))
@@ -1500,7 +1499,7 @@
        (setqs nil)
        (pairs pairs (cddr pairs)))
       ((atom (cdr pairs))
-       `(let ,(nreverse lets) (setq ,@(nreverse setqs)) nil))
+       `(let ,(nreverse lets) (setq ,@(nreverse setqs))))
     (let ((gen (gensym)))
       (push `(,gen ,(cadr pairs)) lets)
       (push (car pairs) setqs)
diff --git a/code/module.lisp b/code/module.lisp
index 5bc38977cf1d3be7e69a04d90000f6de9d288a2b..b6a5e8b2ca571ac4bb1f94b1624334fa33cfc3b9 100644
--- a/code/module.lisp
+++ b/code/module.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/module.lisp,v 1.4 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/module.lisp,v 1.6 1998/07/16 13:30:49 pw Exp $")
 ;;;
 ;;; **********************************************************************
 
@@ -93,5 +93,8 @@
   (typecase name
     (string name)
     (symbol (string-downcase (symbol-name name)))
-    (t (error "Module name must be a string or symbol -- ~S."
-              name))))
+    (t (error 'simple-type-error
+	      :datum name
+	      :expected-type '(or string symbol)
+	      :format-control "Module name must be a string or symbol -- ~S."
+              :format-arguments (list name)))))
diff --git a/code/package.lisp b/code/package.lisp
index e8f6628c334d8e116b71357c571ba5d7535a62f8..7d942d43d1273d9fcc143a3b61cb4f2f6bafbcfb 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.49 1998/07/13 17:44:42 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.51 1998/07/16 13:30:49 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -862,13 +862,15 @@
 	    ((eq found package))
 	    ((string= (the string (package-%name found)) n)
 	     (with-simple-restart (continue "Ignore this nickname.")
-	       (error 'program-error
+	       (error 'simple-package-error
+		      :package package
 		      :format-control
 		      "~S is a package name, so it cannot be a nickname for ~S."
 		      :format-arguments (list n (package-%name package)))))
 	    (t
 	     (with-simple-restart (continue  "Redefine this nickname.")
-	       (error 'program-error
+	       (error 'simple-package-error
+		      :package package
 		      :format-control "~S is already a nickname for ~S."
 		      :format-arguments (list n (package-%name found))))
 	     (setf (gethash n *package-names*) package)
diff --git a/code/seq.lisp b/code/seq.lisp
index be57703192796a4597f531915c050005ebc9287c..b2f393ce9dcaa7f4d1dedf0532c397e78a354a1e 100644
--- a/code/seq.lisp
+++ b/code/seq.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/seq.lisp,v 1.30 1998/06/18 07:06:44 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.32 1998/07/16 13:30:50 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -65,20 +65,31 @@
 ;;;    Given an arbitrary type specifier, return a sane sequence type specifier
 ;;; that we can directly match.
 ;;;
-(defun result-type-or-lose (type &optional nil-ok)
-  (let ((type (specifier-type type)))
+(defun result-type-or-lose (itype &optional nil-ok)
+  (let ((type (specifier-type itype))
+	(expected-type  '(or list string vector bit-vector)))
     (cond
       ((csubtypep type (specifier-type 'nil))
        (if nil-ok
 	   nil
-	   (error "NIL output type invalid for this sequence function.")))
+	   (error 'simple-type-error
+		  :datum itype
+		  :expected-type expected-type
+		  :format-control
+		  "NIL output type invalid for this sequence function."
+		  :format-arguments ())))
       ((dolist (seq-type '(list string simple-vector bit-vector))
 	 (when (csubtypep type (specifier-type seq-type))
 	   (return seq-type))))
       ((csubtypep type (specifier-type 'vector))
        (type-specifier type))
       (t
-       (error "~S is a bad type specifier for sequence functions." type)))))
+       (error 'simple-type-error
+	      :datum itype
+	      :expected-type expected-type
+	      :format-control
+	      "~S is a bad type specifier for sequence functions."
+	      :format-arguments (list itype))))))
 
 (define-condition index-too-large-error (type-error)
   ()
@@ -177,14 +188,24 @@
                              (array-type-specialized-element-type type)))
                      (vlen (car (array-type-dimensions type))))
                  (if (and (numberp vlen) (/= vlen length))
-                   (error "The length of ~S does not match the specified length  of ~S."
-                          (type-specifier type) length))
+                   (error 'simple-type-error
+			  ;; these two are under-specified by ANSI
+			  :datum (type-specifier type)
+			  :expected-type (type-specifier type)
+			  :format-control
+			  "The length of ~S does not match the specified length  of ~S."
+			  :format-arguments
+			  (list (type-specifier type) length)))
 		 (if iep
 		     (make-array length :element-type etype
 				 :initial-element initial-element)
 		     (make-array length :element-type etype)))
 	       (make-array length :initial-element initial-element)))
-	  (t (error "~S is a bad type specifier for sequences." type)))))
+	  (t (error 'simple-type-error
+		    :datum type
+		    :expected-type 'sequence
+		    :format-control "~S is a bad type specifier for sequences."
+		    :format-arguments (list type))))))
 
 
 
diff --git a/code/sort.lisp b/code/sort.lisp
index c1a572380ba94cefc0042b50d11997104bf60714..db929815822198ffaf2d11de59b38d1842b20b85 100644
--- a/code/sort.lisp
+++ b/code/sort.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/sort.lisp,v 1.4 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sort.lisp,v 1.6 1998/07/16 13:30:51 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -39,7 +39,11 @@
 	 (sort-vector sequence predicate key)
 	 sequence))
     (t
-     (error "~S is not a sequence." sequence))))
+     (error 'simple-type-error
+	    :datum sequence
+	    :expected-type 'sequence
+	    :format-control "~S is not a sequence."
+	    :format-arguments (list sequence)))))
 
 
 
@@ -138,7 +142,11 @@
     (vector
      (stable-sort-vector sequence predicate key))
     (t
-     (error "~S is not a sequence." sequence))))
+     (error 'simple-type-error
+	    :datum sequence
+	    :expected-type 'sequence
+	    :format-control "~S is not a sequence."
+	    :format-arguments (list sequence)))))
 
 
 ;;; Stable Sorting Lists
diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp
index 3260802e76b235a4df080fabdf287ace4b9c0fad..cd98babc76efa7796af6d8a5c09b4fb2d640a878 100644
--- a/code/sysmacs.lisp
+++ b/code/sysmacs.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/sysmacs.lisp,v 1.20 1998/05/15 01:01:03 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.21 1998/07/14 18:12:22 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -97,6 +97,12 @@
        (cond ((null ,svar) *standard-input*)
 	     ((eq ,svar t) *terminal-io*)
 	     (T ,@(if check-type `((check-type ,svar ,check-type)))
+		(unless (input-stream-p ,svar)
+		  (error 'simple-type-error
+			 :datum stream
+			 :expected-type '(satisfies input-stream-p)
+			 :format-control "~S isn't an input stream."
+			 :format-arguments ,(list svar)))
 		,svar)))))
 
 (defmacro out-synonym-of (stream &optional check-type)
@@ -105,6 +111,12 @@
        (cond ((null ,svar) *standard-output*)
 	     ((eq ,svar t) *terminal-io*)
 	     (T ,@(if check-type `((check-type ,svar ,check-type)))
+		(unless (output-stream-p ,svar)
+		  (error 'simple-type-error
+			 :datum stream
+			 :expected-type '(satisfies output-stream-p)
+			 :format-control "~S isn't an output stream."
+			 :format-arguments ,(list svar)))
 		,svar)))))
 
 ;;; With-Mumble-Stream calls the function in the given Slot of the
diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 220a02c345b3f41f98ab700de4b74420e990916c..2ec17d9b2673a3e7d6ae8deb7d0dd232075f8c11 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -24,6 +24,9 @@
 ;;; Suggestions, comments and requests for improvements are also welcome.
 ;;; *************************************************************************
 ;;;
+#+cmu
+(ext:file-comment
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.14 1998/07/14 18:12:23 pw Exp $")
 
 (in-package :pcl)
 
@@ -162,66 +165,16 @@ work during bootstrapping.
 ;;;
 (defmacro defgeneric (function-specifier lambda-list &body options)
   (expand-defgeneric function-specifier lambda-list options))
-#+nil ;; original version
-(defun expand-defgeneric (function-specifier lambda-list options)
-  (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
-  (let ((initargs ()))
-    (flet ((duplicate-option (name)
-	     (error "The option ~S appears more than once." name)))
-      ;;
-      ;; INITARG takes this screwy new argument to get around a bad
-      ;; interaction between lexical macros and setf in the Lucid
-      ;; compiler.
-      ;; 
-      (macrolet ((initarg (key &optional new)
-		   (if new
-		       `(setf (getf initargs ,key) ,new)
-		       `(getf initargs ,key))))
-	(dolist (option options)
-	  (ecase (car option)
-	    (:argument-precedence-order
-	      (if (initarg :argument-precedence-order)
-		  (duplicate-option :argument-precedence-order)
-		  (initarg :argument-precedence-order `',(cdr option))))
-	    (declare
-	      (initarg :declarations
-		       (append (cdr option) (initarg :declarations))))
-	    (:documentation
-	      (if (initarg :documentation)
-		  (duplicate-option :documentation)
-		  (initarg :documentation `',(cadr option))))
-	    (:method-combination
-	      (if (initarg :method-combination)
-		  (duplicate-option :method-combination)
-		  (initarg :method-combination `',(cdr option))))
-	    (:generic-function-class
-	      (if (initarg :generic-function-class)
-		  (duplicate-option :generic-function-class)
-		  (initarg :generic-function-class `',(cadr option))))
-	    (:method-class
-	      (if (initarg :method-class)
-		  (duplicate-option :method-class)
-		  (initarg :method-class `',(cadr option))))
-	    (:method
-	      (error
-		"DEFGENERIC doesn't support the :METHOD option yet."))))
-
-	(let ((declarations (initarg :declarations)))
-	  (when declarations (initarg :declarations `',declarations)))))
-    `(progn
-       (proclaim-defgeneric ',function-specifier ',lambda-list)
-       ,(make-top-level-form `(defgeneric ,function-specifier)
-	  *defgeneric-times*
-	  `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)))))
 
-;; pw--Enhanced to support :method options.
 (defun expand-defgeneric (function-specifier lambda-list options)
   (when (listp function-specifier)
     (do-standard-defsetf-1 (cadr function-specifier)))
   (let ((initargs ())
 	(methods ()))
     (flet ((duplicate-option (name)
-	     (error "The option ~S appears more than once." name))
+	     (error 'lisp::simple-program-error
+		    :format-control "The option ~S appears more than once."
+		    :format-arguments (list name)))
 	   (define-method(gf-name q-a-b)
 	     (let* ((arg-pos (position-if #'listp q-a-b))
 		    (arglist (elt q-a-b arg-pos))
@@ -243,7 +196,7 @@ work during bootstrapping.
 		       `(setf (getf initargs ,key) ,new)
 		       `(getf initargs ,key))))
 	(dolist (option options)
-	  (ecase (car option)
+	  (case (car option)
 	    (:argument-precedence-order
 	      (if (initarg :argument-precedence-order)
 		  (duplicate-option :argument-precedence-order)
@@ -267,11 +220,10 @@ work during bootstrapping.
 	      (if (initarg :method-class)
 		  (duplicate-option :method-class)
 		  (initarg :method-class `',(cadr option))))
-	    (:method
-	     #+nil
-	      (error
-		"DEFGENERIC doesn't support the :METHOD option yet.")
-	      (push (cdr option) methods))))
+	    (t ;unsuported things must get a 'program-error
+	     (error 'lisp::simple-program-error
+		    :format-control "Unsupported option ~S."
+		    :format-arguments (list option)))))
 
 	(let ((declarations (initarg :declarations)))
 	  (when declarations (initarg :declarations `',declarations))))
@@ -1333,12 +1285,22 @@ work during bootstrapping.
 
 (defun generic-clobbers-function (function-specifier)
   #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
-  #-Lispm (error "~S already names an ordinary function or a macro,~%~
-                  you may want to replace it with a generic function, but doing so~%~
-                  will require that you decide what to do with the existing function~%~
-                  definition.~%~
-                  The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
-		 function-specifier))
+  #+cmu
+  (error 'lisp::simple-program-error
+	 :format-control
+	 "~S already names an ordinary function or a macro,~%~
+	  you may want to replace it with a generic function, but doing so~%~
+	  will require that you decide what to do with the existing function~%~
+	  definition.~%~
+	  The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
+	 :format-arguments (list function-specifier))
+  #-(or lispm cmu)
+  (error "~S already names an ordinary function or a macro,~%~
+	  you may want to replace it with a generic function, but doing so~%~
+	  will require that you decide what to do with the existing function~%~
+	  definition.~%~
+	  The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
+	 function-specifier))
 
 #+Lispm
 (zl:defflavor generic-clobbers-function (name) (si:error)