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