txlift.rkt (1247B)
1 #lang racket/base 2 (require (for-template racket/base)) 3 (provide txlift 4 get-txlifts-as-definitions 5 with-txlifts 6 call/txlifts) 7 8 ;; Like lifting definitions, but within a single transformer. 9 10 ;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] 11 (define current-liftbox (make-parameter #f)) 12 13 (define (call/txlifts proc) 14 (parameterize ((current-liftbox (box null))) 15 (proc))) 16 17 (define (txlift expr) 18 (let ([liftbox (current-liftbox)]) 19 (check 'txlift liftbox) 20 (let ([var (car (generate-temporaries '(txlift)))]) 21 (set-box! liftbox (cons (list var expr) (unbox liftbox))) 22 var))) 23 24 (define (get-txlifts) 25 (let ([liftbox (current-liftbox)]) 26 (check 'get-txlifts liftbox) 27 (reverse (unbox liftbox)))) 28 29 (define (get-txlifts-as-definitions) 30 (let ([liftbox (current-liftbox)]) 31 (check 'get-txlifts-as-definitions liftbox) 32 (map (lambda (p) 33 #`(define #,@p)) 34 (reverse (unbox liftbox))))) 35 36 (define (check who lb) 37 (unless (box? lb) 38 (error who "not in a txlift-catching context"))) 39 40 (define (with-txlifts proc) 41 (call/txlifts 42 (lambda () 43 (let ([v (proc)]) 44 (with-syntax ([((var rhs) ...) (get-txlifts)]) 45 #`(let* ([var rhs] ...) #,v))))))