From 42efe00d64ebb6a095b4890d8b2ab367c8063383 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Tue, 14 Jul 1998 18:12:23 +0000 Subject: [PATCH] This revision merges in many of the fixes for ANSI condition types in various calls to ERROR. Those easily handled by using new condition types simple-file-error and simple-program-error are included. The only functional change here is that the function CHARACTER no longer accepts an integer argument so as to be ANSI compliant. This may break some code. --- code/array.lisp | 15 +++++-- code/char.lisp | 34 +++++++++------- code/error.lisp | 14 +++++-- code/fd-stream.lisp | 22 +++++++---- code/fdefinition.lisp | 8 +++- code/filesys.lisp | 7 +--- code/load.lisp | 7 +++- code/macros.lisp | 31 +++++++-------- code/module.lisp | 9 +++-- code/package.lisp | 8 ++-- code/seq.lisp | 37 +++++++++++++---- code/sort.lisp | 14 +++++-- code/sysmacs.lisp | 14 ++++++- pcl/boot.lisp | 92 +++++++++++++------------------------------ 14 files changed, 175 insertions(+), 137 deletions(-) diff --git a/code/array.lisp b/code/array.lisp index 2c2743f71..def4c73c2 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 bb8440bdc..3bf82a9c1 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 4343dabae..a18a98f2d 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 74a6d58fd..9f958ab46 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 d9d89dbac..4c84ee21a 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 d3029276f..cebaf1382 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 ac527ac9e..5089ed857 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 bd03d0d05..57a741007 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 5bc38977c..b6a5e8b2c 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 e8f6628c3..7d942d43d 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 be5770319..b2f393ce9 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 c1a572380..db9298158 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 3260802e7..cd98babc7 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 220a02c34..2ec17d9b2 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) -- GitLab