exptime.rkt (3654B)
1 #lang racket 2 3 (require (for-template '#%kernel) 4 racket/syntax 5 racket/struct 6 debug-scopes/superscripts 7 debug-scopes/named-scopes-sli-parameter) 8 9 (provide make-named-scope 10 (rename-out [make-named-scope make-module-like-named-scope]) 11 named-transformer) 12 13 (define (make-named-scope nm) 14 (define name (if (symbol? nm) nm (string->symbol nm))) 15 (define E1 16 (local-expand (datum->syntax #f 17 `(,#'module 18 ,name 19 debug-scopes/named-scopes/dummy-lang 20 '#%kernel 21 list)) 22 'top-level 23 (list))) 24 (define/with-syntax (_module _name _lang (_modbeg (_#%require QK1) Body1)) E1) 25 (define QK (datum->syntax #'QK1 'qk-sym)) 26 (define Body (datum->syntax #'Body1 'body-sym)) 27 (define Zero (datum->syntax #f 'zero)) 28 (define ΔBody (make-syntax-delta-introducer Body Zero)) 29 (define QK-Body (ΔBody QK 'remove)) 30 (define ΔQK-Body (make-syntax-delta-introducer QK-Body Zero)) 31 (define QK-rest (ΔQK-Body QK 'remove)) 32 (define named-scope (make-syntax-delta-introducer QK-rest Zero)) 33 named-scope) 34 35 (define ((has-scope scope) stx) 36 (and (identifier? stx) 37 (bound-identifier=? stx (scope stx 'add)))) 38 39 (define (replace-scope old new) 40 (define (replace e) 41 (cond 42 [(syntax? e) 43 (datum->syntax (if ((has-scope old) e) 44 (new (old e 'remove) 'add) 45 e) 46 (replace (syntax-e e)) 47 e 48 e)] 49 [(pair? e) (cons (replace (car e)) (replace (cdr e)))] 50 [(vector? e) (list->vector (replace (vector->list e)))] 51 [(hash? e) 52 (cond [(hash-eq? e) (make-hasheq (replace (hash->list e)))] 53 [(hash-eqv? e) (make-hasheqv (replace (hash->list e)))] 54 [(hash-equal? e) (make-hash (replace (hash->list e)))] 55 [else e])] 56 [(prefab-struct-key e) 57 => (λ (k) 58 (apply make-prefab-struct k (replace (struct->list e))))] 59 [else e])) 60 replace) 61 62 (define (deep-has-scope sc) 63 (define (scan e) 64 (cond 65 [(syntax? e) (or ((has-scope sc) e) (scan (syntax-e e)))] 66 [(pair? e) (or (scan (car e)) (scan (cdr e)))] 67 [(vector? e) (scan (vector->list e))] 68 [(hash? e) (scan (hash->list e))] 69 [(prefab-struct-key e) (scan (struct->list e))] 70 [else #f])) 71 scan) 72 73 (define (old-macro-scope) 74 (make-syntax-delta-introducer 75 (syntax-local-identifier-as-binding 76 (syntax-local-introduce 77 (datum->syntax #f 'zero))) 78 (datum->syntax #f 'zero))) 79 80 (define (convert-macro-scopes stx) 81 (if (sli-scopes) 82 (let* ([macro (sli-scopes)] 83 [old-macro (old-macro-scope)]) 84 ((replace-scope old-macro macro) stx)) 85 ;; Otherwise leave unchanged. 86 stx)) 87 88 (define ((named-transformer-wrap name f) stx) 89 (parameterize ([sli-scopes (make-named-scope (format "macro: ~a" name))]) 90 ;;; TODO: we should detect the presence of old-* here instead, and 'add them 91 (let ([res (f (convert-macro-scopes stx))]) 92 (when ((deep-has-scope (old-macro-scope)) res) 93 (error (format "original macro scope appeared within the result of a named transformer: ~a\n~a\n~a" 94 res 95 (+scopes res) 96 (with-output-to-string (λ () (print-full-scopes)))))) 97 ((old-macro-scope) ((sli-scopes) res 'flip) 'add)))) 98 99 (define-syntax-rule (named-transformer (name stx) . body) 100 (named-transformer-wrap 'name (λ (stx) . body)))