#lang scheme/base

(require (for-syntax scheme/base))

(provide let-tail-continuation let/tc
         with-continuation-mark*
         trace-begin trace-app)

(define-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))]))