From 38d837ef708a4377ad988a9e73a0ec4429e8c95d Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Fri, 23 Aug 2002 17:08:53 +0000 Subject: [PATCH] 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. --- code/lispinit.lisp | 26 ++++++++- code/package.lisp | 128 ++++++++++++++++++++++++++++++--------------- 2 files changed, 111 insertions(+), 43 deletions(-) diff --git a/code/lispinit.lisp b/code/lispinit.lisp index b9264e7d9..2b1d30587 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.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/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 @@ (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition))) 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") diff --git a/code/package.lisp b/code/package.lisp index fd5584393..3963fb0d1 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.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 @@ ;;; INTERNAL conditions (define-condition simple-package-error (simple-condition package-error)()) -(define-condition simple-program-error (simple-condition program-error)()) (defstruct (package (:constructor internal-make-package) @@ -711,16 +710,13 @@ (,',init-macro ,(car ',ordered-types))))))) (when ,packages ,(when (null symbol-types) - (error 'program-error - :format-control - "Must supply at least one of :internal, :external, or ~ - :inherited.")) + (simple-program-error "Must supply at least one of :internal, ~ + :external, or :inherited.")) ,(dolist (symbol symbol-types) (unless (member symbol '(:internal :external :inherited)) - (error 'program-error - :format-control - "~S is not one of :internal, :external, or :inherited." - :format-argument symbol))) + (simple-program-error "~S is not one of :internal, :external, ~ + or :inherited." + symbol))) (,init-macro ,(car ordered-types)) (flet ((,real-symbol-p (number) (> number 1))) @@ -821,24 +817,20 @@ (doc nil)) (dolist (option options) (unless (consp option) - (error 'program-error - :format-control "Bogus DEFPACKAGE option: ~S" - :format-arguments (list option))) + (simple-program-error "Bogus DEFPACKAGE option: ~S" option)) (case (car option) (:nicknames (setf nicknames (stringify-names (cdr option) "package"))) (:size (cond (size - (error 'program-error - :format-control "Can't specify :SIZE twice.")) + (simple-program-error "Can't specify :SIZE twice.")) ((and (consp (cdr option)) (typep (second option) 'unsigned-byte)) (setf size (second option))) (t - (error - 'program-error - :format-control "Bogus :SIZE, must be a positive integer: ~S" - :format-arguments (list (second option)))))) + (simple-program-error + "Bogus :SIZE, must be a positive integer: ~S" + (second option))))) (:shadow (let ((new (stringify-names (cdr option) "symbol"))) (setf shadows (append shadows new)))) @@ -871,13 +863,10 @@ (setf exports (append exports new)))) (:documentation (when doc - (error 'program-error - :format-control "Can't specify :DOCUMENTATION twice.")) + (simple-program-error "Can't specify :DOCUMENTATION twice.")) (setf doc (coerce (second option) 'simple-string))) (t - (error 'program-error - :format-control "Bogus DEFPACKAGE option: ~S" - :format-arguments (list option))))) + (simple-program-error "Bogus DEFPACKAGE option: ~S" option)))) (check-disjoint `(:intern ,@interns) `(:export ,@exports)) (check-disjoint `(:intern ,@interns) `(:import-from @@ -891,17 +880,19 @@ ',imports ',interns ',exports ',doc)))) (defun check-disjoint (&rest args) - ;; An arg is (:key . set) - (do ((list args (cdr list))) - ((endp list)) - (loop - with x = (car list) - for y in (rest list) - for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=)) - when z do (error 'program-error - :format-control "Parameters ~S and ~S must be disjoint ~ - but have common elements ~% ~S" - :format-arguments (list (car x)(car y) z))))) + ;; Check wether all given arguments specify disjoint sets of symbols. + ;; Each argument is of the form (:key . set). + (loop for (current-arg . rest-args) on args + do + (loop with (key1 . set1) = current-arg + for (key2 . set2) in rest-args + for common = (delete-duplicates + (intersection set1 set2 :test #'string=)) + unless (null common) + do + (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 use imports interns exports doc-string) @@ -1629,13 +1620,66 @@ ;;; Apropos and Apropos-List. (defun briefly-describe-symbol (symbol) - (fresh-line) - (prin1 symbol) - (when (boundp symbol) - (write-string ", value: ") - (prin1 (symbol-value symbol))) - (if (fboundp symbol) - (write-string " (defined)"))) + (let ((prefix-length nil)) + (flet ((print-symbol (&optional kind) + (fresh-line) + (if prefix-length + (dotimes (i prefix-length) + (write-char #\Space)) + (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) (declare (simple-string string)) -- GitLab