;;; the guts.
(defun %describe-fun-compiled (x s kind name)
(declare (type stream s))
- ;; FIXME: The lowercaseness of %SIMPLE-FUN-ARGLIST results, and the
- ;; non-sentenceness of the "Arguments" label, makes awkward output.
- ;; Better would be "Its arguments are: ~S" (with uppercase argument
- ;; names) when arguments are known, and otherwise "There is no
- ;; information available about its arguments." or "It has no
- ;; arguments." (And why is %SIMPLE-FUN-ARGLIST a string instead of a
- ;; list of symbols anyway?)
(let ((args (%simple-fun-arglist x)))
- (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind)
(cond ((not args)
- (format s " There is no argument information available."))
- ((string= args "()")
(write-string " There are no arguments." s))
(t
+ (format s "~@:_~@(The ~@[~A's ~]arguments are:~@:_~)" kind)
(write-string " " s)
- (pprint-logical-block (s nil)
- (pprint-indent :current 2)
- (write-string args s)))))
+ (let ((*print-pretty* t)
+ (*print-escape* t)
+ (*print-base* 10)
+ (*print-radix* nil))
+ (pprint-logical-block (s nil)
+ (pprint-indent :current 2)
+ (format s "~A" args))))))
(let ((name (or name (%simple-fun-name x))))
(%describe-doc name s 'function kind)
(unless (eq kind :macro)
(%describe-fun-name name s (%simple-fun-type x))))
(%describe-compiled-from (sb-kernel:fun-code-header x) s))
-;;; Describe a function with the specified kind and name. The latter
-;;; arguments provide some information about where the function came
-;;; from. KIND=NIL means not from a name.
-(defun %describe-fun (x s &optional (kind nil) name)
+;;; Describe a function object. KIND and NAME provide some information
+;;; about where the function came from.
+(defun %describe-fun (x s &optional (kind :function) (name nil))
(declare (type function x))
(declare (type stream s))
- (declare (type (member :macro :function nil) kind))
+ (declare (type (member :macro :function) kind))
(fresh-line s)
(ecase kind
(:macro (format s "Macro-function: ~S" x))
- (:function (format s "Function: ~S" x))
- ((nil) (format s "~S is a function." x)))
+ (:function (if name
+ (format s "Function: ~S" x)
+ (format s "~S is a function." x))))
(format s "~@:_Its associated name (as in ~S) is ~S."
'function-lambda-expression
(%fun-name x))
((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag)
(%describe-fun-compiled x s kind name))
(#.sb-vm:funcallable-instance-header-widetag
- (typecase x
- (standard-generic-function
- ;; There should be a special method for this case; we'll
- ;; delegate to that.
- (describe-object x s))
- (t
- (format s "~@:_It is an unknown type of funcallable instance."))))
+ ;; Only STANDARD-GENERIC-FUNCTION would be handled here, but
+ ;; since it has its own DESCRIBE-OBJECT method, it should've been
+ ;; picked off before getting here. So hopefully we never get here.
+ (format s "~@:_It is an unknown type of funcallable instance."))
(t
(format s "~@:_It is an unknown type of function."))))
(defmethod describe-object ((x function) s)
- (%describe-fun x s))
-
+ (%describe-fun x s :function))
+
+(defgeneric describe-symbol-fdefinition (function stream &key (name nil) ))
+
+(defmethod describe-symbol-fdefinition ((fun function) stream &key name)
+ (%describe-fun fun stream :function name))
+
+(defmethod describe-symbol-fdefinition ((fun standard-generic-function) stream
+ &key name)
+ (declare (ignore name))
+ ;; just delegate
+ (describe-object fun stream))
+
(defmethod describe-object ((x symbol) s)
(declare (type stream s))
(cond ((macro-function x)
(%describe-fun (macro-function x) s :macro x))
((special-operator-p x)
- (%describe-doc x s 'function "Special form"))
+ (%describe-doc x s :function "Special form"))
((fboundp x)
- (%describe-fun (fdefinition x) s :function x)))
+ (describe-symbol-fdefinition (fdefinition x) s :name x)))
;; FIXME: Print out other stuff from the INFO database:
;; * Does it name a type?
;; Describe the associated class, if any.
(let ((symbol-named-class (cl:find-class x nil)))
(when symbol-named-class
- (format t "~&It names a class ~A." symbol-named-class)
+ (format s "~&It names a class ~A." symbol-named-class)
(describe symbol-named-class))))
(select-component-format component)
(values))
-;;; Takes the list representation of the debug arglist and turns it
-;;; into a string.
-;;;
-;;; FIXME: Why don't we just save this as a list instead of converting
-;;; it to a string?
-(defun make-arg-names (x)
- (declare (type functional x))
- (let ((args (functional-arg-documentation x)))
- (aver (not (eq args :unspecified)))
- (if (null args)
- "()"
- (let ((*print-pretty* t)
- (*print-escape* t)
- (*print-base* 10)
- (*print-radix* nil)
- (*print-case* :downcase))
- (write-to-string args)))))
-
;;; Initialize INFO structure to correspond to the XEP LAMBDA FUN.
(defun compute-entry-info (fun info)
(declare (type clambda fun) (type entry-info info))
(setf (entry-info-name info)
(leaf-debug-name internal-fun))
(when (policy bind (>= debug 1))
- (setf (entry-info-arguments info) (make-arg-names internal-fun))
+ (let ((args (functional-arg-documentation internal-fun)))
+ (aver (not (eq args :unspecified)))
+ (setf (entry-info-arguments info) args))
(setf (entry-info-type info) (type-specifier (leaf-type internal-fun)))))
(values))
:ref-trans %simple-fun-name
:set-known (unsafe)
:set-trans (setf %simple-fun-name))
- (arglist :ref-known (flushable)
+ (arglist :type list
+ :ref-known (flushable)
:ref-trans %simple-fun-arglist
:set-known (unsafe)
:set-trans (setf %simple-fun-arglist))
;; of the function, a symbol or (SETF <symbol>). Otherwise, this is
;; some string that is intended to be informative.
(name "<not computed>" :type (or simple-string list symbol))
- ;; a string representing the argument list that the function was
- ;; defined with
- (arguments nil :type (or simple-string null))
+ ;; the argument list that the function was defined with.
+ (arguments nil :type list)
;; a function type specifier representing the arguments and results
;; of this function
(type 'function :type (or list (member function))))
--- /dev/null
+;;;; This file is for testing debugging functionality, using
+;;;; test machinery which might have side-effects (e.g.
+;;;; executing DEFUN).
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(cl:in-package :cl-user)
+\f
+;;;; Check that we get debug arglists right.
+
+;;; Return the debug arglist of the function object FUN as a list, or
+;;; punt with :UNKNOWN.
+(defun get-arglist (fun)
+ (declare (type function fun))
+ ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
+ (case (sb-kernel:widetag-of fun)
+ ((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag)
+ (sb-kernel:%simple-fun-arglist fun))
+ (#.sb-vm:closure-header-widetag (get-arglist
+ (sb-kernel:%closure-fun fun)))
+ ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
+ ;; like above, and it seems to work. -- MNA 2001-06-12
+ ;;
+ ;; (There might be other cases with arglist info also.
+ ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
+ ;; happen to be the two case that I had my nose rubbed in when
+ ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
+ ;; a closure. -- WHN 2001-06-05)
+ (t :unknown)))
+
+(defun zoop (zeep &key beep)
+ blurp)
+(assert (equal (get-arglist #'zoop) '(zeep &key beep)))
+
+;;; Check some predefined functions too.
+;;;
+;;; (We don't know exactly what the arguments are, e.g. the first
+;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
+;;; whatever. But we do know the general structure that a correct
+;;; answer should have, so we can safely do a lot of checks.)
+(destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
+ (assert (symbolp object-sym))
+ (assert (eql &optional-sym '&optional))
+ (assert (symbolp stream-sym)))
+(destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
+ (get-arglist #'format)
+ (assert (symbolp dest-sym))
+ (assert (symbolp control-sym))
+ (assert (eql &rest-sym '&rest))
+ (assert (symbolp format-args-sym)))
\f
;;;; properties of symbols, e.g. presence of doc strings for public symbols
-;;; Check for fbound external symbols in public packages that have no
-;;; argument list information. (This used to be possible when we got
-;;; carried away with byte compilation, since the byte compiler can't
-;;; record argument list information. Now that there's no byte
-;;; compiler, that can't happen, but it still shouldn't hurt to check
-;;; in case the argument information goes astray some other way.)
-(defvar *public-package-names*
- '("SB-ALIEN" "SB-C-CALL" "SB-DEBUG" "SB-EXT" "SB-GRAY" "SB-MP"
- "SB-PROFILE" "SB-PCL" "COMMON-LISP"))
-(defun has-arglist-info-p (fun)
- (declare (type function fun))
- ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
- (case (sb-kernel:widetag-of fun)
- ((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag)
- (sb-kernel:%simple-fun-arglist fun))
- (#.sb-vm:closure-header-widetag (has-arglist-info-p
- (sb-kernel:%closure-fun fun)))
- ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
- ;; like above, and it seems to work. -- MNA 2001-06-12
- ;;
- ;; (There might be other cases with arglist info also.
- ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
- ;; happen to be the two case that I had my nose rubbed in when
- ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
- ;; a closure. -- WHN 2001-06-05)
- (t nil)))
-(defun check-ext-symbols-arglist (package)
- (format t "~% looking at package: ~A" package)
- (do-external-symbols (ext-sym package)
- (when (fboundp ext-sym)
- (let ((fun (symbol-function ext-sym)))
- (cond ((macro-function ext-sym)
- ;; FIXME: Macro functions should have their argument list
- ;; information checked separately. Just feeding them into
- ;; the ordinary-function logic below doesn't work right,
- ;; though, and I haven't figured out what does work
- ;; right. For now we just punt.
- (values))
- ((typep fun 'generic-function)
- (sb-pcl::generic-function-pretty-arglist fun))
- (t
- (let ((fun (symbol-function ext-sym)))
- (unless (has-arglist-info-p fun)
- (error "Function ~A has no arg-list information available."
- ext-sym)))))))))
-(dolist (public-package *public-package-names*)
- (when (find-package public-package)
- (check-ext-symbols-arglist public-package)))
-(terpri)
-
;;; FIXME: It would probably be good to require here that every
;;; external symbol either has a doc string or has some good excuse
;;; (like being an accessor for a structure which has a doc string).
projects / sbcl.git / commitdiff