gcl.git - GNU Common Lisp

diff --git a/gcl/lsp/gcl_defpackage.lsp b/gcl/lsp/gcl_defpackage.lsp
index 14f874d76..fb8e8a278 100644
--- a/gcl/lsp/gcl_defpackage.lsp
+++ b/gcl/lsp/gcl_defpackage.lsp

@@ -155,9 +155,8 @@

(rest (first result)))))

(sloop for option in '(:size :documentation)

when (<= 2 (count option options ':key #'car))

- do (specific-error :invalid-form

- "DEFPACKAGE option ~s specified more than once."

- option))

+ do (error 'program-error :format-control "DEFPACKAGE option ~s specified more than once."

+ :format-arguments (list option)))

(setq name (string name))

(let ((nicknames (mapcar #'string (option-values ':nicknames options)))

(documentation (first (option-values ':documentation options)))

@@ -203,29 +202,31 @@

(sloop for list in imported-from-symbol-names-list

append (rest list)))

do

- (specific-error

- :invalid-form

- "The symbol ~s cannot coexist in these lists:~{ ~s~}"

- (first duplicate)

- (sloop for num in (rest duplicate)

- collect

- (case num

- (1 ':SHADOW)

- (2 ':INTERN)

- (3 ':SHADOWING-IMPORT-FROM)

- (4 ':IMPORT-FROM)))))

+ (error

+ 'program-error

+ :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}"

+ :format-arguments

+ (list (first duplicate)

+ (sloop for num in (rest duplicate)

+ collect

+ (case num

+ (1 :SHADOW)

+ (2 :INTERN)

+ (3 :SHADOWING-IMPORT-FROM)

+ (4 :IMPORT-FROM))))))

(sloop for duplicate in

(find-duplicates exported-symbol-names interned-symbol-names)

do

- (specific-error

- :invalid-form

- "The symbol ~s cannot coexist in these lists:~{ ~s~}"

- (first duplicate)

- (sloop for num in

- (rest duplicate)

- collect (case num

- (1 ':EXPORT)

- (2 ':INTERN))))))

+ (error

+ 'program-error

+ :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}"

+ :format-arguments

+ (list (first duplicate)

+ (sloop for num in

+ (rest duplicate)

+ collect (case num

+ (1 :EXPORT)

+ (2 :INTERN)))))))

`(eval-when (load eval compile)

(if (find-package ,name)

(progn (rename-package ,name ,name)

@@ -265,12 +266,12 @@

(mapcar #'(lambda (list)

`(SHADOWING-IMPORT

(mapcar #'(lambda (symbol)

- (if (find-symbol symbol ,(first list))

- (intern symbol ,(first list))

-; FIXME better error messages

- (specific-correctable-error :package-error

- "" ,(first list)

- (format nil "Symbol ~S not present~%" symbol))))

+ (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p)

+ (cerror "Continue anyway" 'package-error

+ :package (first list)

+ :format-control "~%Symbol ~a not present"

+ :format-arguments (list symbol)))

+ (intern symbol ,(first list)))

',(rest list))))

SHADOWING-IMPORTed-from-symbol-names-list))

(USE-PACKAGE ',(if (member ':USE options ':test #'option-test)

@@ -279,12 +280,12 @@

,@(when IMPORTed-from-symbol-names-list

(mapcar #'(lambda (list)

`(IMPORT (mapcar #'(lambda (symbol)

- (if (find-symbol symbol ,(first list))

- (intern symbol ,(first list))

-; FIXME better error messages

- (specific-correctable-error :package-error

- "" ,(first list)

- (format nil "Symbol ~S not present~%" symbol))))

+ (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p)

+ (cerror "Continue anyway" 'package-error

+ :package (first list)

+ :format-control "~%Symbol ~a not present"

+ :format-arguments (list symbol)))

+ (intern symbol ,(first list)))

',(rest list))))

IMPORTed-from-symbol-names-list))

,@(when INTERNed-symbol-names

diff --git a/gcl/lsp/gcl_destructuring_bind.lsp b/gcl/lsp/gcl_destructuring_bind.lsp
index e6d458ae6..a5e36bd00 100644
--- a/gcl/lsp/gcl_destructuring_bind.lsp
+++ b/gcl/lsp/gcl_destructuring_bind.lsp

@@ -83,11 +83,6 @@

"Takes a non-keyword symbol, symbol, and returns the corresponding keyword."

(intern (symbol-name symbol) (find-package "KEYWORD")))

-(defun defmacro-error (problem kind name)

-; FIXME check this

- (declare (ignore kind))

- (specific-error :wrong-type-argument "~S is not of type ~S~%" problem name))

-

(defun verify-keywords (key-list valid-keys allow-other-keys)

(do ((already-processed nil)

(unknown-keyword nil)

@@ -159,8 +154,7 @@

(cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))

(setf rest-of-args (cdr rest-of-args))

(push-let-binding (car rest-of-args) arg-list-name nil))

- (t

- (defmacro-error "&WHOLE" error-kind name))))

+ (t (error "Bad &WHOLE"))))

((eq var '&environment)

(cond (env-illegal

(error "&Environment not valid with ~S." error-kind))

@@ -171,8 +165,7 @@

(setf rest-of-args (cdr rest-of-args))

(push-let-binding (car rest-of-args) env-arg-name nil)

(setf env-arg-used t))

- (t

- (defmacro-error "&ENVIRONMENT" error-kind name))))

+ (t (error "Bad &ENVIRONMENT"))))

((or (eq var '&rest) (eq var '&body))

(cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))

(setf rest-of-args (cdr rest-of-args))

@@ -209,8 +202,7 @@

(when doc-string-name

(push-let-binding doc-string-name

`(caddr ,parse-body-values) nil))))

- (t

- (defmacro-error (symbol-name var) error-kind name))))

+ (t (error "Bad lambda list"))))

((eq var '&optional)

(setf now-processing :optionals))

((eq var '&key)

diff --git a/gcl/lsp/gcl_loop.lsp b/gcl/lsp/gcl_loop.lsp
index f27e8aaee..f03d28151 100644
--- a/gcl/lsp/gcl_loop.lsp
+++ b/gcl/lsp/gcl_loop.lsp

@@ -968,7 +968,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.

(defun loop-error (format-string &rest format-args)

#+(or Genera CLOE) (declare (dbg:error-reporter))

#+Genera (setq format-args (copy-list format-args)) ;Don't ask.

- (specific-error :invalid-form "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))

+ (error 'program-error :format-control "~?~%Current LOOP context:~{ ~S~}."

+ :format-arguments (list format-string format-args (loop-context))))

(defun loop-warn (format-string &rest format-args)

@@ -1115,9 +1116,9 @@ collected result will be returned as the value of the LOOP."

(push (loop-construct-return form) *loop-after-epilogue*)

(when *loop-final-value-culprit*

(if *loop-collection-no-into*

- (specific-error :invalid-form "LOOP clause is providing a value for the iteration,~@

+ (error 'program-error :format-control "LOOP clause is providing a value for the iteration,~@

however one was already established by a ~S clause."

- *loop-final-value-culprit*)

+ :format-arguments (list *loop-final-value-culprit*))

(loop-warn "LOOP clause is providing a value for the iteration,~@

however one was already established by a ~S clause."

*loop-final-value-culprit*)))

diff --git a/gcl/lsp/gcl_packlib.lsp b/gcl/lsp/gcl_packlib.lsp
index 0c71ad1b3..e70f487b5 100755
--- a/gcl/lsp/gcl_packlib.lsp
+++ b/gcl/lsp/gcl_packlib.lsp

@@ -181,7 +181,7 @@

(x (gensym))(y (gensym)) (access (gensym)) declaration)

(multiple-value-setq (declaration body) (si::find-declarations body))

(if (null symbol-types)

- (specific-error :too-few-arguments "Symbol type specifiers must be supplied"))

+ (error 'program-error :format-control "Symbol type specifiers must be supplied"))

`(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil)

(,i -1) (,x 0) (,y 0) (,dum nil) (,access nil))

(declare (fixnum ,x ,y))

diff --git a/gcl/lsp/gcl_setf.lsp b/gcl/lsp/gcl_setf.lsp
index c2db59986..9ada67915 100755
--- a/gcl/lsp/gcl_setf.lsp
+++ b/gcl/lsp/gcl_setf.lsp

@@ -142,7 +142,7 @@

((macro-function (car form))

(get-setf-method-multiple-value (macroexpand form)))

(t

- (error "Cannot expand the SETF form ~S." form))))

+ (error 'program-error :format-control "Cannot expand the SETF form ~S." :format-arguments (list form)))))

;;;; SETF definitions.