ddd.rkt (17822B)
1 #lang racket 2 3 ;; Implementation of the (ddd e) macro, which iterates e over the syntax pattern 4 ;; variables present in e. e should contain at least one syntax pattern variable 5 ;; which is under ellipses. 6 7 (provide ddd ?? ?if ?cond ?attr ?@ ?@@ 8 splicing-list splicing-list-l splicing-list?) 9 10 (require stxparse-info/current-pvars 11 phc-toolkit/untyped 12 subtemplate/private/copy-attribute 13 version-case 14 racket/stxparam 15 "lifted-variables-communication.rkt" 16 (for-syntax "optcontract.rkt" 17 racket/syntax 18 phc-toolkit/untyped 19 racket/function 20 racket/struct 21 racket/list 22 syntax/id-set 23 racket/private/sc 24 scope-operations 25 racket/string)) 26 27 (version-case 28 [(version< (version) "6.90.0.24") 29 (require (prefix-in - syntax/parse/private/residual))] 30 [else 31 (require (prefix-in - racket/private/template))]) 32 33 (define-for-syntax x-pvar-scope (make-syntax-introducer)) 34 (define-for-syntax x-pvar-present-marker (make-syntax-introducer)) 35 36 (begin-for-syntax 37 (define/contract (attribute-real-valvar attr) 38 (-> identifier? (or/c #f identifier?)) 39 (define valvar 40 (let ([slv (syntax-local-value attr (λ () #f))]) 41 (if (syntax-pattern-variable? slv) 42 (let* ([valvar (syntax-mapping-valvar slv)] 43 [valvar-slv (syntax-local-value valvar (λ () #f))]) 44 (if (-attribute-mapping? valvar-slv) 45 (-attribute-mapping-var valvar-slv) 46 valvar)) 47 (raise-syntax-error 48 'attribute* 49 "not bound as an attribute or pattern variable" 50 attr)))) 51 (if (syntax-local-value valvar (λ () #f)) ;; is it a macro-ish thing? 52 (begin 53 (log-warning 54 (string-append "Could not extract the plain variable corresponding" 55 " to the pattern variable or attribute ~a" 56 (syntax-e attr))) 57 #f) 58 valvar))) 59 60 ;; free-identifier=? seems to stop working on the valvars once we are outside of 61 ;; the local-expand containing the let which introduced these valvars, therefore 62 ;; we find which pvars were present within that let. 63 (define-syntax/case (detect-present-pvars (pvar …) body) () 64 (define/with-syntax (pvar-real-valvar …) 65 (map syntax-local-introduce 66 (stx-map attribute-real-valvar #'(pvar …)))) 67 68 (define/with-syntax expanded-body 69 (local-expand #`(let-values () 70 (quote-syntax #,(stx-map x-pvar-scope 71 #'(pvar-real-valvar …)) 72 #:local) 73 body) 74 'expression 75 '())) 76 77 ;; Separate the valvars marked with x-pvar-scope, so that we know which valvar 78 ;; to look for. 79 (define-values (marked-real-valvar expanded-ids) 80 (partition (λ (id) (all-scopes-in? x-pvar-scope id)) 81 (extract-ids #'expanded-body))) 82 (define/with-syntax (real-valvar …) 83 (map (λ (x-vv) (x-pvar-scope x-vv 'remove)) 84 marked-real-valvar)) 85 (define expanded-ids-set (immutable-free-id-set expanded-ids)) 86 87 ;; grep for valvars in expanded-body 88 (define/with-syntax present-variables 89 (for/vector ([x-vv (in-syntax #'(real-valvar …))] 90 [pv (in-syntax #'(pvar …))]) ;; TODO: is this line used (I suspect both lists have the same length)? 91 (if (free-id-set-member? expanded-ids-set x-vv) 92 #t 93 #f))) 94 95 #`(let-values () 96 (quote-syntax #,(x-pvar-present-marker #'present-variables)) 97 ;; was "body", instead of "expanded-body". I think that was just a remnant 98 ;; of a debugging session, so I changed it to "expanded-body". 99 expanded-body)) 100 101 (define (=* . vs) 102 (if (< (length vs) 2) 103 #t 104 (apply = vs))) 105 106 ;; map, with extra checks for missing elements (i.e. when one of the l* lists 107 ;; is #f). If allow-missing? is specified, each #f list is replaced by 108 ;; a stream of #f values. If all l* lists are #f, then there is no way to know 109 ;; the number of iterations to make, so #f is returned (indicating that the 110 ;; whole sequence is missing, instead of being merely empty. 111 (define (map#f* allow-missing? f attr-ids l*) 112 (if allow-missing? 113 (let () 114 (define non-#f-l* (filter identity l*)) 115 (unless (apply =* (map length non-#f-l*)) 116 (raise-syntax-error 'ddd 117 "incompatible ellipis counts for template")) 118 (if (= (length non-#f-l*) 0) 119 ;; If all lists are missing (#f), return a single #f value, indicating 120 ;; that there are no elements to create the result list from. 121 #f 122 ;; Or should we use this? 123 ;(apply f (map (const #f) l*)) 124 ;; i.e. just call the function once with every variable bound to #f, 125 ;; i.e. missing. 126 127 ;; replace the missing (#f) lists with a list of N #f values, where N 128 ;; is the length of the other lists. 129 (let* ([repeated-#f (map (const #f) (car non-#f-l*))] 130 [l*/repeated-#f (map (λ (l) (or l repeated-#f)) l*)]) 131 (apply map f l*/repeated-#f)))) 132 (let () 133 (for ([l (in-list l*)] 134 [attr-id (in-list attr-ids)]) 135 (when (eq? l #f) 136 (raise-syntax-error (syntax-e attr-id) 137 "attribute contains an omitted element" 138 attr-id))) 139 (unless (apply =* (map length l*)) 140 (raise-syntax-error 'ddd 141 "incompatible ellipis counts for template")) 142 (apply map f l*)))) 143 144 145 (define-for-syntax (current-pvars-shadowers) 146 (remove-duplicates 147 (map syntax-local-get-shadower 148 (map syntax-local-introduce 149 (filter (conjoin identifier? 150 (λ~> (syntax-local-value _ (thunk #f)) 151 syntax-pattern-variable?) 152 attribute-real-valvar) 153 (reverse (current-pvars))))) 154 bound-identifier=?)) 155 156 (define-for-syntax (extract-present-variables expanded-form stx) 157 ;; present-variables vector 158 (define present-variables** (find-present-variables-vector expanded-form)) 159 (define present-variables* 160 (and (vector? present-variables**) 161 (vector->list present-variables**))) 162 (unless ((listof (syntax/c boolean?)) present-variables*) 163 (raise-syntax-error 'ddd 164 (string-append 165 "internal error: could not extract the vector of" 166 " pattern variables present in the body.") 167 stx)) 168 (define present-variables (map syntax-e present-variables*)) 169 170 ;; lifted variables 171 (define lifted-variables 172 (map (λ (id) 173 (define prop (syntax-property id 'lifted-pvar)) 174 (unless ((cons/c symbol? stx-list?) prop) 175 (raise-syntax-error 'ddd 176 (string-append 177 "internal error: 'lifted-pvar property was " 178 "missing or not a (cons/c symbol? stx-list?)") 179 stx)) 180 prop) 181 (filter (λ (id) (all-scopes-in? x-lifted-pvar-marker id)) 182 (extract-ids expanded-form)))) 183 184 185 (values present-variables lifted-variables)) 186 187 ;(struct splicing-list (l) #:transparent) 188 (require "cross-phase-splicing-list.rkt") 189 190 ;; TODO: dotted rest, identifier macro 191 #;(define-syntax-rule (?@ v ...) 192 (splicing-list (list v ...))) 193 (define (?@ . vs) (splicing-list vs)) 194 (define (?@@ . vs) (splicing-list (map splicing-list vs))) 195 196 (define-for-syntax ((?* mode) stx) 197 (define (parse stx) 198 (syntax-case stx () 199 [(self condition a) 200 (?* (datum->syntax stx `(,#'self ,#'c ,#'a ,#'(?@)) stx stx))] 201 [(_ condition a b) 202 (let () 203 (define/with-syntax (pvar …) (current-pvars-shadowers)) 204 205 (define/with-syntax expanded-condition 206 (local-expand #'(λ (lifted-variables-hash) 207 (syntax-parameterize ([lift-late-pvars-param 208 #'lifted-variables-hash]) 209 (detect-present-pvars (pvar …) condition))) 210 'expression 211 '())) 212 213 (define-values (present-variables lifted-variables) 214 (extract-present-variables #'expanded-condition stx)) 215 216 (define/with-syntax ([lifted-key . lifted-macro+args] …) 217 lifted-variables) 218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TODO: lifted stuff!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 219 220 (define/with-syntax (test-present-attribute …) 221 (for/list ([present? (in-list present-variables)] 222 [pv (in-syntax #'(pvar …))] 223 #:when present? 224 ;; only attributes can have missing elements. 225 #:when (eq? 'attr (car (attribute-info pv '(pvar attr))))) 226 #`(attribute* #,pv))) 227 228 #`(let ([lifted-list (list (cons 'lifted-key 229 lifted-macro+args) 230 …)]) 231 (if (and test-present-attribute … 232 (andmap cdr lifted-list)) 233 #,(if (eq? mode 'if) 234 #'a 235 #'(expanded-condition 236 (make-hash lifted-list))) 237 b)))])) 238 (parse stx)) 239 240 (define-syntax ?if (?* 'if)) 241 242 (define-syntax (?cond stx) 243 (syntax-case stx (else) 244 [(self) #'(raise-syntax-error '?cond 245 "all branches contain omitted elements" 246 (quote-syntax self))] 247 [(self [else]) #'(?@)] 248 [(self [else . v]) #'(begin . v)] 249 [(self [condition v . vs] . rest) 250 (not (free-identifier=? #'condition #'else)) 251 (let ([otherwise (datum->syntax stx `(,#'self . ,#'rest) stx stx)]) 252 (datum->syntax stx 253 `(,#'?if ,#'condition ,#'(begin v . vs) ,otherwise) 254 stx 255 stx))])) 256 257 (define-syntax (?attr stx) 258 (syntax-case stx () 259 [(self condition) 260 (datum->syntax stx `(,#'?if ,#'condition #t #f) stx stx)])) 261 262 (define-syntax (?? stx) 263 (define (parse stx) 264 (syntax-case stx () 265 [(self a) 266 ((?* 'or) (datum->syntax stx `(,#'self ,#'a ,#'a ,#'(?@)) stx stx))] 267 [(self a b) 268 ((?* 'or) (datum->syntax stx `(,#'self ,#'a ,#'a ,#'b) stx stx))] 269 [(self a b c . rest) 270 (let ([else (datum->syntax stx `(,#'self ,#'b ,#'c . ,#'rest) stx stx)]) 271 (datum->syntax stx `(,#'self ,#'a ,else) stx stx))])) 272 (parse stx)) 273 274 (begin-for-syntax 275 (struct presence-info (depth>0? pvar iterated-pvar present? depth) #:prefab)) 276 277 ;;; The body is wrapped in a lambda, with one pvarᵢ for each pvar within scope. 278 ;;; This is used to shadow the pvar with one equal to pvarᵢ, which iterates over 279 ;;; the original pvar. Inside that function, the body is wrapped with 280 ;;; detect-present-pvars, which fully expands the body, leaving a quoted vector 281 ;;; of booleans indicating which pvars are actually used within the body. The 282 ;;; vector is identified by the x-pvar-present-marker scope (created with 283 ;;; make-syntax-introducer), and the extract-present-variables utility finds 284 ;;; that vector in the fully-expanded syntax object. 285 ;;; Auto-generated subscripted pattern variables would normally be derived from 286 ;;; the shadowed pvar. However, this means that within two different ddd forms, 287 ;;; the auto-generated subscripted pvars would be derived from different pvars 288 ;;; (two shadowed copies of the original). This means that the generated pvars 289 ;;; would contain different values. To solve this problem, ddd collaborates with 290 ;;; template-subscripts.rkt. When a subscripted pvar is encountered within a ddd 291 ;;; form, template-subscripts.rkt does not auto-generate its contents. 292 ;;; Instead, it extracts the value of the variable from an additionnal 293 ;;; lifted-variables argument (to the function wrapping the body), and notes down, 294 ;;; marking it with the special scope x-lifted-pvar-marker, so that 295 ;;; extract-present-variables can find it. 296 ;;; In effect, this is semantically equivalent to lifting the problematic 297 ;;; pvar outside of the body. 298 (define-syntax/case (ddd body . tail) () 299 (define/with-syntax allow-missing? 300 (syntax-case #'tail () [() #'#f] [(#:allow-missing) #'#t])) 301 (define/with-syntax (pvar …) (current-pvars-shadowers)) 302 303 (define-temp-ids "~aᵢ" (pvar …)) 304 (define/with-syntax f 305 #`(#%plain-lambda (pvarᵢ … lifted-variables-hash) 306 (shadow pvar pvarᵢ) … 307 (syntax-parameterize ([lift-late-pvars-param 308 #'lifted-variables-hash]) 309 (detect-present-pvars (pvar …) 310 body)))) 311 312 ;; extract all the variable ids present in f 313 (define/with-syntax expanded-f (local-expand #'f 'expression '())) 314 315 (define-values (present-variables lifted-variables) 316 (extract-present-variables #'expanded-f stx)) 317 318 (define/with-syntax ([lifted-key . lifted-macro+args] …) lifted-variables) 319 320 (unless (or (ormap identity present-variables) 321 (not (null? lifted-variables))) 322 (raise-syntax-error 'ddd 323 "no pattern variables were found in the body" 324 stx)) 325 326 (begin 327 ;; present?+pvars is a list of (list shadow? pv pvᵢ present? depth/#f) 328 (define present?+pvars 329 (for/list ([present? (in-list present-variables)] 330 [pv (in-syntax #'(pvar …))] 331 [pvᵢ (in-syntax #'(pvarᵢ …))]) 332 (if present? 333 (match (attribute-info pv '(pvar attr)) 334 [(list* _ _valvar depth _) 335 (if (> depth 0) 336 (presence-info #t pv pvᵢ #t depth) 337 (presence-info #f pv pvᵢ #t depth))]) ;; TODO: detect shadowed bindings, if the pvar was already iterated on, raise an error (we went too deep). 338 (presence-info #f pv pvᵢ #f #f)))) 339 ;; Pvars which are iterated over 340 (define/with-syntax (#s(presence-info _ iterated-pvar iterated-pvarᵢ _ _) …) 341 (filter presence-info-depth>0? present?+pvars)) 342 343 (when (and (stx-null? #'(iterated-pvar …)) 344 (null? lifted-variables)) 345 (no-pvar-to-iterate-error present?+pvars)) 346 347 ;; If the pvar is iterated, use the iterated pvarᵢ 348 ;; otherwise use the original (attribute* pvar) 349 (define/with-syntax (filling-pvar …) 350 (map (match-λ [(presence-info #t pv pvᵢ #t _) pvᵢ] 351 [(presence-info #f pv pvᵢ #t _) #`(attribute* #,pv)] 352 [(presence-info #f pv pvᵢ #f _) #'#f]) 353 present?+pvars))) 354 355 #'(map#f* allow-missing? 356 (λ (iterated-pvarᵢ … lifted-key …) 357 (expanded-f filling-pvar … 358 (make-hash (list (cons 'lifted-key lifted-key) …)))) 359 (list (quote-syntax iterated-pvar) … 360 (quote-syntax lifted-key) …) ;; TODO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! not the real variable 361 (list (attribute* iterated-pvar) … 362 lifted-macro+args …))) 363 364 (define-syntax/case (shadow pvar new-value) () 365 (match (attribute-info #'pvar '(pvar attr)) 366 [`(attr ,valvar ,depth ,_name ,syntax?) 367 #`(copy-raw-syntax-attribute pvar 368 new-value 369 #,(max 0 (sub1 depth)) 370 #,syntax?)] 371 [`(pvar ,valvar ,depth) 372 #`(copy-raw-syntax-attribute pvar 373 new-value 374 #,(max 0 (sub1 depth)) 375 #t) 376 #;#`(define-raw-syntax-mapping pvar 377 tmp-valvar 378 new-value 379 #,(sub1 depth))])) 380 381 (define-for-syntax (extract-ids/tree e) 382 (cond 383 [(identifier? e) e] 384 [(syntax? e) (extract-ids/tree (syntax-e e))] 385 [(pair? e) (cons (extract-ids/tree (car e)) (extract-ids/tree (cdr e)))] 386 [(vector? e) (extract-ids/tree (vector->list e))] 387 [(hash? e) (extract-ids/tree (hash->list e))] 388 [(prefab-struct-key e) (extract-ids/tree (struct->list e))] 389 [else null])) 390 391 (define-for-syntax (extract-ids e) 392 (flatten (extract-ids/tree e))) 393 394 (define-for-syntax (find-present-variables-vector e) 395 (cond 396 [(and (syntax? e) 397 (vector? (syntax-e e)) 398 (all-scopes-in? x-pvar-present-marker e)) 399 (syntax-e e)] 400 [(syntax? e) (find-present-variables-vector (syntax-e e))] 401 [(pair? e) (or (find-present-variables-vector (car e)) 402 (find-present-variables-vector (cdr e)))] 403 [(vector? e) (find-present-variables-vector (vector->list e))] 404 [(hash? e) (find-present-variables-vector (hash->list e))] 405 [(prefab-struct-key e) (find-present-variables-vector (struct->list e))] 406 [else #f])) 407 408 (define-for-syntax (no-pvar-to-iterate-error present?+pvars) 409 (raise-syntax-error 410 'ddd 411 (string-append 412 "no pattern variables with depth > 0 were found in the body\n" 413 " pattern varialbes present in the body:\n" 414 " " 415 (string-join 416 (map (λ (present?+pvar) 417 (format "~a at depth ~a" 418 (syntax-e (presence-info-pvar present?+pvar)) 419 (presence-info-depth present?+pvar))) 420 (filter presence-info-present? present?+pvars)) 421 "\n "))))