80 lines
2.3 KiB
Scheme
80 lines
2.3 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Compiler state, including flags controlling debug data retention.
|
||
|
|
|
||
|
|
|
||
|
|
; Package and location uids and the location name table should be here
|
||
|
|
; as well...
|
||
|
|
|
||
|
|
; Will the use of a fluid variable significantly degrade performance?
|
||
|
|
|
||
|
|
(define (new-template-uid)
|
||
|
|
(let ((uid *template-uid*))
|
||
|
|
(set! *template-uid* (+ *template-uid* 1))
|
||
|
|
uid))
|
||
|
|
|
||
|
|
(define *template-uid* 5000) ; 1548 in initial system as of 1/22/94
|
||
|
|
|
||
|
|
(define (template-uid) *template-uid*)
|
||
|
|
(define (set-template-uid! uid) (set! *template-uid* uid))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
; These variables really ought to be dynamically scoped, not global.
|
||
|
|
; Fix this some day.
|
||
|
|
|
||
|
|
(define debug-flag-names '(names maps files source tabulate table))
|
||
|
|
|
||
|
|
(define type/debug-flags
|
||
|
|
(make-record-type 'debug-flags debug-flag-names))
|
||
|
|
|
||
|
|
(define make-debug-flags
|
||
|
|
(record-constructor type/debug-flags debug-flag-names))
|
||
|
|
|
||
|
|
(define $debug-flags
|
||
|
|
(make-fluid (make-debug-flags #t ;proc names
|
||
|
|
#f ;env maps
|
||
|
|
#f ;no file names
|
||
|
|
#f ;no cont source
|
||
|
|
#f ;no tabulate
|
||
|
|
(make-table))))
|
||
|
|
|
||
|
|
(define (debug-flag-accessor name)
|
||
|
|
(let ((access (record-accessor type/debug-flags name)))
|
||
|
|
(lambda () (access (fluid $debug-flags)))))
|
||
|
|
|
||
|
|
(define (debug-flag-modifier name)
|
||
|
|
(let ((modify (record-modifier type/debug-flags name)))
|
||
|
|
(lambda (new) (modify (fluid $debug-flags) new))))
|
||
|
|
|
||
|
|
(define keep-source-code? (debug-flag-accessor 'source))
|
||
|
|
(define keep-environment-maps? (debug-flag-accessor 'maps))
|
||
|
|
(define keep-procedure-names? (debug-flag-accessor 'names))
|
||
|
|
(define keep-file-names? (debug-flag-accessor 'files))
|
||
|
|
(define tabulate-debug-data? (debug-flag-accessor 'tabulate))
|
||
|
|
(define debug-data-table (debug-flag-accessor 'table))
|
||
|
|
|
||
|
|
|
||
|
|
; Kludge for static linker.
|
||
|
|
|
||
|
|
(define (with-fresh-compiler-state template-uid-origin thunk)
|
||
|
|
(let-fluid $debug-flags (make-debug-flags #t ;proc names
|
||
|
|
#f ;env maps
|
||
|
|
#f ;no file names
|
||
|
|
#f ;no cont source
|
||
|
|
#t ;tabulate ***
|
||
|
|
(make-table))
|
||
|
|
(lambda ()
|
||
|
|
(saving-and-restoring (lambda () *template-uid*)
|
||
|
|
(lambda (s) (set! *template-uid* s))
|
||
|
|
template-uid-origin
|
||
|
|
thunk))))
|
||
|
|
|
||
|
|
(define (saving-and-restoring fetch store! other thunk)
|
||
|
|
(let ((swap (lambda ()
|
||
|
|
(let ((temp (fetch)))
|
||
|
|
(store! other)
|
||
|
|
(set! other temp)))))
|
||
|
|
(dynamic-wind swap thunk swap)))
|