diff --git a/pcl/boot.lisp b/pcl/boot.lisp index 39537417fd194674f77bcd1b877b7d4e5a53e552..0ecdeec3935fd9dd3ef3487e351ec968c67e45b7 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.29 2002/08/26 16:09:33 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.30 2002/08/27 18:46:48 pmai Exp $") (in-package :pcl) @@ -175,9 +175,8 @@ work during bootstrapping. (let ((initargs ()) (methods ())) (flet ((duplicate-option (name) - (error 'kernel:simple-program-error - :format-control "The option ~S appears more than once." - :format-arguments (list name)))) + (simple-program-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 @@ -216,9 +215,7 @@ work during bootstrapping. (push `(defmethod ,function-specifier ,@(cdr option)) methods)) (t ;unsuported things must get a 'program-error - (error 'kernel:simple-program-error - :format-control "Unsupported option ~S." - :format-arguments (list option))))) + (simple-program-error "Unsupported option ~S." option)))) (let ((declarations (initarg :declarations))) (when declarations (initarg :declarations `',declarations)))) @@ -1261,13 +1258,11 @@ work during bootstrapping. (defun generic-clobbers-function (function-specifier) (restart-case - (error - 'kernel:simple-program-error - :format-control + (simple-program-error "~S already names an ordinary function or a macro.~%~ If you want to replace it with a generic function, you should remove~%~ the existing definition beforehand.~%" - :format-arguments (list function-specifier)) + function-specifier) (continue () :report (lambda (stream) (format stream "Discard the existing definition of ~S." diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index 09272a5c188ebac11556d44c7ffbcfe9092f3e6f..7d056bad438308ddc0fc16d4994a14e6b7fbe26a 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.21 2002/08/26 02:23:12 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.22 2002/08/27 18:46:49 pmai Exp $") ;;; (in-package :pcl) @@ -131,16 +131,14 @@ ;; TBD - ANSI compliant class and slot option checking. (dolist (option options) (if (not (listp option)) - (error 'kernel:simple-program-error - :format-control "~S is not a legal defclass option." - :format-arguments (list option)) + (simple-program-error "~S is not a legal defclass option." + option) (when (eq (car option) ':metaclass) (unless (legal-class-name-p (cadr option)) - (error 'kernel:simple-program-error - :format-control - "The value of the :metaclass option (~S) is not a~%~ - legal class name." - :format-arguments (list (cadr option)))) + (simple-program-error + "The value of the :metaclass option (~S) is not a~%~ + legal class name." + (cadr option))) (setq metaclass (case (cadr option) (lisp:standard-class 'standard-class) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index e10a2a0f683b1d2d7b9eb9a4b4bea6623cc2d6e9..35d017f97efd1cd255b9660dc705827036179916 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.32 2002/08/26 02:23:15 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.33 2002/08/27 18:46:49 pmai Exp $") ;;; (in-package :pcl) @@ -374,20 +374,16 @@ *the-class-standard-class*) (t (class-of class))))) - (labels ((program-error (format-control &rest args) - (error 'kernel:simple-program-error - :format-control format-control - :format-arguments args)) - (fix-super (s) - (cond ((classp s) s) - ((not (legal-class-name-p s)) - (program-error "~S is not a class or a legal ~ - class name." s)) - (t - (or (find-class s nil) - (setf (find-class s) - (make-instance 'forward-referenced-class - :name s))))))) + (flet ((fix-super (s) + (cond ((classp s) s) + ((not (legal-class-name-p s)) + (simple-program-error + "~S is not a class or a legal class name." s)) + (t + (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class + :name s))))))) ;; ;; CLHS: signal PROGRAM-ERROR, if ;; (a) there are any duplicate slot names @@ -396,25 +392,28 @@ (loop for (slot . more) on (getf initargs :direct-slots) for slot-name = (getf slot :name) if (some (lambda (s) (eq slot-name (getf s :name))) more) do - (program-error "More than one direct slot with name ~S." - slot-name) + (simple-program-error + "More than one direct slot with name ~S." + slot-name) else do (loop for (option value . more) on slot by #'cddr when (and (member option '(:allocation :type :initform :documentation)) (not (eq unsupplied (getf more option unsupplied)))) do - (program-error "Duplicate slot option ~S for slot ~S." - option slot-name))) + (simple-program-error + "Duplicate slot option ~S for slot ~S." + option slot-name))) ;; ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name ;; appears more than once in :DEFAULT-INITARGS class option. (loop for (initarg . more) on (getf initargs :direct-default-initargs) for name = (car initarg) when (some (lambda (a) (eq (car a) name)) more) do - (program-error "Duplicate initialization argument ~ - name ~S in :default-initargs of class ~A." - name class)) + (simple-program-error + "Duplicate initialization argument ~ + name ~S in :default-initargs of class ~A." + name class)) ;; (loop (unless (remf initargs :metaclass) (return))) (loop (unless (remf initargs :direct-superclasses) (return)))