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

24
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,6 +113,7 @@
stx stx
;(syntax-object->datum stx) ;(syntax-object->datum stx)
)]))]) )]))])
(syntax-recertify
(kernel-syntax-case stx #f (kernel-syntax-case stx #f
[var-stx [var-stx
(identifier? (syntax var-stx)) (identifier? (syntax var-stx))
@ -131,7 +132,7 @@
[(begin . bodies) [(begin . bodies)
#`(begin #,@(recur-on-sequence (syntax->list #'bodies)))] #`(begin #,@(recur-on-sequence (syntax->list #'bodies)))]
[(begin0 . bodies) [(begin0 . bodies)
#`(begin #,@(map recur-non-tail #'bodies))] #`(begin #,@(map recur-non-tail (syntax->list #'bodies)))]
[(let-values . _) [(let-values . _)
(let-values-abstraction stx)] (let-values-abstraction stx)]
[(letrec-values . _) [(letrec-values . _)
@ -155,7 +156,10 @@
stx] stx]
[else [else
(error 'expr-iterator "unknown expr: ~a" (error 'expr-iterator "unknown expr: ~a"
(syntax-object->datum stx))]))) (syntax-object->datum stx))])
stx
insp
#f)))
(define (arglist-flatten arglist) (define (arglist-flatten arglist)
(let loop ([remaining arglist] (let loop ([remaining arglist]