Return to describe.l CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib

Annotation of 43BSDReno/pgrm/lisp/lisplib/describe.l, revision 1.1

1.1     ! root        1: ; -*- Package:SYSTEM-INTERNALS; Mode:LISP; Base:8 -*-
        !             2: ; MACHINE MISCELLANEOUS FUNCTIONS NOT WORTHY OF BEING IN QFCTNS
        !             3: ;      ** (c) Copyright 1980 Massachusetts Institute of Technology **
        !             4: (setq rcs-describe-
        !             5:    "$Header: describe.l,v 1.3 85/03/24 11:23:34 sklower Exp $")
        !             6: 
        !             7: (setq SCCS-describe "@(#) describe.l   1.1     83/01/27 @(#)")
        !             8: 
        !             9: ;Describe anything
        !            10: 
        !            11: (environment-lmlisp (compile eval) (files struct flavorm))
        !            12: 
        !            13: 
        !            14: (declare (special indent))
        !            15: 
        !            16: (defun describe (anything &optional no-complaints &aux (indent 0))
        !            17:   (describe-2 anything no-complaints))
        !            18: 
        !            19: (defun describe-2 (anything no-complaints &aux type)
        !            20:   (cond ((named-structure-p anything)
        !            21:         (describe-defstruct anything))
        !            22:        ((and (instancep anything)
        !            23:              (get-handler-for anything ':describe))
        !            24:         (send anything ':describe))
        !            25:        ((:typep anything 'flavor)
        !            26:         (describe-flavor anything))
        !            27:        ((arrayp anything)
        !            28:         (describe-array anything))
        !            29:        ((symbolp anything)
        !            30:         (describe-symbol anything))
        !            31:        ((listp anything)
        !            32:         (describe-list anything))
        !            33:        ((floatp anything)
        !            34:         (describe-flonum anything))
        !            35:        ((bigp anything)
        !            36:         (describe-bignum anything))
        !            37:        ((fixp anything)
        !            38:         (format t "~%~vX~R is ~[even~;odd~]"
        !            39:                 indent anything (if (evenp anything) 0 1)))
        !            40:        ((not no-complaints)
        !            41:         (format t "~%I don't know how to describe ~S" anything)))
        !            42:   (terpri)
        !            43:   anything)
        !            44: 
        !            45: (defun describe-1 (thing)      ;an internal subroutine
        !            46:   (cond ((or (null thing) ;Don't recursively describe relatively boring things
        !            47:             (numberp thing) (symbolp thing) (stringp thing))
        !            48:         nil)
        !            49:        (t (let ((indent (+ indent 4)))
        !            50:                (describe-2 thing t))
        !            51:           (terpri))))
        !            52: 
        !            53: (defun describe-symbol (sym)
        !            54:   (cond ((boundp sym)
        !            55:         (let ((prinlevel 2) (prinlength 3))
        !            56:           (format t  "~%~vXThe value of ~S is ~S" indent sym (symeval sym)))
        !            57:         (describe-1 (symeval sym))))
        !            58:   (cond ((fboundp sym)
        !            59:         (let ((prinlevel 2) (prinlength 3))
        !            60:           (format t "~%~vX~S is the function ~S: ~S"
        !            61:                   indent sym (getd sym) '(???)))
        !            62:         (describe-1 (getd sym))))
        !            63:   (do ((pl (plist sym) (cddr pl))
        !            64:        (prinlevel 2)
        !            65:        (prinlength 3))
        !            66:       ((null pl))
        !            67: ;   (format t "~%~~vXS has property ~S: ~S"    ; SMH@MIT-EMS
        !            68:     (format t "~%~vX~S has property ~S: ~S"
        !            69:            indent sym (car pl) (cadr pl))
        !            70:     (describe-1 (cadr pl)))
        !            71:   nil)
        !            72: 
        !            73: (defun describe-list (l)
        !            74:   (format t "~%~vX~S is a list" indent l))
        !            75: 
        !            76: ;Fixed indent botch: this is not necessarily called from describe!  SMH@EMS
        !            77: (defun describe-defstruct
        !            78:        (x &optional defstruct-type
        !            79:          &aux description
        !            80:               (indent (cond ((and (boundp 'indent) (fixp indent)) indent)
        !            81:                             (t 0))))
        !            82:   (setq description (get (or defstruct-type (named-structure-symbol x))
        !            83:                         'defstruct-description))
        !            84: ; (format t "~%~vX~S is a ~S~%" indent x (defstruct-description-name)) SMH@EMS
        !            85:   (format t "~%~vX~S is a ~S~%" indent x
        !            86:          (defstruct-description-name description))
        !            87:   (do l (defstruct-description-slot-alist) (cdr l) (null l)
        !            88:       (format t "~vX   ~30A~S~%"
        !            89:              indent
        !            90:              (concat (caar l) ":")
        !            91:              (eval `(,(defstruct-slot-description-ref-macro-name (cdar l))
        !            92:                      ',x)))))
        !            93: 
        !            94: (defun describe-fclosure (cl)
        !            95:   (format t "~vX~%~S is an fclosure of ~S:~%" cl (fclosure-function cl))
        !            96:   (loop for pair in (fclosure-alist cl)
        !            97:        do (format t "~vX   Value cell of ~S:        ~32,7S~%"
        !            98:                   indent
        !            99:                   (car pair) (cadr pair))))
        !           100: 
        !           101: (defun describe-flonum (x)
        !           102:   (format t "~%~vX~S is a flonum.~%  " indent x)
        !           103: ;;  (format T "Excess-2000 exponent ~O, 32-bit mantissa ~O~4,48O~4,48O (including sign)")
        !           104:   )
        !           105: 
        !           106: (defun describe-bignum (x)
        !           107:   (let ((len (haulong x))
        !           108:        (barf nil))
        !           109:     (format t "~&~S is a bignum.~&It is ~R word~:P long."
        !           110:            x len)
        !           111:     (terpri))
        !           112:   x)
        !           113: 
        !           114: (defun describe-array (array &aux arraydims ndims)
        !           115:  (cond ((arrayp array)
        !           116:        (format t "~vX~%This is a ~S type array."
        !           117:                indent (car (getaux array)))
        !           118:        (setq arraydims (cdr (arraydims array)))
        !           119:        (setq ndims (length arraydims))
        !           120:        (cond ((> ndims 1)
        !           121:               (format t  "~vX~%It is ~D-dimensional, with dimensions "
        !           122:                       indent ndims)
        !           123:               (do l arraydims (cdr l) (null l)
        !           124:                   (format t "~s " (car l))))
        !           125:              (t (format t "~%It is ~S long." (car arraydims)))))
        !           126:        (t (ferror nil "~S is not an array" array))))
        !           127: 
        !           128: (declare (macros t))
        !           129: 
        !           130: (defmacro mapatoms (fcnt) `(mapc ,fcnt (oblist)))
        !           131: 
        !           132: (declare (special apropos-substring return-list))
        !           133: 
        !           134: (defun apropos (apropos-substring &rest rest
        !           135:                &aux return-list)
        !           136:   rest 
        !           137:   (mapatoms #'apropos-1 pkg)
        !           138:   return-list)
        !           139: 
        !           140: (defun apropos-1 (symbol)
        !           141:   (cond ((within-string apropos-substring (get_pname symbol))
        !           142:         (push symbol return-list)
        !           143:         (format t "~%~s" symbol)
        !           144:         (and (fboundp symbol)
        !           145:              (format t " - Function"))
        !           146:         (and (boundp symbol)
        !           147:              (cond ((fboundp symbol) (princ ", Bound"))
        !           148:                    (t (princ " - Bound")))))))
        !           149: 
        !           150: (defun within-string (s1 s2 &aux (len (flatc s1)))
        !           151:   (loop for i from 1 to (flatc s2)
        !           152:        with fc = (getcharn s1 1)
        !           153:        when (and (= (getcharn s2 i) fc)
        !           154:                  (eqstr (substring s2 i len) s1))
        !           155:        return t))
        !           156:        

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.