current-pvars.rkt (14259B)
1 (module current-pvars '#%kernel 2 (#%require version-case 3 (only racket/base version)) 4 5 (#%provide (for-syntax current-pvars 6 current-pvars+unique) 7 with-pvars 8 define-pvars) 9 10 (#%require racket/private/small-scheme 11 (for-syntax '#%kernel 12 racket/private/qq-and-or 13 racket/private/stx)) 14 15 (version-case 16 [(version< (version) "6.90") 17 ;; This is a poor man's syntax parameter. Since the implementation of 18 ;; racket/stxparam depends on syntax-case, and we want to add current-pvars to 19 ;; syntax-case, we cannot use syntax parameters, lest we create a cyclic 20 ;; dependency. Instead, we implement here a simplified "syntax parameter". 21 ; Like racket/stxparam, it relies on nested bindings of the same identifier, 22 ;; and on syntax-local-get-shadower to access the most nested binding. 23 24 ;; Since define/with-syntax and define/syntax-parse need to add new ids to 25 ;; the list, they redefine current-pvars-param, shadowing the outer binding. 26 ;; Unfortunately, if a let form contains two uses of define/with-syntax, this 27 ;; would result in two redefinitions of current-pvars-param, which would cause 28 ;; a "duplicate definition" error. Instead of shadowing the outer bindings, we 29 ;; therefore store the list of bound syntax pattern variables in a new, fresh 30 ;; identifier. When accessing the list, (current-pvars) then checks all such 31 ;; identifiers. The identifiers have the form current-pvars-paramNNN and are 32 ;; numbered sequentially, each new "shadowing" identifier using the number 33 ;; following the latest visible identifier. 34 ;; When it is safe to shadow identifiers (i.e. for with-pvars, but not for 35 ;; define-pvars), current-pvars-index-lower-bound is also shadowed. 36 ;; When current-pvars-index-lower-bound is bound, it contains the index of the 37 ;; latest current-pvars-paramNNN at that point. 38 ;; When accessing the latest current-pvars-paramNNN, a dichotomy search is 39 ;; performed between current-pvars-index-lower-bound and an upper bound 40 ;; computed by trying to access lower-bound + 2ᵏ, with increasing values of k, 41 ;; until an unbound identifier is found. 42 43 ;; (poor-man-parameterof exact-nonnegative-integer?) 44 (define-syntaxes (current-pvars-index-lower-bound) 0) 45 ;; (poor-man-parameterof (listof identifier?)) 46 (define-syntaxes (current-pvars-param0) '()) 47 48 (begin-for-syntax 49 ;; (-> any/c (or/c (listof syntax?) #f)) 50 (define-values (syntax*->list) 51 (λ (stxlist) 52 (syntax->list (datum->syntax #f stxlist)))) 53 54 ;; (-> identifier? (or/c #f (listof identifier?))) 55 (define-values (try-current-pvars) 56 (λ (id) 57 (syntax-local-value 58 (syntax-local-get-shadower id 59 #t) 60 ;; Default value if we are outside of any with-pvars. 61 (λ () #f)))) 62 63 ;; (-> exact-nonnegative-integer? identifier?) 64 (define-values (nth-current-pvars-id) 65 (λ (n) 66 (syntax-local-introduce 67 (datum->syntax (quote-syntax here) 68 (string->symbol 69 (format "current-pvars-param~a" n)))))) 70 71 ;; (-> exact-nonnegative-integer? (or/c #f (listof identifier?))) 72 (define-values (try-nth-current-pvars) 73 (λ (n) 74 (try-current-pvars (nth-current-pvars-id n)))) 75 76 ;; (-> exact-nonnegative-integer? exact-nonnegative-integer? 77 ;; exact-nonnegative-integer?) 78 ;; Doubles the value of n until (+ start n) is not a valid index 79 ;; in the current-pvars-param pseudo-array 80 (define-values (double-max) 81 (λ (start n) 82 (if (try-nth-current-pvars (+ start n)) 83 (double-max start (* n 2)) 84 (+ start n)))) 85 86 87 ;; (-> exact-nonnegative-integer? exact-nonnegative-integer? 88 ;; exact-nonnegative-integer?) 89 ;; Preconditions: upper > lower ∧ upper - lower = 2ᵏ ∧ k ∈ ℕ 90 ;; Returns the last valid index in the current-pvars-param pseudo-array, 91 ;; by dichotomy between 92 (define-values (dichotomy) 93 (λ (lower upper) 94 (if (= (- upper lower) 1) 95 (if (try-nth-current-pvars upper) 96 upper ;; Technically not possible, still included for safety. 97 lower) 98 (let ([mid (/ (+ upper lower) 2)]) 99 (if (try-nth-current-pvars mid) 100 (dichotomy mid upper) 101 (dichotomy lower mid)))))) 102 103 ;; (-> exact-nonnegative-integer?) 104 (define-values (find-last-current-pvars) 105 (λ () 106 (let ([lower-bound (syntax-local-value 107 (syntax-local-get-shadower 108 (syntax-local-introduce 109 (quote-syntax current-pvars-index-lower-bound)) 110 #t))]) 111 (if (not (try-nth-current-pvars (+ lower-bound 1))) 112 ;; Short path for the common case where there are no uses 113 ;; of define/with-syntax or define/syntax-parse in the most nested 114 ;; syntax-case, with-syntax or syntax-parse 115 lower-bound 116 ;; Find an upper bound by repeatedly doubling an offset (starting 117 ;; with 1) from the lower bound, then perform a dichotomy between 118 ;; these two bounds. 119 (dichotomy lower-bound 120 (double-max lower-bound 1)))))) 121 122 ;; (-> (listof identifier?)) 123 (define-values (current-pvars) 124 (λ () 125 (map car (try-nth-current-pvars (find-last-current-pvars))))) 126 127 (define-values (current-pvars+unique) 128 (λ () 129 (try-nth-current-pvars (find-last-current-pvars))))) 130 131 ;; (with-pvars [pvar ...] . body) 132 (define-syntaxes (with-pvars) 133 (lambda (stx) 134 (if (not (and (stx-pair? stx) 135 (identifier? (stx-car stx)) 136 (stx-pair? (stx-cdr stx)) 137 (syntax*->list (stx-car (stx-cdr stx))) 138 (andmap identifier? 139 (syntax*->list (stx-car (stx-cdr stx)))))) 140 (raise-syntax-error 'with-pvars "bad syntax" stx) 141 (void)) 142 (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))] 143 [unique-at-runtime (map gensym (map syntax-e pvars))] 144 [stxquoted-pvars+unique (map (λ (v unique) 145 `(cons (quote-syntax ,v) 146 (quote-syntax ,unique))) 147 pvars 148 unique-at-runtime)] 149 [body (stx-cdr (stx-cdr stx))] 150 [old-pvars-index (find-last-current-pvars)] 151 [old-pvars (try-nth-current-pvars old-pvars-index)] 152 [binding (syntax-local-identifier-as-binding 153 (nth-current-pvars-id (+ old-pvars-index 1)))] 154 [lower-bound-binding 155 (syntax-local-identifier-as-binding 156 (syntax-local-introduce 157 (quote-syntax current-pvars-index-lower-bound)))] 158 [do-unique-at-runtime (map (λ (id pvar) 159 `[(,id) (gensym (quote ,pvar))]) 160 unique-at-runtime 161 pvars)]) 162 (datum->syntax 163 (quote-syntax here) 164 `(let-values (,@do-unique-at-runtime) 165 (letrec-syntaxes+values 166 ([(,binding) (list* ,@stxquoted-pvars+unique 167 (try-nth-current-pvars ,old-pvars-index))] 168 [(,lower-bound-binding) ,(+ old-pvars-index 1)]) 169 () 170 . ,body)))))) 171 172 (define-syntaxes (define-pvars) 173 (lambda (stx) 174 (if (not (and (stx-pair? stx) 175 (identifier? (stx-car stx)) 176 (syntax*->list (stx-cdr stx)) 177 (andmap identifier? 178 (syntax*->list (stx-cdr stx))))) 179 (raise-syntax-error 'define-pvars "bad syntax" stx) 180 (void)) 181 (let* ([pvars (reverse (syntax*->list (stx-cdr stx)))] 182 [unique-at-runtime (map gensym (map syntax-e pvars))] 183 [stxquoted-pvars+unique (map (λ (v unique) 184 `(cons (quote-syntax ,v) 185 (quote-syntax ,unique))) 186 pvars 187 unique-at-runtime)] 188 [old-pvars-index (find-last-current-pvars)] 189 [old-pvars (try-nth-current-pvars old-pvars-index)] 190 [binding (syntax-local-identifier-as-binding 191 (nth-current-pvars-id (+ old-pvars-index 1)))]) 192 (datum->syntax 193 (quote-syntax here) 194 `(begin 195 (define-values (,@unique-at-runtime) 196 (values ,@(map (λ (pvar) `(gensym (quote ,pvar))) pvars))) 197 (define-syntaxes (,binding) 198 (list* ,@stxquoted-pvars+unique 199 (try-nth-current-pvars ,old-pvars-index)))))))) 200 ] 201 [else 202 (begin-for-syntax 203 (define-values (current-pvars-param-guard) 204 (lambda (x) 205 ;; TODO: add condition: elements should be pairs of identifiers? 206 ;; Skip the guard, otherwise each operation is O(n). TODO: use a 207 ;; push/pop API which does the check on the head of the list instead. 208 #;(if (list? x) 209 x 210 (error "current-pvars-param should be a list")) 211 x)) 212 213 (define-values (current-pvars-param) 214 (make-parameter '() current-pvars-param-guard)) 215 216 (define-values (current-pvars) 217 (lambda () 218 (pop-unreachable-pvars) 219 (map car (current-pvars-param)))) 220 221 (define-values (current-pvars+unique) 222 (lambda () 223 (pop-unreachable-pvars) 224 (current-pvars-param))) 225 226 (define-values (syntax*->list) 227 (λ (stxlist) 228 (syntax->list (datum->syntax #f stxlist)))) 229 230 (define-values (pop-unreachable-pvars) 231 (lambda () 232 (if (or (null? (current-pvars-param)) 233 (syntax-local-value (caar (current-pvars-param)) 234 (λ () #f))) 235 (void) 236 (begin 237 (current-pvars-param (cdr (current-pvars-param))) 238 (pop-unreachable-pvars)))))) 239 240 ;; (with-pvars [pvar ...] . body) 241 (define-syntaxes (with-pvars) 242 (lambda (stx) 243 (if (not (and (stx-pair? stx) 244 (identifier? (stx-car stx)) 245 (stx-pair? (stx-cdr stx)) 246 (syntax*->list (stx-car (stx-cdr stx))) 247 (andmap identifier? 248 (syntax*->list (stx-car (stx-cdr stx)))))) 249 (raise-syntax-error 'with-pvars "bad syntax" stx) 250 (void)) 251 (let* ([pvars (syntax*->list (stx-car (stx-cdr stx)))] 252 [body (stx-cdr (stx-cdr stx))]) 253 (datum->syntax 254 (quote-syntax here) 255 `(let-values () 256 (define-pvars ,@pvars) 257 ,@body)))) 258 #;(lambda (stx) 259 (if (not (and (stx-pair? stx) 260 (identifier? (stx-car stx)) 261 (stx-pair? (stx-cdr stx)) 262 (syntax*->list (stx-car (stx-cdr stx))) 263 (andmap identifier? 264 (syntax*->list (stx-car (stx-cdr stx)))))) 265 (raise-syntax-error 'with-pvars "bad syntax" stx) 266 (void)) 267 (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))] 268 [unique-at-runtime (map gensym (map syntax-e pvars))] 269 [pvars+unique (map cons pvars unique-at-runtime)] 270 [body (stx-cdr (stx-cdr stx))] 271 [do-unique-at-runtime (map (λ (id pvar) 272 `[(,id) (gensym (quote ,pvar))]) 273 unique-at-runtime 274 pvars)] 275 [wrapped-body (datum->syntax 276 (quote-syntax here) 277 `(let-values (,@do-unique-at-runtime) 278 ,@body))]) 279 280 (pop-unreachable-pvars) 281 282 (with-continuation-mark 283 parameterization-key 284 (extend-parameterization 285 (continuation-mark-set-first #f parameterization-key) 286 current-pvars-param 287 (append pvars+unique 288 (current-pvars-param))) 289 (let-values ([(stx opaque) 290 (syntax-local-expand-expression wrapped-body #t)]) 291 opaque)) 292 293 ;; above is the manual expansion of: 294 #;(parameterize ([current-pvars-param 295 (list* stxquoted-pvars+unique 296 (current-pvars-param))]) 297 … syntax-local-expand-expression …)))) 298 299 ;; (define-pvars pv1 … pvn) 300 (define-syntaxes (define-pvars) 301 (lambda (stx) 302 (if (not (and (stx-pair? stx) 303 (identifier? (stx-car stx)) 304 (syntax*->list (stx-cdr stx)) 305 (andmap identifier? 306 (syntax*->list (stx-cdr stx))))) 307 (raise-syntax-error 'define-pvars "bad syntax" stx) 308 (void)) 309 (let* ([pvars (reverse (syntax*->list (stx-cdr stx)))] 310 [unique-at-runtime (map gensym (map syntax-e pvars))] 311 [stxquoted-pvars+unique (map (λ (v unique) 312 `(cons (quote-syntax ,v) 313 (quote-syntax ,unique))) 314 pvars 315 unique-at-runtime)]) 316 (datum->syntax 317 (quote-syntax here) 318 `(begin 319 (define-values (,@unique-at-runtime) 320 (values ,@(map (λ (pvar) `(gensym (quote ,pvar))) pvars))) 321 (define-syntaxes () 322 (begin 323 (pop-unreachable-pvars) 324 (current-pvars-param 325 (list* ,@stxquoted-pvars+unique 326 (current-pvars-param))) 327 (values))))))))]))