From d002fd43e98dc4da830fb98bc81e3d989c61fffd Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Thu, 16 Jul 1998 13:30:53 +0000
Subject: [PATCH] Fixes and improvements to July-14 commit dealing with
 condition types in calls to error. From Douglas.

---
 code/error.lisp     |  5 ++---
 code/exports.lisp   |  5 +++--
 code/fd-stream.lisp |  6 ++----
 code/stream.lisp    | 26 +++++++++++++++++++++-----
 code/sysmacs.lisp   | 14 +-------------
 pcl/boot.lisp       |  8 +++++---
 6 files changed, 34 insertions(+), 30 deletions(-)

diff --git a/code/error.lisp b/code/error.lisp
index a18a98f2d..9cf3d317a 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.49 1998/07/14 18:12:15 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.50 1998/07/16 13:30:43 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -20,8 +20,7 @@
 
 (in-package "KERNEL")
 (export '(layout-invalid simple-style-warning condition-function-name
-			 ;;simple-program-error simple-file-error
-			 ))
+			 simple-program-error simple-file-error))
 
 (in-package "LISP")
 (export '(break error warn cerror
diff --git a/code/exports.lisp b/code/exports.lisp
index c5cfb3e8e..172d88df3 100644
--- a/code/exports.lisp
+++ b/code/exports.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/exports.lisp,v 1.155 1998/05/27 03:32:59 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.156 1998/07/16 13:30:44 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1661,7 +1661,8 @@
 	   "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH"
 
 	   "MAKE-UNDEFINED-CLASS" "%COMPILER-ONLY-DEFSTRUCT"
-	   "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT" "SIMPLE-STYLE-WARNING"
+	   "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT" "SIMPLE-FILE-ERROR"
+	   "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING"
 	   "BYTE-FUNCTION-TYPE" "SLOT-CLASS-PRINT-FUNCTION"
 	   "REDEFINE-LAYOUT-WARNING" "SLOT-CLASS" "INSURED-FIND-CLASS"
 	   "CONDITION-FUNCTION-NAME"))
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index 9f958ab46..4a411d068 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.44 1998/07/14 18:12:15 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.45 1998/07/16 13:30:45 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1260,9 +1260,7 @@ 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."
-
-  (unless (eq external-format :default)
-    (error "Only :DEFAULT is acceptable for :EXTERNAL-FORMAT."))
+  (declare (ignore external-format))
 
   ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
   (setf direction
diff --git a/code/stream.lisp b/code/stream.lisp
index 5d263ab30..b97a05fc5 100644
--- a/code/stream.lisp
+++ b/code/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/stream.lisp,v 1.33 1998/05/15 01:03:18 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.34 1998/07/16 13:30:52 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -66,16 +66,32 @@
 
 (defun ill-in (stream &rest ignore)
   (declare (ignore ignore))
-  (error "~S is not a character input stream." stream))
+  (error 'simple-type-error
+	 :datum stream
+	 :expected-type '(satisfies input-stream-p)
+	 :format-control "~S is not a character input stream."
+	 :format-arguments (list stream)))
 (defun ill-out (stream &rest ignore)
   (declare (ignore ignore))
-  (error "~S is not a character output stream." stream))
+  (error 'simple-type-error
+	 :datum stream
+	 :expected-type '(satisfies output-stream-p)
+	 :format-control "~S is not a character output stream."
+	 :format-arguments (list stream)))
 (defun ill-bin (stream &rest ignore)
   (declare (ignore ignore))
-  (error "~S is not a binary input stream." stream))
+  (error 'simple-type-error
+	 :datum stream
+	 :expected-type '(satisfies input-stream-p)
+	 :format-control "~S is not a binary input stream."
+	 :format-arguments (list stream)))
 (defun ill-bout (stream &rest ignore)
   (declare (ignore ignore))
-  (error "~S is not a binary output stream." stream))
+  (error 'simple-type-error
+	 :datum stream
+	 :expected-type '(satisfies output-stream-p)
+	 :format-control "~S is not a binary output stream."
+	 :format-arguments (list stream)))
 (defun closed-flame (stream &rest ignore)
   (declare (ignore ignore))
   (error "~S is closed." stream))
diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp
index cd98babc7..eda733fd6 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.21 1998/07/14 18:12:22 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.22 1998/07/16 13:30:52 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -97,12 +97,6 @@
        (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)
@@ -111,12 +105,6 @@
        (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 2ec17d9b2..3bb989bf8 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -26,7 +26,7 @@
 ;;;
 #+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 $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.15 1998/07/16 13:30:53 pw Exp $")
 
 (in-package :pcl)
 
@@ -172,7 +172,7 @@ work during bootstrapping.
   (let ((initargs ())
 	(methods ()))
     (flet ((duplicate-option (name)
-	     (error 'lisp::simple-program-error
+	     (error 'kernel:simple-program-error
 		    :format-control "The option ~S appears more than once."
 		    :format-arguments (list name)))
 	   (define-method(gf-name q-a-b)
@@ -220,6 +220,8 @@ work during bootstrapping.
 	      (if (initarg :method-class)
 		  (duplicate-option :method-class)
 		  (initarg :method-class `',(cadr option))))
+	    (:method
+	     (push (cdr option) methods))
 	    (t ;unsuported things must get a 'program-error
 	     (error 'lisp::simple-program-error
 		    :format-control "Unsupported option ~S."
@@ -1286,7 +1288,7 @@ work during bootstrapping.
 (defun generic-clobbers-function (function-specifier)
   #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
   #+cmu
-  (error 'lisp::simple-program-error
+  (error 'kernel: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~%~
-- 
GitLab