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