inspect.scm 5.8 KB

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