Commit | Line | Data |
---|---|---|
ea9c5dab | 1 | ;;; Repl commands |
17e90c5e | 2 | |
5745de91 | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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) |
c6025e76 | 32 | #:use-module ((system vm frame) #:select (frame-return-values)) |
eb721799 | 33 | #:autoload (system base language) (lookup-language language-reader) |
e7544f39 | 34 | #:autoload (system vm trace) (call-with-trace) |
1a1a10d3 AW |
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) |
8fdd85f8 | 44 | #:export (meta-command define-meta-command)) |
4bfb26f5 KN |
45 | |
46 | \f | |
47 | ;;; | |
8f5cfc81 | 48 | ;;; Meta command interface |
4bfb26f5 KN |
49 | ;;; |
50 | ||
51 | (define *command-table* | |
439e032b | 52 | '((help (help h) (show) (apropos a) (describe d)) |
cdab9fc6 | 53 | (module (module m) (import use) (load l) (reload re) (binding b) (in)) |
4bfb26f5 KN |
54 | (language (language L)) |
55 | (compile (compile c) (compile-file cc) | |
d62dd766 | 56 | (expand exp) (optimize opt) |
4bfb26f5 | 57 | (disassemble x) (disassemble-file xx)) |
33df2ec7 AW |
58 | (profile (time t) (profile pr) (trace tr)) |
59 | (debug (backtrace bt) (up) (down) (frame fr) | |
b9badc35 | 60 | (procedure proc) (locals) (error-message error) |
fb5c4dc5 | 61 | (break br bp) (break-at-source break-at bs) |
439e032b AW |
62 | (step s) (step-instruction si) |
63 | (next n) (next-instruction ni) | |
c6025e76 | 64 | (finish) |
fb5c4dc5 | 65 | (tracepoint tp) |
542f975e AW |
66 | (traps) (delete del) (disable) (enable) |
67 | (registers regs)) | |
33df2ec7 AW |
68 | (inspect (inspect i) (pretty-print pp)) |
69 | (system (gc) (statistics stat) (option o) | |
70 | (quit q continue cont)))) | |
4bfb26f5 | 71 | |
dca9a4d6 AW |
72 | (define *show-table* |
73 | '((show (warranty w) (copying c) (version v)))) | |
74 | ||
4bfb26f5 KN |
75 | (define (group-name g) (car g)) |
76 | (define (group-commands g) (cdr g)) | |
77 | ||
8fdd85f8 | 78 | (define *command-infos* (make-hash-table)) |
4bfb26f5 | 79 | (define (command-name c) (car c)) |
33df2ec7 | 80 | (define (command-abbrevs c) (cdr c)) |
8fdd85f8 AR |
81 | (define (command-info c) (hashq-ref *command-infos* (command-name c))) |
82 | (define (command-procedure c) (command-info-procedure (command-info c))) | |
4bfb26f5 KN |
83 | (define (command-doc c) (procedure-documentation (command-procedure c))) |
84 | ||
8fdd85f8 AR |
85 | (define (make-command-info proc arguments-reader) |
86 | (cons proc arguments-reader)) | |
87 | ||
88 | (define (command-info-procedure info) | |
89 | (car info)) | |
90 | ||
91 | (define (command-info-arguments-reader info) | |
92 | (cdr info)) | |
93 | ||
4bfb26f5 KN |
94 | (define (command-usage c) |
95 | (let ((doc (command-doc c))) | |
96 | (substring doc 0 (string-index doc #\newline)))) | |
97 | ||
98 | (define (command-summary c) | |
99 | (let* ((doc (command-doc c)) | |
100 | (start (1+ (string-index doc #\newline)))) | |
101 | (cond ((string-index doc #\newline start) | |
102 | => (lambda (end) (substring doc start end))) | |
103 | (else (substring doc start))))) | |
104 | ||
105 | (define (lookup-group name) | |
106 | (assq name *command-table*)) | |
107 | ||
dca9a4d6 AW |
108 | (define* (lookup-command key #:optional (table *command-table*)) |
109 | (let loop ((groups table) (commands '())) | |
4bfb26f5 KN |
110 | (cond ((and (null? groups) (null? commands)) #f) |
111 | ((null? commands) | |
112 | (loop (cdr groups) (cdar groups))) | |
113 | ((memq key (car commands)) (car commands)) | |
114 | (else (loop groups (cdr commands)))))) | |
115 | ||
dca9a4d6 | 116 | (define* (display-group group #:optional (abbrev? #t)) |
33df2ec7 | 117 | (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?) |
4bfb26f5 KN |
118 | (for-each (lambda (c) |
119 | (display-summary (command-usage c) | |
33df2ec7 | 120 | (if abbrev? (command-abbrevs c) '()) |
4bfb26f5 KN |
121 | (command-summary c))) |
122 | (group-commands group)) | |
123 | (newline)) | |
124 | ||
125 | (define (display-command command) | |
126 | (display "Usage: ") | |
127 | (display (command-doc command)) | |
128 | (newline)) | |
129 | ||
33df2ec7 AW |
130 | (define (display-summary usage abbrevs summary) |
131 | (let* ((usage-len (string-length usage)) | |
132 | (abbrevs (if (pair? abbrevs) | |
133 | (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs)) | |
134 | "")) | |
135 | (abbrevs-len (string-length abbrevs))) | |
136 | (format #t " ,~A~A~A - ~A\n" | |
137 | usage | |
138 | (cond | |
139 | ((> abbrevs-len 32) | |
140 | (error "abbrevs too long" abbrevs)) | |
141 | ((> (+ usage-len abbrevs-len) 32) | |
142 | (format #f "~%~v_" (+ 2 (- 32 abbrevs-len)))) | |
143 | (else | |
144 | (format #f "~v_" (- 32 abbrevs-len usage-len)))) | |
145 | abbrevs | |
146 | summary))) | |
147 | ||
148 | (define (read-command repl) | |
149 | (catch #t | |
c372cd74 | 150 | (lambda () (read)) |
33df2ec7 AW |
151 | (lambda (key . args) |
152 | (pmatch args | |
153 | ((,subr ,msg ,args . ,rest) | |
154 | (format #t "Throw to key `~a' while reading command:\n" key) | |
155 | (display-error #f (current-output-port) subr msg args rest)) | |
156 | (else | |
157 | (format #t "Throw to key `~a' with args `~s' while reading command.\n" | |
158 | key args))) | |
159 | (force-output) | |
160 | *unspecified*))) | |
eb721799 | 161 | |
8fdd85f8 AR |
162 | (define (read-command-arguments c repl) |
163 | ((command-info-arguments-reader (command-info c)) repl)) | |
164 | ||
eb721799 | 165 | (define (meta-command repl) |
33df2ec7 AW |
166 | (let ((command (read-command repl))) |
167 | (cond | |
168 | ((eq? command *unspecified*)) ; read error, already signalled; pass. | |
169 | ((not (symbol? command)) | |
170 | (format #t "Meta-command not a symbol: ~s~%" command)) | |
171 | ((lookup-command command) | |
8fdd85f8 AR |
172 | => (lambda (c) |
173 | (and=> (read-command-arguments c repl) | |
174 | (lambda (args) (apply (command-procedure c) repl args))))) | |
33df2ec7 AW |
175 | (else |
176 | (format #t "Unknown meta command: ~A~%" command))))) | |
eb721799 | 177 | |
8fdd85f8 AR |
178 | (define (add-meta-command! name category proc argument-reader) |
179 | (hashq-set! *command-infos* name (make-command-info proc argument-reader)) | |
180 | (if category | |
181 | (let ((entry (assq category *command-table*))) | |
182 | (if entry | |
183 | (set-cdr! entry (append (cdr entry) (list (list name)))) | |
184 | (set! *command-table* | |
185 | (append *command-table* | |
186 | (list (list category (list name))))))))) | |
187 | ||
eb721799 AW |
188 | (define-syntax define-meta-command |
189 | (syntax-rules () | |
8fdd85f8 AR |
190 | ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...) |
191 | (add-meta-command! | |
192 | 'name | |
193 | 'category | |
194 | (lambda* (repl expression0 ... . datums) | |
195 | docstring | |
196 | b0 b1 ...) | |
197 | (lambda (repl) | |
198 | (define (handle-read-error form-name key args) | |
199 | (pmatch args | |
200 | ((,subr ,msg ,args . ,rest) | |
201 | (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n" | |
202 | key form-name 'name) | |
203 | (display-error #f (current-output-port) subr msg args rest)) | |
204 | (else | |
205 | (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n" | |
206 | key args form-name 'name))) | |
207 | (abort)) | |
208 | (% (let* ((expression0 | |
33df2ec7 | 209 | (catch #t |
8fdd85f8 AR |
210 | (lambda () |
211 | (repl-reader | |
212 | "" | |
213 | (lambda* (#:optional (port (current-input-port))) | |
214 | ((language-reader (repl-language repl)) | |
215 | port (current-module))))) | |
216 | (lambda (k . args) | |
217 | (handle-read-error 'expression0 k args)))) | |
218 | ...) | |
219 | (append | |
220 | (list expression0 ...) | |
221 | (catch #t | |
33df2ec7 | 222 | (lambda () |
c372cd74 | 223 | (let ((port (open-input-string (read-line)))) |
33df2ec7 AW |
224 | (let lp ((out '())) |
225 | (let ((x (read port))) | |
226 | (if (eof-object? x) | |
227 | (reverse out) | |
228 | (lp (cons x out))))))) | |
229 | (lambda (k . args) | |
230 | (handle-read-error #f k args))))) | |
8fdd85f8 AR |
231 | (lambda (k) #f))))) ; the abort handler |
232 | ||
233 | ((_ ((name category) repl . datums) docstring b0 b1 ...) | |
234 | (define-meta-command ((name category) repl () . datums) | |
235 | docstring b0 b1 ...)) | |
236 | ||
237 | ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...) | |
238 | (define-meta-command ((name #f) repl (expression0 ...) . datums) | |
239 | docstring b0 b1 ...)) | |
33df2ec7 | 240 | |
eb721799 | 241 | ((_ (name repl . datums) docstring b0 b1 ...) |
8fdd85f8 | 242 | (define-meta-command ((name #f) repl () . datums) |
eb721799 AW |
243 | docstring b0 b1 ...)))) |
244 | ||
4bfb26f5 KN |
245 | |
246 | \f | |
247 | ;;; | |
248 | ;;; Help commands | |
249 | ;;; | |
250 | ||
eb721799 | 251 | (define-meta-command (help repl . args) |
33df2ec7 AW |
252 | "help [all | GROUP | [-c] COMMAND] |
253 | Show help. | |
eb721799 AW |
254 | |
255 | With one argument, tries to look up the argument as a group name, giving | |
256 | help on that group if successful. Otherwise tries to look up the | |
257 | argument as a command, giving help on the command. | |
258 | ||
259 | If there is a command whose name is also a group name, use the ,help | |
260 | -c COMMAND form to give help on the command instead of the group. | |
261 | ||
8f5cfc81 | 262 | Without any argument, a list of help commands and command groups |
eb721799 | 263 | are displayed." |
e429de1e | 264 | (pmatch args |
4bfb26f5 KN |
265 | (() |
266 | (display-group (lookup-group 'help)) | |
267 | (display "Command Groups:\n\n") | |
268 | (display-summary "help all" #f "List all commands") | |
269 | (for-each (lambda (g) | |
270 | (let* ((name (symbol->string (group-name g))) | |
271 | (usage (string-append "help " name)) | |
272 | (header (string-append "List " name " commands"))) | |
273 | (display-summary usage #f header))) | |
274 | (cdr *command-table*)) | |
275 | (newline) | |
019fdc97 AW |
276 | (display |
277 | "Type `,help -c COMMAND' to show documentation of a particular command.") | |
4bfb26f5 | 278 | (newline)) |
e429de1e | 279 | ((all) |
4bfb26f5 | 280 | (for-each display-group *command-table*)) |
e429de1e | 281 | ((,group) (guard (lookup-group group)) |
4bfb26f5 | 282 | (display-group (lookup-group group))) |
eb721799 AW |
283 | ((,command) (guard (lookup-command command)) |
284 | (display-command (lookup-command command))) | |
285 | ((-c ,command) (guard (lookup-command command)) | |
286 | (display-command (lookup-command command))) | |
287 | ((,command) | |
33df2ec7 | 288 | (format #t "Unknown command or group: ~A~%" command)) |
eb721799 | 289 | ((-c ,command) |
33df2ec7 | 290 | (format #t "Unknown command: ~A~%" command)) |
8f5cfc81 | 291 | (else |
33df2ec7 | 292 | (format #t "Bad arguments: ~A~%" args)))) |
4bfb26f5 | 293 | |
dca9a4d6 | 294 | (define-meta-command (show repl . args) |
33df2ec7 | 295 | "show [TOPIC] |
dca9a4d6 AW |
296 | Gives information about Guile. |
297 | ||
298 | With one argument, tries to show a particular piece of information; | |
299 | ||
300 | currently supported topics are `warranty' (or `w'), `copying' (or `c'), | |
301 | and `version' (or `v'). | |
302 | ||
303 | Without any argument, a list of topics is displayed." | |
304 | (pmatch args | |
305 | (() | |
306 | (display-group (car *show-table*) #f) | |
307 | (newline)) | |
308 | ((,topic) (guard (lookup-command topic *show-table*)) | |
309 | ((command-procedure (lookup-command topic *show-table*)) repl)) | |
310 | ((,command) | |
33df2ec7 | 311 | (format #t "Unknown topic: ~A~%" command)) |
dca9a4d6 | 312 | (else |
33df2ec7 | 313 | (format #t "Bad arguments: ~A~%" args)))) |
dca9a4d6 | 314 | |
de9a0f00 AR |
315 | ;;; `warranty', `copying' and `version' are "hidden" meta-commands, only |
316 | ;;; accessible via `show'. They have an entry in *command-infos* but not | |
317 | ;;; in *command-table*. | |
318 | ||
319 | (define-meta-command (warranty repl) | |
dca9a4d6 AW |
320 | "show warranty |
321 | Details on the lack of warranty." | |
322 | (display *warranty*) | |
323 | (newline)) | |
324 | ||
de9a0f00 | 325 | (define-meta-command (copying repl) |
dca9a4d6 AW |
326 | "show copying |
327 | Show the LGPLv3." | |
328 | (display *copying*) | |
329 | (newline)) | |
330 | ||
de9a0f00 | 331 | (define-meta-command (version repl) |
dca9a4d6 AW |
332 | "show version |
333 | Version information." | |
334 | (display *version*) | |
335 | (newline)) | |
336 | ||
eb721799 | 337 | (define-meta-command (apropos repl regexp) |
8f5cfc81 | 338 | "apropos REGEXP |
4bfb26f5 | 339 | Find bindings/modules/packages." |
8fdd85f8 | 340 | (apropos (->string regexp))) |
4bfb26f5 | 341 | |
eb721799 | 342 | (define-meta-command (describe repl (form)) |
4bfb26f5 KN |
343 | "describe OBJ |
344 | Show description/documentation." | |
e1fb0e81 DK |
345 | (display |
346 | (object-documentation | |
347 | (let ((input (repl-parse repl form))) | |
348 | (if (symbol? input) | |
349 | (module-ref (current-module) input) | |
350 | (repl-eval repl input))))) | |
8f5cfc81 | 351 | (newline)) |
4bfb26f5 | 352 | |
eb721799 | 353 | (define-meta-command (option repl . args) |
8d48877d | 354 | "option [NAME] [EXP] |
4bfb26f5 | 355 | List/show/set options." |
e429de1e | 356 | (pmatch args |
f21dfea6 | 357 | (() |
c27d140a AW |
358 | (for-each (lambda (spec) |
359 | (format #t " ~A~24t~A\n" (car spec) (cadr spec))) | |
ce0925e1 | 360 | (repl-options repl))) |
8d48877d AW |
361 | ((,name) |
362 | (display (repl-option-ref repl name)) | |
f21dfea6 | 363 | (newline)) |
8d48877d AW |
364 | ((,name ,exp) |
365 | ;; Would be nice to evaluate in the current language, but the REPL | |
366 | ;; option parser doesn't permit that, currently. | |
367 | (repl-option-set! repl name (eval exp (current-module)))))) | |
4bfb26f5 | 368 | |
eb721799 | 369 | (define-meta-command (quit repl) |
4bfb26f5 KN |
370 | "quit |
371 | Quit this session." | |
372 | (throw 'quit)) | |
373 | ||
374 | \f | |
375 | ;;; | |
376 | ;;; Module commands | |
377 | ;;; | |
378 | ||
eb721799 | 379 | (define-meta-command (module repl . args) |
4bfb26f5 KN |
380 | "module [MODULE] |
381 | Change modules / Show current module." | |
e429de1e | 382 | (pmatch args |
db917b41 | 383 | (() (puts (module-name (current-module)))) |
482015af AW |
384 | ((,mod-name) (guard (list? mod-name)) |
385 | (set-current-module (resolve-module mod-name))) | |
386 | (,mod-name (set-current-module (resolve-module mod-name))))) | |
4bfb26f5 | 387 | |
eb721799 | 388 | (define-meta-command (import repl . args) |
4bfb26f5 KN |
389 | "import [MODULE ...] |
390 | Import modules / List those imported." | |
9246a486 AW |
391 | (let () |
392 | (define (use name) | |
393 | (let ((mod (resolve-interface name))) | |
394 | (if mod | |
395 | (module-use! (current-module) mod) | |
33df2ec7 | 396 | (format #t "No such module: ~A~%" name)))) |
9246a486 AW |
397 | (if (null? args) |
398 | (for-each puts (map module-name (module-uses (current-module)))) | |
399 | (for-each use args)))) | |
4bfb26f5 | 400 | |
019fdc97 | 401 | (define-meta-command (load repl file) |
8f5cfc81 | 402 | "load FILE |
019fdc97 | 403 | Load a file in the current module." |
8fdd85f8 | 404 | (load (->string file))) |
4bfb26f5 | 405 | |
cdab9fc6 AW |
406 | (define-meta-command (reload repl . args) |
407 | "reload [MODULE] | |
408 | Reload the given module, or the current module if none was given." | |
409 | (pmatch args | |
410 | (() (reload-module (current-module))) | |
411 | ((,mod-name) (guard (list? mod-name)) | |
412 | (reload-module (resolve-module mod-name))) | |
413 | (,mod-name (reload-module (resolve-module mod-name))))) | |
414 | ||
eb721799 | 415 | (define-meta-command (binding repl) |
8f5cfc81 | 416 | "binding |
4bfb26f5 | 417 | List current bindings." |
db917b41 AW |
418 | (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v)) |
419 | (current-module))) | |
4bfb26f5 | 420 | |
8fdd85f8 AR |
421 | (define-meta-command (in repl module command-or-expression . args) |
422 | "in MODULE COMMAND-OR-EXPRESSION | |
423 | Evaluate an expression or command in the context of module." | |
424 | (let ((m (resolve-module module #:ensure #f))) | |
425 | (if m | |
426 | (pmatch command-or-expression | |
427 | (('unquote ,command) (guard (lookup-command command)) | |
428 | (save-module-excursion | |
429 | (lambda () | |
430 | (set-current-module m) | |
431 | (apply (command-procedure (lookup-command command)) repl args)))) | |
432 | (,expression | |
433 | (guard (null? args)) | |
434 | (repl-print repl (eval expression m))) | |
435 | (else | |
436 | (format #t "Invalid arguments to `in': expected a single expression or a command.\n"))) | |
437 | (format #t "No such module: ~s\n" module)))) | |
438 | ||
4bfb26f5 KN |
439 | \f |
440 | ;;; | |
441 | ;;; Language commands | |
442 | ;;; | |
443 | ||
eb721799 | 444 | (define-meta-command (language repl name) |
4bfb26f5 KN |
445 | "language LANGUAGE |
446 | Change languages." | |
dca9a4d6 AW |
447 | (let ((lang (lookup-language name)) |
448 | (cur (repl-language repl))) | |
4d75554d | 449 | (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n" |
dca9a4d6 | 450 | (language-title lang) (language-name cur)) |
5745de91 | 451 | (current-language lang) |
dca9a4d6 | 452 | (set! (repl-language repl) lang))) |
4bfb26f5 KN |
453 | |
454 | \f | |
455 | ;;; | |
456 | ;;; Compile commands | |
457 | ;;; | |
458 | ||
35d70ecc | 459 | (define-meta-command (compile repl (form)) |
33df2ec7 | 460 | "compile EXP |
35d70ecc AW |
461 | Generate compiled code." |
462 | (let ((x (repl-compile repl (repl-parse repl form)))) | |
81e002fc | 463 | (cond ((objcode? x) (guile:disassemble x)) |
b0b180d5 | 464 | (else (repl-print repl x))))) |
4bfb26f5 | 465 | |
eb721799 | 466 | (define-meta-command (compile-file repl file . opts) |
8f5cfc81 | 467 | "compile-file FILE |
4bfb26f5 | 468 | Compile a file." |
8fdd85f8 | 469 | (compile-file (->string file) #:opts opts)) |
4bfb26f5 | 470 | |
d62dd766 AW |
471 | (define-meta-command (expand repl (form)) |
472 | "expand EXP | |
473 | Expand any macros in a form." | |
474 | (let ((x (repl-expand repl (repl-parse repl form)))) | |
475 | (run-hook before-print-hook x) | |
476 | (pp x))) | |
477 | ||
478 | (define-meta-command (optimize repl (form)) | |
479 | "optimize EXP | |
480 | Run the optimizer on a piece of code and print the result." | |
481 | (let ((x (repl-optimize repl (repl-parse repl form)))) | |
482 | (run-hook before-print-hook x) | |
483 | (pp x))) | |
484 | ||
9bb8012d AW |
485 | (define (guile:disassemble x) |
486 | ((@ (language assembly disassemble) disassemble) x)) | |
487 | ||
eb721799 | 488 | (define-meta-command (disassemble repl (form)) |
33df2ec7 AW |
489 | "disassemble EXP |
490 | Disassemble a compiled procedure." | |
fb6df3ea AW |
491 | (let ((obj (repl-eval repl (repl-parse repl form)))) |
492 | (if (or (program? obj) (objcode? obj)) | |
493 | (guile:disassemble obj) | |
494 | (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%" | |
495 | obj)))) | |
4bfb26f5 | 496 | |
eb721799 | 497 | (define-meta-command (disassemble-file repl file) |
4bfb26f5 KN |
498 | "disassemble-file FILE |
499 | Disassemble a file." | |
9bb8012d | 500 | (guile:disassemble (load-objcode (->string file)))) |
4bfb26f5 KN |
501 | |
502 | \f | |
503 | ;;; | |
504 | ;;; Profile commands | |
505 | ;;; | |
506 | ||
eb721799 | 507 | (define-meta-command (time repl (form)) |
33df2ec7 | 508 | "time EXP |
8f5cfc81 | 509 | Time execution." |
e5f5113c | 510 | (let* ((gc-start (gc-run-time)) |
c1e3e9aa AW |
511 | (real-start (get-internal-real-time)) |
512 | (run-start (get-internal-run-time)) | |
b0b180d5 | 513 | (result (repl-eval repl (repl-parse repl form))) |
c1e3e9aa AW |
514 | (run-end (get-internal-run-time)) |
515 | (real-end (get-internal-real-time)) | |
e5f5113c | 516 | (gc-end (gc-run-time))) |
c1e3e9aa AW |
517 | (define (diff start end) |
518 | (/ (- end start) 1.0 internal-time-units-per-second)) | |
8f5cfc81 | 519 | (repl-print repl result) |
c1e3e9aa AW |
520 | (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n" |
521 | (diff real-start real-end) | |
522 | (diff run-start run-end) | |
523 | (diff gc-start gc-end)) | |
8f5cfc81 KN |
524 | result)) |
525 | ||
a6dc56a7 | 526 | (define-meta-command (profile repl (form) . opts) |
33df2ec7 | 527 | "profile EXP |
4bfb26f5 | 528 | Profile execution." |
a6dc56a7 | 529 | ;; FIXME opts |
01c0082f | 530 | (apply statprof |
d8e2ba23 | 531 | (repl-prepare-eval-thunk repl (repl-parse repl form)) |
01c0082f | 532 | opts)) |
a6dc56a7 | 533 | |
01c0082f | 534 | (define-meta-command (trace repl (form) . opts) |
33df2ec7 | 535 | "trace EXP |
737caee8 | 536 | Trace execution." |
7e9f9602 | 537 | ;; FIXME: doc options, or somehow deal with them better |
e7544f39 | 538 | (apply call-with-trace |
d8e2ba23 | 539 | (repl-prepare-eval-thunk repl (repl-parse repl form)) |
74e4dd27 | 540 | (cons* #:width (terminal-width) opts))) |
4bfb26f5 | 541 | |
33df2ec7 AW |
542 | \f |
543 | ;;; | |
544 | ;;; Debug commands | |
545 | ;;; | |
546 | ||
547 | (define-syntax define-stack-command | |
548 | (lambda (x) | |
549 | (syntax-case x () | |
550 | ((_ (name repl . args) docstring body body* ...) | |
551 | #`(define-meta-command (name repl . args) | |
552 | docstring | |
553 | (let ((debug (repl-debug repl))) | |
554 | (if debug | |
555 | (letrec-syntax | |
556 | ((#,(datum->syntax #'repl 'frames) | |
557 | (identifier-syntax (debug-frames debug))) | |
54d9a994 JOR |
558 | (#,(datum->syntax #'repl 'message) |
559 | (identifier-syntax (debug-error-message debug))) | |
5aa12c69 AW |
560 | (#,(datum->syntax #'repl 'for-trap?) |
561 | (identifier-syntax (debug-for-trap? debug))) | |
33df2ec7 AW |
562 | (#,(datum->syntax #'repl 'index) |
563 | (identifier-syntax | |
564 | (id (debug-index debug)) | |
565 | ((set! id exp) (set! (debug-index debug) exp)))) | |
566 | (#,(datum->syntax #'repl 'cur) | |
567 | (identifier-syntax | |
568 | (vector-ref #,(datum->syntax #'repl 'frames) | |
569 | #,(datum->syntax #'repl 'index))))) | |
570 | body body* ...) | |
571 | (format #t "Nothing to debug.~%")))))))) | |
572 | ||
573 | (define-stack-command (backtrace repl #:optional count | |
090f14b8 | 574 | #:key (width (terminal-width)) full?) |
33df2ec7 AW |
575 | "backtrace [COUNT] [#:width W] [#:full? F] |
576 | Print a backtrace. | |
577 | ||
578 | Print a backtrace of all stack frames, or innermost COUNT frames. | |
579 | If COUNT is negative, the last COUNT frames will be shown." | |
54d9a994 | 580 | (print-frames frames |
33df2ec7 AW |
581 | #:count count |
582 | #:width width | |
5aa12c69 AW |
583 | #:full? full? |
584 | #:for-trap? for-trap?)) | |
54d9a994 | 585 | |
33df2ec7 AW |
586 | (define-stack-command (up repl #:optional (count 1)) |
587 | "up [COUNT] | |
588 | Select a calling stack frame. | |
589 | ||
590 | Select and print stack frames that called this one. | |
591 | An argument says how many frames up to go." | |
592 | (cond | |
593 | ((or (not (integer? count)) (<= count 0)) | |
594 | (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%")) | |
595 | ((>= (+ count index) (vector-length frames)) | |
596 | (cond | |
597 | ((= index (1- (vector-length frames))) | |
598 | (format #t "Already at outermost frame.\n")) | |
599 | (else | |
600 | (set! index (1- (vector-length frames))) | |
5aa12c69 AW |
601 | (print-frame cur #:index index |
602 | #:next-source? (and (zero? index) for-trap?))))) | |
33df2ec7 AW |
603 | (else |
604 | (set! index (+ count index)) | |
5aa12c69 AW |
605 | (print-frame cur #:index index |
606 | #:next-source? (and (zero? index) for-trap?))))) | |
33df2ec7 AW |
607 | |
608 | (define-stack-command (down repl #:optional (count 1)) | |
609 | "down [COUNT] | |
610 | Select a called stack frame. | |
611 | ||
612 | Select and print stack frames called by this one. | |
613 | An argument says how many frames down to go." | |
614 | (cond | |
615 | ((or (not (integer? count)) (<= count 0)) | |
616 | (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%")) | |
617 | ((< (- index count) 0) | |
618 | (cond | |
619 | ((zero? index) | |
620 | (format #t "Already at innermost frame.\n")) | |
621 | (else | |
622 | (set! index 0) | |
5aa12c69 | 623 | (print-frame cur #:index index #:next-source? for-trap?)))) |
33df2ec7 AW |
624 | (else |
625 | (set! index (- index count)) | |
5aa12c69 AW |
626 | (print-frame cur #:index index |
627 | #:next-source? (and (zero? index) for-trap?))))) | |
33df2ec7 AW |
628 | |
629 | (define-stack-command (frame repl #:optional idx) | |
630 | "frame [IDX] | |
631 | Show a frame. | |
632 | ||
633 | Show the selected frame. | |
634 | With an argument, select a frame by index, then show it." | |
635 | (cond | |
636 | (idx | |
637 | (cond | |
638 | ((or (not (integer? idx)) (< idx 0)) | |
639 | (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%")) | |
640 | ((< idx (vector-length frames)) | |
641 | (set! index idx) | |
5aa12c69 AW |
642 | (print-frame cur #:index index |
643 | #:next-source? (and (zero? index) for-trap?))) | |
33df2ec7 AW |
644 | (else |
645 | (format #t "No such frame.~%")))) | |
5aa12c69 AW |
646 | (else (print-frame cur #:index index |
647 | #:next-source? (and (zero? index) for-trap?))))) | |
33df2ec7 AW |
648 | |
649 | (define-stack-command (procedure repl) | |
650 | "procedure | |
0ddbd883 | 651 | Print the procedure for the selected frame." |
33df2ec7 | 652 | (repl-print repl (frame-procedure cur))) |
54d9a994 | 653 | |
090f14b8 | 654 | (define-stack-command (locals repl #:key (width (terminal-width))) |
33df2ec7 AW |
655 | "locals |
656 | Show local variables. | |
657 | ||
658 | Show locally-bound variables in the selected frame." | |
47b86dbf | 659 | (print-locals cur #:width width)) |
54d9a994 | 660 | |
b9badc35 AW |
661 | (define-stack-command (error-message repl) |
662 | "error-message | |
663 | Show error message. | |
664 | ||
665 | Display the message associated with the error that started the current | |
666 | debugging REPL." | |
667 | (format #t "~a~%" (if (string? message) message "No error message"))) | |
668 | ||
669 | (define-meta-command (break repl (form)) | |
670 | "break PROCEDURE | |
671 | Break on calls to PROCEDURE. | |
672 | ||
673 | Starts a recursive prompt when PROCEDURE is called." | |
674 | (let ((proc (repl-eval repl (repl-parse repl form)))) | |
675 | (if (not (procedure? proc)) | |
676 | (error "Not a procedure: ~a" proc) | |
677 | (let ((idx (add-trap-at-procedure-call! proc))) | |
95720533 | 678 | (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))) |
b9badc35 | 679 | |
fb5c4dc5 AW |
680 | (define-meta-command (break-at-source repl file line) |
681 | "break-at-source FILE LINE | |
682 | Break when control reaches the given source location. | |
683 | ||
684 | Starts a recursive prompt when control reaches line LINE of file FILE. | |
685 | Note that the given source location must be inside a procedure." | |
686 | (let ((file (if (symbol? file) (symbol->string file) file))) | |
687 | (let ((idx (add-trap-at-source-location! file line))) | |
688 | (format #t "Trap ~a: ~a.~%" idx (trap-name idx))))) | |
689 | ||
aee24bac | 690 | (define (repl-pop-continuation-resumer repl msg) |
e8e4e731 AW |
691 | ;; Capture the dynamic environment with this prompt thing. The |
692 | ;; result is a procedure that takes a frame. | |
693 | (% (call-with-values | |
694 | (lambda () | |
695 | (abort | |
696 | (lambda (k) | |
697 | ;; Call frame->stack-vector before reinstating the | |
698 | ;; continuation, so that we catch the %stacks fluid at | |
699 | ;; the time of capture. | |
700 | (lambda (frame) | |
701 | (k frame | |
702 | (frame->stack-vector | |
703 | (frame-previous frame))))))) | |
704 | (lambda (from stack) | |
705 | (format #t "~a~%" msg) | |
706 | (let ((vals (frame-return-values from))) | |
707 | (if (null? vals) | |
08002eae | 708 | (format #t "No return values.~%") |
e8e4e731 | 709 | (begin |
08002eae | 710 | (format #t "Return values:~%") |
e8e4e731 AW |
711 | (for-each (lambda (x) (repl-print repl x)) vals)))) |
712 | ((module-ref (resolve-interface '(system repl repl)) 'start-repl) | |
a36c3a45 | 713 | #:debug (make-debug stack 0 msg #t)))))) |
e8e4e731 | 714 | |
c6025e76 AW |
715 | (define-stack-command (finish repl) |
716 | "finish | |
717 | Run until the current frame finishes. | |
718 | ||
719 | Resume execution, breaking when the current frame finishes." | |
e8e4e731 | 720 | (let ((handler (repl-pop-continuation-resumer |
aee24bac | 721 | repl (format #f "Return from ~a" cur)))) |
e8e4e731 | 722 | (add-ephemeral-trap-at-frame-finish! cur handler) |
c6025e76 AW |
723 | (throw 'quit))) |
724 | ||
439e032b AW |
725 | (define (repl-next-resumer msg) |
726 | ;; Capture the dynamic environment with this prompt thing. The | |
727 | ;; result is a procedure that takes a frame. | |
728 | (% (let ((stack (abort | |
729 | (lambda (k) | |
730 | ;; Call frame->stack-vector before reinstating the | |
731 | ;; continuation, so that we catch the %stacks fluid | |
732 | ;; at the time of capture. | |
733 | (lambda (frame) | |
734 | (k (frame->stack-vector frame))))))) | |
735 | (format #t "~a~%" msg) | |
736 | ((module-ref (resolve-interface '(system repl repl)) 'start-repl) | |
a36c3a45 | 737 | #:debug (make-debug stack 0 msg #t))))) |
439e032b AW |
738 | |
739 | (define-stack-command (step repl) | |
740 | "step | |
741 | Step until control reaches a different source location. | |
742 | ||
743 | Step until control reaches a different source location." | |
744 | (let ((msg (format #f "Step into ~a" cur))) | |
745 | (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) | |
746 | #:into? #t #:instruction? #f) | |
747 | (throw 'quit))) | |
748 | ||
749 | (define-stack-command (step-instruction repl) | |
750 | "step-instruction | |
751 | Step until control reaches a different instruction. | |
752 | ||
753 | Step until control reaches a different VM instruction." | |
754 | (let ((msg (format #f "Step into ~a" cur))) | |
755 | (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) | |
756 | #:into? #t #:instruction? #t) | |
757 | (throw 'quit))) | |
758 | ||
759 | (define-stack-command (next repl) | |
760 | "next | |
761 | Step until control reaches a different source location in the current frame. | |
762 | ||
763 | Step until control reaches a different source location in the current frame." | |
764 | (let ((msg (format #f "Step into ~a" cur))) | |
765 | (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) | |
766 | #:into? #f #:instruction? #f) | |
767 | (throw 'quit))) | |
768 | ||
1ecf39a6 | 769 | (define-stack-command (next-instruction repl) |
439e032b AW |
770 | "next-instruction |
771 | Step until control reaches a different instruction in the current frame. | |
772 | ||
773 | Step until control reaches a different VM instruction in the current frame." | |
774 | (let ((msg (format #f "Step into ~a" cur))) | |
775 | (add-ephemeral-stepping-trap! cur (repl-next-resumer msg) | |
776 | #:into? #f #:instruction? #t) | |
777 | (throw 'quit))) | |
778 | ||
25361a80 AW |
779 | (define-meta-command (tracepoint repl (form)) |
780 | "tracepoint PROCEDURE | |
781 | Add a tracepoint to PROCEDURE. | |
782 | ||
783 | A tracepoint will print out the procedure and its arguments, when it is | |
784 | called, and its return value(s) when it returns." | |
785 | (let ((proc (repl-eval repl (repl-parse repl form)))) | |
786 | (if (not (procedure? proc)) | |
787 | (error "Not a procedure: ~a" proc) | |
788 | (let ((idx (add-trace-at-procedure-call! proc))) | |
95720533 | 789 | (format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))) |
25361a80 | 790 | |
589520bc AW |
791 | (define-meta-command (traps repl) |
792 | "traps | |
793 | Show the set of currently attached traps. | |
794 | ||
66519688 | 795 | Show the set of currently attached traps (breakpoints and tracepoints)." |
589520bc AW |
796 | (let ((traps (list-traps))) |
797 | (if (null? traps) | |
66519688 | 798 | (format #t "No traps set.~%") |
3e2c5f1e | 799 | (for-each (lambda (idx) |
589520bc | 800 | (format #t " ~a: ~a~a~%" |
66519688 | 801 | idx (trap-name idx) |
589520bc | 802 | (if (trap-enabled? idx) "" " (disabled)"))) |
3e2c5f1e | 803 | traps)))) |
589520bc AW |
804 | |
805 | (define-meta-command (delete repl idx) | |
806 | "delete IDX | |
807 | Delete a trap. | |
808 | ||
809 | Delete a trap." | |
810 | (if (not (integer? idx)) | |
811 | (error "expected a trap index (a non-negative integer)" idx) | |
812 | (delete-trap! idx))) | |
813 | ||
814 | (define-meta-command (disable repl idx) | |
815 | "disable IDX | |
816 | Disable a trap. | |
817 | ||
818 | Disable a trap." | |
819 | (if (not (integer? idx)) | |
820 | (error "expected a trap index (a non-negative integer)" idx) | |
821 | (disable-trap! idx))) | |
822 | ||
823 | (define-meta-command (enable repl idx) | |
824 | "enable IDX | |
825 | Enable a trap. | |
826 | ||
827 | Enable a trap." | |
828 | (if (not (integer? idx)) | |
829 | (error "expected a trap index (a non-negative integer)" idx) | |
830 | (enable-trap! idx))) | |
831 | ||
542f975e AW |
832 | (define-stack-command (registers repl) |
833 | "registers | |
834 | Print registers. | |
835 | ||
836 | Print the registers of the current frame." | |
837 | (print-registers cur)) | |
838 | ||
47b86dbf MG |
839 | (define-meta-command (width repl #:optional x) |
840 | "width [X] | |
841 | Set debug output width. | |
842 | ||
843 | Set the number of screen columns in the output from `backtrace' and | |
844 | `locals'." | |
090f14b8 AW |
845 | (terminal-width x) |
846 | (format #t "Set screen width to ~a columns.~%" (terminal-width))) | |
847 | ||
b9badc35 | 848 | |
33df2ec7 AW |
849 | \f |
850 | ;;; | |
851 | ;;; Inspection commands | |
852 | ;;; | |
853 | ||
542f975e | 854 | (define-meta-command (inspect repl (form)) |
33df2ec7 AW |
855 | "inspect EXP |
856 | Inspect the result(s) of evaluating EXP." | |
d8e2ba23 | 857 | (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form)) |
33df2ec7 AW |
858 | (lambda args |
859 | (for-each %inspect args)))) | |
860 | ||
861 | (define-meta-command (pretty-print repl (form)) | |
862 | "pretty-print EXP | |
863 | Pretty-print the result(s) of evaluating EXP." | |
d8e2ba23 | 864 | (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form)) |
33df2ec7 AW |
865 | (lambda args |
866 | (for-each | |
867 | (lambda (x) | |
868 | (run-hook before-print-hook x) | |
869 | (pp x)) | |
870 | args)))) | |
4bfb26f5 KN |
871 | |
872 | \f | |
873 | ;;; | |
54d9a994 | 874 | ;;; System commands |
4bfb26f5 KN |
875 | ;;; |
876 | ||
eb721799 | 877 | (define-meta-command (gc repl) |
4bfb26f5 KN |
878 | "gc |
879 | Garbage collection." | |
8fdd85f8 | 880 | (gc)) |
4bfb26f5 | 881 | |
eb721799 | 882 | (define-meta-command (statistics repl) |
4bfb26f5 KN |
883 | "statistics |
884 | Display statistics." | |
885 | (let ((this-tms (times)) | |
4bfb26f5 | 886 | (this-gcs (gc-stats)) |
ce0925e1 | 887 | (last-tms (repl-tm-stats repl)) |
ce0925e1 | 888 | (last-gcs (repl-gc-stats repl))) |
4bfb26f5 KN |
889 | ;; GC times |
890 | (let ((this-times (assq-ref this-gcs 'gc-times)) | |
891 | (last-times (assq-ref last-gcs 'gc-times))) | |
892 | (display-diff-stat "GC times:" #t this-times last-times "times") | |
893 | (newline)) | |
894 | ;; Memory size | |
c7d6f8b2 AW |
895 | (let ((this-heap (assq-ref this-gcs 'heap-size)) |
896 | (this-free (assq-ref this-gcs 'heap-free-size))) | |
4bfb26f5 | 897 | (display-stat-title "Memory size:" "current" "limit") |
c7d6f8b2 | 898 | (display-stat "heap" #f (- this-heap this-free) this-heap "bytes") |
4bfb26f5 KN |
899 | (newline)) |
900 | ;; Cells collected | |
c7d6f8b2 AW |
901 | (let ((this-alloc (assq-ref this-gcs 'heap-total-allocated)) |
902 | (last-alloc (assq-ref last-gcs 'heap-total-allocated))) | |
903 | (display-stat-title "Bytes allocated:" "diff" "total") | |
904 | (display-diff-stat "allocated" #f this-alloc last-alloc "bytes") | |
4bfb26f5 KN |
905 | (newline)) |
906 | ;; GC time taken | |
c7d6f8b2 | 907 | (let ((this-total (assq-ref this-gcs 'gc-time-taken)) |
4bfb26f5 KN |
908 | (last-total (assq-ref last-gcs 'gc-time-taken))) |
909 | (display-stat-title "GC time taken:" "diff" "total") | |
4bfb26f5 KN |
910 | (display-time-stat "total" this-total last-total) |
911 | (newline)) | |
912 | ;; Process time spent | |
913 | (let ((this-utime (tms:utime this-tms)) | |
914 | (last-utime (tms:utime last-tms)) | |
915 | (this-stime (tms:stime this-tms)) | |
916 | (last-stime (tms:stime last-tms)) | |
917 | (this-cutime (tms:cutime this-tms)) | |
918 | (last-cutime (tms:cutime last-tms)) | |
919 | (this-cstime (tms:cstime this-tms)) | |
920 | (last-cstime (tms:cstime last-tms))) | |
921 | (display-stat-title "Process time spent:" "diff" "total") | |
922 | (display-time-stat "user" this-utime last-utime) | |
923 | (display-time-stat "system" this-stime last-stime) | |
924 | (display-time-stat "child user" this-cutime last-cutime) | |
925 | (display-time-stat "child system" this-cstime last-cstime) | |
926 | (newline)) | |
4bfb26f5 KN |
927 | ;; Save statistics |
928 | ;; Save statistics | |
ce0925e1 | 929 | (set! (repl-tm-stats repl) this-tms) |
ce0925e1 | 930 | (set! (repl-gc-stats repl) this-gcs))) |
cb4cca12 KN |
931 | |
932 | (define (display-stat title flag field1 field2 unit) | |
5414d333 AW |
933 | (let ((fmt (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@")))) |
934 | (format #t fmt title field1 field2 unit))) | |
cb4cca12 KN |
935 | |
936 | (define (display-stat-title title field1 field2) | |
937 | (display-stat title #t field1 field2 "")) | |
938 | ||
939 | (define (display-diff-stat title flag this last unit) | |
940 | (display-stat title flag (- this last) this unit)) | |
941 | ||
942 | (define (display-time-stat title this last) | |
943 | (define (conv num) | |
b9d8ed05 | 944 | (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second)))) |
cb4cca12 KN |
945 | (display-stat title #f (conv (- this last)) (conv this) "s")) |
946 | ||
947 | (define (display-mips-stat title this-time this-clock last-time last-clock) | |
948 | (define (mips time clock) | |
b9d8ed05 | 949 | (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0)))) |
cb4cca12 KN |
950 | (display-stat title #f |
951 | (mips (- this-time last-time) (- this-clock last-clock)) | |
952 | (mips this-time this-clock) "mips")) |