#lang scheme/base (require (for-syntax scheme/base)) (provide let-tail-continuation let/tc with-continuation-mark* trace-begin (for-syntax trace-app)) (define-for-syntax (trace-app stx) (syntax-case stx () [(_ e1 es ...) (syntax/loc stx (#%app call-with-values (lambda () (#%app e1 es ...)) values))])) (define-syntax let-tail-continuation (syntax-rules () [(_ k body1 body2 ...) (let ([thunk (let/cc return (let-syntax ([k (syntax-rules () [(k e) (return (lambda () e))])]) (lambda () body1 body2 ...)))]) (thunk))])) (define-syntax let/tc (make-rename-transformer #'let-tail-continuation)) (define-syntax trace-begin (syntax-rules () [(_ e1 e2 ...) (call-with-values (lambda () e1 e2 ...) values)])) (define (with-continuation-mark** key new update thunk) (let ([ccm (continuation-mark-set->list (current-continuation-marks) key)]) (if (null? ccm) (with-continuation-mark key new (thunk)) (let ([original (car ccm)]) (with-continuation-mark key 'dummy (if (= (length ccm) (length (continuation-mark-set->list (current-continuation-marks) key))) (with-continuation-mark key original (with-continuation-mark key (update original) (thunk))) (with-continuation-mark key new (thunk)))))))) (define-syntax with-continuation-mark* (syntax-rules () [(with-continuation-mark* key new update body) (with-continuation-mark** key new update (lambda () body))]))