mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-02-24 07:40:40 -08:00
Code Issues Projects Releases Packages Wiki Activity

New function SIMPLE-PROGRAM-ERROR creates PROGRAM-ERROR with messages. Consistency and syntax checks added all over CLOS. Signalled errors are of SIMPLE-PROGRAM-ERROR type.

Browse source
This commit is contained in:
jjgarcia 2003-05-03 17:32:34 +00:00
parent 6b5725787a
commit 0c54b35b46
7 changed files with 61 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

35
src/clos/defclass.lsp
View file

@ -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)))

3
src/clos/kernel.lsp
View file

@ -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)

17
src/clos/slot.lsp
View file

@ -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))

43
src/lsp/defpackage.lsp
View file

@ -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

5
src/lsp/loop.lsp
View file

@ -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

7
src/lsp/loop2.lsp
View file

@ -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)

4
src/lsp/mislib.lsp
View file

@ -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))