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