1 ;;; Guile VM debugging facilities
3 ;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
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.
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.
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
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)
26 #:use-module (system vm disassembler)
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)
34 (define (reverse-hashq h)
35 (let ((ret (make-hash-table)))
38 (hashq-set! ret v (cons k (hashq-ref ret v '()))))
42 (define (catch-bad-arguments thunk bad-args-thunk)
43 (catch 'wrong-number-of-args
45 (catch 'keyword-argument-error
52 (define (read-args prompt)
53 (define (read* reader)
54 (repl-reader prompt reader))
59 ((eof-object? chr) (list chr))
60 ((char=? chr #\newline) (cmd (next)))
61 ((char-whitespace? chr) (cmd (next)))
64 (let ((tok (read* read)))
65 (args (list tok) (next))))))
66 (define (args out chr)
68 ((eof-object? chr) (reverse out))
69 ((char=? chr #\newline) (reverse out))
70 ((char-whitespace? chr) (args out (next)))
73 (let ((tok (read* read)))
74 (args (cons tok out) (next))))))
83 (define-syntax-rule (define-command ((mod cname alias ...) . args)
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))
93 (let ((commands (make-module)))
95 (format #f "~20@y inspect> " x))
97 (define-command ((commands quit q continue cont c))
101 (define-command ((commands print p))
102 "Print the current object using `pretty-print'."
105 (define-command ((commands write w))
106 "Print the current object using `write'."
109 (define-command ((commands display d))
110 "Print the current object using `display'."
113 (define-command ((commands disassemble x))
114 "Disassemble the current object, which should be a procedure."
117 (disassemble-program x))
119 (format #t "Error disassembling object: ~a\n" args))))
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))
127 (canonical-name (procedure-name p)))
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))))
137 ((and (symbol? cmd) (module-local-variable commands cmd))
140 (format #t "Invalid command ~s.~%" cmd)
141 (format #t "Try `help' for a list of commands~%"))))
146 (procedure-name (variable-ref k)))
149 (string<? (symbol->string x)
150 (symbol->string y))))))
151 (format #t "Available commands:~%~%")
152 (for-each help-cmd names))))))
154 (define (handle cmd . args)
157 (module-local-variable commands cmd))
159 (let ((proc (variable-ref var)))
162 (apply (variable-ref var) args))
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))
173 (format (current-error-port)
174 "~&Unknown command: ~a. Try `help'.~%" cmd)
182 (save-module-excursion
184 (set-current-module commands)
185 (read-args prompt))))
188 (apply values args)))))