with-stx.rkt (4134B)
1 ;;---------------------------------------------------------------------- 2 ;; with-syntax, generate-temporaries 3 4 (module with-stx '#%kernel 5 (#%require racket/private/stx racket/private/define-et-al racket/private/qq-and-or racket/private/cond "stxcase.rkt" 6 (for-syntax '#%kernel "stxcase.rkt" "stxloc.rkt" 7 racket/private/gen-temp racket/private/sc racket/private/qq-and-or racket/private/cond)) 8 9 (-define (with-syntax-fail stx) 10 (raise-syntax-error 11 'with-syntax 12 "binding match failed" 13 stx)) 14 15 (-define (with-datum-fail stx) 16 (raise-syntax-error 17 'with-datum 18 "binding match failed" 19 stx)) 20 21 ;; Partly from Dybvig 22 (begin-for-syntax 23 (define-values (gen-with-syntax) 24 (let ([here-stx (quote-syntax here)]) 25 (lambda (x s-exp?) 26 (syntax-case x () 27 ((_ () e1 e2 ...) 28 (syntax/loc x (let () e1 e2 ...))) 29 ((_ ((out in) ...) e1 e2 ...) 30 (let ([ins (syntax->list (syntax (in ...)))]) 31 ;; Check for duplicates or other syntax errors: 32 (get-match-vars (syntax _) x (syntax (out ...)) null) 33 ;; Generate temps and contexts: 34 (let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)] 35 [heres (map (lambda (x) 36 (datum->syntax 37 x 38 'here 39 x)) 40 ins)] 41 [outs (syntax->list (syntax (out ...)))]) 42 ;; Let-bind RHSs, then build up nested syntax-cases: 43 (datum->syntax 44 here-stx 45 `(let ,(map (lambda (tmp here in) 46 `[,tmp ,(if s-exp? 47 in 48 `(datum->syntax 49 (quote-syntax ,here) 50 ,in))]) 51 tmps heres ins) 52 ,(let loop ([tmps tmps][outs outs]) 53 (cond 54 [(null? tmps) 55 (syntax (begin e1 e2 ...))] 56 [else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp? 57 [,(car outs) ,(loop (cdr tmps) 58 (cdr outs))] 59 [_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail) 60 ;; Minimize the syntax structure we keep: 61 (quote-syntax ,(datum->syntax 62 #f 63 (syntax->datum (car outs)) 64 (car outs))))])]))) 65 x))))))))) 66 67 (-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f))) 68 (-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t))) 69 70 (-define counter 0) 71 (-define (append-number s) 72 (set! counter (add1 counter)) 73 (string->symbol (format "~a~s" s counter))) 74 75 (-define (generate-temporaries sl) 76 (unless (stx-list? sl) 77 (raise-argument-error 78 'generate-temporaries 79 "(or/c list? syntax->list)" 80 sl)) 81 (let ([l (stx->list sl)]) 82 (map (lambda (x) 83 ((make-syntax-introducer) 84 (cond 85 [(symbol? x) 86 (datum->syntax #f (append-number x))] 87 [(string? x) 88 (datum->syntax #f (append-number x))] 89 [(keyword? x) 90 (datum->syntax #f (append-number (keyword->string x)))] 91 [(identifier? x) 92 (datum->syntax #f (append-number (syntax-e x)))] 93 [(and (syntax? x) (keyword? (syntax-e x))) 94 (datum->syntax #f (append-number (keyword->string (syntax-e x))))] 95 [else 96 (datum->syntax #f (append-number 'temp))]))) 97 l))) 98 99 (#%provide with-syntax with-datum generate-temporaries))