90 lines
2.5 KiB
Scheme
90 lines
2.5 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Stuff moved from segment.scm 6/5/93
|
||
|
|
|
||
|
|
|
||
|
|
; Debug-data records are for communicating information from the
|
||
|
|
; compiler to various debugging tools.
|
||
|
|
|
||
|
|
; Entries in an environment-maps list have the form
|
||
|
|
; #(parent-uid pc-in-parent (env-map ...))
|
||
|
|
|
||
|
|
(define-record-type debug-data :debug-data
|
||
|
|
(make-debug-data uid name parent pc-in-parent env-maps source)
|
||
|
|
debug-data?
|
||
|
|
(uid debug-data-uid)
|
||
|
|
(name debug-data-name)
|
||
|
|
(parent debug-data-parent)
|
||
|
|
(pc-in-parent debug-data-pc-in-parent)
|
||
|
|
(env-maps debug-data-env-maps set-debug-data-env-maps!)
|
||
|
|
(source debug-data-source set-debug-data-source!))
|
||
|
|
|
||
|
|
(define (new-debug-data name parent pc-in-parent)
|
||
|
|
(make-debug-data (new-template-uid) name parent pc-in-parent '() '()))
|
||
|
|
|
||
|
|
(define-record-discloser :debug-data
|
||
|
|
(lambda (dd)
|
||
|
|
(list 'debug-data (debug-data-uid dd) (debug-data-name dd))))
|
||
|
|
|
||
|
|
|
||
|
|
; "Info" means either a debug data record or an integer index into a
|
||
|
|
; table of same. An "info" is stored in a reserved place in every
|
||
|
|
; template.
|
||
|
|
|
||
|
|
(define (debug-data->info debug-data)
|
||
|
|
(make-immutable! debug-data)
|
||
|
|
(if (interesting-debug-data? debug-data)
|
||
|
|
(if (tabulate-debug-data?)
|
||
|
|
(begin (note-debug-data! debug-data)
|
||
|
|
(debug-data-uid debug-data))
|
||
|
|
debug-data)
|
||
|
|
(debug-data-uid debug-data))) ;+++
|
||
|
|
|
||
|
|
(define (get-debug-data info) ;info->debug-data
|
||
|
|
(cond ((debug-data? info) info)
|
||
|
|
((integer? info)
|
||
|
|
(table-ref (debug-data-table) info))
|
||
|
|
(else #f)))
|
||
|
|
|
||
|
|
(define (note-debug-data! dd)
|
||
|
|
(table-set! (debug-data-table) (debug-data-uid dd) dd))
|
||
|
|
|
||
|
|
(define (interesting-debug-data? debug-data)
|
||
|
|
(and (debug-data? debug-data)
|
||
|
|
(or (debug-data-name debug-data)
|
||
|
|
(interesting-debug-data? (debug-data-parent debug-data))
|
||
|
|
(not (null? (debug-data-env-maps debug-data)))
|
||
|
|
(not (null? (debug-data-source debug-data))))))
|
||
|
|
|
||
|
|
; 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 dd
|
||
|
|
(cons (debug-data-name dd)
|
||
|
|
(debug-data-names (debug-data-parent dd)))
|
||
|
|
'())))
|
||
|
|
|
||
|
|
|
||
|
|
; 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)
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(define (template-names tem)
|
||
|
|
(debug-data-names (template-info tem)))
|