Commit | Line | Data |
---|---|---|
ea9c5dab | 1 | ;;; Describe objects |
17e90c5e KN |
2 | |
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl describe) | |
1a1a10d3 AW |
23 | #:use-module (oop goops) |
24 | #:use-module (ice-9 regex) | |
25 | #:use-module (ice-9 format) | |
26 | #:use-module (ice-9 and-let-star) | |
27 | #:export (describe)) | |
17e90c5e | 28 | |
8f5cfc81 | 29 | (define-method (describe (symbol <symbol>)) |
17e90c5e KN |
30 | (format #t "`~s' is " symbol) |
31 | (if (not (defined? symbol)) | |
32 | (display "not defined in the current module.\n") | |
8f5cfc81 | 33 | (describe-object (module-ref (current-module) symbol)))) |
17e90c5e KN |
34 | |
35 | \f | |
36 | ;;; | |
37 | ;;; Display functions | |
38 | ;;; | |
39 | ||
40 | (define (safe-class-name class) | |
41 | (if (slot-bound? class 'name) | |
42 | (class-name class) | |
43 | class)) | |
44 | ||
45 | (define-method (display-class class . args) | |
46 | (let* ((name (safe-class-name class)) | |
47 | (desc (if (pair? args) (car args) name))) | |
48 | (if (eq? *describe-format* 'tag) | |
49 | (format #t "@class{~a}{~a}" name desc) | |
50 | (format #t "~a" desc)))) | |
51 | ||
77046be3 | 52 | (define (display-list title list) |
17e90c5e KN |
53 | (if title (begin (display title) (display ":\n\n"))) |
54 | (if (null? list) | |
55 | (display "(not defined)\n") | |
56 | (for-each display-summary list))) | |
57 | ||
77046be3 | 58 | (define (display-slot-list title instance list) |
17e90c5e KN |
59 | (if title (begin (display title) (display ":\n\n"))) |
60 | (if (null? list) | |
61 | (display "(not defined)\n") | |
62 | (for-each (lambda (slot) | |
63 | (let ((name (slot-definition-name slot))) | |
64 | (display "Slot: ") | |
65 | (display name) | |
66 | (if (and instance (slot-bound? instance name)) | |
67 | (begin | |
68 | (display " = ") | |
69 | (display (slot-ref instance name)))) | |
70 | (newline))) | |
71 | list))) | |
72 | ||
77046be3 | 73 | (define (display-file location) |
17e90c5e KN |
74 | (display "Defined in ") |
75 | (if (eq? *describe-format* 'tag) | |
76 | (format #t "@location{~a}.\n" location) | |
77 | (format #t "`~a'.\n" location))) | |
78 | ||
77046be3 | 79 | (define (format-documentation doc) |
17e90c5e KN |
80 | (with-current-buffer (make-buffer #:text doc) |
81 | (lambda () | |
5163e951 | 82 | (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?"))) |
17e90c5e KN |
83 | (do-while (match (re-search-forward regexp)) |
84 | (let ((key (string->symbol (match:substring match 1))) | |
85 | (value (match:substring match 3))) | |
86 | (case key | |
87 | ((deffnx) | |
88 | (delete-region! (match:start match) | |
89 | (begin (forward-line) (point)))) | |
90 | ((var) | |
91 | (replace-match! match 0 (string-upcase value))) | |
92 | ((code) | |
93 | (replace-match! match 0 (string-append "`" value "'"))))))) | |
94 | (display (string (current-buffer))) | |
95 | (newline)))) | |
96 | ||
97 | \f | |
98 | ;;; | |
99 | ;;; Top | |
100 | ;;; | |
101 | ||
102 | (define description-table | |
103 | (list | |
104 | (cons <boolean> "a boolean") | |
105 | (cons <null> "an empty list") | |
106 | (cons <integer> "an integer") | |
107 | (cons <real> "a real number") | |
108 | (cons <complex> "a complex number") | |
109 | (cons <char> "a character") | |
110 | (cons <symbol> "a symbol") | |
111 | (cons <keyword> "a keyword") | |
112 | (cons <promise> "a promise") | |
113 | (cons <hook> "a hook") | |
114 | (cons <fluid> "a fluid") | |
115 | (cons <stack> "a stack") | |
116 | (cons <variable> "a variable") | |
117 | (cons <regexp> "a regexp object") | |
118 | (cons <module> "a module object") | |
119 | (cons <unknown> "an unknown object"))) | |
120 | ||
121 | (define-generic describe-object) | |
122 | (export describe-object) | |
123 | ||
124 | (define-method (describe-object (obj <top>)) | |
125 | (display-type obj) | |
126 | (display-location obj) | |
127 | (newline) | |
128 | (display-value obj) | |
129 | (newline) | |
130 | (display-documentation obj)) | |
131 | ||
132 | (define-generic display-object) | |
133 | (define-generic display-summary) | |
134 | (define-generic display-type) | |
135 | (define-generic display-value) | |
136 | (define-generic display-location) | |
137 | (define-generic display-description) | |
138 | (define-generic display-documentation) | |
139 | (export display-object display-summary display-type display-value | |
140 | display-location display-description display-documentation) | |
141 | ||
142 | (define-method (display-object (obj <top>)) | |
143 | (write obj)) | |
144 | ||
145 | (define-method (display-summary (obj <top>)) | |
146 | (display "Value: ") | |
147 | (display-object obj) | |
148 | (newline)) | |
149 | ||
150 | (define-method (display-type (obj <top>)) | |
151 | (cond | |
152 | ((eof-object? obj) (display "the end-of-file object")) | |
153 | ((unspecified? obj) (display "unspecified")) | |
154 | (else (let ((class (class-of obj))) | |
155 | (display-class class (or (assq-ref description-table class) | |
156 | (safe-class-name class)))))) | |
157 | (display ".\n")) | |
158 | ||
159 | (define-method (display-value (obj <top>)) | |
160 | (if (not (unspecified? obj)) | |
161 | (begin (display-object obj) (newline)))) | |
162 | ||
163 | (define-method (display-location (obj <top>)) | |
164 | *unspecified*) | |
165 | ||
166 | (define-method (display-description (obj <top>)) | |
167 | (let* ((doc (with-output-to-string (lambda () (display-documentation obj)))) | |
168 | (index (string-index doc #\newline))) | |
169 | (display (make-shared-substring doc 0 (1+ index))))) | |
170 | ||
171 | (define-method (display-documentation (obj <top>)) | |
172 | (display "Not documented.\n")) | |
173 | ||
174 | \f | |
175 | ;;; | |
176 | ;;; Pairs | |
177 | ;;; | |
178 | ||
179 | (define-method (display-type (obj <pair>)) | |
180 | (cond | |
181 | ((list? obj) (display-class <list> "a list")) | |
182 | ((pair? (cdr obj)) (display "an improper list")) | |
183 | (else (display-class <pair> "a pair"))) | |
184 | (display ".\n")) | |
185 | ||
186 | \f | |
187 | ;;; | |
188 | ;;; Strings | |
189 | ;;; | |
190 | ||
191 | (define-method (display-type (obj <string>)) | |
192 | (if (read-only-string? 'obj) | |
193 | (display "a read-only string") | |
194 | (display-class <string> "a string")) | |
195 | (display ".\n")) | |
196 | ||
197 | \f | |
198 | ;;; | |
199 | ;;; Procedures | |
200 | ;;; | |
201 | ||
202 | (define-method (display-object (obj <procedure>)) | |
203 | (cond | |
204 | ((closure? obj) | |
205 | ;; Construct output from the source. | |
206 | (display "(") | |
207 | (display (procedure-name obj)) | |
208 | (let ((args (cadr (procedure-source obj)))) | |
209 | (cond ((null? args) (display ")")) | |
210 | ((pair? args) | |
211 | (let ((str (with-output-to-string (lambda () (display args))))) | |
212 | (format #t " ~a" (string-upcase! (substring str 1))))) | |
213 | (else | |
214 | (format #t " . ~a)" (string-upcase! (symbol->string args))))))) | |
215 | (else | |
216 | ;; Primitive procedure. Let's lookup the dictionary. | |
217 | (and-let* ((entry (lookup-procedure obj))) | |
218 | (let ((name (entry-property entry 'name)) | |
219 | (print-arg (lambda (arg) | |
220 | (display " ") | |
221 | (display (string-upcase (symbol->string arg)))))) | |
222 | (display "(") | |
223 | (display name) | |
224 | (and-let* ((args (entry-property entry 'args))) | |
225 | (for-each print-arg args)) | |
226 | (and-let* ((opts (entry-property entry 'opts))) | |
227 | (display " &optional") | |
228 | (for-each print-arg opts)) | |
229 | (and-let* ((rest (entry-property entry 'rest))) | |
230 | (display " &rest") | |
231 | (print-arg rest)) | |
232 | (display ")")))))) | |
233 | ||
234 | (define-method (display-summary (obj <procedure>)) | |
235 | (display "Procedure: ") | |
236 | (display-object obj) | |
237 | (newline) | |
238 | (display " ") | |
239 | (display-description obj)) | |
240 | ||
241 | (define-method (display-type (obj <procedure>)) | |
242 | (cond | |
243 | ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk")) | |
244 | ((closure? obj) (display-class <procedure> "a procedure")) | |
245 | ((procedure-with-setter? obj) | |
246 | (display-class <procedure-with-setter> "a procedure with setter")) | |
247 | ((not (struct? obj)) (display "a primitive procedure")) | |
248 | (else (display-class <procedure> "a procedure"))) | |
249 | (display ".\n")) | |
250 | ||
251 | (define-method (display-location (obj <procedure>)) | |
252 | (and-let* ((entry (lookup-procedure obj))) | |
253 | (display-file (entry-file entry)))) | |
254 | ||
255 | (define-method (display-documentation (obj <procedure>)) | |
256 | (cond ((cond ((closure? obj) (procedure-documentation obj)) | |
257 | ((lookup-procedure obj) => entry-text) | |
258 | (else #f)) | |
259 | => format-documentation) | |
260 | (else (next-method)))) | |
261 | ||
262 | \f | |
263 | ;;; | |
264 | ;;; Classes | |
265 | ;;; | |
266 | ||
267 | (define-method (describe-object (obj <class>)) | |
268 | (display-type obj) | |
269 | (display-location obj) | |
270 | (newline) | |
271 | (display-documentation obj) | |
272 | (newline) | |
273 | (display-value obj)) | |
274 | ||
275 | (define-method (display-summary (obj <class>)) | |
276 | (display "Class: ") | |
277 | (display-class obj) | |
278 | (newline) | |
279 | (display " ") | |
280 | (display-description obj)) | |
281 | ||
282 | (define-method (display-type (obj <class>)) | |
283 | (display-class <class> "a class") | |
284 | (if (not (eq? (class-of obj) <class>)) | |
285 | (begin (display " of ") (display-class (class-of obj)))) | |
286 | (display ".\n")) | |
287 | ||
288 | (define-method (display-value (obj <class>)) | |
289 | (display-list "Class precedence list" (class-precedence-list obj)) | |
290 | (newline) | |
291 | (display-list "Direct superclasses" (class-direct-supers obj)) | |
292 | (newline) | |
293 | (display-list "Direct subclasses" (class-direct-subclasses obj)) | |
294 | (newline) | |
295 | (display-slot-list "Direct slots" #f (class-direct-slots obj)) | |
296 | (newline) | |
297 | (display-list "Direct methods" (class-direct-methods obj))) | |
298 | ||
299 | \f | |
300 | ;;; | |
301 | ;;; Instances | |
302 | ;;; | |
303 | ||
8f5cfc81 | 304 | (define-method (display-type (obj <object>)) |
17e90c5e KN |
305 | (display-class <object> "an instance") |
306 | (display " of class ") | |
307 | (display-class (class-of obj)) | |
308 | (display ".\n")) | |
309 | ||
8f5cfc81 | 310 | (define-method (display-value (obj <object>)) |
17e90c5e KN |
311 | (display-slot-list #f obj (class-slots (class-of obj)))) |
312 | ||
313 | \f | |
314 | ;;; | |
315 | ;;; Generic functions | |
316 | ;;; | |
317 | ||
8f5cfc81 | 318 | (define-method (display-type (obj <generic>)) |
17e90c5e KN |
319 | (display-class <generic> "a generic function") |
320 | (display " of class ") | |
321 | (display-class (class-of obj)) | |
322 | (display ".\n")) | |
323 | ||
8f5cfc81 | 324 | (define-method (display-value (obj <generic>)) |
17e90c5e KN |
325 | (display-list #f (generic-function-methods obj))) |
326 | ||
327 | \f | |
328 | ;;; | |
329 | ;;; Methods | |
330 | ;;; | |
331 | ||
332 | (define-method (display-object (obj <method>)) | |
333 | (display "(") | |
334 | (let ((gf (method-generic-function obj))) | |
335 | (display (if gf (generic-function-name gf) "#<anonymous>"))) | |
336 | (let loop ((args (method-specializers obj))) | |
337 | (cond | |
338 | ((null? args)) | |
339 | ((pair? args) | |
340 | (display " ") | |
341 | (display-class (car args)) | |
342 | (loop (cdr args))) | |
343 | (else (display " . ") (display-class args)))) | |
344 | (display ")")) | |
345 | ||
346 | (define-method (display-summary (obj <method>)) | |
347 | (display "Method: ") | |
348 | (display-object obj) | |
349 | (newline) | |
350 | (display " ") | |
351 | (display-description obj)) | |
352 | ||
353 | (define-method (display-type (obj <method>)) | |
354 | (display-class <method> "a method") | |
355 | (display " of class ") | |
356 | (display-class (class-of obj)) | |
357 | (display ".\n")) | |
358 | ||
359 | (define-method (display-documentation (obj <method>)) | |
360 | (let ((doc (procedure-documentation (method-procedure obj)))) | |
361 | (if doc (format-documentation doc) (next-method)))) |