Skip to content
Snippets Groups Projects
Commit 38d837ef authored by pmai's avatar pmai
Browse files

Added simple-program-error function that works like error, except that

it defaults to simple-program-error.  Removed duplicate definition of
simple-program-error from package.lisp, and converted various places
to use the new simple-program-error function.  Also rewrote the
function check-disjoint for clarity.
parent 7973fabc
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.66 2002/07/10 16:15:59 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.67 2002/08/23 17:08:52 pmai Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -248,6 +248,30 @@ ...@@ -248,6 +248,30 @@
(format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition))) (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition)))
nil) nil)
;;; Utility functions
(defun simple-program-error (datum &rest arguments)
"Invokes the signal facility on a condition formed from datum and arguments.
If the condition is not handled, the debugger is invoked. This function
is just like error, except that the condition type defaults to the type
simple-program-error, instead of program-error."
(kernel:infinite-error-protect
(let ((condition (coerce-to-condition datum arguments
'simple-program-error
'simple-program-error))
(debug:*stack-top-hint* debug:*stack-top-hint*))
(unless (and (condition-function-name condition) debug:*stack-top-hint*)
(multiple-value-bind
(name frame)
(kernel:find-caller-name)
(unless (condition-function-name condition)
(setf (condition-function-name condition) name))
(unless debug:*stack-top-hint*
(setf debug:*stack-top-hint* frame))))
(let ((debug:*stack-top-hint* nil))
(signal condition))
(invoke-debugger condition))))
(in-package "LISP") (in-package "LISP")
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.58 2001/07/08 17:37:54 pw Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.59 2002/08/23 17:08:53 pmai Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -40,7 +40,6 @@ ...@@ -40,7 +40,6 @@
;;; INTERNAL conditions ;;; INTERNAL conditions
(define-condition simple-package-error (simple-condition package-error)()) (define-condition simple-package-error (simple-condition package-error)())
(define-condition simple-program-error (simple-condition program-error)())
(defstruct (package (defstruct (package
(:constructor internal-make-package) (:constructor internal-make-package)
...@@ -711,16 +710,13 @@ ...@@ -711,16 +710,13 @@
(,',init-macro ,(car ',ordered-types))))))) (,',init-macro ,(car ',ordered-types)))))))
(when ,packages (when ,packages
,(when (null symbol-types) ,(when (null symbol-types)
(error 'program-error (simple-program-error "Must supply at least one of :internal, ~
:format-control :external, or :inherited."))
"Must supply at least one of :internal, :external, or ~
:inherited."))
,(dolist (symbol symbol-types) ,(dolist (symbol symbol-types)
(unless (member symbol '(:internal :external :inherited)) (unless (member symbol '(:internal :external :inherited))
(error 'program-error (simple-program-error "~S is not one of :internal, :external, ~
:format-control or :inherited."
"~S is not one of :internal, :external, or :inherited." symbol)))
:format-argument symbol)))
(,init-macro ,(car ordered-types)) (,init-macro ,(car ordered-types))
(flet ((,real-symbol-p (number) (flet ((,real-symbol-p (number)
(> number 1))) (> number 1)))
...@@ -821,24 +817,20 @@ ...@@ -821,24 +817,20 @@
(doc nil)) (doc nil))
(dolist (option options) (dolist (option options)
(unless (consp option) (unless (consp option)
(error 'program-error (simple-program-error "Bogus DEFPACKAGE option: ~S" option))
:format-control "Bogus DEFPACKAGE option: ~S"
:format-arguments (list option)))
(case (car option) (case (car option)
(:nicknames (:nicknames
(setf nicknames (stringify-names (cdr option) "package"))) (setf nicknames (stringify-names (cdr option) "package")))
(:size (:size
(cond (size (cond (size
(error 'program-error (simple-program-error "Can't specify :SIZE twice."))
:format-control "Can't specify :SIZE twice."))
((and (consp (cdr option)) ((and (consp (cdr option))
(typep (second option) 'unsigned-byte)) (typep (second option) 'unsigned-byte))
(setf size (second option))) (setf size (second option)))
(t (t
(error (simple-program-error
'program-error "Bogus :SIZE, must be a positive integer: ~S"
:format-control "Bogus :SIZE, must be a positive integer: ~S" (second option)))))
:format-arguments (list (second option))))))
(:shadow (:shadow
(let ((new (stringify-names (cdr option) "symbol"))) (let ((new (stringify-names (cdr option) "symbol")))
(setf shadows (append shadows new)))) (setf shadows (append shadows new))))
...@@ -871,13 +863,10 @@ ...@@ -871,13 +863,10 @@
(setf exports (append exports new)))) (setf exports (append exports new))))
(:documentation (:documentation
(when doc (when doc
(error 'program-error (simple-program-error "Can't specify :DOCUMENTATION twice."))
:format-control "Can't specify :DOCUMENTATION twice."))
(setf doc (coerce (second option) 'simple-string))) (setf doc (coerce (second option) 'simple-string)))
(t (t
(error 'program-error (simple-program-error "Bogus DEFPACKAGE option: ~S" option))))
:format-control "Bogus DEFPACKAGE option: ~S"
:format-arguments (list option)))))
(check-disjoint `(:intern ,@interns) `(:export ,@exports)) (check-disjoint `(:intern ,@interns) `(:export ,@exports))
(check-disjoint `(:intern ,@interns) (check-disjoint `(:intern ,@interns)
`(:import-from `(:import-from
...@@ -891,17 +880,19 @@ ...@@ -891,17 +880,19 @@
',imports ',interns ',exports ',doc)))) ',imports ',interns ',exports ',doc))))
(defun check-disjoint (&rest args) (defun check-disjoint (&rest args)
;; An arg is (:key . set) ;; Check wether all given arguments specify disjoint sets of symbols.
(do ((list args (cdr list))) ;; Each argument is of the form (:key . set).
((endp list)) (loop for (current-arg . rest-args) on args
(loop do
with x = (car list) (loop with (key1 . set1) = current-arg
for y in (rest list) for (key2 . set2) in rest-args
for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=)) for common = (delete-duplicates
when z do (error 'program-error (intersection set1 set2 :test #'string=))
:format-control "Parameters ~S and ~S must be disjoint ~ unless (null common)
but have common elements ~% ~S" do
:format-arguments (list (car x)(car y) z))))) (simple-program-error "Parameters ~S and ~S must be disjoint ~
but have common elements ~% ~S"
key1 key2 common))))
(defun %defpackage (name nicknames size shadows shadowing-imports (defun %defpackage (name nicknames size shadows shadowing-imports
use imports interns exports doc-string) use imports interns exports doc-string)
...@@ -1629,13 +1620,66 @@ ...@@ -1629,13 +1620,66 @@
;;; Apropos and Apropos-List. ;;; Apropos and Apropos-List.
(defun briefly-describe-symbol (symbol) (defun briefly-describe-symbol (symbol)
(fresh-line) (let ((prefix-length nil))
(prin1 symbol) (flet ((print-symbol (&optional kind)
(when (boundp symbol) (fresh-line)
(write-string ", value: ") (if prefix-length
(prin1 (symbol-value symbol))) (dotimes (i prefix-length)
(if (fboundp symbol) (write-char #\Space))
(write-string " (defined)"))) (let ((symbol-string (prin1-to-string symbol)))
(write-string symbol-string)
(setq prefix-length (length symbol-string))))
(when kind
(write-string " [")
(write-string kind)
(write-string "] "))))
;; Variable namespace
(multiple-value-bind (kind recorded-p) (info variable kind symbol)
(when (or (boundp symbol) recorded-p)
(print-symbol (ecase kind
(:special "special variable")
(:constant "constant")
(:global "undefined variable")
(:macro "symbol macro")
(:alien "alien variable")))
(when (boundp symbol)
(write-string "value: ")
(let ((*print-length*
(or ext:*describe-print-length* *print-length*))
(*print-level*
(or ext:*describe-print-level* *print-level*)))
(prin1 (symbol-value symbol))))))
;; Function namespace
(when (fboundp symbol)
(cond
((macro-function symbol)
(print-symbol "macro")
(let ((arglist (kernel:%function-arglist (macro-function symbol))))
(when (stringp arglist) (write-string arglist))))
((special-operator-p symbol)
(print-symbol "special operator")
(let ((arglist (kernel:%function-arglist (symbol-function symbol))))
(when (stringp arglist) (write-string arglist))))
(t
(print-symbol "function")
;; could do better than this with (kernel:type-specifier
;; (info function type symbol)) when it's a byte-compiled function
(let ((arglist (kernel:%function-arglist (symbol-function symbol))))
(when (stringp arglist) (write-string arglist))))))
;; Class and Type Namespace(s)
(cond
((find-class symbol nil)
(print-symbol "class"))
((info type kind symbol)
(print-symbol "type")))
;; Make sure we at least print the symbol itself if we don't know
;; anything else about it:
(when (null prefix-length)
(print-symbol)))))
(defun apropos-search (symbol string) (defun apropos-search (symbol string)
(declare (simple-string string)) (declare (simple-string string))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment