mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
These were found with: make GUILE_WARNINGS='-W1 -Wunused-module' * module/ice-9/copy-tree.scm: * module/ice-9/eval-string.scm: * module/ice-9/getopt-long.scm: * module/ice-9/poll.scm: * module/ice-9/popen.scm: * module/ice-9/sandbox.scm: * module/ice-9/threads.scm: * module/sxml/apply-templates.scm: * module/sxml/simple.scm: * module/system/base/types.scm: * module/system/repl/command.scm: * module/system/repl/common.scm: * module/system/repl/coop-server.scm: * module/system/repl/debug.scm: * module/system/repl/error-handling.scm: * module/system/repl/repl.scm: * module/system/repl/server.scm: * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm: * module/system/vm/dwarf.scm: * module/system/vm/elf.scm: * module/system/vm/frame.scm: * module/system/vm/inspect.scm: * module/system/vm/linker.scm: * module/system/vm/program.scm: * module/system/vm/trace.scm: * module/system/vm/trap-state.scm: * module/system/vm/traps.scm: * module/system/xref.scm: * module/texinfo/indexing.scm: * module/texinfo/plain-text.scm: * module/texinfo/reflection.scm: * module/texinfo/string-utils.scm: * module/web/client.scm: * module/web/http.scm: * module/web/request.scm: * module/web/response.scm: Remove imports of unused modules.
183 lines
5.8 KiB
Scheme
183 lines
5.8 KiB
Scheme
;;; Guile VM debugging facilities
|
||
|
||
;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||
;;;
|
||
;;; This library is free software; you can redistribute it and/or
|
||
;;; modify it under the terms of the GNU Lesser General Public
|
||
;;; License as published by the Free Software Foundation; either
|
||
;;; version 3 of the License, or (at your option) any later version.
|
||
;;;
|
||
;;; This library is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;; Lesser General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU Lesser General Public
|
||
;;; License along with this library; if not, write to the Free Software
|
||
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
;;; Code:
|
||
|
||
(define-module (system vm inspect)
|
||
#:use-module (system vm disassembler)
|
||
#:use-module (ice-9 pretty-print)
|
||
#:use-module (ice-9 format)
|
||
#:use-module (system vm program)
|
||
#:export (inspect))
|
||
|
||
|
||
(define (reverse-hashq h)
|
||
(let ((ret (make-hash-table)))
|
||
(hash-for-each
|
||
(lambda (k v)
|
||
(hashq-set! ret v (cons k (hashq-ref ret v '()))))
|
||
h)
|
||
ret))
|
||
|
||
(define (catch-bad-arguments thunk bad-args-thunk)
|
||
(catch 'wrong-number-of-args
|
||
(lambda ()
|
||
(catch 'keyword-argument-error
|
||
thunk
|
||
(lambda (k . args)
|
||
(bad-args-thunk))))
|
||
(lambda (k . args)
|
||
(bad-args-thunk))))
|
||
|
||
(define (read-args prompt)
|
||
(define (read* reader)
|
||
(repl-reader prompt reader))
|
||
(define (next)
|
||
(read* read-char))
|
||
(define (cmd chr)
|
||
(cond
|
||
((eof-object? chr) (list chr))
|
||
((char=? chr #\newline) (cmd (next)))
|
||
((char-whitespace? chr) (cmd (next)))
|
||
(else
|
||
(unread-char chr)
|
||
(let ((tok (read* read)))
|
||
(args (list tok) (next))))))
|
||
(define (args out chr)
|
||
(cond
|
||
((eof-object? chr) (reverse out))
|
||
((char=? chr #\newline) (reverse out))
|
||
((char-whitespace? chr) (args out (next)))
|
||
(else
|
||
(unread-char chr)
|
||
(let ((tok (read* read)))
|
||
(args (cons tok out) (next))))))
|
||
(cmd (next)))
|
||
|
||
|
||
;;;
|
||
;;; Inspector
|
||
;;;
|
||
|
||
(define (inspect x)
|
||
(define-syntax-rule (define-command ((mod cname alias ...) . args)
|
||
body ...)
|
||
(define cname
|
||
(let ((c (lambda* args body ...)))
|
||
(set-procedure-property! c 'name 'cname)
|
||
(module-define! mod 'cname c)
|
||
(module-add! mod 'alias (module-local-variable mod 'cname))
|
||
...
|
||
c)))
|
||
|
||
(let ((commands (make-module)))
|
||
(define (prompt)
|
||
(format #f "~20@y inspect> " x))
|
||
|
||
(define-command ((commands quit q continue cont c))
|
||
"Quit the inspector."
|
||
(throw 'quit))
|
||
|
||
(define-command ((commands print p))
|
||
"Print the current object using `pretty-print'."
|
||
(pretty-print x))
|
||
|
||
(define-command ((commands write w))
|
||
"Print the current object using `write'."
|
||
(write x))
|
||
|
||
(define-command ((commands display d))
|
||
"Print the current object using `display'."
|
||
(display x))
|
||
|
||
(define-command ((commands disassemble x))
|
||
"Disassemble the current object, which should be a procedure."
|
||
(catch #t
|
||
(lambda ()
|
||
(disassemble-program x))
|
||
(lambda args
|
||
(format #t "Error disassembling object: ~a\n" args))))
|
||
|
||
(define-command ((commands help h ?) #:optional cmd)
|
||
"Show this help message."
|
||
(let ((rhash (reverse-hashq (module-obarray commands))))
|
||
(define (help-cmd cmd)
|
||
(let* ((v (module-local-variable commands cmd))
|
||
(p (variable-ref v))
|
||
(canonical-name (procedure-name p)))
|
||
;; la la la
|
||
(format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
|
||
canonical-name (program-lambda-list p)
|
||
"~#[~:;~40t(aliases: ~@{~a~^, ~})~]"
|
||
(delq canonical-name (hashq-ref rhash v))
|
||
(procedure-documentation p))))
|
||
(cond
|
||
(cmd
|
||
(cond
|
||
((and (symbol? cmd) (module-local-variable commands cmd))
|
||
(help-cmd cmd))
|
||
(else
|
||
(format #t "Invalid command ~s.~%" cmd)
|
||
(format #t "Try `help' for a list of commands~%"))))
|
||
(else
|
||
(let ((names (sort
|
||
(hash-map->list
|
||
(lambda (k v)
|
||
(procedure-name (variable-ref k)))
|
||
rhash)
|
||
(lambda (x y)
|
||
(string<? (symbol->string x)
|
||
(symbol->string y))))))
|
||
(format #t "Available commands:~%~%")
|
||
(for-each help-cmd names))))))
|
||
|
||
(define (handle cmd . args)
|
||
(cond
|
||
((and (symbol? cmd)
|
||
(module-local-variable commands cmd))
|
||
=> (lambda (var)
|
||
(let ((proc (variable-ref var)))
|
||
(catch-bad-arguments
|
||
(lambda ()
|
||
(apply (variable-ref var) args))
|
||
(lambda ()
|
||
(format (current-error-port)
|
||
"Invalid arguments to ~a. Try `help ~a'.~%"
|
||
(procedure-name proc) (procedure-name proc)))))))
|
||
; ((and (integer? cmd) (exact? cmd))
|
||
; (nth cmd))
|
||
((eof-object? cmd)
|
||
(newline)
|
||
(throw 'quit))
|
||
(else
|
||
(format (current-error-port)
|
||
"~&Unknown command: ~a. Try `help'.~%" cmd)
|
||
*unspecified*)))
|
||
|
||
(catch 'quit
|
||
(lambda ()
|
||
(let loop ()
|
||
(apply
|
||
handle
|
||
(save-module-excursion
|
||
(lambda ()
|
||
(set-current-module commands)
|
||
(read-args prompt))))
|
||
(loop)))
|
||
(lambda (k . args)
|
||
(apply values args)))))
|