/usr/share/scheme48-1.9/env/disclosers.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 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; --------------------
; DISCLOSE methods
(define-method &disclose ((obj <closure>))
(let ((id (template-id (closure-template obj)))
(name (template-print-name (closure-template obj))))
(if name
(list 'procedure
id
;; A heuristic that sometimes loses.
; (if (and (pair? name)
; (eq? (car name) '#t) ;Curried
; (vector? (closure-env obj)))
; (error-form
; (if (null? (cdddr name))
; (caddr name)
; (cdddr name))
; (reverse (cdr (vector->list (closure-env obj)))))
; name)
name)
(list 'procedure id))))
(define-method &disclose ((obj <template>))
(let ((id (template-id obj))
(name (template-print-name obj)))
(if name
(list 'template id name)
(list 'template id))))
(define-method &disclose ((obj <location>))
(cons 'location
(cons (location-id obj)
(let ((name (location-name obj)))
(if (and name (not (eq? name (location-id obj))))
(list name (location-package-name obj))
'())))))
(define-method &disclose ((obj <cell>))
(if (cell-unassigned? obj)
(list 'uninitialized-cell)
(list 'cell (cell-ref obj))))
;; this overwrites the method defined in rts/continuation.scm
(define-method &disclose ((obj <continuation>))
(list (if (vm-exception-continuation? obj)
'vm-exception-continuation
'continuation)
(list 'pc (continuation-pc obj))
(let ((tem (continuation-template obj)))
(if tem
(or (template-print-name tem) ; <-- the original method doesn't have this
(template-id tem))
'?))))
(define-method &disclose ((obj <code-vector>))
(cons 'byte-vector
(let ((z (code-vector-length obj)))
(do ((i (- z 1) (- i 1))
(l '() (cons (code-vector-ref obj i) l)))
((< i 0) l))))
)
(define-method &disclose ((obj <channel>))
(let ((status (channel-status obj)))
(list (cond ((= status (enum channel-status-option closed))
'closed-channel)
((or (= status (enum channel-status-option input))
(= status (enum channel-status-option special-input)))
'input-channel)
((or (= status (enum channel-status-option output))
(= status (enum channel-status-option special-output)))
'output-channel)
(else ; shouldn't happen unless we get out of sync
'unknown-channel))
(channel-id obj)
(channel-os-index obj))))
(define-method &disclose ((obj <port>))
(disclose-port obj))
(define (template-print-name tem)
(make-print-name (template-names tem)))
(define (make-print-name names)
(if (null? names)
#f
(let ((name (car names))
(parent-name (make-print-name (cdr names))))
(cond (parent-name
`(,(if name name 'unnamed)
in
,@(if (pair? parent-name) parent-name (list parent-name))))
((string? name) #f) ;File name
(else name)))))
(define (template-file-name tem)
(let loop ((names (template-names tem)))
(if (null? names)
#f
(if (string? (car names))
(car names)
(loop (cdr names))))))
; --------------------
; Location names
(define (location-info loc)
(let ((id (location-id loc)))
(if (integer? id)
(table-ref location-info-table id)
#f)))
(define (location-name loc)
(let ((probe (location-info loc)))
(if probe
(car probe)
#f)))
(define (location-package-name loc)
(let ((probe (location-info loc)))
(if probe
(table-ref package-name-table (cdr probe))
#f)))
; --------------------
; Associating names with templates
(define (template-debug-data tem)
(get-debug-data (template-info tem)))
(define (template-id tem)
(let ((info (template-info tem)))
(if (debug-data? info)
(debug-data-uid info)
info)))
(define (template-name tem)
(let ((probe (template-debug-data tem)))
(if probe
(debug-data-name probe)
'?)))
(define (template-names tem)
(debug-data-names (template-info tem)))
; We can follow parent links to get a full description of procedure
; nesting: "foo in bar in unnamed in baz"
(define (debug-data-names info)
(let ((dd (get-debug-data info)))
(if (debug-data? dd) ;paranoid
(cons (debug-data-name dd)
(debug-data-names (debug-data-parent dd)))
'())))
; --------------------
; Utilities
(define (error-form proc args)
(cons proc (map value->expression args)))
; Print non-self-evaluating value X as 'X.
(define (value->expression obj) ;mumble
(if (or (symbol? obj)
(pair? obj)
(null? obj)
(vector? obj))
`',obj
obj))
|