![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to describe.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib|
Return to describe.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib |
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.