7c2a7c9ef9
fixed scheme end of lifts issue (needs C fix too) added step limit to help catch nonterminating expansions svn: r15950
88 lines
2.6 KiB
Scheme
88 lines
2.6 KiB
Scheme
|
|
#lang scheme/base
|
|
(require scheme/promise
|
|
parser-tools/lex
|
|
"deriv.ss"
|
|
"deriv-parser.ss"
|
|
"deriv-tokens.ss")
|
|
|
|
(provide trace
|
|
trace*
|
|
trace/result
|
|
trace-verbose?
|
|
events->token-generator
|
|
current-expand-observe
|
|
|
|
trace-macro-limit
|
|
trace-limit-handler)
|
|
|
|
(define current-expand-observe
|
|
(dynamic-require ''#%expobs 'current-expand-observe))
|
|
|
|
(define trace-verbose? (make-parameter #f))
|
|
|
|
;; trace : stx -> Deriv
|
|
(define (trace stx)
|
|
(let-values ([(result events derivp) (trace* stx expand)])
|
|
(force derivp)))
|
|
|
|
;; trace/result : stx -> stx/exn Deriv
|
|
(define (trace/result stx)
|
|
(let-values ([(result events derivp) (trace* stx expand)])
|
|
(values result
|
|
(force derivp))))
|
|
|
|
;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
|
|
(define (trace* stx expander)
|
|
(let-values ([(result events) (expand/events stx expander)])
|
|
(values result
|
|
events
|
|
(delay (parse-derivation
|
|
(events->token-generator events))))))
|
|
|
|
;; events->token-generator : (list-of event) -> (-> token)
|
|
(define (events->token-generator events)
|
|
(let ([pos 0])
|
|
(lambda ()
|
|
(define sig+val (car events))
|
|
(set! events (cdr events))
|
|
(let* ([sig (car sig+val)]
|
|
[val (cdr sig+val)]
|
|
[t (tokenize sig val pos)])
|
|
(when (trace-verbose?)
|
|
(printf "~s: ~s~n" pos
|
|
(token-name (position-token-token t))))
|
|
(set! pos (add1 pos))
|
|
t))))
|
|
|
|
(define trace-macro-limit (make-parameter #f))
|
|
(define trace-limit-handler (make-parameter #f))
|
|
|
|
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
|
|
(define (expand/events sexpr expander)
|
|
(define events null)
|
|
(define counter 0)
|
|
(define (add! x y)
|
|
(set! events (cons (cons x y) events)))
|
|
(define add!/check
|
|
(let ([limit (trace-macro-limit)]
|
|
[handler (trace-limit-handler)])
|
|
(if (and limit handler (exact-positive-integer? limit))
|
|
(lambda (x y)
|
|
(add! x y)
|
|
(when (= x 8) ;; enter-macro
|
|
(set! counter (add1 counter))
|
|
(when (= counter limit)
|
|
(set! limit (handler counter)))))
|
|
add!)))
|
|
(parameterize ((current-expand-observe add!/check))
|
|
(let ([result
|
|
(with-handlers ([(lambda (exn) #t)
|
|
(lambda (exn)
|
|
(add! 'error exn)
|
|
exn)])
|
|
(expander sexpr))])
|
|
(add! 'EOF #f)
|
|
(values result
|
|
(reverse events)))))
|