stxcase-scheme.rkt (2945B)
1 2 ;;---------------------------------------------------------------------- 3 ;; #%stxcase-scheme: adds let-syntax, syntax-rules, and 4 ;; check-duplicate-identifier, and assembles everything we have so far 5 6 (module stxcase-scheme '#%kernel 7 (#%require racket/private/small-scheme racket/private/stx "stxcase.rkt" 8 "with-stx.rkt" (all-except racket/private/stxloc syntax/loc) 9 (for-syntax '#%kernel racket/private/small-scheme 10 racket/private/stx "stxcase.rkt" 11 (all-except racket/private/stxloc syntax/loc))) 12 13 (-define (check-duplicate-identifier names) 14 (unless (and (list? names) (andmap identifier? names)) 15 (raise-argument-error 'check-duplicate-identifier "(listof identifier?)" names)) 16 (let/ec escape 17 (let ([ht (make-hasheq)]) 18 (for-each 19 (lambda (defined-name) 20 (unless (identifier? defined-name) 21 (raise-argument-error 'check-duplicate-identifier 22 "(listof identifier?)" names)) 23 (let ([l (hash-ref ht (syntax-e defined-name) null)]) 24 (when (ormap (lambda (i) (bound-identifier=? i defined-name)) l) 25 (escape defined-name)) 26 (hash-set! ht (syntax-e defined-name) (cons defined-name l)))) 27 names) 28 #f))) 29 30 (begin-for-syntax 31 (define-values (check-sr-rules) 32 (lambda (stx kws) 33 (for-each (lambda (id) 34 (unless (identifier? id) 35 (raise-syntax-error 36 #f 37 "pattern must start with an identifier, found something else" 38 stx 39 id))) 40 (syntax->list kws))))) 41 42 ;; From Dybvig, mostly: 43 (-define-syntax syntax-rules 44 (lambda (stx) 45 (syntax-case** syntax-rules #t stx () free-identifier=? #f 46 ((sr (k ...) ((keyword . pattern) template) ...) 47 (andmap identifier? (syntax->list (syntax (k ...)))) 48 (begin 49 (check-sr-rules stx (syntax (keyword ...))) 50 (syntax/loc stx 51 (lambda (x) 52 (syntax-case** sr #t x (k ...) free-identifier=? #f 53 ((_ . pattern) (syntax-protect (syntax/loc x template))) 54 ...)))))))) 55 56 (-define-syntax syntax-id-rules 57 (lambda (x) 58 (syntax-case** syntax-id-rules #t x () free-identifier=? #f 59 ((sidr (k ...) (pattern template) ...) 60 (andmap identifier? (syntax->list (syntax (k ...)))) 61 (syntax/loc x 62 (make-set!-transformer 63 (lambda (x) 64 (syntax-case** sidr #t x (k ...) free-identifier=? #f 65 (pattern (syntax-protect (syntax/loc x template))) 66 ...)))))))) 67 68 (-define (syntax-protect stx) 69 (if (syntax? stx) 70 (syntax-arm stx #f #t) 71 (raise-argument-error 'syntax-protect "syntax?" stx))) 72 73 (#%provide syntax datum (all-from "with-stx.rkt") 74 (all-from racket/private/stxloc) 75 check-duplicate-identifier syntax-protect 76 syntax-rules syntax-id-rules 77 (for-syntax syntax-pattern-variable?)))