test-current-pvars.rkt (21663B)
1 #lang racket 2 (require stxparse-info/parse 3 stxparse-info/case 4 stxparse-info/current-pvars 5 racket/stxparam 6 rackunit 7 syntax/macro-testing 8 (for-syntax racket/list)) 9 10 ;; Test utilities 11 (define-syntax (list-pvars stx) 12 #`'#,(current-pvars)) 13 14 (define-syntax (list-pvars+unique-id stx) 15 #`'#,(current-pvars+unique)) 16 17 (define-syntax (list-pvars+unique-val stx) 18 (with-syntax ([([pv . un] ...) (current-pvars+unique)]) 19 #`(list (cons 'pv un) ...))) 20 21 ;; Check that the identifier has the right scopes 22 (define-syntax (ref-nth-pvar stx) 23 (syntax-case stx () 24 [(_ n) 25 (number? (syntax-e #'n)) 26 #`#'#,(let ([pvar (if (>= (syntax-e #'n) (length (current-pvars))) 27 #'too-big! 28 (list-ref (current-pvars) (syntax-e #'n)))]) 29 (datum->syntax pvar (syntax-e pvar) stx))])) 30 31 ;; First check that (current-pvars) returns the empty list before anything 32 ;; is done: 33 34 (check-equal? (list-pvars) 35 '()) 36 37 (let () 38 (define/with-syntax x #'1) 39 (void)) 40 41 (check-equal? (list-pvars) 42 '()) 43 44 ;; test that the x is correctly removed, even if no querry was made 45 ;; between its creation and the creation of the y. 46 (let () (define/with-syntax x #'1) (void)) 47 (let () 48 (define/with-syntax y #'2) 49 (check-equal? (list-pvars) 50 '(y)) 51 (void)) 52 53 (check-equal? (list (list-pvars) 54 (syntax-case #'() () 55 [() (list (list-pvars) 56 (syntax-case #'(1 2 3 a b c) () 57 [(x y ...) 58 (list-pvars)]) 59 (list-pvars))]) 60 (list-pvars)) 61 '(() (() (y x) ()) ())) 62 63 (check-equal? (list (list-pvars) 64 (syntax-case #'(-1 -2) () 65 [(k l) (list (list-pvars) 66 (syntax-case #'(1 2 3 a b c) () 67 [(z t ...) 68 (list-pvars)]) 69 (list-pvars))]) 70 (list-pvars)) 71 '(() ((l k) (t z l k) (l k)) ())) 72 73 ;; Simple case: 74 (check-equal? (syntax-parse #'(1 2 3 a b c) 75 [(x y ...) 76 (list-pvars)]) 77 '(y x)) 78 79 ;; Simple case: 80 (check-equal? (syntax-case #'() () 81 [() (syntax-parse #'(1 2 3 a b c) 82 [(x y ...) 83 (list-pvars)])]) 84 '(y x)) 85 86 ;; Mixed definitions from user code and from a macro 87 (begin 88 (define-syntax (mixed stx) 89 (syntax-case stx () 90 [(_ val def body) 91 #'(let () 92 (define/syntax-parse x #'val) 93 def 94 body)])) 95 96 (check-equal? (mixed 1 (define/syntax-parse y #'2) 97 (mixed 3 (define/syntax-parse y #'4) 98 (list-pvars))) 99 '(y x y x)) 100 101 (check-equal? (mixed 1 (define/syntax-parse y #'2) 102 (mixed 3 (define/syntax-parse y #'4) 103 (list (syntax->datum (ref-nth-pvar 0)) 104 (syntax->datum (ref-nth-pvar 1)) 105 (syntax->datum (ref-nth-pvar 2)) 106 (syntax->datum (ref-nth-pvar 3))))) 107 '(4 3 2 1))) 108 109 (check-equal? (list-pvars) 110 '()) 111 112 ;; Tests for syntax-parse 113 (begin 114 (check-equal? (syntax-parse #'(1 2 3 a b c) 115 [(x y:nat ... {~parse w (list-pvars)} z ...) 116 (syntax->datum #`[w #,(list-pvars)])]) 117 '([y x] [z w y x])) 118 119 (check-equal? (list-pvars) 120 '()) 121 122 (check-equal? (syntax-parse #'1 123 [x 124 (syntax->datum (ref-nth-pvar 0))]) 125 1) 126 127 (check-equal? (syntax-parse #'1 128 [x 129 (cons (syntax->datum (ref-nth-pvar 0)) 130 (syntax-parse #'2 131 [x 132 (list (syntax->datum (ref-nth-pvar 0)) 133 (syntax->datum (ref-nth-pvar 1)))]))]) 134 '(1 2 1))) 135 136 ;; Tests for syntax-case 137 (begin 138 (check-equal? (list-pvars) 139 '()) 140 141 (check-equal? (syntax-case #'(1 (2 3) a b c) () 142 [(_ ...) 143 (list-pvars)]) 144 '()) 145 146 (check-equal? (syntax-case #'(1 (2 3) a b c) () 147 [(x (y ...) z ...) 148 (list-pvars)]) 149 '(z y x)) 150 151 (check-equal? (list-pvars) 152 '()) 153 154 (check-equal? (syntax-case #'(x) () 155 [(_) 156 (list-pvars)]) 157 '()) 158 159 (check-equal? (syntax-case #'() () 160 [() 161 (list-pvars)]) 162 '()) 163 164 (check-equal? (syntax-parse #'1 165 [x 166 (syntax->datum (ref-nth-pvar 0))]) 167 1) 168 169 (check-equal? (syntax-parse #'1 170 [x 171 (cons (syntax->datum (ref-nth-pvar 0)) 172 (syntax-parse #'2 173 [x 174 (list (syntax->datum (ref-nth-pvar 0)) 175 (syntax->datum (ref-nth-pvar 1)))]))]) 176 '(1 2 1))) 177 178 ;; tests for define/syntax-parse and define/syntax-case 179 (define-syntax-rule (gen-test-define define/xxx) 180 (... 181 (begin 182 (check-equal? (syntax-parse #'1 183 [_ 184 (list (list-pvars) 185 (let () 186 (define/xxx z #'3) 187 (list-pvars)))]) 188 '(() (z))) 189 190 (check-equal? (syntax-parse #'1 191 [_ 192 (syntax-parse #'2 193 [_ 194 (list-pvars)])]) 195 '()) 196 197 (check-equal? (let () 198 (define/xxx _ #'1) 199 (list-pvars)) 200 '()) 201 202 (check-equal? (let () 203 (define/xxx (_ ...) #'(1 2 3)) 204 (list-pvars)) 205 '()) 206 207 (check-equal? (syntax-parse #'1 208 [x 209 #:with y #'2 210 (define/xxx z #'3) 211 (list-pvars)]) 212 '(z y x)) 213 214 (check-equal? (syntax-parse #'1 215 [x 216 #:with y #'2 217 (define/xxx z #'3) 218 (list (syntax->datum (ref-nth-pvar 0)) 219 (syntax->datum (ref-nth-pvar 1)) 220 (syntax->datum (ref-nth-pvar 2)))]) 221 '(3 2 1)) 222 223 (check-equal? (syntax-parse #'1 224 [x 225 #:with y #'2 226 (define/xxx x #'3) 227 (list-pvars)]) 228 '(x y x)) 229 230 (check-equal? (syntax-parse #'1 231 [x 232 #:with (y ...) #'(2 3) 233 (define/xxx (x ...) #'(4 5)) 234 (list-pvars)]) 235 '(x y x)) 236 237 (check-equal? (syntax-parse #'1 238 [x 239 #:with y #'2 240 (define/xxx x #'3) 241 (list (syntax->datum (ref-nth-pvar 0)) 242 (syntax->datum (ref-nth-pvar 1)) 243 (syntax->datum (ref-nth-pvar 2)))]) 244 '(3 2 1)) 245 246 (check-equal? (syntax-parse #'1 247 [x 248 #:with y #'2 249 (define/xxx x #'3) 250 (define/xxx y #'4) 251 (list (syntax->datum (ref-nth-pvar 0)) 252 (syntax->datum (ref-nth-pvar 1)) 253 (syntax->datum (ref-nth-pvar 2)) 254 (syntax->datum (ref-nth-pvar 3)))]) 255 '(4 3 2 1)) 256 257 (check-equal? (syntax-parse #'1 258 [x 259 #:with y #'2 260 (define/xxx x #'3) 261 (define/xxx y #'4) 262 (define/xxx z #'5) 263 (list (syntax->datum (ref-nth-pvar 0)) 264 (syntax->datum (ref-nth-pvar 1)) 265 (syntax->datum (ref-nth-pvar 2)) 266 (syntax->datum (ref-nth-pvar 3)) 267 (syntax->datum (ref-nth-pvar 4)))]) 268 '(5 4 3 2 1)) 269 270 (check-equal? (syntax-parse #'(1 2 3) 271 [(x y z) 272 (define/xxx x #'4) 273 (define/xxx y #'5) 274 (list (syntax->datum (ref-nth-pvar 0)) 275 (syntax->datum (ref-nth-pvar 1)) 276 (syntax->datum (ref-nth-pvar 2)) 277 (syntax->datum (ref-nth-pvar 3)) 278 (syntax->datum (ref-nth-pvar 4)))]) 279 '(5 4 3 2 1)) 280 281 (check-equal? (syntax-parse #'(1 2 3) 282 [(x y z) 283 (define/xxx x #'4) 284 (define/xxx y #'5) 285 (list-pvars)]) 286 '(y x z y x)) 287 288 ;; Test with nested let, less variables in the nested let 289 (check-equal? (let () 290 (define/xxx w #'1) 291 (define/xxx x #'2) 292 (define/xxx y #'3) 293 (define/xxx z #'4) 294 (list (list-pvars) 295 (let () 296 (define/xxx w #'5) 297 (define/xxx x #'6) 298 (list-pvars)) 299 (list-pvars))) 300 '((z y x w) (x w z y x w) (z y x w))) 301 302 ;; Test with nested let, more variables in the nested let 303 (check-equal? (let () 304 (define/xxx w #'1) 305 (define/xxx x #'2) 306 (list (list-pvars) 307 (let () 308 (define/xxx w #'3) 309 (define/xxx x #'4) 310 (define/xxx y #'5) 311 (define/xxx z #'6) 312 (list-pvars)) 313 (list-pvars))) 314 '((x w) (z y x w x w) (x w))) 315 316 (check-equal? (let () 317 (define/xxx w #'1) 318 (define/xxx x #'2) 319 (define/xxx y #'3) 320 (define/xxx z #'4) 321 (list (list-pvars) 322 (syntax-parse #'5 323 [k 324 (define/xxx w #'5) 325 (define/xxx x #'6) 326 (list-pvars)]) 327 (list-pvars))) 328 '((z y x w) (x w k z y x w) (z y x w))) 329 330 (check-equal? (let () 331 (define/xxx w #'1) 332 (define/xxx x #'2) 333 (list (list-pvars) 334 (syntax-parse #'5 335 [k 336 (define/xxx w #'3) 337 (define/xxx x #'4) 338 (define/xxx y #'5) 339 (define/xxx z #'6) 340 (list-pvars)]) 341 (list-pvars))) 342 '((x w) (z y x w k x w) (x w))) 343 344 (check-equal? (let () 345 (define/xxx w #'1) 346 (define/xxx x #'2) 347 (list (list-pvars) 348 (syntax-parse #'5 349 [k 350 (define/xxx w #'3) 351 (define/xxx x #'4) 352 (define/xxx y #'5) 353 (define/xxx z #'6) 354 (list (list-pvars) 355 (syntax-parse #'5 356 [k 357 (define/xxx x #'4) 358 (define/xxx y #'4) 359 (list-pvars)]) 360 (list-pvars))]) 361 (list-pvars))) 362 '((x w) 363 ((z y x w k x w) 364 (y x k z y x w k x w) 365 (z y x w k x w)) 366 (x w)))))) 367 (gen-test-define define/syntax-parse) 368 (gen-test-define define/with-syntax) 369 370 (check-exn #rx"bad syntax" 371 (λ () 372 (convert-compile-time-error 373 (with-pvars a 'body)))) 374 375 (check-exn #rx"bad syntax" 376 (λ () 377 (convert-compile-time-error 378 (with-pvars ((a)) 'body)))) 379 380 (check-exn #rx"bad syntax" 381 (λ () 382 (convert-compile-time-error 383 (with-pvars ((a) b) 'body)))) 384 385 (check-exn #rx"bad syntax" 386 (λ () 387 (convert-compile-time-error 388 (with-pvars (a) 'body1 . 2)))) 389 390 (check-exn #rx"bad syntax" 391 (λ () 392 (convert-compile-time-error 393 (let () 394 (define-pvars (a)))))) 395 396 (check-exn #rx"bad syntax" 397 (λ () 398 (convert-compile-time-error 399 (let () 400 (define-pvars (a) b))))) 401 402 (check-exn #rx"bad syntax" 403 (λ () 404 (convert-compile-time-error 405 (let () 406 (define-pvars a . 2))))) 407 408 (check-true (match (syntax-case #'(1 2 3) () 409 [(x ... y) 410 (list-pvars+unique-id)]) 411 [(list (cons 'y (? symbol?)) 412 (cons 'x (? symbol?))) 413 #true] 414 [_ 415 #false])) 416 417 (let () 418 (define/with-syntax (x ... y) #'(1 2 3)) 419 (check-true (match (list-pvars+unique-val) 420 [(list (cons 'y (? symbol?)) 421 (cons 'x (? symbol?))) 422 #true] 423 [v 424 (displayln v) 425 #false]))) 426 427 (check-true (match (syntax-case #'(1 2 3) () 428 [(x ... y) 429 (list-pvars+unique-val)]) 430 [(list (cons 'y (? symbol?)) 431 (cons 'x (? symbol?))) 432 #true] 433 [_ 434 #false])) 435 436 (check-equal? (match (map (λ (v) 437 (syntax-case v () 438 [(x ... y) 439 (list-pvars+unique-id)])) ;; ID 440 (list #'(a b c) #'(d))) 441 [(list (list (cons 'y (? symbol? y-unique1)) 442 (cons 'x (? symbol? x-unique1))) 443 (list (cons 'y (? symbol? y-unique2)) 444 (cons 'x (? symbol? x-unique2)))) 445 (list (eq? y-unique1 y-unique1) 446 (eq? y-unique1 x-unique1) 447 (eq? y-unique1 y-unique2) 448 (eq? y-unique1 x-unique2) 449 450 (eq? x-unique1 y-unique1) 451 (eq? x-unique1 x-unique1) 452 (eq? x-unique1 y-unique2) 453 (eq? x-unique1 x-unique2) 454 455 (eq? y-unique2 y-unique1) 456 (eq? y-unique2 x-unique1) 457 (eq? y-unique2 y-unique2) 458 (eq? y-unique2 x-unique2) 459 460 (eq? x-unique2 y-unique1) 461 (eq? x-unique2 x-unique1) 462 (eq? x-unique2 y-unique2) 463 (eq? x-unique2 x-unique2))] 464 [_ 465 #false]) 466 (list #t #f #t #f 467 #f #t #f #t 468 #t #f #t #f 469 #f #t #f #t)) 470 471 (check-equal? (match (map (λ (v) 472 (syntax-case v () 473 [(x ... y) 474 (list-pvars+unique-val)])) ;; VAL 475 (list #'(a b c) #'(d))) 476 [(list (list (cons 'y (? symbol? y-unique1)) 477 (cons 'x (? symbol? x-unique1))) 478 (list (cons 'y (? symbol? y-unique2)) 479 (cons 'x (? symbol? x-unique2)))) 480 (list (eq? y-unique1 y-unique1) 481 (eq? y-unique1 x-unique1) 482 (eq? y-unique1 y-unique2) 483 (eq? y-unique1 x-unique2) 484 485 (eq? x-unique1 y-unique1) 486 (eq? x-unique1 x-unique1) 487 (eq? x-unique1 y-unique2) 488 (eq? x-unique1 x-unique2) 489 490 (eq? y-unique2 y-unique1) 491 (eq? y-unique2 x-unique1) 492 (eq? y-unique2 y-unique2) 493 (eq? y-unique2 x-unique2) 494 495 (eq? x-unique2 y-unique1) 496 (eq? x-unique2 x-unique1) 497 (eq? x-unique2 y-unique2) 498 (eq? x-unique2 x-unique2))] 499 [_ 500 #false]) 501 (list #t #f #f #f 502 #f #t #f #f 503 #f #f #t #f 504 #f #f #f #t)) 505 506 (check-equal? (syntax-case #'(1 2 3) () 507 [(_ ... _) 508 (list-pvars+unique-id)]) 509 '()) 510 511 (check-equal? (syntax-case #'(1 2 3) () 512 [(_ ... _) 513 (list-pvars+unique-val)]) 514 '()) 515 516 ;; stress-test the binary tree implementation 517 (define-syntax-rule (defs1 pv ...) 518 (let () 519 (define/with-syntax pv #'12321) 520 ... 521 (list-pvars))) 522 523 (define-syntax (check-defs1 stx) 524 (syntax-case stx () 525 [(_ n) 526 (with-syntax ([(pv ...) (map (λ (_) (gensym)) 527 (range (syntax-e #'n)))]) 528 #'(check-equal? (reverse (defs1 pv ...)) '(pv ...)))])) 529 530 (define-syntax (check-defs1* stx) 531 (syntax-case stx () 532 [(_ start end) 533 (with-syntax ([(nᵢ ...) (range (syntax-e #'start) (syntax-e #'end))]) 534 #'(begin 535 (check-defs1 nᵢ) 536 ...))])) 537 538 (check-equal? (reverse (defs1)) '()) 539 (check-equal? (reverse (defs1 a)) '(a)) 540 (check-equal? (reverse (defs1 a b)) '(a b)) 541 (check-equal? (reverse (defs1 a b c)) '(a b c)) 542 (check-equal? (reverse (defs1 a b c d)) '(a b c d)) 543 (check-equal? (reverse (defs1 a b c d e)) '(a b c d e)) 544 (check-defs1* 6 65) ;; continue tests with 6 till 65 pvars 545 546 (define-syntax-rule (defs2 pv ...) 547 (let () 548 (define/with-syntax xyz #'12300) 549 (define/with-syntax pv #'12321) 550 ... 551 (define/with-syntax www #'12399) 552 (let () 553 (define/with-syntax pv #'12321) 554 ... 555 (list-pvars)))) 556 557 (define-syntax (check-defs2 stx) 558 (syntax-case stx () 559 [(_ n) 560 (with-syntax ([(pv ...) (map (λ (_) (gensym)) 561 (range (syntax-e #'n)))]) 562 #'(check-equal? (reverse (defs2 pv ...)) '(xyz pv ... www pv ...)))])) 563 564 (define-syntax (check-defs2* stx) 565 (syntax-case stx () 566 [(_ start end) 567 (with-syntax ([(nᵢ ...) (range (syntax-e #'start) (syntax-e #'end))]) 568 #'(begin 569 (check-defs2 nᵢ) 570 ...))])) 571 572 (check-equal? (reverse (defs2)) '(xyz www)) 573 (check-equal? (reverse (defs2 a)) '(xyz a www a)) 574 (check-equal? (reverse (defs2 a b)) '(xyz a b www a b)) 575 (check-equal? (reverse (defs2 a b c)) '(xyz a b c www a b c)) 576 (check-equal? (reverse (defs2 a b c d)) '(xyz a b c d www a b c d)) 577 (check-equal? (reverse (defs2 a b c d e)) '(xyz a b c d e www a b c d e)) 578 (check-defs2* 6 65) ;; continue tests with 6 till 65 pvars 579 580 (define-syntax (defs3 stx) 581 (syntax-case stx () 582 [(_) 583 #'(list (list-pvars))] 584 [(_ pv₀ pvᵢ ...) 585 #'(cons (list-pvars) 586 (let () 587 (define/with-syntax pv₀ #'12321) 588 (defs3 pvᵢ ...)))])) 589 590 (define-syntax (*expected-defs3 stx) 591 (syntax-case stx () 592 [(_) 593 #'(list '())] 594 [(_ pvᵢ ... pvₙ) 595 #'(cons '(pvᵢ ... pvₙ) 596 (*expected-defs3 pvᵢ ...))])) 597 (define-syntax-rule (expected-defs3 pv ...) 598 (reverse (*expected-defs3 pv ...))) 599 600 (define-syntax (check-defs3 stx) 601 (syntax-case stx () 602 [(_ n) 603 (with-syntax ([(pv ...) (map (λ (_) (gensym)) 604 (range (syntax-e #'n)))]) 605 #'(check-equal? (map reverse (defs3 pv ...)) 606 (expected-defs3 pv ...)))])) 607 608 (define-syntax (check-defs3* stx) 609 (syntax-case stx () 610 [(_ start end) 611 (with-syntax ([(nᵢ ...) (range (syntax-e #'start) (syntax-e #'end))]) 612 #'(begin 613 (check-defs3 nᵢ) 614 ...))])) 615 616 (check-equal? (map reverse (defs3)) '(())) 617 (check-equal? (map reverse (defs3 a)) '(() (a))) 618 (check-equal? (map reverse (defs3 a b)) '(() (a) (a b))) 619 (check-equal? (map reverse (defs3 a b c)) '(() (a) (a b) (a b c))) 620 (check-equal? (map reverse (defs3 a b c d)) '(() (a) (a b) (a b c) (a b c d))) 621 (check-equal? (map reverse (defs3 a b c d e)) 622 '(() (a) (a b) (a b c) (a b c d) (a b c d e))) 623 624 (check-equal? (expected-defs3) '(())) 625 (check-equal? (expected-defs3 a) '(() (a))) 626 (check-equal? (expected-defs3 a b) '(() (a) (a b))) 627 (check-equal? (expected-defs3 a b c) '(() (a) (a b) (a b c))) 628 (check-equal? (expected-defs3 a b c d) '(() (a) (a b) (a b c) (a b c d))) 629 (check-equal? (expected-defs3 a b c d e) 630 '(() (a) (a b) (a b c) (a b c d) (a b c d e))) 631 632 (check-defs3* 6 65) ;; continue tests with 6 till 65 pvars 633 634 (check-equal? (list-pvars) 635 '())