Commit | Line | Data |
---|---|---|
ea9c5dab | 1 | ;;; Repl commands |
17e90c5e | 2 | |
6f3b0cc2 | 3 | ;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. |
17e90c5e | 4 | |
eb721799 AW |
5 | ;; This library is free software; you can redistribute it and/or |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
54d9a994 | 9 | ;; |
eb721799 | 10 | ;; This library is distributed in the hope that it will be useful, |
17e90c5e | 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
eb721799 AW |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;; Lesser General Public License for more details. | |
54d9a994 | 14 | ;; |
eb721799 AW |
15 | ;; You should have received a copy of the GNU Lesser General Public |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
18 | ;; 02110-1301 USA | |
17e90c5e KN |
19 | |
20 | ;;; Code: | |
21 | ||
22 | (define-module (system repl command) | |
8239263f | 23 | #:use-module (system base syntax) |
1a1a10d3 AW |
24 | #:use-module (system base pmatch) |
25 | #:use-module (system base compile) | |
26 | #:use-module (system repl common) | |
33df2ec7 | 27 | #:use-module (system repl debug) |
1a1a10d3 AW |
28 | #:use-module (system vm objcode) |
29 | #:use-module (system vm program) | |
b9badc35 | 30 | #:use-module (system vm trap-state) |
1a1a10d3 | 31 | #:use-module (system vm vm) |
eb721799 | 32 | #:autoload (system base language) (lookup-language language-reader) |
7e9f9602 | 33 | #:autoload (system vm trace) (vm-trace) |
1a1a10d3 AW |
34 | #:autoload (system vm profile) (vm-profile) |
35 | #:use-module (ice-9 format) | |
36 | #:use-module (ice-9 session) | |
37 | #:use-module (ice-9 documentation) | |
38 | #:use-module (ice-9 and-let-star) | |
eb721799 | 39 | #:use-module (ice-9 rdelim) |
33df2ec7 AW |
40 | #:use-module (ice-9 control) |
41 | #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp))) | |
42 | #:use-module ((system vm inspect) #:select ((inspect . %inspect))) | |
a6dc56a7 | 43 | #:use-module (statprof) |
1a1a10d3 | 44 | #:export (meta-command)) |
4bfb26f5 KN |
45 | |
46 | \f | |
47 | ;;; | |
8f5cfc81 | 48 | ;;; Meta command interface |
4bfb26f5 KN |
49 | ;;; |
50 | ||
51 | (define *command-table* | |
33df2ec7 AW |
52 | '((help (help h) (show s) (apropos a) (describe d)) |
53 | (module (module m) (import use) (load l) (binding b)) | |
4bfb26f5 KN |
54 | (language (language L)) |
55 | (compile (compile c) (compile-file cc) | |
56 | (disassemble x) (disassemble-file xx)) | |
33df2ec7 AW |
57 | (profile (time t) (profile pr) (trace tr)) |
58 | (debug (backtrace bt) (up) (down) (frame fr) | |
b9badc35 | 59 | (procedure proc) (locals) (error-message error) |
25361a80 | 60 | (break br bp) (tracepoint tp) |
589520bc | 61 | (traps) (delete del) (disable) (enable)) |
33df2ec7 AW |
62 | (inspect (inspect i) (pretty-print pp)) |
63 | (system (gc) (statistics stat) (option o) | |
64 | (quit q continue cont)))) | |
4bfb26f5 | 65 | |
dca9a4d6 AW |
66 | (define *show-table* |
67 | '((show (warranty w) (copying c) (version v)))) | |
68 | ||
4bfb26f5 KN |
69 | (define (group-name g) (car g)) |
70 | (define (group-commands g) (cdr g)) | |
71 | ||
72 | (define *command-module* (current-module)) | |
73 | (define (command-name c) (car c)) | |
33df2ec7 | 74 | (define (command-abbrevs c) (cdr c)) |
4bfb26f5 KN |
75 | (define (command-procedure c) (module-ref *command-module* (command-name c))) |
76 | (define (command-doc c) (procedure-documentation (command-procedure c))) | |
77 | ||
78 | (define (command-usage c) | |
79 | (let ((doc (command-doc c))) | |
80 | (substring doc 0 (string-index doc #\newline)))) | |
81 | ||
82 | (define (command-summary c) | |
83 | (let* ((doc (command-doc c)) | |
84 | (start (1+ (string-index doc #\newline)))) | |
85 | (cond ((string-index doc #\newline start) | |
86 | => (lambda (end) (substring doc start end))) | |
87 | (else (substring doc start))))) | |
88 | ||
89 | (define (lookup-group name) | |
90 | (assq name *command-table*)) | |
91 | ||
dca9a4d6 AW |
92 | (define* (lookup-command key #:optional (table *command-table*)) |
93 | (let loop ((groups table) (commands '())) | |
4bfb26f5 KN |
94 | (cond ((and (null? groups) (null? commands)) #f) |
95 | ((null? commands) | |
96 | (loop (cdr groups) (cdar groups))) | |
97 | ((memq key (car commands)) (car commands)) | |
98 | (else (loop groups (cdr commands)))))) | |
99 | ||
dca9a4d6 | 100 | (define* (display-group group #:optional (abbrev? #t)) |
33df2ec7 | 101 | (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?) |
4bfb26f5 KN |
102 | (for-each (lambda (c) |
103 | (display-summary (command-usage c) | |
33df2ec7 | 104 | (if abbrev? (command-abbrevs c) '()) |
4bfb26f5 KN |
105 | (command-summary c))) |
106 | (group-commands group)) | |
107 | (newline)) | |
108 | ||
109 | (define (display-command command) | |
110 | (display "Usage: ") | |
111 | (display (command-doc command)) | |
112 | (newline)) | |
113 | ||
33df2ec7 AW |
114 | (define (display-summary usage abbrevs summary) |
115 | (let* ((usage-len (string-length usage)) | |
116 | (abbrevs (if (pair? abbrevs) | |
117 | (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs)) | |
118 | "")) | |
119 | (abbrevs-len (string-length abbrevs))) | |
120 | (format #t " ,~A~A~A - ~A\n" | |
121 | usage | |
122 | (cond | |
123 | ((> abbrevs-len 32) | |
124 | (error "abbrevs too long" abbrevs)) | |
125 | ((> (+ usage-len abbrevs-len) 32) | |
126 | (format #f "~%~v_" (+ 2 (- 32 abbrevs-len)))) | |
127 | (else | |
128 | (format #f "~v_" (- 32 abbrevs-len usage-len)))) | |
129 | abbrevs | |
130 | summary))) | |
131 | ||
132 | (define (read-command repl) | |
133 | (catch #t | |
3ae78d95 | 134 | (lambda () (read (repl-inport repl))) |
33df2ec7 AW |
135 | (lambda (key . args) |
136 | (pmatch args | |
137 | ((,subr ,msg ,args . ,rest) | |
138 | (format #t "Throw to key `~a' while reading command:\n" key) | |
139 | (display-error #f (current-output-port) subr msg args rest)) | |
140 | (else | |
141 | (format #t "Throw to key `~a' with args `~s' while reading command.\n" | |
142 | key args))) | |
143 | (force-output) | |
144 | *unspecified*))) | |
eb721799 AW |
145 | |
146 | (define read-line | |
147 | (let ((orig-read-line read-line)) | |
148 | (lambda (repl) | |
5b27d9d2 | 149 | (orig-read-line (repl-inport repl))))) |
eb721799 AW |
150 | |
151 | (define (meta-command repl) | |
33df2ec7 AW |
152 | (let ((command (read-command repl))) |
153 | (cond | |
154 | ((eq? command *unspecified*)) ; read error, already signalled; pass. | |
155 | ((not (symbol? command)) | |
156 | (format #t "Meta-command not a symbol: ~s~%" command)) | |
157 | ((lookup-command command) | |
158 | => (lambda (c) ((command-procedure c) repl))) | |
159 | (else | |
160 | (format #t "Unknown meta command: ~A~%" command))))) | |
eb721799 AW |
161 | |
162 | (define-syntax define-meta-command | |
163 | (syntax-rules () | |
164 | ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) | |
165 | (define (name repl) | |
166 | docstring | |
33df2ec7 AW |
167 | (define (handle-read-error form-name key args) |
168 | (pmatch args | |
169 | ((,subr ,msg ,args . ,rest) | |
170 | (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n" | |
171 | key form-name 'name) | |
172 | (display-error #f (current-output-port) subr msg args rest)) | |
173 | (else | |
174 | (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n" | |
175 | key args form-name 'name))) | |
176 | (abort)) | |
54d9a994 | 177 | |
33df2ec7 AW |
178 | (% (let* ((expression0 |
179 | (catch #t | |
180 | (lambda () | |
181 | (repl-reader "" | |
182 | (lambda* (#:optional (port (repl-inport repl))) | |
183 | ((language-reader (repl-language repl)) | |
184 | port (current-module))))) | |
185 | (lambda (k . args) | |
186 | (handle-read-error 'expression0 k args)))) | |
187 | ...) | |
188 | (apply (lambda* datums | |
189 | (with-output-to-port (repl-outport repl) | |
190 | (lambda () b0 b1 ...))) | |
191 | (catch #t | |
192 | (lambda () | |
193 | (let ((port (open-input-string (read-line repl)))) | |
194 | (let lp ((out '())) | |
195 | (let ((x (read port))) | |
196 | (if (eof-object? x) | |
197 | (reverse out) | |
198 | (lp (cons x out))))))) | |
199 | (lambda (k . args) | |
200 | (handle-read-error #f k args))))) | |
201 | (lambda (k) #f)))) ; the abort handler | |
202 | ||
eb721799 AW |
203 | ((_ (name repl . datums) docstring b0 b1 ...) |
204 | (define-meta-command (name repl () . datums) | |
205 | docstring b0 b1 ...)))) | |
206 | ||
4bfb26f5 KN |
207 | |
208 | \f | |
209 | ;;; | |
210 | ;;; Help commands | |
211 | ;;; | |
212 | ||
eb721799 | 213 | (define-meta-command (help repl . args) |
33df2ec7 AW |
214 | "help [all | GROUP | [-c] COMMAND] |
215 | Show help. | |
eb721799 AW |
216 | |
217 | With one argument, tries to look up the argument as a group name, giving | |
218 | help on that group if successful. Otherwise tries to look up the | |
219 | argument as a command, giving help on the command. | |
220 | ||
221 | If there is a command whose name is also a group name, use the ,help | |
222 | -c COMMAND form to give help on the command instead of the group. | |
223 | ||
8f5cfc81 | 224 | Without any argument, a list of help commands and command groups |
eb721799 | 225 | are displayed." |
e429de1e | 226 | (pmatch args |
4bfb26f5 KN |
227 | (() |
228 | (display-group (lookup-group 'help)) | |
229 | (display "Command Groups:\n\n") | |
230 | (display-summary "help all" #f "List all commands") | |
231 | (for-each (lambda (g) | |
232 | (let* ((name (symbol->string (group-name g))) | |
233 | (usage (string-append "help " name)) | |
234 | (header (string-append "List " name " commands"))) | |
235 | (display-summary usage #f header))) | |
236 | (cdr *command-table*)) | |
237 | (newline) | |
019fdc97 AW |
238 | (display |
239 | "Type `,help -c COMMAND' to show documentation of a particular command.") | |
4bfb26f5 | 240 | (newline)) |
e429de1e | 241 | ((all) |
4bfb26f5 | 242 | (for-each display-group *command-table*)) |
e429de1e | 243 | ((,group) (guard (lookup-group group)) |
4bfb26f5 | 244 | (display-group (lookup-group group))) |
eb721799 AW |
245 | ((,command) (guard (lookup-command command)) |
246 | (display-command (lookup-command command))) | |
247 | ((-c ,command) (guard (lookup-command command)) | |
248 | (display-command (lookup-command command))) | |
249 | ((,command) | |
33df2ec7 | 250 | (format #t "Unknown command or group: ~A~%" command)) |
eb721799 | 251 | ((-c ,command) |
33df2ec7 | 252 | (format #t "Unknown command: ~A~%" command)) |
8f5cfc81 | 253 | (else |
33df2ec7 | 254 | (format #t "Bad arguments: ~A~%" args)))) |
4bfb26f5 | 255 | |
dca9a4d6 | 256 | (define-meta-command (show repl . args) |
33df2ec7 | 257 | "show [TOPIC] |
dca9a4d6 AW |
258 | Gives information about Guile. |
259 | ||
260 | With one argument, tries to show a particular piece of information; | |
261 | ||
262 | currently supported topics are `warranty' (or `w'), `copying' (or `c'), | |
263 | and `version' (or `v'). | |
264 | ||
265 | Without any argument, a list of topics is displayed." | |
266 | (pmatch args | |
267 | (() | |
268 | (display-group (car *show-table*) #f) | |
269 | (newline)) | |
270 | ((,topic) (guard (lookup-command topic *show-table*)) | |
271 | ((command-procedure (lookup-command topic *show-table*)) repl)) | |
272 | ((,command) | |
33df2ec7 | 273 | (format #t "Unknown topic: ~A~%" command)) |
dca9a4d6 | 274 | (else |
33df2ec7 | 275 | (format #t "Bad arguments: ~A~%" args)))) |
dca9a4d6 AW |
276 | |
277 | (define (warranty repl) | |
278 | "show warranty | |
279 | Details on the lack of warranty." | |
280 | (display *warranty*) | |
281 | (newline)) | |
282 | ||
283 | (define (copying repl) | |
284 | "show copying | |
285 | Show the LGPLv3." | |
286 | (display *copying*) | |
287 | (newline)) | |
288 | ||
289 | (define (version repl) | |
290 | "show version | |
291 | Version information." | |
292 | (display *version*) | |
293 | (newline)) | |
294 | ||
8f5cfc81 | 295 | (define guile:apropos apropos) |
eb721799 | 296 | (define-meta-command (apropos repl regexp) |
8f5cfc81 | 297 | "apropos REGEXP |
4bfb26f5 | 298 | Find bindings/modules/packages." |
8f5cfc81 | 299 | (guile:apropos (->string regexp))) |
4bfb26f5 | 300 | |
eb721799 | 301 | (define-meta-command (describe repl (form)) |
4bfb26f5 KN |
302 | "describe OBJ |
303 | Show description/documentation." | |
eb721799 | 304 | (display (object-documentation (repl-eval repl (repl-parse repl form)))) |
8f5cfc81 | 305 | (newline)) |
4bfb26f5 | 306 | |
eb721799 | 307 | (define-meta-command (option repl . args) |
8f5cfc81 | 308 | "option [KEY VALUE] |
4bfb26f5 | 309 | List/show/set options." |
e429de1e | 310 | (pmatch args |
f21dfea6 | 311 | (() |
c27d140a AW |
312 | (for-each (lambda (spec) |
313 | (format #t " ~A~24t~A\n" (car spec) (cadr spec))) | |
ce0925e1 | 314 | (repl-options repl))) |
e429de1e | 315 | ((,key) |
f21dfea6 KN |
316 | (display (repl-option-ref repl key)) |
317 | (newline)) | |
e429de1e | 318 | ((,key ,val) |
7e9f9602 | 319 | (repl-option-set! repl key val)))) |
4bfb26f5 | 320 | |
eb721799 | 321 | (define-meta-command (quit repl) |
4bfb26f5 KN |
322 | "quit |
323 | Quit this session." | |
324 | (throw 'quit)) | |
325 | ||
326 | \f | |
327 | ;;; | |
328 | ;;; Module commands | |
329 | ;;; | |
330 | ||
eb721799 | 331 | (define-meta-command (module repl . args) |
4bfb26f5 KN |
332 | "module [MODULE] |
333 | Change modules / Show current module." | |
e429de1e | 334 | (pmatch args |
db917b41 | 335 | (() (puts (module-name (current-module)))) |
482015af AW |
336 | ((,mod-name) (guard (list? mod-name)) |
337 | (set-current-module (resolve-module mod-name))) | |
338 | (,mod-name (set-current-module (resolve-module mod-name))))) | |
4bfb26f5 | 339 | |
eb721799 | 340 | (define-meta-command (import repl . args) |
4bfb26f5 KN |
341 | "import [MODULE ...] |
342 | Import modules / List those imported." | |
9246a486 AW |
343 | (let () |
344 | (define (use name) | |
345 | (let ((mod (resolve-interface name))) | |
346 | (if mod | |
347 | (module-use! (current-module) mod) | |
33df2ec7 | 348 | (format #t "No such module: ~A~%" name)))) |
9246a486 AW |
349 | (if (null? args) |
350 | (for-each puts (map module-name (module-uses (current-module)))) | |
351 | (for-each use args)))) | |
4bfb26f5 | 352 | |
84012ef4 | 353 | (define guile:load load) |
019fdc97 | 354 | (define-meta-command (load repl file) |
8f5cfc81 | 355 | "load FILE |
019fdc97 AW |
356 | Load a file in the current module." |
357 | (guile:load (->string file))) | |
4bfb26f5 | 358 | |
eb721799 | 359 | (define-meta-command (binding repl) |
8f5cfc81 | 360 | "binding |
4bfb26f5 | 361 | List current bindings." |
db917b41 AW |
362 | (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) |
363 | (current-module))) | |
4bfb26f5 KN |
364 | |
365 | \f | |
366 | ;;; | |
367 | ;;; Language commands | |
368 | ;;; | |
369 | ||
eb721799 | 370 | (define-meta-command (language repl name) |
4bfb26f5 KN |
371 | "language LANGUAGE |
372 | Change languages." | |
dca9a4d6 AW |
373 | (let ((lang (lookup-language name)) |
374 | (cur (repl-language repl))) | |
4d75554d | 375 | (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n" |
dca9a4d6 AW |
376 | (language-title lang) (language-name cur)) |
377 | (set! (repl-language repl) lang))) | |
4bfb26f5 KN |
378 | |
379 | \f | |
380 | ;;; | |
381 | ;;; Compile commands | |
382 | ;;; | |
383 | ||
35d70ecc | 384 | (define-meta-command (compile repl (form)) |
33df2ec7 | 385 | "compile EXP |
35d70ecc AW |
386 | Generate compiled code." |
387 | (let ((x (repl-compile repl (repl-parse repl form)))) | |
81e002fc | 388 | (cond ((objcode? x) (guile:disassemble x)) |
b0b180d5 | 389 | (else (repl-print repl x))))) |
4bfb26f5 | 390 | |
f21dfea6 | 391 | (define guile:compile-file compile-file) |
eb721799 | 392 | (define-meta-command (compile-file repl file . opts) |
8f5cfc81 | 393 | "compile-file FILE |
4bfb26f5 | 394 | Compile a file." |
b0b180d5 | 395 | (guile:compile-file (->string file) #:opts opts)) |
4bfb26f5 | 396 | |
9bb8012d AW |
397 | (define (guile:disassemble x) |
398 | ((@ (language assembly disassemble) disassemble) x)) | |
399 | ||
eb721799 | 400 | (define-meta-command (disassemble repl (form)) |
33df2ec7 AW |
401 | "disassemble EXP |
402 | Disassemble a compiled procedure." | |
eb721799 | 403 | (guile:disassemble (repl-eval repl (repl-parse repl form)))) |
4bfb26f5 | 404 | |
eb721799 | 405 | (define-meta-command (disassemble-file repl file) |
4bfb26f5 KN |
406 | "disassemble-file FILE |
407 | Disassemble a file." | |
9bb8012d | 408 | (guile:disassemble (load-objcode (->string file)))) |
4bfb26f5 KN |
409 | |
410 | \f | |
411 | ;;; | |
412 | ;;; Profile commands | |
413 | ;;; | |
414 | ||
eb721799 | 415 | (define-meta-command (time repl (form)) |
33df2ec7 | 416 | "time EXP |
8f5cfc81 | 417 | Time execution." |
e5f5113c | 418 | (let* ((gc-start (gc-run-time)) |
8f5cfc81 | 419 | (tms-start (times)) |
b0b180d5 | 420 | (result (repl-eval repl (repl-parse repl form))) |
8f5cfc81 | 421 | (tms-end (times)) |
e5f5113c | 422 | (gc-end (gc-run-time))) |
8f5cfc81 | 423 | (define (get proc start end) |
17d1b4bf | 424 | (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second))) |
8f5cfc81 KN |
425 | (repl-print repl result) |
426 | (display "clock utime stime cutime cstime gctime\n") | |
427 | (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" | |
428 | (get tms:clock tms-start tms-end) | |
429 | (get tms:utime tms-start tms-end) | |
430 | (get tms:stime tms-start tms-end) | |
431 | (get tms:cutime tms-start tms-end) | |
432 | (get tms:cstime tms-start tms-end) | |
433 | (get identity gc-start gc-end)) | |
434 | result)) | |
435 | ||
a6dc56a7 | 436 | (define-meta-command (profile repl (form) . opts) |
33df2ec7 | 437 | "profile EXP |
4bfb26f5 | 438 | Profile execution." |
a6dc56a7 | 439 | ;; FIXME opts |
01c0082f | 440 | (apply statprof |
d8e2ba23 | 441 | (repl-prepare-eval-thunk repl (repl-parse repl form)) |
01c0082f | 442 | opts)) |
a6dc56a7 | 443 | |
01c0082f | 444 | (define-meta-command (trace repl (form) . opts) |
33df2ec7 | 445 | "trace EXP |
737caee8 | 446 | Trace execution." |
7e9f9602 | 447 | ;; FIXME: doc options, or somehow deal with them better |
737caee8 | 448 | (apply vm-trace |
01c0082f | 449 | (the-vm) |
d8e2ba23 | 450 | (repl-prepare-eval-thunk repl (repl-parse repl form)) |
b0b180d5 | 451 | opts)) |
4bfb26f5 | 452 | |
33df2ec7 AW |
453 | \f |
454 | ;;; | |
455 | ;;; Debug commands | |
456 | ;;; | |
457 | ||
458 | (define-syntax define-stack-command | |
459 | (lambda (x) | |
460 | (syntax-case x () | |
461 | ((_ (name repl . args) docstring body body* ...) | |
462 | #`(define-meta-command (name repl . args) | |
463 | docstring | |
464 | (let ((debug (repl-debug repl))) | |
465 | (if debug | |
466 | (letrec-syntax | |
467 | ((#,(datum->syntax #'repl 'frames) | |
468 | (identifier-syntax (debug-frames debug))) | |
54d9a994 JOR |
469 | (#,(datum->syntax #'repl 'message) |
470 | (identifier-syntax (debug-error-message debug))) | |
33df2ec7 AW |
471 | (#,(datum->syntax #'repl 'index) |
472 | (identifier-syntax | |
473 | (id (debug-index debug)) | |
474 | ((set! id exp) (set! (debug-index debug) exp)))) | |
475 | (#,(datum->syntax #'repl 'cur) | |
476 | (identifier-syntax | |
477 | (vector-ref #,(datum->syntax #'repl 'frames) | |
478 | #,(datum->syntax #'repl 'index))))) | |
479 | body body* ...) | |
480 | (format #t "Nothing to debug.~%")))))))) | |
481 | ||
482 | (define-stack-command (backtrace repl #:optional count | |
483 | #:key (width 72) full?) | |
484 | "backtrace [COUNT] [#:width W] [#:full? F] | |
485 | Print a backtrace. | |
486 | ||
487 | Print a backtrace of all stack frames, or innermost COUNT frames. | |
488 | If COUNT is negative, the last COUNT frames will be shown." | |
54d9a994 | 489 | (print-frames frames |
33df2ec7 AW |
490 | #:count count |
491 | #:width width | |
492 | #:full? full?)) | |
54d9a994 | 493 | |
33df2ec7 AW |
494 | (define-stack-command (up repl #:optional (count 1)) |
495 | "up [COUNT] | |
496 | Select a calling stack frame. | |
497 | ||
498 | Select and print stack frames that called this one. | |
499 | An argument says how many frames up to go." | |
500 | (cond | |
501 | ((or (not (integer? count)) (<= count 0)) | |
502 | (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%")) | |
503 | ((>= (+ count index) (vector-length frames)) | |
504 | (cond | |
505 | ((= index (1- (vector-length frames))) | |
506 | (format #t "Already at outermost frame.\n")) | |
507 | (else | |
508 | (set! index (1- (vector-length frames))) | |
509 | (print-frame cur #:index index)))) | |
510 | (else | |
511 | (set! index (+ count index)) | |
512 | (print-frame cur #:index index)))) | |
513 | ||
514 | (define-stack-command (down repl #:optional (count 1)) | |
515 | "down [COUNT] | |
516 | Select a called stack frame. | |
517 | ||
518 | Select and print stack frames called by this one. | |
519 | An argument says how many frames down to go." | |
520 | (cond | |
521 | ((or (not (integer? count)) (<= count 0)) | |
522 | (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%")) | |
523 | ((< (- index count) 0) | |
524 | (cond | |
525 | ((zero? index) | |
526 | (format #t "Already at innermost frame.\n")) | |
527 | (else | |
528 | (set! index 0) | |
529 | (print-frame cur #:index index)))) | |
530 | (else | |
531 | (set! index (- index count)) | |
532 | (print-frame cur #:index index)))) | |
533 | ||
534 | (define-stack-command (frame repl #:optional idx) | |
535 | "frame [IDX] | |
536 | Show a frame. | |
537 | ||
538 | Show the selected frame. | |
539 | With an argument, select a frame by index, then show it." | |
540 | (cond | |
541 | (idx | |
542 | (cond | |
543 | ((or (not (integer? idx)) (< idx 0)) | |
544 | (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%")) | |
545 | ((< idx (vector-length frames)) | |
546 | (set! index idx) | |
547 | (print-frame cur #:index index)) | |
548 | (else | |
549 | (format #t "No such frame.~%")))) | |
550 | (else (print-frame cur #:index index)))) | |
551 | ||
552 | (define-stack-command (procedure repl) | |
553 | "procedure | |
0ddbd883 | 554 | Print the procedure for the selected frame." |
33df2ec7 | 555 | (repl-print repl (frame-procedure cur))) |
54d9a994 | 556 | |
33df2ec7 AW |
557 | (define-stack-command (locals repl) |
558 | "locals | |
559 | Show local variables. | |
560 | ||
561 | Show locally-bound variables in the selected frame." | |
562 | (print-locals cur)) | |
54d9a994 | 563 | |
b9badc35 AW |
564 | (define-stack-command (error-message repl) |
565 | "error-message | |
566 | Show error message. | |
567 | ||
568 | Display the message associated with the error that started the current | |
569 | debugging REPL." | |
570 | (format #t "~a~%" (if (string? message) message "No error message"))) | |
571 | ||
572 | (define-meta-command (break repl (form)) | |
573 | "break PROCEDURE | |
574 | Break on calls to PROCEDURE. | |
575 | ||
576 | Starts a recursive prompt when PROCEDURE is called." | |
577 | (let ((proc (repl-eval repl (repl-parse repl form)))) | |
578 | (if (not (procedure? proc)) | |
579 | (error "Not a procedure: ~a" proc) | |
580 | (let ((idx (add-trap-at-procedure-call! proc))) | |
581 | (format #t "Added breakpoint ~a at ~a.~%" idx proc))))) | |
582 | ||
25361a80 AW |
583 | (define-meta-command (tracepoint repl (form)) |
584 | "tracepoint PROCEDURE | |
585 | Add a tracepoint to PROCEDURE. | |
586 | ||
587 | A tracepoint will print out the procedure and its arguments, when it is | |
588 | called, and its return value(s) when it returns." | |
589 | (let ((proc (repl-eval repl (repl-parse repl form)))) | |
590 | (if (not (procedure? proc)) | |
591 | (error "Not a procedure: ~a" proc) | |
592 | (let ((idx (add-trace-at-procedure-call! proc))) | |
593 | (format #t "Added tracepoint ~a at ~a.~%" idx proc))))) | |
594 | ||
589520bc AW |
595 | (define-meta-command (traps repl) |
596 | "traps | |
597 | Show the set of currently attached traps. | |
598 | ||
599 | Show the set of currently attached traps (breakpoints)." | |
600 | (let ((traps (list-traps))) | |
601 | (if (null? traps) | |
602 | (format #t "No traps enabled.~%") | |
603 | (for-each (lambda (idx name) | |
604 | (format #t " ~a: ~a~a~%" | |
605 | idx name | |
606 | (if (trap-enabled? idx) "" " (disabled)"))) | |
607 | (map car traps) (map cdr traps))))) | |
608 | ||
609 | (define-meta-command (delete repl idx) | |
610 | "delete IDX | |
611 | Delete a trap. | |
612 | ||
613 | Delete a trap." | |
614 | (if (not (integer? idx)) | |
615 | (error "expected a trap index (a non-negative integer)" idx) | |
616 | (delete-trap! idx))) | |
617 | ||
618 | (define-meta-command (disable repl idx) | |
619 | "disable IDX | |
620 | Disable a trap. | |
621 | ||
622 | Disable a trap." | |
623 | (if (not (integer? idx)) | |
624 | (error "expected a trap index (a non-negative integer)" idx) | |
625 | (disable-trap! idx))) | |
626 | ||
627 | (define-meta-command (enable repl idx) | |
628 | "enable IDX | |
629 | Enable a trap. | |
630 | ||
631 | Enable a trap." | |
632 | (if (not (integer? idx)) | |
633 | (error "expected a trap index (a non-negative integer)" idx) | |
634 | (enable-trap! idx))) | |
635 | ||
b9badc35 | 636 | |
33df2ec7 AW |
637 | \f |
638 | ;;; | |
639 | ;;; Inspection commands | |
640 | ;;; | |
641 | ||
642 | (define-stack-command (inspect repl (form)) | |
643 | "inspect EXP | |
644 | Inspect the result(s) of evaluating EXP." | |
d8e2ba23 | 645 | (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form)) |
33df2ec7 AW |
646 | (lambda args |
647 | (for-each %inspect args)))) | |
648 | ||
649 | (define-meta-command (pretty-print repl (form)) | |
650 | "pretty-print EXP | |
651 | Pretty-print the result(s) of evaluating EXP." | |
d8e2ba23 | 652 | (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form)) |
33df2ec7 AW |
653 | (lambda args |
654 | (for-each | |
655 | (lambda (x) | |
656 | (run-hook before-print-hook x) | |
657 | (pp x)) | |
658 | args)))) | |
4bfb26f5 KN |
659 | |
660 | \f | |
661 | ;;; | |
54d9a994 | 662 | ;;; System commands |
4bfb26f5 KN |
663 | ;;; |
664 | ||
8f5cfc81 | 665 | (define guile:gc gc) |
eb721799 | 666 | (define-meta-command (gc repl) |
4bfb26f5 KN |
667 | "gc |
668 | Garbage collection." | |
8f5cfc81 | 669 | (guile:gc)) |
4bfb26f5 | 670 | |
eb721799 | 671 | (define-meta-command (statistics repl) |
4bfb26f5 KN |
672 | "statistics |
673 | Display statistics." | |
674 | (let ((this-tms (times)) | |
4bfb26f5 | 675 | (this-gcs (gc-stats)) |
ce0925e1 | 676 | (last-tms (repl-tm-stats repl)) |
ce0925e1 | 677 | (last-gcs (repl-gc-stats repl))) |
4bfb26f5 KN |
678 | ;; GC times |
679 | (let ((this-times (assq-ref this-gcs 'gc-times)) | |
680 | (last-times (assq-ref last-gcs 'gc-times))) | |
681 | (display-diff-stat "GC times:" #t this-times last-times "times") | |
682 | (newline)) | |
683 | ;; Memory size | |
684 | (let ((this-cells (assq-ref this-gcs 'cells-allocated)) | |
685 | (this-heap (assq-ref this-gcs 'cell-heap-size)) | |
686 | (this-bytes (assq-ref this-gcs 'bytes-malloced)) | |
687 | (this-malloc (assq-ref this-gcs 'gc-malloc-threshold))) | |
688 | (display-stat-title "Memory size:" "current" "limit") | |
689 | (display-stat "heap" #f this-cells this-heap "cells") | |
690 | (display-stat "malloc" #f this-bytes this-malloc "bytes") | |
691 | (newline)) | |
692 | ;; Cells collected | |
693 | (let ((this-marked (assq-ref this-gcs 'cells-marked)) | |
694 | (last-marked (assq-ref last-gcs 'cells-marked)) | |
695 | (this-swept (assq-ref this-gcs 'cells-swept)) | |
696 | (last-swept (assq-ref last-gcs 'cells-swept))) | |
697 | (display-stat-title "Cells collected:" "diff" "total") | |
698 | (display-diff-stat "marked" #f this-marked last-marked "cells") | |
699 | (display-diff-stat "swept" #f this-swept last-swept "cells") | |
700 | (newline)) | |
701 | ;; GC time taken | |
702 | (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken)) | |
703 | (last-mark (assq-ref last-gcs 'gc-mark-time-taken)) | |
4bfb26f5 KN |
704 | (this-total (assq-ref this-gcs 'gc-time-taken)) |
705 | (last-total (assq-ref last-gcs 'gc-time-taken))) | |
706 | (display-stat-title "GC time taken:" "diff" "total") | |
707 | (display-time-stat "mark" this-mark last-mark) | |
4bfb26f5 KN |
708 | (display-time-stat "total" this-total last-total) |
709 | (newline)) | |
710 | ;; Process time spent | |
711 | (let ((this-utime (tms:utime this-tms)) | |
712 | (last-utime (tms:utime last-tms)) | |
713 | (this-stime (tms:stime this-tms)) | |
714 | (last-stime (tms:stime last-tms)) | |
715 | (this-cutime (tms:cutime this-tms)) | |
716 | (last-cutime (tms:cutime last-tms)) | |
717 | (this-cstime (tms:cstime this-tms)) | |
718 | (last-cstime (tms:cstime last-tms))) | |
719 | (display-stat-title "Process time spent:" "diff" "total") | |
720 | (display-time-stat "user" this-utime last-utime) | |
721 | (display-time-stat "system" this-stime last-stime) | |
722 | (display-time-stat "child user" this-cutime last-cutime) | |
723 | (display-time-stat "child system" this-cstime last-cstime) | |
724 | (newline)) | |
4bfb26f5 KN |
725 | ;; Save statistics |
726 | ;; Save statistics | |
ce0925e1 | 727 | (set! (repl-tm-stats repl) this-tms) |
ce0925e1 | 728 | (set! (repl-gc-stats repl) this-gcs))) |
cb4cca12 KN |
729 | |
730 | (define (display-stat title flag field1 field2 unit) | |
731 | (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@")))) | |
732 | (format #t str title field1 field2 unit))) | |
733 | ||
734 | (define (display-stat-title title field1 field2) | |
735 | (display-stat title #t field1 field2 "")) | |
736 | ||
737 | (define (display-diff-stat title flag this last unit) | |
738 | (display-stat title flag (- this last) this unit)) | |
739 | ||
740 | (define (display-time-stat title this last) | |
741 | (define (conv num) | |
b9d8ed05 | 742 | (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second)))) |
cb4cca12 KN |
743 | (display-stat title #f (conv (- this last)) (conv this) "s")) |
744 | ||
745 | (define (display-mips-stat title this-time this-clock last-time last-clock) | |
746 | (define (mips time clock) | |
b9d8ed05 | 747 | (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0)))) |
cb4cca12 KN |
748 | (display-stat title #f |
749 | (mips (- this-time last-time) (- this-clock last-clock)) | |
750 | (mips this-time this-clock) "mips")) |