suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix begin0 processing and add needed recertification

Browse Source 
svn: r3252
This commit is contained in:
Matthew Flatt 2006-06-06 20:17:39 +00:00
parent 58cc9eaf85
commit acc14ecf29
1 changed files with 55 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/trace/stacktrace.ss
View File

@ -42,10 +42,10 @@
(kernel-syntax-case stx #f (kernel-syntax-case stx #f
[(define-values (var ...) expr) [(define-values (var ...) expr)
(let ([var-list (syntax->list #'(var ...))]) (let ([var-list (syntax->list #'(var ...))])
(cond [(= (length var-list) 1) #`(define-values (var ...) #,(expr-iterator #'expr (car var-list)))] (cond [(= (length var-list) 1) #`(define-values (var ...) #,(expr-iterator #'expr (car var-list) (current-code-inspector)))]
[else #`(define-values (var ...) #,(expr-iterator #'expr #f))]))] [else #`(define-values (var ...) #,(expr-iterator #'expr #f (current-code-inspector)))]))]
[(define-syntaxes (var ...) expr) [(define-syntaxes (var ...) expr)
#`(define-syntaxes (var ...) #,(expr-iterator #'expr #f))] #`(define-syntaxes (var ...) #,(expr-iterator #'expr #f (current-code-inspector)))]
[(begin . top-level-exprs) [(begin . top-level-exprs)
#`(begin #,@(map top-level-expr-iterator (syntax->list #'top-level-exprs)))] #`(begin #,@(map top-level-expr-iterator (syntax->list #'top-level-exprs)))]
[(require . require-specs) [(require . require-specs)
@ -53,13 +53,13 @@
[(require-for-syntax . require-specs) [(require-for-syntax . require-specs)
stx] stx]
[else [else
(expr-iterator stx #f)])) (expr-iterator stx #f (current-code-inspector))]))
(define (expr-iterator stx potential-name) (define (expr-iterator stx potential-name insp)
(let* ([name-guess (or (syntax-property stx 'inferred-name) potential-name)] (let* ([name-guess (or (syntax-property stx 'inferred-name) potential-name)]
[recur-tail (lambda (expr) (expr-iterator expr name-guess))] [recur-tail (lambda (expr) (expr-iterator expr name-guess insp))]
[recur-non-tail (lambda (expr) (expr-iterator expr #f))] [recur-non-tail (lambda (expr) (expr-iterator expr #f insp))]
[recur-with-name (lambda (expr name) (expr-iterator expr name))] [recur-with-name (lambda (expr name) (expr-iterator expr name insp))]
[recur-on-sequence (lambda (exprs) [recur-on-sequence (lambda (exprs)
(let loop ([remaining exprs]) (let loop ([remaining exprs])
(cond [(null? remaining) null] (cond [(null? remaining) null]
@ -113,49 +113,53 @@
stx stx
;(syntax-object->datum stx) ;(syntax-object->datum stx)
)]))]) )]))])
(kernel-syntax-case stx #f (syntax-recertify
[var-stx (kernel-syntax-case stx #f
(identifier? (syntax var-stx)) [var-stx
stx] (identifier? (syntax var-stx))
[(lambda . clause) stx]
#`(lambda #,@(lambda-clause-abstraction #'clause))] [(lambda . clause)
[(case-lambda . clauses) #`(lambda #,@(lambda-clause-abstraction #'clause))]
#`(case-lambda #,@(map lambda-clause-abstraction (syntax->list #'clauses)))] [(case-lambda . clauses)
[(if test then) #`(case-lambda #,@(map lambda-clause-abstraction (syntax->list #'clauses)))]
#`(if #,(recur-non-tail #'test) #,(recur-tail #'then))] [(if test then)
[(if test then else) #`(if #,(recur-non-tail #'test) #,(recur-tail #'then))]
#`(if [(if test then else)
#,(recur-non-tail #'test) #`(if
#,(recur-non-tail #'then) #,(recur-non-tail #'test)
#,(recur-non-tail #'else))] #,(recur-non-tail #'then)
[(begin . bodies) #,(recur-non-tail #'else))]
#`(begin #,@(recur-on-sequence (syntax->list #'bodies)))] [(begin . bodies)
[(begin0 . bodies) #`(begin #,@(recur-on-sequence (syntax->list #'bodies)))]
#`(begin #,@(map recur-non-tail #'bodies))] [(begin0 . bodies)
[(let-values . _) #`(begin #,@(map recur-non-tail (syntax->list #'bodies)))]
(let-values-abstraction stx)] [(let-values . _)
[(letrec-values . _) (let-values-abstraction stx)]
(let-values-abstraction stx)] [(letrec-values . _)
[(set! var val) (let-values-abstraction stx)]
#`(set! var #,(recur-with-name #'val #'var))] [(set! var val)
[(quote _) #`(set! var #,(recur-with-name #'val #'var))]
stx] [(quote _)
[(quote-syntax _) stx]
stx] [(quote-syntax _)
[(with-continuation-mark key mark body) stx]
#`(with-continuation-mark [(with-continuation-mark key mark body)
#,(recur-non-tail #'key) #`(with-continuation-mark
#,(recur-non-tail #'mark) #,(recur-non-tail #'key)
#,(recur-tail #'body))] #,(recur-non-tail #'mark)
[(#%app . exprs) #,(recur-tail #'body))]
#`(#%app #,@(map recur-non-tail (syntax->list #'exprs)))] [(#%app . exprs)
[(#%datum . _) #`(#%app #,@(map recur-non-tail (syntax->list #'exprs)))]
stx] [(#%datum . _)
[(#%top . var) stx]
stx] [(#%top . var)
[else stx]
(error 'expr-iterator "unknown expr: ~a" [else
(syntax-object->datum stx))]))) (error 'expr-iterator "unknown expr: ~a"
(syntax-object->datum stx))])
stx
insp
#f)))
(define (arglist-flatten arglist) (define (arglist-flatten arglist)
(let loop ([remaining arglist] (let loop ([remaining arglist]