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))

(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))))

(defmacro defdescribe (ignore type args &body body)
  (declare (ignore ignore))
  `(setf (symbol-function (concat-pnames 'internal-describe- ',type
	 #'(lambda ,args

(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)
	      (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))))
	       (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~}."