diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index eb6578e39..264bc7559 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -53,8 +53,11 @@ `',constants-list `(list* ,@lambdas-list ',constants-list))) (when (endp (cdr scan)) - (error "Wrong number of elements in :DEFAULT-INITARGS option.")) + (si::simple-program-error "Wrong number of elements in :DEFAULT-INITARGS option.")) (setq slot-name (second scan) initform (first scan)) + (when (getf scan slot-name) + (si::simple-program-error "~S is duplicated in :DEFAULT-INITARGS form ~S" + slot-name default-initargs)) (cond ((typep initform '(or number character string array keyword)) (setq constants-list (list* slot-name initform constants-list))) ((and (consp initform) (eq 'quote (first initform))) @@ -141,40 +144,46 @@ (let* (name superclasses slots options metaclass-name default-initargs documentation) (unless args - (error "Illegal defclass form: the class name, the superclasses and the slots should always be provided")) + (si::simple-program-error "Illegal defclass form: the class name, the superclasses and the slots should always be provided")) (setq name (pop args)) (unless args - (error "Illegal defclass form: the class name, the superclasses list and the slot specifier list should always be provided")) + (si::simple-program-error "Illegal defclass form: the class name, the superclasses list and the slot specifier list should always be provided")) (unless (listp (first args)) - (error "Illegal defclass form: the superclasses should be a list")) + (si::simple-program-error "Illegal defclass form: the superclasses should be a list")) (setq superclasses (pop args)) (unless args - (error "Illegal defclass form: the class name, the superclasses list and the slot specifier list should always be provided")) + (si::simple-program-error "Illegal defclass form: the class name, the superclasses list and the slot specifier list should always be provided")) (unless (listp (first args)) - (error "Illegal defclass form: the slots should be a list")) + (si::simple-program-error "Illegal defclass form: the slots should be a list")) (setq slots (pop args)) (setq options args) (unless (legal-class-name-p name) - (error "Illegal defclass form: the class name should be a symbol")) + (si::simple-program-error "Illegal defclass form: the class name should be a symbol")) ;; process options (dolist (option options) (case (first option) (:metaclass (if metaclass-name - (error "Option :metaclass specified more than once for class ~A" - name) + (si::simple-program-error + "Option :metaclass specified more than once for class ~A" + name) ;; else (setq metaclass-name (second option)))) (:default-initargs (if default-initargs - (error "Option :default-initargs specified more than once for class ~A" name) + (si::simple-program-error + "Option :default-initargs specified more than once for class ~A" + name) (setq default-initargs (cdr option)))) (:documentation (if documentation - (error "Option :documentation specified more than once for class ~A" - name) + (si::simple-program-error + "Option :documentation specified more than once for class ~A" + name) (setq documentation (second option)))) - (otherwise (error "~S is not a legal class-option." (first option))))) + (otherwise + (si::simple-program-error "~S is not a legal class-option." + (first option))))) (values name superclasses slots metaclass-name default-initargs documentation))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 5acd3b476..e4b8080a8 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -54,9 +54,10 @@ (defun classp (obj) (and (si:instancep obj) - (search-make-instance obj) + (subclassp (si::instance-class obj) (find-class 'CLASS)) t)) +#+nil (defun metaclassp (obj) (declare (si::c-local)) (and (si:instancep obj) diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 034eb20c7..be10a05fc 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -42,14 +42,19 @@ (loop (when (null options) (return t)) (setq option (pop options)) (unless (legal-slot-option-p option) - (error "In the slot description ~S,~%~ - the option ~S is not legal." - slot option)) + (si::simple-program-error + "In the slot description ~S,~%the option ~S is not legal" + slot option)) (if (endp options) - (error "In the slot description ~S,~%~ - the option ~S is missing an argument" - slot option) + (si::simple-program-error + "In the slot description ~S,~%the option ~S is missing an argument" + slot option) (setq value (pop options))) + (when (and (member option '(:allocation initform :type :documentation)) + (getf options option)) + (si::simple-program-error + "In the slot descrition ~S,~%the option ~S is duplicated" + slot option)) (case option (:initarg (push value initargs)) (:initform (setq initform value)) diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index bcc13723a..de2763aa5 100644 --- a/src/lsp/defpackage.lsp +++ b/src/lsp/defpackage.lsp @@ -129,9 +129,8 @@ output)) (dolist (option '(:SIZE :DOCUMENTATION)) (when (<= 2 (count option options ':key #'car)) - (error 'simple-program-error - :format-control "DEFPACKAGE option ~s specified more than once." - :format-arguments (list option)))) + (si::simple-program-error "DEFPACKAGE option ~s specified more than once." + option))) (setq name (string name)) (let* ((nicknames (option-values ':nicknames options)) (documentation (option-values ':documentation options)) @@ -147,30 +146,24 @@ interned-symbol-names (loop for list in shadowing-imported-from-symbol-names-list append (rest list)) (loop for list in imported-from-symbol-names-list append (rest list)))) - (error 'simple-program-error - :format-control - "The symbol ~s cannot coexist in these lists:~{ ~s~}" - :format-arguments - (list - (first duplicate) - (loop for num in (rest duplicate) - collect (case num - (1 ':SHADOW) - (2 ':INTERN) - (3 ':SHADOWING-IMPORT-FROM) - (4 ':IMPORT-FROM)))))) + (si::simple-program-error + "The symbol ~s cannot coexist in these lists:~{ ~s~}" + (first duplicate) + (loop for num in (rest duplicate) + collect (case num + (1 ':SHADOW) + (2 ':INTERN) + (3 ':SHADOWING-IMPORT-FROM) + (4 ':IMPORT-FROM))))) (dolist (duplicate (find-duplicates exported-symbol-names interned-symbol-names)) - (error 'simple-program-error - :format-control - "The symbol ~s cannot coexist in these lists:~{ ~s~}" - :format-arguments - (list - (first duplicate) - (loop for num in (rest duplicate) collect - (case num - (1 ':EXPORT) - (2 ':INTERN)))))) + (si::simple-program-error + "The symbol ~s cannot coexist in these lists:~{ ~s~}" + (first duplicate) + (loop for num in (rest duplicate) collect + (case num + (1 ':EXPORT) + (2 ':INTERN))))) `(si::%defpackage ,name ',nicknames diff --git a/src/lsp/loop.lsp b/src/lsp/loop.lsp index fa5986f53..7780bbc23 100644 --- a/src/lsp/loop.lsp +++ b/src/lsp/loop.lsp @@ -117,9 +117,8 @@ ;;;; Random Macros (defmacro loop-simple-error (unquoted-message &optional (datum nil datump)) - `(error 'simple-program-error - :format-control ,(if datump "LOOP: ~S ~A" "LOOP: ~A") - :format-arguments (list ',unquoted-message ,@(and datump (list datum))))) + `(si::simple-program-error ,(if datump "LOOP: ~S ~A" "LOOP: ~A") + ',unquoted-message ,@(and datump (list datum)))) (defmacro loop-warn (unquoted-message &optional (datum nil datump)) (if datump diff --git a/src/lsp/loop2.lsp b/src/lsp/loop2.lsp index d62745cd0..149a3c2f9 100755 --- a/src/lsp/loop2.lsp +++ b/src/lsp/loop2.lsp @@ -979,11 +979,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-error (format-string &rest format-args) (declare (si::c-local)) - #+(or Genera CLOE) (declare (dbg:error-reporter)) - #+Genera (setq format-args (copy-list format-args)) ;Don't ask. - (error 'simple-program-error - :format-control "~?~%Current LOOP context:~{ ~S~}." - :format-arguments (list format-string format-args (loop-context)))) + (si::simple-program-error "~?~%Current LOOP context:~{ ~S~}." + format-string format-args (loop-context))) (defun loop-warn (format-string &rest format-args) diff --git a/src/lsp/mislib.lsp b/src/lsp/mislib.lsp index 7af757ee9..07827f19e 100644 --- a/src/lsp/mislib.lsp +++ b/src/lsp/mislib.lsp @@ -154,3 +154,7 @@ Sunday is the *last* day of the week!!" (values)) (set-dispatch-macro-character #\# #\! 'sharp-!-reader) + +(defun si::simple-program-error (message &rest datum) + (error 'simple-program-error :format-control message + :format-arguments datum))