74 lines
2.2 KiB
Scheme
74 lines
2.2 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)
|
|
|
|
(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))))
|
|
|
|
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
|
|
(define (expand/events sexpr expander)
|
|
(let ([events null])
|
|
(define (add! x)
|
|
(set! events (cons x events)))
|
|
(parameterize ((current-expand-observe
|
|
(let ([c 0])
|
|
(lambda (sig val)
|
|
(set! c (add1 c))
|
|
(add! (cons sig val))))))
|
|
(let ([result
|
|
(with-handlers ([(lambda (exn) #t)
|
|
(lambda (exn)
|
|
(add! (cons 'error exn))
|
|
exn)])
|
|
(expander sexpr))])
|
|
(add! (cons 'EOF #f))
|
|
(values result
|
|
(reverse events))))))
|