/usr/share/scheme48-1.9/env/inspect.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; A dirty little inspector.
; Look and feel shamelessly plagiarized from the Lucid Lisp inspector.
; There are three commands for invoking the inspector with different
; initial objects:
; ,inspect -> focus object
; ,inspect <exp> -> value of <exp>
; ,debug -> continuation of stopped thread(s), preferentially
; chooses the thread with the most recent error
; ,threads -> list of current command level's threads
(define-command-syntax 'inspect "[<exp>]" "invoke the inspector"
'(&opt form))
(define-command-syntax 'debug "" "inspect the current continuation" '())
(define-command-syntax 'threads "" "inspect stopped threads" '())
(define (debug)
(new-selection (or (command-continuation)
(command-threads)))
(set-command-results! (list (focus-object)) #f) ; force menu printing
(if (not (value-stack))
(set-value-stack! '())))
(define (threads)
(set-focus-object! (command-threads))
(set-command-results! (focus-object) #f)
(if (not (value-stack))
(set-value-stack! '())))
(define (inspect . maybe-exp)
(if (null? maybe-exp)
(set-command-results! (list (focus-object)) #f) ; force menu printing
(evaluate-and-select (car maybe-exp)
(environment-for-commands)))
(if (not (value-stack))
(set-value-stack! '())))
;----------------
; Menu commands.
(define-command-syntax 'menu "" "print a selection menu for the focus object"
'())
(define menu present-menu)
(define-command-syntax 'm #f #f '())
(define m present-more-menu)
; Leaving.
(define-command-syntax 'q "" "leave inspection mode" '())
(define (q)
(set-command-results! (list (focus-object)) #f)
(set-value-stack! #f))
; Menu selection
(define (select-menu-item . selection-commands)
(execute-selection-commands selection-commands))
(define (execute-selection-commands commands)
(for-each execute-selection-command commands))
(define (new-selection value)
(set-focus-object! value)
(set-command-results! (list value) #f))
(define (execute-selection-command name)
(if (integer? name)
(begin
(if (and (>= name 0)
(< name (current-menu-length)))
(new-selection (current-menu-ref name))
(write-line "Invalid choice." (command-output))))
(case name
((u)
(let ((stack (value-stack)))
(cond ((null? stack)
(write-line "Can't go up from here." (command-output)))
((not stack)
(write-line "No value stack: not in inspection mode."
(command-output)))
(else
(pop-value-stack!)
(set-command-results! (list (focus-object)))))))
((d)
(if (continuation? (focus-object))
(new-selection (continuation-cont (focus-object)))
(write-line "Can't go down from a non-continuation."
(command-output))))
((template)
(let ((template (coerce-to-template (focus-object))))
(if template
(new-selection template)
(write-line
(if (continuation? (focus-object))
"Unable to locate a template in this continuation."
"Not a procedure or a continuation.")
(command-output)))))
(else
(assertion-violation 'execute-selection-command
"bad selection command" name)))))
(define (coerce-to-template obj)
(cond ((template? obj)
obj)
((closure? obj)
(closure-template obj))
((continuation? obj)
(continuation-template obj))
(else
#f)))
(define (selection-command name)
(lambda more-commands
(execute-selection-commands (cons name more-commands))))
(define template (selection-command 'template))
(define u (selection-command 'u))
(define d (selection-command 'd))
(define-command-syntax 'template "" "inspect template" '(&rest selection-command))
(define-command-syntax 'u "" "pop inspector stack" '(&rest selection-command))
(define-command-syntax 'd "" "down stack" '(&rest selection-command))
;----------------
; A command to print out the file in which a procedure is defined.
; Why is this here and not in debug.scm?
(define-command-syntax 'where "[<procedure>]"
"show procedure's source file name"
'(&opt expression))
(define (where . maybe-exp)
(let ((proc (if (null? maybe-exp)
(focus-object)
(eval (car maybe-exp) (environment-for-commands))))
(port (command-output)))
(if (procedure? proc)
(let ((probe (where-defined proc)))
(if probe
(display probe port)
(display "Source file not recorded" port)))
(display "Not a procedure" port))
(newline port)))
(define (where-defined thing)
(let loop ((dd (template-debug-data (closure-template thing))))
(if (debug-data? dd)
(if (string? (debug-data-name dd))
(debug-data-name dd)
(loop (debug-data-parent dd)))
#f)))
|