syntax.rkt (8189B)
1 #lang racket/base 2 (require (only-in "stxloc.rkt" syntax-case) 3 stxparse-info/current-pvars 4 (for-syntax racket/base 5 racket/private/sc 6 auto-syntax-e/utils)) 7 (provide define/with-syntax 8 9 current-recorded-disappeared-uses 10 with-disappeared-uses 11 syntax-local-value/record 12 record-disappeared-uses 13 14 format-symbol 15 format-id 16 17 current-syntax-context 18 wrong-syntax 19 20 generate-temporary 21 internal-definition-context-apply 22 syntax-local-eval 23 with-syntax*) 24 25 ;; == Defining pattern variables == 26 27 (define-syntax (define/with-syntax stx) 28 (syntax-case stx () 29 [(define/with-syntax pattern rhs) 30 (let* ([pvar-env (get-match-vars #'define/with-syntax 31 stx 32 #'pattern 33 '())] 34 [depthmap (for/list ([x pvar-env]) 35 (let loop ([x x] [d 0]) 36 (if (pair? x) 37 (loop (car x) (add1 d)) 38 (cons x d))))] 39 [pvars (map car depthmap)] 40 [depths (map cdr depthmap)] 41 [mark (make-syntax-introducer)]) 42 (with-syntax ([(pvar ...) pvars] 43 [(depth ...) depths] 44 [(valvar ...) (generate-temporaries pvars)]) 45 #'(begin (define-values (valvar ...) 46 (with-syntax ([pattern rhs]) 47 (values (pvar-value pvar) ...))) 48 (define-syntax pvar 49 (make-auto-pvar 'depth (quote-syntax valvar))) 50 ... 51 (define-pvars pvar ...))))])) 52 ;; Ryan: alternative name: define/syntax-pattern ?? 53 54 ;; auxiliary macro 55 (define-syntax (pvar-value stx) 56 (syntax-case stx () 57 [(_ pvar) 58 (identifier? #'pvar) 59 (let ([mapping (syntax-local-value #'pvar)]) 60 (unless (syntax-pattern-variable? mapping) 61 (raise-syntax-error #f "not a pattern variable" #'pvar)) 62 (syntax-mapping-valvar mapping))])) 63 64 65 ;; == Disappeared uses == 66 67 (define current-recorded-disappeared-uses (make-parameter #f)) 68 69 (define-syntax-rule (with-disappeared-uses body-expr ... stx-expr) 70 (let-values ([(stx disappeared-uses) 71 (parameterize ((current-recorded-disappeared-uses null)) 72 (let ([result (let () body-expr ... stx-expr)]) 73 (values result (current-recorded-disappeared-uses))))]) 74 (syntax-property stx 75 'disappeared-use 76 (append (or (syntax-property stx 'disappeared-use) null) 77 disappeared-uses)))) 78 79 (define (syntax-local-value/record id pred) 80 (unless (identifier? id) 81 (raise-argument-error 'syntax-local-value/record 82 "identifier?" 83 0 id pred)) 84 (unless (and (procedure? pred) 85 (procedure-arity-includes? pred 1)) 86 (raise-argument-error 'syntax-local-value/record 87 "(-> any/c boolean?)" 88 1 id pred)) 89 (let ([value (syntax-local-value id (lambda () #f))]) 90 (and (pred value) 91 (begin (record-disappeared-uses (list id)) 92 value)))) 93 94 (define (record-disappeared-uses ids) 95 (cond 96 [(identifier? ids) (record-disappeared-uses (list ids))] 97 [(and (list? ids) (andmap identifier? ids)) 98 (let ([uses (current-recorded-disappeared-uses)]) 99 (when uses 100 (current-recorded-disappeared-uses 101 (append 102 (if (syntax-transforming?) 103 (map syntax-local-introduce ids) 104 ids) 105 uses))))] 106 [else (raise-argument-error 'record-disappeared-uses 107 "(or/c identifier? (listof identifier?))" 108 ids)])) 109 110 111 ;; == Identifier formatting == 112 113 (define (format-id lctx 114 #:source [src #f] 115 #:props [props #f] 116 #:cert [cert #f] 117 fmt . args) 118 (define (convert x) (->atom x 'format-id)) 119 (check-restricted-format-string 'format-id fmt) 120 (let* ([args (map convert args)] 121 [str (apply format fmt args)] 122 [sym (string->symbol str)]) 123 (datum->syntax lctx sym src props cert))) 124 ;; Eli: This looks very *useful*, but I'd like to see it more convenient to 125 ;; "preserve everything". Maybe add a keyword argument that when #t makes 126 ;; all the others use values lctx, and when syntax makes the others use that 127 ;; syntax? 128 ;; Finally, if you get to add this, then another useful utility in the same 129 ;; spirit is one that concatenates symbols and/or strings and/or identifiers 130 ;; into a new identifier. I considered something like that, which expects a 131 ;; single syntax among its inputs, and will use it for the context etc, or 132 ;; throw an error if there's more or less than 1. 133 134 (define (format-symbol fmt . args) 135 (define (convert x) (->atom x 'format-symbol)) 136 (check-restricted-format-string 'format-symbol fmt) 137 (let ([args (map convert args)]) 138 (string->symbol (apply format fmt args)))) 139 140 (define (restricted-format-string? fmt) 141 (regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt)) 142 143 (define (check-restricted-format-string who fmt) 144 (unless (restricted-format-string? fmt) 145 (raise-arguments-error who 146 (format "format string should have ~a placeholders" 147 fmt) 148 "format string" fmt))) 149 150 (define (->atom x err) 151 (cond [(string? x) x] 152 [(symbol? x) x] 153 [(identifier? x) (syntax-e x)] 154 [(keyword? x) (keyword->string x)] 155 [(number? x) x] 156 [(char? x) x] 157 [else (raise-argument-error err 158 "(or/c string? symbol? identifier? keyword? char? number?)" 159 x)])) 160 161 162 ;; == Error reporting == 163 164 (define current-syntax-context 165 (make-parameter #f 166 (lambda (new-value) 167 (unless (or (syntax? new-value) (eq? new-value #f)) 168 (raise-argument-error 'current-syntax-context 169 "(or/c syntax? #f)" 170 new-value)) 171 new-value))) 172 173 (define (wrong-syntax stx #:extra [extras null] format-string . args) 174 (unless (or (eq? stx #f) (syntax? stx)) 175 (raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args))) 176 (let* ([ctx (current-syntax-context)] 177 [blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))]) 178 (raise-syntax-error (if (symbol? blame) blame #f) 179 (apply format format-string args) 180 ctx 181 stx 182 extras))) 183 ;; Eli: The `report-error-as' thing seems arbitrary to me. 184 185 186 ;; == Other utilities == 187 188 ;; generate-temporary : any -> identifier 189 (define (generate-temporary [stx 'g]) 190 (car (generate-temporaries (list stx)))) 191 192 ;; Included for backwards compatibility. 193 (define (internal-definition-context-apply intdefs stx) 194 ; The old implementation of internal-definition-context-apply implicitly converted its stx argument 195 ; to syntax, which some things seem to (possibly unintentionally) rely on, so replicate that 196 ; behavior here: 197 (internal-definition-context-introduce intdefs (datum->syntax #f stx) 'add)) 198 199 (define (syntax-local-eval stx [intdefs '()]) 200 (let* ([name (generate-temporary)] 201 [intdef (syntax-local-make-definition-context)]) 202 (syntax-local-bind-syntaxes (list name) 203 #`(call-with-values (lambda () #,stx) list) 204 intdef 205 intdefs) 206 (apply values 207 (syntax-local-value (internal-definition-context-introduce intdef name) 208 #f intdef)))) 209 210 (define-syntax (with-syntax* stx) 211 (syntax-case stx () 212 [(_ (cl) body ...) #'(with-syntax (cl) body ...)] 213 [(_ (cl cls ...) body ...) 214 #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))