Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/describe.clisp
There are no other files named describe.clisp in the archive.
;;;-*- Mode:CLISP; Package:LISP -*-
(in-package 'lisp)
(export '(describe defdescribe))
(defun concat-pnames (name1 name2 &optional (package *package*))
(if name1
(intern (string-concatenate (symbol-name name1)
(symbol-name name2))
package)
name2))
(defun describe (object)
"Prints a description of the object"
(let* ((type (cond ((symbolp (type-of object)) (type-of object))
((structurep object) 'structure)
((arrayp object) 'array)
(t (type-of object))))
(fun (concat-pnames 'internal-describe- type *lisp-package*)))
(if (fboundp fun)
(funcall fun object)
(format t "~&~S is a ~s." object (type-of object))))
(values))
(defmacro defdescribe (ignore type args &body body)
(declare (ignore ignore))
`(setf (symbol-function (concat-pnames 'internal-describe- ',type
*lisp-package*))
#'(lambda ,args
,@body)))
(defdescribe x symbol (x)
(let ((pack (symbol-package x))
(name (symbol-name x)))
(format t "~&~@(~S~) is an ~@(~a~) Symbol in the ~a package."
x (symbol-name (multiple-value-bind (foo bar)
(find-symbol name pack)
bar))
(package-name pack)))
(if (boundp X)
(let ((*print-level* 3)
(*print-length* 5))
(format t "~%Its value is ~S." (symbol-value x))))
(desc-doc x 'variable "Documentation on the variable:")
(if (fboundp x)
(let ((function (symbol-function x))
(*package* (symbol-package x)))
(cond ((and (listp function)
(eq (car function) 'macro))
(format t "~%It can be called as a macro ~
in the following way:~% ~S"
(cons x (desc-arglist x))))
((special-form-p x)
(format t "~%It can be called as a special form ~
in the following way:~% ~S"
(cons x (desc-arglist x))))
(t
(format t "~%It can be called as a function ~
in the following way:~% ~S"
(cons x (desc-arglist x)))))))
(desc-doc x 'function "Documentation on the function:")
(desc-doc x 'structure "Documentation on the structure:")
(desc-doc x 'type "Documentation on the type:")
(desc-doc x 'setf "Documentation on the SETF form:")
(desc-doc x 'source "It was defined in the file:")
(do ((plist (symbol-plist X) (cddr plist)))
((null plist) ())
(unless (member (car plist) *implementation-properties*)
(format t "~%Its ~S property is ~S." (car plist) (cadr plist)))))
(defdescribe x hash-table (x)
(format t "~&~S is a Hash-table." x)
(format t "~%It currently has ~S entries and ~S buckets."
(hash-table-count x) (hash-table-size x)))
(defdescribe x array (x)
(format t "~&~S is an Array (~(~s~))." x (car (type-of x)))
(let ((type (array-element-type x))
(rank (array-rank x))
(dims (array-dimensions x))
(tsize (array-total-size x))
(adjp (adjustable-array-p x)))
(format t "~%It has type ~a, and is ~@[not ~]adjustable." type (not adjp))
(format t "~%Is has rank ~d, and dimensions ~s." rank dims)))
(defdescribe x package (x)
(format t "~&~S is a Package." x)
(format t "~%The name of this package is ~a." (package-name x))
(let ((nicknames (package-nicknames x))
(uselist (package-use-list x))
(usedlist (package-used-by-list x))
(shadowing (package-shadowing-symbols x)))
(if nicknames
(apply #'format t "~%It has nickname~p~#[ none~; ~a~; ~a and ~a~:;~
~@{~#[~; and~] ~a~^,~}~]."
(length nicknames) nicknames))
(if uselist
(apply #'format t "~%It uses package~p~#[ none~; ~a~; ~a and ~a~:;~
~@{~#[~; and~] ~a~^,~}~]."
(length uselist) (mapcar #'package-name uselist)))
(if usedlist
(apply #'format t "~%Is is used by package~p~#[ none~; ~a~; ~a and ~a~
~:;~@{~#[~; and~] ~a~^,~}~]."
(length usedlist) (mapcar #'package-name usedlist)))
(if shadowing
(format t "~%It has ~d shadowing symbol~:p."
(length shadowing)))))
(defdescribe x stream (x)
(format t "~&~S is a Stream." x)
(let ((outp (output-stream-p x))
(inp (input-stream-p x)))
(cond ((or inp outp)
(let ((type (stream-element-type x)))
(if (and inp outp)
(format t "~%It can be used for both input and output.")
(if inp
(format t "~%It can be used for input only."))
(if outp
(format t "~%It can be used for output only.")))
(format t "~%It is of type ~a." type)))
(t (format t "~%It can not be used for in- or output.")))))
(defdescribe x structure (x)
(let ((type-of (type-of x))
(printer (get (type-of x) 'structure-print)))
(format t "~S~%~2,tis a structure of type ~a." x type-of)
(when printer
(format t "~%It prints like:~%")
(funcall printer x *standard-output* 0))
(desc-doc type-of 'structure "Documentation on the structure:")
(let ((info (get type-of 'defstruct-description)))
(if info
(let ((name (defstruct-description-name info))
(type (defstruct-description-type info))
(options (defstruct-description-options info))
(size (defstruct-description-size info))
(conc-name (defstruct-description-conc-name info))
(constructor (defstruct-description-constructor info))
(slot-names (defstruct-description-slot-names info))
(slot-pure-names (defstruct-description-slot-pure-names info))
(slot-defaults (defstruct-description-slot-defaults info))
(slot-numbers (defstruct-description-slot-numbers info))
(slot-types (defstruct-description-slot-types info))
(slot-keywords (defstruct-description-slot-keywords info))
(slot-options (defstruct-description-slot-options info)))
(if name (format t "~%~@TIts name is ~a." name))
(if type (format t "~%~@tIts type is ~a." type))
(if options (format t "~%~@tIts options are ~s." options))
(format t "~%~@tIts size is ~d." size)
(format t "~%~@tIts conc-name is ~a." conc-name)
(format t "~%~@tIts conctructor is ~a." constructor)
(format t "~%~@tIts slot-names are~{ ~a~}." slot-names)
(if (delete nil slot-defaults)
(format t "~%~@tIts slot-defaults are~{ ~a~}." slot-defaults))
(if slot-types
(format t "~%~@tIts slot-types are~{ ~a~}." slot-types))
(format t "~%~@tIts slot-keywords are~{ ~a~}." slot-keywords)
(if (delete nil slot-options)
(format t "~%~@tIts slot-options are~{ ~a~}."
slot-options)))))))