Commit | Line | Data |
---|---|---|
13ae9151 | 1 | ;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. |
0e81dabd MD |
2 | ;;;; |
3 | ;;;; This program is free software; you can redistribute it and/or modify | |
4 | ;;;; it under the terms of the GNU General Public License as published by | |
5 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
6 | ;;;; any later version. | |
7 | ;;;; | |
8 | ;;;; This program is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ;;;; GNU General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU General Public License | |
14 | ;;;; along with this software; see the file COPYING. If not, write to | |
c6e23ea2 JB |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | ;;;; Boston, MA 02111-1307 USA | |
0e81dabd MD |
17 | ;;;; |
18 | \f | |
19 | ||
bbefd480 | 20 | (define-module (ice-9 session) |
13ae9151 | 21 | :use-module (ice-9 doc) |
bbefd480 | 22 | :no-backtrace) |
0e81dabd MD |
23 | |
24 | \f | |
25 | ||
13ae9151 MD |
26 | ;;; Documentation |
27 | ;;; | |
28 | (define-public help | |
29 | (procedure->syntax | |
30 | (lambda (exp env) | |
31 | "(help [NAME]) | |
32 | Prints useful information. Try `(help)'." | |
33 | (if (not (= (length exp) 2)) | |
34 | (help-usage) | |
35 | (let* ((sym (cadr exp)) | |
36 | (obj (catch #t | |
37 | (lambda () | |
38 | (local-eval sym env)) | |
39 | (lambda args | |
40 | #f)))) | |
41 | (cond ;; *fixme*: when we have GOOPS | |
42 | ;;((or obj (not sym)) (describe obj)) | |
43 | ((and (or obj (not sym)) | |
44 | (cond ((procedure? obj) | |
45 | (display (proc-doc obj)) | |
46 | (newline) | |
47 | #t) | |
48 | ((and (macro? obj) (macro-transformer obj)) | |
49 | (display (proc-doc (macro-transformer obj))) | |
50 | (newline)) | |
51 | (else #f)))) | |
52 | ((symbol? sym) | |
53 | (documentation sym)) | |
54 | (else | |
55 | (display "No documentation for `") | |
56 | (display sym) | |
57 | (display "'\n"))) | |
58 | *unspecified*))))) | |
59 | ||
60 | (define (help-usage) | |
61 | (display "Usage: (help NAME) gives documentation about NAME (unquoted) | |
62 | (help) gives this text | |
63 | ||
64 | Example: (help help) | |
65 | ||
66 | Other useful sources of helpful information: | |
67 | ||
68 | (apropos STRING) | |
69 | (arity PROCEDURE) | |
70 | (name PROCEDURE-OR-MACRO) | |
71 | (source PROCEDURE-OR-MACRO) | |
72 | ||
73 | Tools: | |
74 | ||
75 | (debug) ;the debugger | |
76 | (backtrace) ;backtrace from last error | |
77 | ||
78 | (OPTIONSET-options 'full) ;display option information | |
79 | (OPTIONSET-enable 'OPTION) | |
80 | (OPTIONSET-disable 'OPTION) | |
81 | (OPTIONSET-set! OPTION VALUE) | |
82 | ||
83 | where OPTIONSET is one of debug, read, eval, print | |
84 | ||
85 | ")) | |
86 | ||
0e81dabd MD |
87 | ;;; {Apropos} |
88 | ;;; | |
89 | ;;; Author: Roland Orre <orre@nada.kth.se> | |
90 | ;;; | |
91 | ||
92 | (define (id x) x) | |
93 | ||
0e81dabd MD |
94 | (define-public (apropos rgx . options) |
95 | "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" | |
96 | (if (zero? (string-length rgx)) | |
97 | "Empty string not allowed" | |
4f161c5c | 98 | (let* ((match (make-regexp rgx)) |
0e81dabd MD |
99 | (modules (cons (current-module) |
100 | (module-uses (current-module)))) | |
101 | (separator #\tab) | |
102 | (shadow (member 'shadow options)) | |
103 | (value (member 'value options))) | |
104 | (cond ((member 'full options) | |
105 | (set! shadow #t) | |
106 | (set! value #t))) | |
107 | (for-each | |
108 | (lambda (module) | |
109 | (let* ((builtin (or (eq? module the-scm-module) | |
110 | (eq? module the-root-module))) | |
111 | (name (module-name module)) | |
112 | (obarrays (if builtin | |
113 | (list (builtin-weak-bindings) | |
114 | (builtin-bindings)) | |
115 | (list (module-obarray module)))) | |
116 | (get-refs (if builtin | |
117 | (list id id) | |
118 | (list variable-ref))) | |
119 | ) | |
120 | (for-each | |
121 | (lambda (obarray get-ref) | |
68aed3ea | 122 | (array-for-each |
0e81dabd MD |
123 | (lambda (oblist) |
124 | (for-each | |
125 | (lambda (x) | |
4f161c5c | 126 | (cond ((regexp-exec match (car x)) |
0e81dabd MD |
127 | (display name) |
128 | (display ": ") | |
129 | (display (car x)) | |
130 | (cond ((procedure? (get-ref (cdr x))) | |
131 | (display separator) | |
132 | (display (get-ref (cdr x)))) | |
133 | (value | |
134 | (display separator) | |
135 | (display (get-ref (cdr x))))) | |
136 | (if (and shadow | |
137 | (not (eq? (module-ref module | |
138 | (car x)) | |
139 | (module-ref (current-module) | |
140 | (car x))))) | |
141 | (display " shadowed")) | |
142 | (newline) | |
143 | ))) | |
144 | oblist)) | |
145 | obarray)) | |
146 | obarrays get-refs))) | |
147 | modules)))) | |
68aed3ea MD |
148 | |
149 | (define-public (apropos-internal rgx) | |
150 | "Return a list of accessible variable names." | |
bbefd480 MD |
151 | (letrec ((match (make-regexp rgx)) |
152 | (recorded (make-vector 61 '())) | |
153 | (obarray-names | |
154 | (lambda (obarray names) | |
70558403 | 155 | (hash-fold (lambda (name var vars) |
bbefd480 MD |
156 | (if (and (regexp-exec match name) |
157 | (not (hashq-get-handle recorded name))) | |
158 | (begin | |
159 | (hashq-set! recorded name #t) | |
160 | (cons name vars)) | |
161 | vars)) | |
70558403 MD |
162 | names |
163 | obarray)))) | |
bbefd480 MD |
164 | (do ((modules (cons (current-module) (module-uses (current-module))) |
165 | (cdr modules)) | |
166 | (names '() | |
167 | (if (or (eq? (car modules) the-scm-module) | |
168 | (eq? (car modules) the-root-module)) | |
169 | (obarray-names (builtin-weak-bindings) | |
170 | (obarray-names (builtin-bindings) | |
171 | names)) | |
172 | (obarray-names (module-obarray (car modules)) | |
173 | names)))) | |
174 | ((null? modules) names)))) | |
7cfae7e6 MD |
175 | |
176 | (define-public (name obj) | |
177 | (cond ((procedure? obj) (procedure-name obj)) | |
178 | ((macro? obj) (macro-name obj)) | |
179 | (else #f))) | |
180 | ||
181 | (define-public (source obj) | |
182 | (cond ((procedure? obj) (procedure-source obj)) | |
183 | ((macro? obj) (procedure-source (macro-transformer obj))) | |
184 | (else #f))) | |
4a9f464e MD |
185 | |
186 | (define-public (arity obj) | |
187 | (let ((arity (procedure-property obj 'arity))) | |
188 | (display (car arity)) | |
189 | (cond ((caddr arity) | |
190 | (display " or more")) | |
191 | ((not (zero? (cadr arity))) | |
192 | (display " required and ") | |
193 | (display (cadr arity)) | |
194 | (display " optional"))) | |
195 | (if (and (not (caddr arity)) | |
196 | (= (car arity) 1) | |
197 | (<= (cadr arity) 1)) | |
198 | (display " argument") | |
199 | (display " arguments")) | |
200 | (if (closure? obj) | |
201 | (let ((formals (cadr (procedure-source obj)))) | |
202 | (if (pair? formals) | |
203 | (begin | |
204 | (display ": `") | |
205 | (display (car formals)) | |
206 | (let loop ((ls (cdr formals))) | |
207 | (cond ((null? ls) | |
208 | (display #\')) | |
209 | ((not (pair? ls)) | |
210 | (display "', the rest in `") | |
211 | (display ls) | |
212 | (display #\')) | |
213 | (else | |
214 | (if (pair? (cdr ls)) | |
215 | (display "', `") | |
216 | (display "' and `")) | |
217 | (display (car ls)) | |
218 | (loop (cdr ls)))))) | |
219 | (begin | |
220 | (display " in `") | |
221 | (display formals) | |
222 | (display #\'))))) | |
223 | (display ".\n"))) | |
6ae34994 MD |
224 | |
225 | (define-public system-module | |
226 | (procedure->syntax | |
227 | (lambda (exp env) | |
228 | (let* ((m (nested-ref the-root-module | |
229 | (append '(app modules) (cadr exp))))) | |
230 | (if (not m) | |
231 | (error "Couldn't find any module named" (cadr exp))) | |
232 | (let ((s (not (procedure-property (module-eval-closure m) | |
233 | 'system-module)))) | |
234 | (set-system-module! m s) | |
235 | (string-append "Module " (symbol->string (module-name m)) | |
236 | " is now a " (if s "system" "user") " module.")))))) |