core/parser/parser-tests.factor

   1 USING: arrays math parser tools.test kernel generic words
   2 io.streams.string namespaces classes effects source-files assocs
   3 sequences strings io.files io.pathnames definitions
   4 continuations sorting classes.tuple compiler.units debugger
   5 vocabs vocabs.loader accessors eval combinators lexer
   6 vocabs.parser words.symbol multiline ;
   7 IN: parser.tests
   8
   9 \ run-file must-infer
  10
  11 [
  12     [ 1 [ 2 [ 3 ] 4 ] 5 ]
  13     [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
  14     unit-test
  15
  16     [ t t f f ]
  17     [ "t t f f" eval ]
  18     unit-test
  19
  20     [ "hello world" ]
  21     [ "\"hello world\"" eval ]
  22     unit-test
  23
  24     [ "\n\r\t\\" ]
  25     [ "\"\\n\\r\\t\\\\\"" eval ]
  26     unit-test
  27
  28     [ "hello world" ]
  29     [
  30         "IN: parser.tests : hello \"hello world\" ;"
  31         eval "USE: parser.tests hello" eval
  32     ] unit-test
  33
  34     [ ]
  35     [ "! This is a comment, people." eval ]
  36     unit-test
  37
  38     ! Test escapes
  39
  40     [ " " ]
  41     [ "\"\\u000020\"" eval ]
  42     unit-test
  43
  44     [ "'" ]
  45     [ "\"\\u000027\"" eval ]
  46     unit-test
  47
  48     ! Test EOL comments in multiline strings.
  49     [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test
  50
  51     [ word ] [ \ f class ] unit-test
  52
  53     ! Test stack effect parsing
  54
  55     : effect-parsing-test ( a b -- c ) + ;
  56
  57     [ t ] [
  58         "effect-parsing-test" "parser.tests" lookup
  59         \ effect-parsing-test eq?
  60     ] unit-test
  61
  62     [ T{ effect f { "a" "b" } { "c" } f } ]
  63     [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
  64
  65     : baz ( a b -- * ) 2array throw ;
  66
  67     [ t ]
  68     [ \ baz "declared-effect" word-prop terminated?>> ]
  69     unit-test
  70
  71     [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
  72
  73     [ t ] [
  74         "effect-parsing-test" "parser.tests" lookup
  75         \ effect-parsing-test eq?
  76     ] unit-test
  77
  78     [ T{ effect f { "a" "b" } { "d" } f } ]
  79     [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
  80
  81     [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test
  82
  83     [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
  84
  85     ! Funny bug
  86     [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test
  87
  88     [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
  89
  90     ! These should throw errors
  91     [ "HEX: zzz" eval ] must-fail
  92     [ "OCT: 999" eval ] must-fail
  93     [ "BIN: --0" eval ] must-fail
  94
  95     ! Another funny bug
  96     [ t ] [
  97         [
  98             "scratchpad" in set
  99             { "scratchpad" "arrays" } set-use
 100             [
 101                 ! This shouldn't modify in/use in the outer scope!
 102             ] with-file-vocabs
 103
 104             use get { "scratchpad" "arrays" } set-use use get =
 105         ] with-scope
 106     ] unit-test
 107     DEFER: foo
 108
 109     "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
 110
 111     [ ] [ "USE: parser.tests foo" eval ] unit-test
 112
 113     "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval
 114
 115     [ t ] [
 116         "USE: parser.tests \\ foo" eval
 117         "foo" "parser.tests" lookup eq?
 118     ] unit-test
 119
 120     ! Test smudging
 121
 122     [ 1 ] [
 123         "IN: parser.tests : smudge-me ;" <string-reader> "foo"
 124         parse-stream drop
 125
 126         "foo" source-file definitions>> first assoc-size
 127     ] unit-test
 128
 129     [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
 130
 131     [ ] [
 132         "IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
 133         parse-stream drop
 134     ] unit-test
 135
 136     [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
 137     [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
 138
 139     [ 3 ] [
 140         "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
 141         parse-stream drop
 142
 143         "foo" source-file definitions>> first assoc-size
 144     ] unit-test
 145
 146     [ 1 ] [
 147         "IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
 148         parse-stream drop
 149
 150         "bar" source-file definitions>> first assoc-size
 151     ] unit-test
 152
 153     [ 2 ] [
 154         "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
 155         parse-stream drop
 156
 157         "foo" source-file definitions>> first assoc-size
 158     ] unit-test
 159
 160     [ t ] [
 161         array "smudge-me" "parser.tests" lookup order memq?
 162     ] unit-test
 163
 164     [ t ] [
 165         integer "smudge-me" "parser.tests" lookup order memq?
 166     ] unit-test
 167
 168     [ f ] [
 169         string "smudge-me" "parser.tests" lookup order memq?
 170     ] unit-test
 171
 172     [ ] [
 173         "IN: parser.tests USE: math 2 2 +" <string-reader> "a"
 174         parse-stream drop
 175     ] unit-test
 176
 177     [ t ] [
 178         "a" <pathname> \ + usage member?
 179     ] unit-test
 180
 181     [ ] [
 182         "IN: parser.tests USE: math 2 2 -" <string-reader> "a"
 183         parse-stream drop
 184     ] unit-test
 185
 186     [ f ] [
 187         "a" <pathname> \ + usage member?
 188     ] unit-test
 189
 190     [ ] [
 191         "a" source-files get delete-at
 192         2 [
 193             "IN: parser.tests DEFER: x : y x ; : x y ;"
 194             <string-reader> "a" parse-stream drop
 195         ] times
 196     ] unit-test
 197
 198     "a" source-files get delete-at
 199
 200     [
 201         "IN: parser.tests : x ; : y 3 throw ; this is an error"
 202         <string-reader> "a" parse-stream
 203     ] [ source-file-error? ] must-fail-with
 204
 205     [ t ] [
 206         "y" "parser.tests" lookup >boolean
 207     ] unit-test
 208
 209     [ f ] [
 210         "IN: parser.tests : x ;"
 211         <string-reader> "a" parse-stream drop
 212
 213         "y" "parser.tests" lookup
 214     ] unit-test
 215
 216     ! Test new forward definition logic
 217     [ ] [
 218         "IN: axx : axx ;"
 219         <string-reader> "axx" parse-stream drop
 220     ] unit-test
 221
 222     [ ] [
 223         "USE: axx IN: bxx : bxx ; : cxx axx bxx ;"
 224         <string-reader> "bxx" parse-stream drop
 225     ] unit-test
 226
 227     ! So we move the bxx word to axx...
 228     [ ] [
 229         "IN: axx : axx ; : bxx ;"
 230         <string-reader> "axx" parse-stream drop
 231     ] unit-test
 232
 233     [ t ] [ "bxx" "axx" lookup >boolean ] unit-test
 234
 235     ! And reload the file that uses it...
 236     [ ] [
 237         "USE: axx IN: bxx : cxx axx bxx ;"
 238         <string-reader> "bxx" parse-stream drop
 239     ] unit-test
 240
 241     ! And hope not to get a forward-error!
 242
 243     ! Turning a generic into a non-generic could cause all
 244     ! kinds of funnyness
 245     [ ] [
 246         "IN: ayy USE: kernel GENERIC: ayy M: object ayy ;"
 247         <string-reader> "ayy" parse-stream drop
 248     ] unit-test
 249
 250     [ ] [
 251         "IN: ayy USE: kernel : ayy ;"
 252         <string-reader> "ayy" parse-stream drop
 253     ] unit-test
 254
 255     [ ] [
 256         "IN: azz TUPLE: my-class ; GENERIC: a-generic"
 257         <string-reader> "azz" parse-stream drop
 258     ] unit-test
 259
 260     [ ] [
 261         "USE: azz M: my-class a-generic ;"
 262         <string-reader> "azz-2" parse-stream drop
 263     ] unit-test
 264
 265     [ ] [
 266         "IN: azz GENERIC: a-generic"
 267         <string-reader> "azz" parse-stream drop
 268     ] unit-test
 269
 270     [ ] [
 271         "USE: azz USE: math M: integer a-generic ;"
 272         <string-reader> "azz-2" parse-stream drop
 273     ] unit-test
 274
 275     [ ] [
 276         "IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
 277         <string-reader> "bogus-error" parse-stream drop
 278     ] unit-test
 279
 280     [ ] [
 281         "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
 282         <string-reader> "bogus-error" parse-stream drop
 283     ] unit-test
 284
 285     ! Problems with class predicates -vs- ordinary words
 286     [ ] [
 287         "IN: parser.tests TUPLE: killer ;"
 288         <string-reader> "removing-the-predicate" parse-stream drop
 289     ] unit-test
 290
 291     [ ] [
 292         "IN: parser.tests GENERIC: killer? ( a -- b )"
 293         <string-reader> "removing-the-predicate" parse-stream drop
 294     ] unit-test
 295
 296     [ t ] [
 297         "killer?" "parser.tests" lookup >boolean
 298     ] unit-test
 299
 300     [
 301         "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
 302         <string-reader> "removing-the-predicate" parse-stream
 303     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 304
 305     [
 306         "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
 307         <string-reader> "redefining-a-class-1" parse-stream
 308     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 309
 310     [ ] [
 311         "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
 312         <string-reader> "redefining-a-class-2" parse-stream drop
 313     ] unit-test
 314
 315     [
 316         "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
 317         <string-reader> "redefining-a-class-3" parse-stream drop
 318     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 319
 320     [ ] [
 321         "IN: parser.tests TUPLE: class-fwd-test ;"
 322         <string-reader> "redefining-a-class-3" parse-stream drop
 323     ] unit-test
 324
 325     [
 326         "IN: parser.tests \\ class-fwd-test"
 327         <string-reader> "redefining-a-class-3" parse-stream drop
 328     ] [ error>> error>> error>> no-word-error? ] must-fail-with
 329
 330     [ ] [
 331         "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
 332         <string-reader> "redefining-a-class-3" parse-stream drop
 333     ] unit-test
 334
 335     [
 336         "IN: parser.tests \\ class-fwd-test"
 337         <string-reader> "redefining-a-class-3" parse-stream drop
 338     ] [ error>> error>> error>> no-word-error? ] must-fail-with
 339
 340     [
 341         "IN: parser.tests : foo ; TUPLE: foo ;"
 342         <string-reader> "redefining-a-class-4" parse-stream drop
 343     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 344
 345     [ ] [
 346         "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
 347     ] unit-test
 348
 349     [
 350         "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
 351     ] must-fail
 352 ] with-file-vocabs
 353
 354 [ ] [
 355     "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
 356 ] unit-test
 357
 358 [ t ] [
 359     "foo?" "parser.tests" lookup word eq?
 360 ] unit-test
 361
 362 [ ] [
 363     [
 364         "redefining-a-class-5" forget-source
 365         "redefining-a-class-6" forget-source
 366         "redefining-a-class-7" forget-source
 367     ] with-compilation-unit
 368 ] unit-test
 369
 370 2 [
 371     [ ] [
 372         "IN: parser.tests TUPLE: foo ; GENERIC: foo"
 373         <string-reader> "redefining-a-class-5" parse-stream drop
 374     ] unit-test
 375
 376     [ ] [
 377         "IN: parser.tests M: f foo ;"
 378         <string-reader> "redefining-a-class-6" parse-stream drop
 379     ] unit-test
 380
 381     [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
 382
 383     [ ] [
 384         "IN: parser.tests TUPLE: foo ; GENERIC: foo"
 385         <string-reader> "redefining-a-class-5" parse-stream drop
 386     ] unit-test
 387
 388     [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
 389
 390     [ ] [
 391         "IN: parser.tests TUPLE: foo ; GENERIC: foo"
 392     <string-reader> "redefining-a-class-7" parse-stream drop
 393     ] unit-test
 394
 395     [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
 396
 397     [ ] [
 398         "IN: parser.tests TUPLE: foo ;"
 399         <string-reader> "redefining-a-class-7" parse-stream drop
 400     ] unit-test
 401
 402     [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
 403 ] times
 404
 405 [ "vocab:parser/test/assert-depth.factor" run-file ]
 406 [ got>> { 1 2 3 } sequence= ]
 407 must-fail-with
 408
 409 2 [
 410     [ ] [
 411         "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
 412         <string-reader> "d-f-s-test" parse-stream drop
 413     ] unit-test
 414
 415     [ ] [
 416         "IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s"
 417         <string-reader> "d-f-s-test" parse-stream drop
 418     ] unit-test
 419
 420     [ ] [
 421         "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
 422         <string-reader> "d-f-s-test" parse-stream drop
 423     ] unit-test
 424 ] times
 425
 426 [ ] [
 427     [ "this-better-not-exist" forget-vocab ] with-compilation-unit
 428 ] unit-test
 429
 430 [
 431     "USE: this-better-not-exist" eval
 432 ] must-fail
 433
 434 [ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
 435
 436 [ 92 ] [ "CHAR: \\" eval ] unit-test
 437 [ 92 ] [ "CHAR: \\\\" eval ] unit-test
 438
 439 [ ] [
 440     {
 441         "IN: parser.tests"
 442         "USING: math arrays ;"
 443         "GENERIC: change-combination"
 444         "M: integer change-combination 1 ;"
 445         "M: array change-combination 2 ;"
 446     } "\n" join <string-reader> "change-combination-test" parse-stream drop
 447 ] unit-test
 448
 449 [ ] [
 450     {
 451         "IN: parser.tests"
 452         "USING: math arrays ;"
 453         "GENERIC# change-combination 1"
 454         "M: integer change-combination 1 ;"
 455         "M: array change-combination 2 ;"
 456     } "\n" join <string-reader> "change-combination-test" parse-stream drop
 457 ] unit-test
 458
 459 [ 2 ] [
 460     "change-combination" "parser.tests" lookup
 461     "methods" word-prop assoc-size
 462 ] unit-test
 463
 464 [ ] [
 465     2 [
 466         "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
 467         <string-reader> "twice-fails-test" parse-stream drop
 468     ] times
 469 ] unit-test
 470
 471 [ [ ] ] [
 472     "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
 473     <string-reader> "staging-problem-test" parse-stream
 474 ] unit-test
 475
 476 [ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
 477
 478 [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
 479
 480 [ [ ] ] [
 481     "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
 482     <string-reader> "staging-problem-test" parse-stream
 483 ] unit-test
 484
 485 [ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
 486
 487 [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
 488
 489 [ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
 490
 491 [
 492     "IN: parser.tests : blahy ; parsing FORGET: blahy" eval
 493 ] [
 494     error>> staging-violation?
 495 ] must-fail-with
 496
 497 ! Bogus error message
 498 DEFER: blahy
 499
 500 [ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
 501 [ error>> error>> def>> \ blahy eq? ] must-fail-with
 502
 503 [ ] [ f lexer set f file set "Hello world" note. ] unit-test
 504
 505 [ "CHAR: \\u9999999999999" eval ] must-fail
 506
 507 SYMBOLS: a b c ;
 508
 509 [ a ] [ a ] unit-test
 510 [ b ] [ b ] unit-test
 511 [ c ] [ c ] unit-test
 512
 513 DEFER: blah
 514
 515 [ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
 516 [ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
 517
 518 [ f ] [ \ blah generic? ] unit-test
 519 [ t ] [ \ blah symbol? ] unit-test
 520
 521 DEFER: blah1
 522
 523 [ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
 524 [ error>> error>> def>> \ blah1 eq? ]
 525 must-fail-with
 526
 527 IN: qualified.tests.foo
 528 : x 1 ;
 529 : y 5 ;
 530 IN: qualified.tests.bar
 531 : x 2 ;
 532 : y 4 ;
 533 IN: qualified.tests.baz
 534 : x 3 ;
 535
 536 QUALIFIED: qualified.tests.foo
 537 QUALIFIED: qualified.tests.bar
 538 [ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
 539
 540 QUALIFIED-WITH: qualified.tests.bar p
 541 [ 2 ] [ p:x ] unit-test
 542
 543 RENAME: x qualified.tests.baz => y
 544 [ 3 ] [ y ] unit-test
 545
 546 FROM: qualified.tests.baz => x ;
 547 [ 3 ] [ x ] unit-test
 548 [ 3 ] [ y ] unit-test
 549
 550 EXCLUDE: qualified.tests.bar => x ;
 551 [ 3 ] [ x ] unit-test
 552 [ 4 ] [ y ] unit-test
 553
 554 [ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
 555 [ error>> no-word-error? ] must-fail-with
 556
 557 [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
 558 [ error>> no-word-error? ] must-fail-with
 559
 560 ! Two similar bugs
 561
 562 ! Replace : def with something in << >>
 563 /* [ [ ] ] [
 564     "IN: parser.tests : was-once-a-word-bug ( -- ) ;"
 565     <string-reader> "was-once-a-word-test" parse-stream
 566 ] unit-test
 567
 568 [ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
 569
 570 [ [ ] ] [
 571     "IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create [ ] (( -- )) define-declared >>"
 572     <string-reader> "was-once-a-word-test" parse-stream
 573 ] unit-test
 574
 575 [ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test */
 576
 577 ! Replace : def with DEFER:
 578 [ [ ] ] [
 579     "IN: parser.tests : is-not-deferred ( -- ) ;"
 580     <string-reader> "is-not-deferred" parse-stream
 581 ] unit-test
 582
 583 [ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
 584 [ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test
 585
 586 [ [ ] ] [
 587     "IN: parser.tests DEFER: is-not-deferred"
 588     <string-reader> "is-not-deferred" parse-stream
 589 ] unit-test
 590
 591 [ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
 592 [ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test