Commit | Line | Data |
---|---|---|
3b12702f AW |
1 | ;;; Guile VM debugging facilities |
2 | ||
f3c0b533 | 3 | ;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. |
3b12702f AW |
4 | ;;; |
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. | |
9 | ;;; | |
10 | ;;; This library is distributed in the hope that it will be useful, | |
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;; Lesser General Public License for more details. | |
14 | ;;; | |
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 02110-1301 USA | |
18 | ||
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm inspect) | |
22 | #:use-module (system base pmatch) | |
23 | #:use-module (system base syntax) | |
24 | #:use-module (system vm vm) | |
25 | #:use-module (system vm frame) | |
f3c0b533 | 26 | #:use-module (system vm disassembler) |
3b12702f AW |
27 | #:use-module (ice-9 rdelim) |
28 | #:use-module (ice-9 pretty-print) | |
29 | #:use-module (ice-9 format) | |
30 | #:use-module (system vm program) | |
31 | #:export (inspect)) | |
32 | ||
33 | \f | |
34 | (define (reverse-hashq h) | |
35 | (let ((ret (make-hash-table))) | |
36 | (hash-for-each | |
37 | (lambda (k v) | |
38 | (hashq-set! ret v (cons k (hashq-ref ret v '())))) | |
39 | h) | |
40 | ret)) | |
41 | ||
42 | (define (catch-bad-arguments thunk bad-args-thunk) | |
43 | (catch 'wrong-number-of-args | |
44 | (lambda () | |
45 | (catch 'keyword-argument-error | |
46 | thunk | |
47 | (lambda (k . args) | |
48 | (bad-args-thunk)))) | |
49 | (lambda (k . args) | |
50 | (bad-args-thunk)))) | |
51 | ||
52 | (define (read-args prompt) | |
53 | (define (read* reader) | |
54 | (repl-reader prompt reader)) | |
55 | (define (next) | |
56 | (read* read-char)) | |
57 | (define (cmd chr) | |
58 | (cond | |
59 | ((eof-object? chr) (list chr)) | |
60 | ((char=? chr #\newline) (cmd (next))) | |
61 | ((char-whitespace? chr) (cmd (next))) | |
62 | (else | |
63 | (unread-char chr) | |
64 | (let ((tok (read* read))) | |
65 | (args (list tok) (next)))))) | |
66 | (define (args out chr) | |
67 | (cond | |
68 | ((eof-object? chr) (reverse out)) | |
69 | ((char=? chr #\newline) (reverse out)) | |
70 | ((char-whitespace? chr) (args out (next))) | |
71 | (else | |
72 | (unread-char chr) | |
73 | (let ((tok (read* read))) | |
74 | (args (cons tok out) (next)))))) | |
75 | (cmd (next))) | |
76 | ||
77 | ||
78 | ;;; | |
79 | ;;; Inspector | |
80 | ;;; | |
81 | ||
82 | (define (inspect x) | |
0c65f52c AW |
83 | (define-syntax-rule (define-command ((mod cname alias ...) . args) |
84 | body ...) | |
85 | (define cname | |
86 | (let ((c (lambda* args body ...))) | |
87 | (set-procedure-property! c 'name 'cname) | |
88 | (module-define! mod 'cname c) | |
89 | (module-add! mod 'alias (module-local-variable mod 'cname)) | |
90 | ... | |
91 | c))) | |
3b12702f AW |
92 | |
93 | (let ((commands (make-module))) | |
94 | (define (prompt) | |
95 | (format #f "~20@y inspect> " x)) | |
96 | ||
97 | (define-command ((commands quit q continue cont c)) | |
98 | "Quit the inspector." | |
99 | (throw 'quit)) | |
100 | ||
101 | (define-command ((commands print p)) | |
102 | "Print the current object using `pretty-print'." | |
103 | (pretty-print x)) | |
104 | ||
105 | (define-command ((commands write w)) | |
106 | "Print the current object using `write'." | |
107 | (write x)) | |
108 | ||
109 | (define-command ((commands display d)) | |
110 | "Print the current object using `display'." | |
111 | (display x)) | |
112 | ||
113 | (define-command ((commands disassemble x)) | |
f3c0b533 | 114 | "Disassemble the current object, which should be a procedure." |
3b12702f AW |
115 | (catch #t |
116 | (lambda () | |
f3c0b533 | 117 | (disassemble-program x)) |
3b12702f AW |
118 | (lambda args |
119 | (format #t "Error disassembling object: ~a\n" args)))) | |
120 | ||
121 | (define-command ((commands help h ?) #:optional cmd) | |
122 | "Show this help message." | |
123 | (let ((rhash (reverse-hashq (module-obarray commands)))) | |
124 | (define (help-cmd cmd) | |
125 | (let* ((v (module-local-variable commands cmd)) | |
126 | (p (variable-ref v)) | |
127 | (canonical-name (procedure-name p))) | |
128 | ;; la la la | |
129 | (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%" | |
130 | canonical-name (program-lambda-list p) | |
131 | "~#[~:;~40t(aliases: ~@{~a~^, ~})~]" | |
132 | (delq canonical-name (hashq-ref rhash v)) | |
133 | (procedure-documentation p)))) | |
134 | (cond | |
135 | (cmd | |
136 | (cond | |
137 | ((and (symbol? cmd) (module-local-variable commands cmd)) | |
138 | (help-cmd cmd)) | |
139 | (else | |
140 | (format #t "Invalid command ~s.~%" cmd) | |
141 | (format #t "Try `help' for a list of commands~%")))) | |
142 | (else | |
143 | (let ((names (sort | |
144 | (hash-map->list | |
145 | (lambda (k v) | |
146 | (procedure-name (variable-ref k))) | |
147 | rhash) | |
148 | (lambda (x y) | |
149 | (string<? (symbol->string x) | |
150 | (symbol->string y)))))) | |
151 | (format #t "Available commands:~%~%") | |
152 | (for-each help-cmd names)))))) | |
153 | ||
154 | (define (handle cmd . args) | |
155 | (cond | |
156 | ((and (symbol? cmd) | |
157 | (module-local-variable commands cmd)) | |
158 | => (lambda (var) | |
159 | (let ((proc (variable-ref var))) | |
160 | (catch-bad-arguments | |
161 | (lambda () | |
162 | (apply (variable-ref var) args)) | |
163 | (lambda () | |
164 | (format (current-error-port) | |
165 | "Invalid arguments to ~a. Try `help ~a'.~%" | |
166 | (procedure-name proc) (procedure-name proc))))))) | |
167 | ; ((and (integer? cmd) (exact? cmd)) | |
168 | ; (nth cmd)) | |
169 | ((eof-object? cmd) | |
170 | (newline) | |
171 | (throw 'quit)) | |
172 | (else | |
173 | (format (current-error-port) | |
174 | "~&Unknown command: ~a. Try `help'.~%" cmd) | |
175 | *unspecified*))) | |
176 | ||
177 | (catch 'quit | |
178 | (lambda () | |
179 | (let loop () | |
180 | (apply | |
181 | handle | |
182 | (save-module-excursion | |
183 | (lambda () | |
184 | (set-current-module commands) | |
185 | (read-args prompt)))) | |
186 | (loop))) | |
187 | (lambda (k . args) | |
188 | (apply values args))))) |