123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148 |
- (define-record-type frame :frame
- (really-make-frame literals count debug-data template-index env-index closure-index size)
- frame?
- (template-index frame-template-index)
- (env-index frame-env-index)
- (closure-index frame-closure-index)
- (size frame-size set-frame-size!)
- (literals frame-literals set-frame-literals!)
- (count frame-count set-frame-count!)
- (debug-data frame-debug-data))
- (define (make-frame parent name size template? env? closure?)
- (let* ((ddata (new-debug-data (adjust-procedure-name name)
- (if parent
- (frame-debug-data parent)
- #f))))
-
- (define (allocate-index really?)
- (and really?
- (let ((index size))
- (set! size (+ 1 size))
- index)))
- (let* ((closure-index (allocate-index closure?))
- (env-index (allocate-index env?))
- (template-index (allocate-index template?)))
- (really-make-frame '()
- 0
- ddata
- template-index env-index closure-index
- size))))
- (define (adjust-procedure-name name)
- (cond ((string? name)
- (if (keep-file-names?)
- name
- #f))
- ((and (keep-procedure-names?)
- (name? name))
- (name->symbol name))
- (else
- #f)))
- (define (index->offset index depth)
- (- depth (+ index 1)))
- (define (template-offset frame depth)
- (if (frame-template-index frame)
- (index->offset (frame-template-index frame)
- depth)
- #f))
- (define (environment-offset frame depth)
- (index->offset (frame-env-index frame)
- depth))
- (define (depth-check! frame depth)
- (if (< (frame-size frame)
- depth)
- (set-frame-size! frame depth)))
- (define (binding->index frame binding name assigned?)
- (let loop ((i 0) (l (frame-literals frame)))
- (cond ((null? l)
- (really-literal->index frame
- (make-thingie binding name assigned?)
- #f))
- ((and (thingie? (car l))
- (eq? binding (thingie-binding (car l)))
- (eq? name (thingie-name (car l))))
- (if assigned?
- (set-thingie-assigned?! (car l) #t))
- (really-literal->index frame #f i))
- (else
- (loop (+ i 1) (cdr l))))))
- (define (literal->index frame thing)
- (really-literal->index frame thing
- (position thing (frame-literals frame))))
- (define (really-literal->index frame thing probe)
- (let ((count (frame-count frame)))
- (if probe
-
-
-
-
- (+ (- count probe)
- (- template-overhead 1))
- (begin
- (if (>= count two-byte-limit)
- (assertion-violation 'literal->index
- "compiler bug: too many literals"
- thing))
- (set-frame-literals! frame
- (cons thing
- (frame-literals frame)))
- (set-frame-count! frame (+ count 1))
-
- (+ count template-overhead)))))
- (define (position elt list)
- (let loop ((i 0) (l list))
- (cond ((null? l)
- #f)
- ((equal? elt (car l))
- i)
- (else
- (loop (+ i 1) (cdr l))))))
|