added scheme/base import and re-tabified
svn: r14029
This commit is contained in:
Robby Findler
parent
6fe0677aa7
commit
b7c0a22430
|
|
@ -1,178 +1,177 @@
|
|||
#lang scheme/base
|
||||
(require mzlib/unit
|
||||
syntax/kerncase
|
||||
syntax/stx
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(module stacktrace scheme/base
|
||||
(require mzlib/unit
|
||||
syntax/kerncase
|
||||
syntax/stx)
|
||||
(provide stacktrace@ stacktrace^ stacktrace-imports^)
|
||||
|
||||
(define-signature stacktrace-imports^ (calltrace-key print-call-trace))
|
||||
(define-signature stacktrace^ (annotate))
|
||||
|
||||
(define o (current-output-port))
|
||||
(define (oprintf . args) (apply fprintf o args))
|
||||
|
||||
(define-struct stx-protector (stx))
|
||||
|
||||
(define-unit stacktrace@
|
||||
(import stacktrace-imports^)
|
||||
(export stacktrace^)
|
||||
|
||||
(provide stacktrace@ stacktrace^ stacktrace-imports^)
|
||||
;; TEMPLATE FUNCTIONS:
|
||||
;; these functions' definitions follow the data definitions presented in the Syntax
|
||||
;; chapter of the MzScheme Manual.
|
||||
|
||||
(define-signature stacktrace-imports^ (calltrace-key print-call-trace))
|
||||
(define-signature stacktrace^ (annotate))
|
||||
(define (top-level-expr-iterator stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||
#`(module identifier name
|
||||
(#%plain-module-begin
|
||||
#,@(map module-level-expr-iterator (syntax->list #'module-level-exprs))))]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx)]))
|
||||
|
||||
(define o (current-output-port))
|
||||
(define (oprintf . args) (apply fprintf o args))
|
||||
(define (module-level-expr-iterator stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(#%provide . provide-specs)
|
||||
stx]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx)]))
|
||||
|
||||
(define-struct stx-protector (stx))
|
||||
(define (general-top-level-expr-iterator stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(define-values (var ...) expr)
|
||||
(let ([var-list (syntax->list #'(var ...))])
|
||||
(cond [(= (length var-list) 1) #`(define-values (var ...)
|
||||
#,(expr-iterator #'expr
|
||||
(car var-list)
|
||||
(current-code-inspector)
|
||||
#f))]
|
||||
[else #`(define-values (var ...) #,(expr-iterator #'expr #f (current-code-inspector) #f))]))]
|
||||
[(define-syntaxes (var ...) expr)
|
||||
#`(define-syntaxes (var ...) #,(expr-iterator #'expr #f (current-code-inspector) #t))]
|
||||
[(begin . top-level-exprs)
|
||||
#`(begin #,@(map top-level-expr-iterator (syntax->list #'top-level-exprs)))]
|
||||
[(#%require . require-specs)
|
||||
stx]
|
||||
[else
|
||||
(expr-iterator stx #f (current-code-inspector) #f)]))
|
||||
|
||||
(define-unit stacktrace@
|
||||
(import stacktrace-imports^)
|
||||
(export stacktrace^)
|
||||
|
||||
;; TEMPLATE FUNCTIONS:
|
||||
;; these functions' definitions follow the data definitions presented in the Syntax
|
||||
;; chapter of the MzScheme Manual.
|
||||
|
||||
(define (top-level-expr-iterator stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(module identifier name (#%plain-module-begin . module-level-exprs))
|
||||
#`(module identifier name
|
||||
(#%plain-module-begin
|
||||
#,@(map module-level-expr-iterator (syntax->list #'module-level-exprs))))]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx)]))
|
||||
|
||||
(define (module-level-expr-iterator stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(#%provide . provide-specs)
|
||||
stx]
|
||||
[else-stx
|
||||
(general-top-level-expr-iterator stx)]))
|
||||
|
||||
(define (general-top-level-expr-iterator stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(define-values (var ...) expr)
|
||||
(let ([var-list (syntax->list #'(var ...))])
|
||||
(cond [(= (length var-list) 1) #`(define-values (var ...)
|
||||
#,(expr-iterator #'expr
|
||||
(car var-list)
|
||||
(current-code-inspector)
|
||||
#f))]
|
||||
[else #`(define-values (var ...) #,(expr-iterator #'expr #f (current-code-inspector) #f))]))]
|
||||
[(define-syntaxes (var ...) expr)
|
||||
#`(define-syntaxes (var ...) #,(expr-iterator #'expr #f (current-code-inspector) #t))]
|
||||
[(begin . top-level-exprs)
|
||||
#`(begin #,@(map top-level-expr-iterator (syntax->list #'top-level-exprs)))]
|
||||
[(#%require . require-specs)
|
||||
stx]
|
||||
[else
|
||||
(expr-iterator stx #f (current-code-inspector) #f)]))
|
||||
(define (expr-iterator stx potential-name insp trans?-expr)
|
||||
(let* ([name-guess (or (syntax-property stx 'inferred-name) potential-name)]
|
||||
[recur-tail (lambda (expr) (expr-iterator expr name-guess insp trans?-expr))]
|
||||
[recur-non-tail (lambda (expr) (expr-iterator expr #f insp trans?-expr))]
|
||||
[recur-with-name (lambda (expr name) (expr-iterator expr name insp trans?-expr))]
|
||||
[recur-on-sequence (lambda (exprs)
|
||||
(let loop ([remaining exprs])
|
||||
(cond [(null? remaining) null]
|
||||
[(null? (cdr remaining)) (list (recur-tail (car remaining)))]
|
||||
[else (cons (recur-non-tail (car remaining))
|
||||
(loop (cdr remaining)))])))]
|
||||
[lambda-clause-abstraction
|
||||
(lambda (clause)
|
||||
(kernel-syntax-case clause #f
|
||||
[(arglist . bodies)
|
||||
(let-values ([(arglist-proper improper?) (arglist-flatten #'arglist)])
|
||||
(if name-guess
|
||||
#`(arglist (with-continuation-mark
|
||||
#,calltrace-key
|
||||
'unimportant
|
||||
(begin (let ([call-depth (length (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
#,calltrace-key))])
|
||||
(#,print-call-trace
|
||||
(quote-syntax #,name-guess)
|
||||
#,(syntax-original? name-guess)
|
||||
(#,stx-protector-stx #,(make-stx-protector stx))
|
||||
(list #,@arglist-proper)
|
||||
#,improper?
|
||||
call-depth))
|
||||
#,@(recur-on-sequence (syntax->list #'bodies)))))
|
||||
#`(arglist #,@(recur-on-sequence (syntax->list #'bodies)))))]
|
||||
[else
|
||||
(error 'expr-syntax-iterator
|
||||
"unexpected (case-)lambda clause: ~a"
|
||||
(syntax->datum stx))]))]
|
||||
[let-values-abstraction
|
||||
(lambda (stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(kwd (((variable ...) rhs) ...) . bodies)
|
||||
(let* ([clause-fn
|
||||
(lambda (vars rhs)
|
||||
(let ([var-list (syntax->list vars)])
|
||||
(cond [(= (length var-list) 1)
|
||||
#`(#,vars #,(recur-with-name rhs (car var-list)))]
|
||||
[else
|
||||
#`(#,vars #,(recur-non-tail rhs))])))])
|
||||
(with-syntax ([(new-clause ...)
|
||||
(map clause-fn
|
||||
(syntax->list #`((variable ...) ...))
|
||||
(syntax->list #`(rhs ...)))])
|
||||
#`(kwd (new-clause ...) #,@(recur-on-sequence (syntax->list #'bodies)))))]
|
||||
[else
|
||||
(error 'expr-syntax-iterator
|
||||
"unexpected let(rec) expression: ~a"
|
||||
stx
|
||||
;(syntax->datum stx)
|
||||
)]))])
|
||||
(syntax-recertify
|
||||
(kernel-syntax-case stx trans?-expr
|
||||
[var-stx
|
||||
(identifier? (syntax var-stx))
|
||||
stx]
|
||||
[(#%plain-lambda . clause)
|
||||
#`(#%plain-lambda #,@(lambda-clause-abstraction #'clause))]
|
||||
[(case-lambda . clauses)
|
||||
#`(case-lambda #,@(map lambda-clause-abstraction (syntax->list #'clauses)))]
|
||||
[(if test then else)
|
||||
#`(if
|
||||
#,(recur-non-tail #'test)
|
||||
#,(recur-non-tail #'then)
|
||||
#,(recur-non-tail #'else))]
|
||||
[(begin . bodies)
|
||||
#`(begin #,@(recur-on-sequence (syntax->list #'bodies)))]
|
||||
[(begin0 . bodies)
|
||||
#`(begin #,@(map recur-non-tail (syntax->list #'bodies)))]
|
||||
[(let-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(letrec-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(set! var val)
|
||||
#`(set! var #,(recur-with-name #'val #'var))]
|
||||
[(quote _)
|
||||
stx]
|
||||
[(quote-syntax _)
|
||||
stx]
|
||||
[(with-continuation-mark key mark body)
|
||||
#`(with-continuation-mark
|
||||
#,(recur-non-tail #'key)
|
||||
#,(recur-non-tail #'mark)
|
||||
#,(recur-tail #'body))]
|
||||
[(#%plain-app . exprs)
|
||||
#`(#%plain-app #,@(map recur-non-tail (syntax->list #'exprs)))]
|
||||
[(#%top . var)
|
||||
stx]
|
||||
[else
|
||||
(error 'expr-iterator "unknown expression (phase ~s): ~s ~s"
|
||||
trans?-expr
|
||||
stx
|
||||
(syntax->datum stx))])
|
||||
stx
|
||||
insp
|
||||
#f)))
|
||||
|
||||
(define (expr-iterator stx potential-name insp trans?-expr)
|
||||
(let* ([name-guess (or (syntax-property stx 'inferred-name) potential-name)]
|
||||
[recur-tail (lambda (expr) (expr-iterator expr name-guess insp trans?-expr))]
|
||||
[recur-non-tail (lambda (expr) (expr-iterator expr #f insp trans?-expr))]
|
||||
[recur-with-name (lambda (expr name) (expr-iterator expr name insp trans?-expr))]
|
||||
[recur-on-sequence (lambda (exprs)
|
||||
(let loop ([remaining exprs])
|
||||
(cond [(null? remaining) null]
|
||||
[(null? (cdr remaining)) (list (recur-tail (car remaining)))]
|
||||
[else (cons (recur-non-tail (car remaining))
|
||||
(loop (cdr remaining)))])))]
|
||||
[lambda-clause-abstraction
|
||||
(lambda (clause)
|
||||
(kernel-syntax-case clause #f
|
||||
[(arglist . bodies)
|
||||
(let-values ([(arglist-proper improper?) (arglist-flatten #'arglist)])
|
||||
(if name-guess
|
||||
#`(arglist (with-continuation-mark
|
||||
#,calltrace-key
|
||||
'unimportant
|
||||
(begin (let ([call-depth (length (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
#,calltrace-key))])
|
||||
(#,print-call-trace
|
||||
(quote-syntax #,name-guess)
|
||||
#,(syntax-original? name-guess)
|
||||
(#,stx-protector-stx #,(make-stx-protector stx))
|
||||
(list #,@arglist-proper)
|
||||
#,improper?
|
||||
call-depth))
|
||||
#,@(recur-on-sequence (syntax->list #'bodies)))))
|
||||
#`(arglist #,@(recur-on-sequence (syntax->list #'bodies)))))]
|
||||
[else
|
||||
(error 'expr-syntax-iterator
|
||||
"unexpected (case-)lambda clause: ~a"
|
||||
(syntax->datum stx))]))]
|
||||
[let-values-abstraction
|
||||
(lambda (stx)
|
||||
(kernel-syntax-case stx #f
|
||||
[(kwd (((variable ...) rhs) ...) . bodies)
|
||||
(let* ([clause-fn
|
||||
(lambda (vars rhs)
|
||||
(let ([var-list (syntax->list vars)])
|
||||
(cond [(= (length var-list) 1)
|
||||
#`(#,vars #,(recur-with-name rhs (car var-list)))]
|
||||
[else
|
||||
#`(#,vars #,(recur-non-tail rhs))])))])
|
||||
(with-syntax ([(new-clause ...)
|
||||
(map clause-fn
|
||||
(syntax->list #`((variable ...) ...))
|
||||
(syntax->list #`(rhs ...)))])
|
||||
#`(kwd (new-clause ...) #,@(recur-on-sequence (syntax->list #'bodies)))))]
|
||||
[else
|
||||
(error 'expr-syntax-iterator
|
||||
"unexpected let(rec) expression: ~a"
|
||||
stx
|
||||
;(syntax->datum stx)
|
||||
)]))])
|
||||
(syntax-recertify
|
||||
(kernel-syntax-case stx trans?-expr
|
||||
[var-stx
|
||||
(identifier? (syntax var-stx))
|
||||
stx]
|
||||
[(#%plain-lambda . clause)
|
||||
#`(#%plain-lambda #,@(lambda-clause-abstraction #'clause))]
|
||||
[(case-lambda . clauses)
|
||||
#`(case-lambda #,@(map lambda-clause-abstraction (syntax->list #'clauses)))]
|
||||
[(if test then else)
|
||||
#`(if
|
||||
#,(recur-non-tail #'test)
|
||||
#,(recur-non-tail #'then)
|
||||
#,(recur-non-tail #'else))]
|
||||
[(begin . bodies)
|
||||
#`(begin #,@(recur-on-sequence (syntax->list #'bodies)))]
|
||||
[(begin0 . bodies)
|
||||
#`(begin #,@(map recur-non-tail (syntax->list #'bodies)))]
|
||||
[(let-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(letrec-values . _)
|
||||
(let-values-abstraction stx)]
|
||||
[(set! var val)
|
||||
#`(set! var #,(recur-with-name #'val #'var))]
|
||||
[(quote _)
|
||||
stx]
|
||||
[(quote-syntax _)
|
||||
stx]
|
||||
[(with-continuation-mark key mark body)
|
||||
#`(with-continuation-mark
|
||||
#,(recur-non-tail #'key)
|
||||
#,(recur-non-tail #'mark)
|
||||
#,(recur-tail #'body))]
|
||||
[(#%plain-app . exprs)
|
||||
#`(#%plain-app #,@(map recur-non-tail (syntax->list #'exprs)))]
|
||||
[(#%top . var)
|
||||
stx]
|
||||
[else
|
||||
(if trans?-expr
|
||||
stx
|
||||
(error 'expr-iterator "unknown expression: ~s ~s"
|
||||
stx
|
||||
(syntax->datum stx)))])
|
||||
stx
|
||||
insp
|
||||
#f)))
|
||||
|
||||
(define (arglist-flatten arglist)
|
||||
(let loop ([remaining arglist]
|
||||
[so-far null])
|
||||
(syntax-case remaining ()
|
||||
[()
|
||||
(values (reverse so-far) #f)]
|
||||
[var
|
||||
(identifier? (syntax var))
|
||||
(values (reverse (cons #'var so-far)) #t)]
|
||||
[(var . rest)
|
||||
(loop #'rest (cons #'var so-far))])))
|
||||
|
||||
|
||||
(define (annotate x) (top-level-expr-iterator x))))
|
||||
(define (arglist-flatten arglist)
|
||||
(let loop ([remaining arglist]
|
||||
[so-far null])
|
||||
(syntax-case remaining ()
|
||||
[()
|
||||
(values (reverse so-far) #f)]
|
||||
[var
|
||||
(identifier? (syntax var))
|
||||
(values (reverse (cons #'var so-far)) #t)]
|
||||
[(var . rest)
|
||||
(loop #'rest (cons #'var so-far))])))
|
||||
|
||||
|
||||
(define (annotate x) (top-level-expr-iterator x)))
|
||||
Loading…
Reference in New Issue
Block a user