From b7c0a224306772336598f83d9c41da92f5852e56 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 10 Mar 2009 16:43:44 +0000 Subject: [PATCH] added scheme/base import and re-tabified svn: r14029 --- collects/trace/stacktrace.ss | 341 +++++++++++++++++------------------ 1 file changed, 170 insertions(+), 171 deletions(-) diff --git a/collects/trace/stacktrace.ss b/collects/trace/stacktrace.ss index 931e8e0513..d721cf790c 100644 --- a/collects/trace/stacktrace.ss +++ b/collects/trace/stacktrace.ss @@ -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))) \ No newline at end of file