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