123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177 |
- ; 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))
|