usr/src/pgrm/lisp/lisplib/describe.l

; -*- Package:SYSTEM-INTERNALS; Mode:LISP; Base:8 -*-
; MACHINE MISCELLANEOUS FUNCTIONS NOT WORTHY OF BEING IN QFCTNS
;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
(setq rcs-describe-
   "$Header: describe.l,v 1.3 85/03/24 11:23:34 sklower Exp $")

(setq SCCS-describe "@(#) describe.l    1.1     83/01/27 @(#)")

;Describe anything

(environment-lmlisp (compile eval) (files struct flavorm))


(declare (special indent))

(defun describe (anything &optional no-complaints &aux (indent 0))
  (describe-2 anything no-complaints))

(defun describe-2 (anything no-complaints &aux type)
  (cond ((named-structure-p anything)
         (describe-defstruct anything))
        ((and (instancep anything)
              (get-handler-for anything ':describe))
         (send anything ':describe))
        ((:typep anything 'flavor)
         (describe-flavor anything))
        ((arrayp anything)
         (describe-array anything))
        ((symbolp anything)
         (describe-symbol anything))
        ((listp anything)
         (describe-list anything))
        ((floatp anything)
         (describe-flonum anything))
        ((bigp anything)
         (describe-bignum anything))
        ((fixp anything)
         (format t "~%~vX~R is ~[even~;odd~]"
                 indent anything (if (evenp anything) 0 1)))
        ((not no-complaints)
         (format t "~%I don't know how to describe ~S" anything)))
  (terpri)
  anything)

(defun describe-1 (thing)       ;an internal subroutine
  (cond ((or (null thing) ;Don't recursively describe relatively boring things
             (numberp thing) (symbolp thing) (stringp thing))
         nil)
        (t (let ((indent (+ indent 4)))
                (describe-2 thing t))
           (terpri))))

(defun describe-symbol (sym)
  (cond ((boundp sym)
         (let ((prinlevel 2) (prinlength 3))
           (format t  "~%~vXThe value of ~S is ~S" indent sym (symeval sym)))
         (describe-1 (symeval sym))))
  (cond ((fboundp sym)
         (let ((prinlevel 2) (prinlength 3))
           (format t "~%~vX~S is the function ~S: ~S"
                   indent sym (getd sym) '(???)))
         (describe-1 (getd sym))))
  (do ((pl (plist sym) (cddr pl))
       (prinlevel 2)
       (prinlength 3))
      ((null pl))
;   (format t "~%~~vXS has property ~S: ~S"     ; SMH@MIT-EMS
    (format t "~%~vX~S has property ~S: ~S"
            indent sym (car pl) (cadr pl))
    (describe-1 (cadr pl)))
  nil)

(defun describe-list (l)
  (format t "~%~vX~S is a list" indent l))

;Fixed indent botch: this is not necessarily called from describe!  SMH@EMS
(defun describe-defstruct
       (x &optional defstruct-type
          &aux description
               (indent (cond ((and (boundp 'indent) (fixp indent)) indent)
                             (t 0))))
  (setq description (get (or defstruct-type (named-structure-symbol x))
                         'defstruct-description))
; (format t "~%~vX~S is a ~S~%" indent x (defstruct-description-name)) SMH@EMS
  (format t "~%~vX~S is a ~S~%" indent x
          (defstruct-description-name description))
  (do l (defstruct-description-slot-alist) (cdr l) (null l)
      (format t "~vX   ~30A~S~%"
              indent
              (concat (caar l) ":")
              (eval `(,(defstruct-slot-description-ref-macro-name (cdar l))
                      ',x)))))

(defun describe-fclosure (cl)
  (format t "~vX~%~S is an fclosure of ~S:~%" cl (fclosure-function cl))
  (loop for pair in (fclosure-alist cl)
        do (format t "~vX   Value cell of ~S:        ~32,7S~%"
                   indent
                   (car pair) (cadr pair))))

(defun describe-flonum (x)
  (format t "~%~vX~S is a flonum.~%  " indent x)
;;  (format T "Excess-2000 exponent ~O, 32-bit mantissa ~O~4,48O~4,48O (including sign)")
  )

(defun describe-bignum (x)
  (let ((len (haulong x))
        (barf nil))
    (format t "~&~S is a bignum.~&It is ~R word~:P long."
            x len)
    (terpri))
  x)

(defun describe-array (array &aux arraydims ndims)
 (cond ((arrayp array)
        (format t "~vX~%This is a ~S type array."
                indent (car (getaux array)))
        (setq arraydims (cdr (arraydims array)))
        (setq ndims (length arraydims))
        (cond ((> ndims 1)
               (format t  "~vX~%It is ~D-dimensional, with dimensions "
                       indent ndims)
               (do l arraydims (cdr l) (null l)
                   (format t "~s " (car l))))
              (t (format t "~%It is ~S long." (car arraydims)))))
       (t (ferror nil "~S is not an array" array))))
\f
(declare (macros t))

(defmacro mapatoms (fcnt) `(mapc ,fcnt (oblist)))

(declare (special apropos-substring return-list))

(defun apropos (apropos-substring &rest rest
                &aux return-list)
  rest
  (mapatoms #'apropos-1 pkg)
  return-list)

(defun apropos-1 (symbol)
  (cond ((within-string apropos-substring (get_pname symbol))
         (push symbol return-list)
         (format t "~%~s" symbol)
         (and (fboundp symbol)
              (format t " - Function"))
         (and (boundp symbol)
              (cond ((fboundp symbol) (princ ", Bound"))
                    (t (princ " - Bound")))))))

(defun within-string (s1 s2 &aux (len (flatc s1)))
  (loop for i from 1 to (flatc s2)
        with fc = (getcharn s1 1)
        when (and (= (getcharn s2 i) fc)
                  (eqstr (substring s2 i len) s1))
        return t))