t/op/string.t

   1 #!./parrot
   2 # Copyright (C) 2001-2010, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/op/string.t - Parrot Strings
   8
   9 =head1 SYNOPSIS
  10
  11      % prove t/op/string.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests Parrot string registers and operations.
  16
  17 =cut
  18
  19 .include 'except_types.pasm'
  20
  21 .sub main :main
  22     .include 'test_more.pir'
  23
  24     set_s_s_sc()
  25     test_clone()
  26     clone_null()
  27     test_length_i_s()
  28     zero_length_substr()
  29     chopn_with_clone()
  30     chopn_oob_values()
  31     three_argument_chopn()
  32     three_argument_chopn__oob_values()
  33     substr_tests()
  34     neg_substr_offset()
  35     exception_substr_null_string()
  36     exception_substr_oob()
  37     exception_substr_oob_neg()
  38     len_greater_than_strlen()
  39     len_greater_than_strlen_neg_offset()
  40     replace_w_rep_eq_length()
  41     replace_w_replacement_gt_length()
  42     replace_w_replacement_lt_length()
  43     replace_vs_hash()
  44     replace__offset_at_end_of_string()
  45     exception_replace__offset_past_end_of_string()
  46     replace_neg_offset_repl_eq_length()
  47     replace_neg_offset_repl_gt_length()
  48     replace_neg_offset_repl_lt_length()
  49     exception_replace_neg_offset_out_of_string()
  50     replace_length_gt_strlen()
  51     replace_length_gt_strlen_neg_offset()
  52     replace_only_substr()
  53     three_arg_substr()
  54     exception_substr__pos_offset_zero_length_string()
  55     substr_offset_zero_zero_length_string()
  56     exception_substr_offset_one_zero_length_string()
  57     exception_substr_neg_offset_zero_length_string()
  58     zero_length_substr_zero_length_string()
  59     zero_length_substr_zero_length_string()
  60     three_arg_substr_zero_length_string()
  61     replace_zero_length_string()
  62     four_arg_substr_replace_zero_length_string()
  63     concat_s_s_sc_null_onto_null()
  64     concat_s_sc_repeated_two_arg_concats()
  65     concat_s_s_sc_foo_one_onto_null()
  66     test_concat_s_s_sc()
  67     concat_s_s_sc_s_sc()
  68     concat_ensure_copy_is_made()
  69
  70     same_constant_twice_bug()
  71     exception_two_param_ord_empty_string()
  72     exception_two_param_ord_empty_string_register()
  73     exception_three_param_ord_empty_string()
  74     exception_three_param_ord_empty_string_register()
  75     two_param_ord_one_character_string()
  76     two_param_ord_multi_character_string()
  77     two_param_ord_one_character_string_register()
  78     three_param_ord_one_character_string()
  79     three_param_ord_one_character_string_register()
  80     three_param_ord_multi_character_string()
  81     three_param_ord_multi_character_string_register()
  82     exception_three_param_ord_multi_character_string()
  83     exception_three_param_ord_multi_character_string()
  84     three_param_ord_one_character_string_from_end()
  85     three_param_ord_one_character_string_register_from_end()
  86     three_param_ord_multi_character_string_from_end()
  87     three_param_ord_multi_character_string_register_from_end()
  88     exception_three_param_ord_multi_character_string_register_from_end_oob()
  89     chr_of_thirty_two_is_space_in_ascii()
  90     chr_of_sixty_five_is_a_in_ascii()
  91     chr_of_one_hundred_and_twenty_two_is_z_in_ascii()
  92     test_if_s_ic()
  93     repeat_s_s_sc_i_ic()
  94     exception_repeat_oob()
  95     exception_repeat_oob_repeat_p_p_p()
  96     exception_repeat_oob_repeate_p_p_i()
  97     encodingname_oob()
  98     index_three_arg_form()
  99     index_four_arg_form()
 100     index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen()
 101     index_trac_1482()
 102     index_null_strings()
 103     index_embedded_nulls()
 104     index_big_strings()
 105     index_big_hard_to_match_strings()
 106     index_with_different_charsets()
 107     negative_index_bug_35959()
 108     index_multibyte_matching()
 109     index_multibyte_matching_two()
 110     num_to_string()
 111     string_to_int()
 112     string_to_num()
 113     concat_or_substr_cow()
 114     constant_to_cstring()
 115     cow_with_chopn_leaving_original_untouched()
 116     check_that_bug_bug_16874_was_fixed()
 117     stress_concat()
 118     ord_and_substring_see_bug_17035()
 119
 120     test_sprintf()
 121     other_form_of_sprintf_op()
 122     sprintf_left_justify()
 123     correct_precision_for_sprintf_x()
 124     test_find_encoding()
 125     test_assign()
 126     assign_and_globber()
 127     split_on_null_string()
 128     split_on_empty_string()
 129     split_on_non_empty_string()
 130     test_join()
 131     test_join_many()
 132     eq_addr_or_ne_addr()
 133     test_if_null_s_ic()
 134     test_upcase()
 135     test_downcase()
 136     test_titlecase()
 137     three_param_ord_one_character_string_register_i()
 138     three_param_ord_multi_character_string_i()
 139     three_param_ord_multi_character_string_register_i()
 140     exception_three_param_ord_multi_character_string_i()
 141     exception_three_param_ord_multi_character_string_i()
 142     three_param_ord_one_character_string_from_end_i()
 143     three_param_ord_one_character_string_register_from_end_i()
 144     three_param_ord_multi_character_string_from_end_i()
 145     three_param_ord_multi_character_string_register_from_end_i()
 146     exception_three_param_ord_multi_character_string_register_from_end_oob_i()
 147     more_string_to_int()
 148     constant_string_and_modify_in_situ_op_rt_bug_60030()
 149     corner_cases_of_numification()
 150     non_canonical_nan_and_inf()
 151     split_hll_mapped()
 152     # END_OF_TESTS
 153     join_get_string_returns_a_null_string()
 154
 155     done_testing()
 156 .end
 157
 158 .macro exception_is ( M )
 159     .local pmc exception
 160     .local string message
 161     .get_results (exception)
 162
 163     message = exception['message']
 164     is( message, .M, .M )
 165 .endm
 166
 167 .sub set_s_s_sc
 168     set $S4, "JAPH"
 169     set $S5, $S4
 170
 171     is( $S4, "JAPH", '' )
 172     is( $S5, "JAPH", '' )
 173 .end
 174
 175 .sub test_clone
 176     set   $S0, "Foo1"
 177     clone $S1, $S0
 178
 179     is( $S0, "Foo1", '' )
 180     is( $S1, "Foo1", '' )
 181
 182     clone $S1, "Bar1"
 183     is( $S1, "Bar1", '' )
 184 .end
 185
 186 .sub clone_null
 187     null $S0
 188     clone $S1, $S0
 189     is( $S1, $S0, '' )
 190 .end
 191
 192 .sub test_length_i_s
 193     set $I4, 0
 194     set $S4, "JAPH"
 195     length  $I4, $S4
 196     is( $I4, "4", '' )
 197 .end
 198
 199 .sub zero_length_substr
 200     set $I4, 0
 201     set $S4, "JAPH"
 202     substr  $S3, $S4, 1, 0
 203     length  $I4, $S3
 204     is( $I4, "0", '' )
 205 .end
 206
 207 .sub chopn_with_clone
 208     set $S4, "JAPHxyzw"
 209     set $S5, "japhXYZW"
 210     clone $S3, $S4
 211     set $I1, 4
 212     $S4 = chopn $S4, 3
 213     $S4 = chopn $S4, 1
 214     $S5 = chopn $S5, $I1
 215
 216     is( $S4, "JAPH", '' )
 217     is( $S5, "japh", '' )
 218     is( $S3, "JAPHxyzw", '' )
 219 .end
 220
 221 .sub chopn_oob_values
 222     set $S1, "A string of length 21"
 223     $S1 = chopn $S1, 0
 224     is( $S1, "A string of length 21", '' )
 225
 226     $S1 = chopn $S1, 4
 227     is( $S1, "A string of lengt", '' )
 228
 229     # -length cuts now
 230     $S1 = chopn $S1, -4
 231     is( $S1, "A st", '' )
 232
 233     $S1 = chopn $S1, 1000
 234     is( $S1, "", '' )
 235 .end
 236
 237 .sub three_argument_chopn
 238     set $S1, "Parrot"
 239     chopn   $S2, $S1, 0
 240     is( $S1, "Parrot", '' )
 241     is( $S2, "Parrot", '' )
 242
 243     chopn   $S2, $S1, 1
 244     is( $S1, "Parrot", '' )
 245     is( $S2, "Parro", '' )
 246
 247     set     $I0, 2
 248     chopn   $S2, $S1, $I0
 249     is( $S1, "Parrot", '' )
 250     is( $S2, "Parr", '' )
 251
 252     chopn   $S2, "Parrot", 3
 253     is( $S2, "Par", '' )
 254
 255     chopn   $S1, $S1, 5
 256     is( $S1, "P", '' )
 257
 258     set     $S1, "Parrot"
 259     set     $S3, $S1
 260     chopn   $S2, $S1, 3
 261     is( $S3, "Parrot", '' )
 262 .end
 263 #
 264 .sub three_argument_chopn__oob_values
 265     set $S1, "Parrot"
 266     chopn   $S2, $S1, 7
 267     is( $S1, "Parrot", '' )
 268     is( $S2, "", '' )
 269
 270     chopn   $S2, $S1, -1
 271     is( $S1, "Parrot", '' )
 272     is( $S2, "P", '' )
 273 .end
 274
 275 .sub substr_tests
 276     set $S4, "12345JAPH01"
 277     set $I4, 5
 278     set $I5, 4
 279
 280     substr  $S5, $S4, $I4, $I5
 281     is( $S5, "JAPH", '' )
 282
 283     substr $S5, $S4, $I4, 4
 284     is( $S5, "JAPH", '' )
 285
 286     substr $S5, $S4, 5, $I5
 287     is( $S5, "JAPH", '' )
 288
 289     substr $S5, $S4, 5, 4
 290     is( $S5, "JAPH", '' )
 291
 292     substr $S5, "12345JAPH01", $I4, $I5
 293     is( $S5, "JAPH", '' )
 294
 295     substr $S5, "12345JAPH01", $I4, 4
 296     is( $S5, "JAPH", '' )
 297
 298     substr $S5, "12345JAPH01", 5, $I5
 299     is( $S5, "JAPH", '' )
 300
 301     substr $S5, "12345JAPH01", 5, 4
 302     is( $S5, "JAPH", '' )
 303 .end
 304
 305 # negative offsets
 306 .sub neg_substr_offset
 307     set $S0, "A string of length 21"
 308     set $I0, -9
 309     set $I1, 6
 310     substr $S1, $S0, $I0, $I1
 311     is( $S0, "A string of length 21", '' )
 312     is( $S1, "length", '' )
 313 .end
 314
 315 .sub exception_substr_null_string
 316     .local string s
 317     .local pmc eh
 318     .local int r
 319     null s
 320     eh = new ['ExceptionHandler']
 321     eh.'handle_types'(.EXCEPTION_SUBSTR_OUT_OF_STRING)
 322     set_addr eh, handler
 323     push_eh eh
 324     r = 1
 325     substr s, s, 0, 0
 326     r = 0
 327   handler:
 328     pop_eh
 329     is(r, 1, "substr with null string throws" )
 330 .end
 331
 332 # This asks for substring that shouldn't be allowed...
 333 .sub exception_substr_oob
 334     .local pmc eh
 335     .local int r
 336     set $S0, "A string of length 21"
 337     set $I0, 99
 338     set $I1, 6
 339     eh = new ['ExceptionHandler']
 340     eh.'handle_types'(.EXCEPTION_SUBSTR_OUT_OF_STRING)
 341     set_addr eh, handler
 342     push_eh eh
 343     r = 1
 344
 345     substr $S1, $S0, $I0, $I1
 346     r = 0
 347   handler:
 348     pop_eh
 349     is(r, 1, "substr outside string throws" )
 350 .end
 351
 352 # This asks for substring that shouldn't be allowed...
 353 .sub exception_substr_oob_neg
 354     .local pmc eh
 355     .local int r
 356     set $S0, "A string of length 21"
 357     set $I0, -99
 358     set $I1, 6
 359     eh = new ['ExceptionHandler']
 360     eh.'handle_types'(.EXCEPTION_SUBSTR_OUT_OF_STRING)
 361     set_addr eh, handler
 362     push_eh eh
 363     r = 1
 364
 365     substr $S1, $S0, $I0, $I1
 366     r = 0
 367   handler:
 368     pop_eh
 369     is(r, 1, "substr outside string throws - negative" )
 370 .end
 371
 372 # This asks for substring much greater than length of original string
 373 .sub len_greater_than_strlen
 374     set $S0, "A string of length 21"
 375     set $I0, 12
 376     set $I1, 1000
 377     substr $S1, $S0, $I0, $I1
 378     is( $S0, "A string of length 21", '' )
 379     is( $S1, "length 21", '' )
 380 .end
 381
 382 # The same, with a negative offset
 383 .sub len_greater_than_strlen_neg_offset
 384     set $S0, "A string of length 21"
 385     set $I0, -9
 386     set $I1, 1000
 387     substr $S1, $S0, $I0, $I1
 388     is( $S0, "A string of length 21", '' )
 389     is( $S1, "length 21", '' )
 390 .end
 391
 392 .sub replace_w_rep_eq_length
 393     set $S0, "abcdefghijk"
 394     set $S1, "xyz"
 395     replace $S2, $S0, 4, 3, $S1
 396     is( $S2, "abcdxyzhijk", '' )
 397 .end
 398
 399 .sub replace_w_replacement_gt_length
 400     set $S0, "abcdefghijk"
 401     set $S1, "xyz0123"
 402     $S2 = replace $S0, 4, 3, $S1
 403     is( $S2, "abcdxyz0123hijk", '' )
 404 .end
 405
 406 .sub replace_w_replacement_lt_length
 407     set $S0, "abcdefghijk"
 408     set $S1, "x"
 409     $S2 = replace $S0, 4, 3, $S1
 410     is( $S2, "abcdxhijk", '' )
 411 .end
 412
 413 .sub replace__offset_at_end_of_string
 414     set $S0, "abcdefghijk"
 415     set $S1, "xyz"
 416     $S2 = replace $S0, 11, 3, $S1
 417     is( $S2, "abcdefghijkxyz", '' )
 418 .end
 419
 420 .sub replace_vs_hash
 421     # Check that string hashval properly updated.
 422     .local pmc hash
 423     hash = new ['Hash']
 424     $S0 = "fooo"
 425     hash[$S0]   = 1
 426     hash["foo"] = 42
 427     $S0 = replace $S0, 1, 1, ''
 428     $S1 = hash[$S0]
 429     is( $S1, '42', 'replace behave it self')
 430 .end
 431
 432 .sub exception_replace__offset_past_end_of_string
 433     set $S0, "abcdefghijk"
 434     set $S1, "xyz"
 435     push_eh handler
 436     $S2 = replace $S0, 12, 3, $S1
 437     ok(0,"no exception")
 438 handler:
 439     .exception_is( "Can only replace inside string or index after end of string" )
 440 .end
 441
 442 .sub replace_neg_offset_repl_eq_length
 443     set $S0, "abcdefghijk"
 444     set $S1, "xyz"
 445     $S2 = replace $S0, -3, 3, $S1
 446     is( $S2, "abcdefghxyz", '' )
 447 .end
 448
 449 .sub replace_neg_offset_repl_gt_length
 450     set $S0, "abcdefghijk"
 451     set $S1, "xyz"
 452     $S2 = replace $S0, -6, 2, $S1
 453     is( $S2, "abcdexyzhijk", '' )
 454 .end
 455
 456 .sub replace_neg_offset_repl_lt_length
 457     set $S0, "abcdefghijk"
 458     set $S1, "xyz"
 459     $S2 = replace $S0, -6, 4, $S1
 460     is( $S2, "abcdexyzjk", '' )
 461 .end
 462
 463 .sub exception_replace_neg_offset_out_of_string
 464     set $S0, "abcdefghijk"
 465     set $S1, "xyz"
 466     push_eh handler
 467     $S2 = replace $S0, -12, 4, $S1
 468     ok(0,"no exception")
 469 handler:
 470     .exception_is( "Can only replace inside string or index after end of string" )
 471 .end
 472
 473 .sub replace_length_gt_strlen
 474     set $S0, "abcdefghijk"
 475     set $S1, "xyz"
 476     $S2 = replace $S0, 3, 11, $S1
 477     is( $S2, "abcxyz", '' )
 478 .end
 479
 480 .sub replace_length_gt_strlen_neg_offset
 481     set $S0, "abcdefghijk"
 482     set $S1, "xyz"
 483     $S2 = replace $S0, -3, 11, $S1
 484     is( $S2, "abcdefghxyz", '' )
 485 .end
 486
 487 .sub replace_only_substr
 488     set $S0, "abcdefghijk"
 489     set $S1, "xyz"
 490     $S2 = replace $S0, 3, 3, $S1
 491     is( $S2, "abcxyzghijk", '' )
 492 .end
 493
 494 .sub three_arg_substr
 495     set $S0, "JAPH"
 496     substr $S1, $S0, 2
 497     is( $S1, "PH", '' )
 498 .end
 499
 500 .sub exception_substr__pos_offset_zero_length_string
 501     set $S0, ""
 502     push_eh handler
 503     substr $S1, $S0, 10, 3
 504     ok(0,"no exception")
 505 handler:
 506     .exception_is( "Cannot take substr outside string" )
 507 .end
 508
 509 .sub substr_offset_zero_zero_length_string
 510     set $S0, ""
 511     substr $S1, $S0, 0, 1
 512     is( $S1, "", '' )
 513 .end
 514
 515 .sub exception_substr_offset_one_zero_length_string
 516     set $S0, ""
 517     push_eh handler
 518     substr $S1, $S0, -1, 1
 519     ok(0,"no exception")
 520 handler:
 521     .exception_is( "Cannot take substr outside string" )
 522 .end
 523
 524 .sub exception_substr_neg_offset_zero_length_string
 525     set $S0, ""
 526     push_eh handler
 527     substr $S1, $S0, -10, 5
 528 handler:
 529     .exception_is( "Cannot take substr outside string" )
 530 .end
 531
 532 .sub zero_length_substr_zero_length_string
 533     set $S0, ""
 534     substr $S1, $S0, 10, 0
 535     is( $S1, "", '' )
 536 .end
 537
 538 .sub zero_length_substr_zero_length_string
 539     set $S0, ""
 540     substr $S1, $S0, -10, 0
 541     is( $S1, "", '' )
 542 .end
 543
 544 .sub three_arg_substr_zero_length_string
 545     set $S0, ""
 546     substr $S1, $S0, 2
 547     is( $S1, "", '' )
 548 .end
 549
 550 .sub replace_zero_length_string
 551     set $S0, ""
 552     set $S1, "xyz"
 553     $S2 = replace $S0, 0, 3, $S1
 554     is( $S2, "xyz", '' )
 555
 556     set $S3, ""
 557     set $S4, "abcde"
 558     $S5 = replace $S3, 0, 0, $S4
 559     is( $S5, "abcde", '' )
 560 .end
 561
 562 .sub four_arg_substr_replace_zero_length_string
 563     set $S0, ""
 564     set $S1, "xyz"
 565     $S0 = replace $S0, 0, 3, $S1
 566     is( $S0, "xyz", '' )
 567
 568     set $S2, ""
 569     set $S3, "abcde"
 570     $S2 = replace $S2, 0, 0, $S3
 571     is( $S2, "abcde", '' )
 572 .end
 573
 574 .sub concat_s_s_sc_null_onto_null
 575     concat $S0, $S0
 576     is( $S0, "", '' )
 577     concat $S1, ""
 578     is( $S1, "", '' )
 579 .end
 580
 581 .sub concat_s_sc_repeated_two_arg_concats
 582     set $S12, ""
 583     set $I0, 0
 584 WHILE:
 585     concat $S12, "hi"
 586     add $I0, 1
 587     lt $I0, 10, WHILE
 588     is( $S12, "hihihihihihihihihihi", '' )
 589 .end
 590
 591 .sub concat_s_s_sc_foo_one_onto_null
 592     concat $S0, "foo1"
 593     set $S1, "foo2"
 594     concat $S2, $S1
 595     is( $S0, "foo1", '' )
 596     is( $S2, "foo2", '' )
 597 .end
 598
 599 .sub test_concat_s_s_sc
 600     set $S1, "fish"
 601     set $S2, "bone"
 602     concat $S1, $S2
 603     is( $S1, "fishbone", '' )
 604 .end
 605
 606 .sub concat_s_s_sc_s_sc
 607     set $S1, "japh"
 608     set $S2, "JAPH"
 609     concat $S0, "japh", "JAPH"
 610     is( $S0, "japhJAPH", '' )
 611
 612     concat $S0, $S1, "JAPH"
 613     is( $S0, "japhJAPH", '' )
 614
 615     concat $S0, "japh", $S2
 616     is( $S0, "japhJAPH", '' )
 617
 618     concat $S0, $S1, $S2
 619     is( $S0, "japhJAPH", '' )
 620 .end
 621
 622 .sub concat_ensure_copy_is_made
 623     set $S2, "JAPH"
 624     concat $S0, $S2, ""
 625     concat $S1, "", $S2
 626     $S0 = chopn $S0, 1
 627     $S1 = chopn $S1, 1
 628     is( $S2, "JAPH", '' )
 629 .end
 630
 631 .sub same_constant_twice_bug
 632    set     $S0, ""
 633    set     $S1, ""
 634    set     $S2, "foo"
 635    concat  $S1,$S1,$S2
 636    is( $S1, "foo", 'same constant twice bug' )
 637    is( $S0, "", 'same constant twice bug' )
 638 .end
 639
 640 .sub exception_two_param_ord_empty_string
 641    push_eh handler
 642    ord $I0,""
 643    ok(0, 'no exception: 2-param ord, empty string' )
 644   handler:
 645    .exception_is( 'Cannot get character of empty string' )
 646 .end
 647
 648 .sub exception_two_param_ord_empty_string_register
 649    push_eh handler
 650    ord $I0,$S0
 651    ok( 0, 'no exception: 2-param ord, empty string register' )
 652  handler:
 653    .exception_is( 'Cannot get character of NULL string' )
 654 .end
 655
 656 .sub exception_three_param_ord_empty_string
 657    push_eh handler
 658    ord $I0,"",0
 659    ok(0, 'no exception: 3-param ord, empty string' )
 660  handler:
 661    .exception_is( 'Cannot get character of empty string' )
 662 .end
 663
 664 .sub exception_three_param_ord_empty_string_register
 665    push_eh handler
 666    ord $I0,$S0,0
 667    ok( 0, 'no exception: 3-param ord, empty string register' )
 668  handler:
 669    .exception_is( 'Cannot get character of NULL string' )
 670 .end
 671
 672 .sub two_param_ord_one_character_string
 673    ord $I0,"a"
 674    is( $I0, "97", '2-param ord, one-character string' )
 675 .end
 676
 677 .sub two_param_ord_multi_character_string
 678    ord $I0,"abc"
 679    is( $I0, "97", '2-param ord, multi-character string' )
 680 .end
 681
 682 .sub two_param_ord_one_character_string_register
 683    set $S0,"a"
 684    ord $I0,$S0
 685    is( $I0, "97", '2-param ord, one-character string register' )
 686 .end
 687
 688 .sub three_param_ord_one_character_string
 689    ord $I0,"a",0
 690    is( $I0, "97", '3-param ord, one-character string' )
 691 .end
 692
 693 .sub three_param_ord_one_character_string_register
 694    set $S0,"a"
 695    ord $I0,$S0,0
 696    is( $I0, "97", '3-param ord, one-character string register' )
 697 .end
 698
 699 .sub three_param_ord_multi_character_string
 700    ord $I0,"ab",1
 701    is( $I0, "98", '3-param ord, multi-character string' )
 702 .end
 703
 704 .sub three_param_ord_multi_character_string_register
 705    set $S0,"ab"
 706    ord $I0,$S0,1
 707    is( $I0, "98", '3-param ord, multi-character string register' )
 708 .end
 709
 710 .sub exception_three_param_ord_multi_character_string
 711    push_eh handler
 712    ord $I0,"ab",2
 713    ok( 0, 'no exception: 3-param ord, multi-character string' )
 714  handler:
 715    .exception_is( 'Cannot get character past end of string' )
 716 .end
 717
 718 .sub exception_three_param_ord_multi_character_string
 719    push_eh handler
 720    set $S0,"ab"
 721    ord $I0,$S0,2
 722    ok( 0, 'no exception: 3-param ord, multi-character string' )
 723  handler:
 724    .exception_is( 'Cannot get character past end of string' )
 725 .end
 726
 727 .sub three_param_ord_one_character_string_from_end
 728    ord $I0,"a",-1
 729    is( $I0, "97", '3-param ord, one-character string, from end' )
 730 .end
 731
 732 .sub three_param_ord_one_character_string_register_from_end
 733    set $S0,"a"
 734    ord $I0,$S0,-1
 735    is( $I0, "97", '3-param ord, one-character string register, from end' )
 736 .end
 737
 738 .sub three_param_ord_multi_character_string_from_end
 739    ord $I0,"ab",-1
 740    is( $I0, "98", '3-param ord, multi-character string, from end' )
 741 .end
 742
 743 .sub three_param_ord_multi_character_string_register_from_end
 744     set $S0,"ab"
 745     ord $I0,$S0,-1
 746     is( $I0, "98", '3-param ord, multi-character string register, from end' )
 747 .end
 748
 749 .sub exception_three_param_ord_multi_character_string_register_from_end_oob
 750     push_eh handler
 751     set $S0,"ab"
 752     ord $I0,$S0,-3
 753     ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB' )
 754   handler:
 755     .exception_is( 'Cannot get character before beginning of string' )
 756 .end
 757
 758 .sub chr_of_thirty_two_is_space_in_ascii
 759     chr $S0, 32
 760     is( $S0, " ", 'chr of 32 is space in ASCII' )
 761 .end
 762
 763 .sub chr_of_sixty_five_is_a_in_ascii
 764     chr $S0, 65
 765     is( $S0, "A", 'chr of 65 is A in ASCII' )
 766 .end
 767
 768 .sub chr_of_one_hundred_and_twenty_two_is_z_in_ascii
 769     chr $S0, 122
 770     is( $S0, "z", 'chr of 122 is z in ASCII' )
 771 .end
 772
 773 .sub test_if_s_ic
 774     set $S0, "I've told you once, I've told you twice..."
 775     ok( $S0, 'normal strings are true' )
 776
 777     set $S0, "0.0"
 778     ok( $S0, '0.0 is true' )
 779
 780     set $S0, ""
 781     nok( $S0, 'empty string is false' )
 782
 783     set $S0, "0"
 784     nok( $S0, '"0" string is false' )
 785
 786     set $S0, "0e0"
 787     ok( $S0, 'string "0e0" is true' )
 788
 789     set $S0, "x"
 790     ok( $S0, 'string "x" is true' )
 791
 792     set $S0, "\\x0"
 793     ok( $S0, 'string "\\x0" is true' )
 794
 795     set $S0, "\n"
 796     ok( $S0, 'string "\n" is true' )
 797
 798     set $S0, " "
 799     ok( $S0, 'string " " is true' )
 800
 801     # An empty register should be false...
 802     nok( $S1, 'empty register is false' )
 803 .end
 804
 805 .sub repeat_s_s_sc_i_ic
 806     set $S0, "x"
 807     repeat $S1, $S0, 12
 808     is( $S0, "x", 'repeat_s_s|sc_i|ic' )
 809     is( $S1, "xxxxxxxxxxxx", 'repeat_s_s|sc_i|ic' )
 810
 811     set $I0, 12
 812     set $S2, "X"
 813     repeat $S3, $S2, $I0
 814     is( $S2, "X", 'repeat_s_s|sc_i|ic' )
 815     is( $S3, "XXXXXXXXXXXX", 'repeat_s_s|sc_i|ic' )
 816
 817     repeat $S4, "~", 12
 818     is( $S4, "~~~~~~~~~~~~", 'repeat_s_s|sc_i|ic' )
 819
 820     repeat $S5, "~", $I0
 821     is( $S5, "~~~~~~~~~~~~", 'repeat_s_s|sc_i|ic' )
 822
 823
 824     repeat $S6, "***", 0
 825     is( $S6, "", 'repeat_s_s|sc_i|ic' )
 826 .end
 827
 828 .sub exception_repeat_oob
 829     push_eh handler
 830     repeat $S0, "japh", -1
 831   handler:
 832     .exception_is( 'Cannot repeat with negative arg' )
 833 .end
 834
 835 .sub exception_repeat_oob_repeat_p_p_p
 836     push_eh handler
 837     $P0 = new ['String']
 838     $P1 = new ['String']
 839     $P2 = new ['Integer']
 840     $P2 = -1
 841     repeat $P1, $P0, $P2
 842   handler:
 843     .exception_is( 'Cannot repeat with negative arg' )
 844 .end
 845
 846 .sub exception_repeat_oob_repeate_p_p_i
 847     push_eh handler
 848     $P0 = new ['String']
 849     $P1 = new ['String']
 850     repeat $P1, $P0, -1
 851   handler:
 852     .exception_is( 'Cannot repeat with negative arg' )
 853 .end
 854
 855 .sub encodingname_oob
 856     $I0 = -1
 857     $S0 = encodingname -1
 858     $S0 = encodingname $I0
 859     ok( 1, "no exceptions in encodingname_oob" )
 860 .end
 861
 862 .sub index_three_arg_form
 863     set $S0, "Parrot"
 864     set $S1, "Par"
 865     index $I1, $S0, $S1
 866     is( $I1, "0", 'index, 3-arg form' )
 867
 868     set $S1, "rot"
 869     index $I1, $S0, $S1
 870     is( $I1, "3", 'index, 3-arg form' )
 871
 872     set $S1, "bar"
 873     index $I1, $S0, $S1
 874     is( $I1, "-1", 'index, 3-arg form' )
 875
 876     # Ascii - Non-ascii, same content
 877     set $S0, "hello"
 878     set $S1, unicode:"hello"
 879     index $I1, $S0, $S1
 880     is( $I1, "0", 'index, 3-arg form' )
 881     index $I1, $S1, $S0
 882     is( $I1, "0", 'index, 3-arg form' )
 883
 884     # Non-ascii, source shorter than searched
 885     set $S0, unicode:"-o"
 886     set $S1, unicode:"@INC"
 887     index $I1, $S0, $S1
 888     is( $I1, "-1", 'index, 3-arg form' )
 889 .end
 890
 891 .sub index_four_arg_form
 892     set $S0, "Barbarian"
 893     set $S1, "ar"
 894     index $I1, $S0, $S1, 0
 895     is( $I1, "1", 'index, 4-arg form' )
 896
 897     index $I1, $S0, $S1, 2
 898     is( $I1, "4", 'index, 4-arg form' )
 899
 900     set $S1, "qwx"
 901     index $I1, $S0, $S1, 0
 902     is( $I1, "-1", 'index, 4-arg form' )
 903
 904     # Ascii - Non-ascii, same content
 905     set $S0, "hello"
 906     set $S1, unicode:"hello"
 907     index $I1, $S0, $S1, 0
 908     is( $I1, "0", 'index, 4-arg form' )
 909     index $I1, $S1, $S0, 0
 910     is( $I1, "0", 'index, 4-arg form' )
 911 .end
 912
 913 .sub index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen
 914     set $S1, "This is not quite right"
 915     set $S0, " is "
 916     index $I0, $S1, $S0, 0
 917     is( $I0, "4", 'index, 4-arg form, bug 22718' )
 918
 919     set $S0, "is"
 920     index $I0, $S1, $S0, 0
 921     is( $I0, "2", 'index, 4-arg form, bug 22718' )
 922 .end
 923
 924 .sub index_trac_1482
 925     $S0 = unicode:"bubuc"
 926     $S1 = unicode:"buc"
 927
 928     $I0 = index $S0, $S1, 0
 929     is ($I0, 2, 'index, 4-arg, partial-match causes failure: TT #1482')
 930 .end
 931
 932 .sub index_null_strings
 933     set $S0, "Parrot"
 934     set $S1, ""
 935     index $I1, $S0, $S1
 936     is( $I1, "-1", 'index, null strings' )
 937
 938     index $I1, $S0, $S1, 0
 939     is( $I1, "-1", 'index, null strings' )
 940
 941     index $I1, $S0, $S1, 5
 942     is( $I1, "-1", 'index, null strings' )
 943
 944     index $I1, $S0, $S1, 6
 945     is( $I1, "-1", 'index, null strings' )
 946
 947     set $S0, ""
 948     set $S1, "a"
 949     index $I1, $S0, $S1
 950     is( $I1, "-1", 'index, null strings' )
 951
 952     index $I1, $S0, $S1, 0
 953     is( $I1, "-1", 'index, null strings' )
 954
 955     set $S0, "Parrot"
 956     null $S1
 957     index $I1, $S0, $S1
 958     is( $I1, "-1", 'index, null strings' )
 959
 960     null $S0
 961     null $S1
 962     index $I1, $S0, $S1
 963     is( $I1, "-1", 'index, null strings' )
 964 .end
 965
 966 .sub index_embedded_nulls
 967     set $S0, "Par\0\0rot"
 968     set $S1, "\0"
 969     index $I1, $S0, $S1
 970     is( $I1, "3", 'index, embedded nulls' )
 971
 972     index $I1, $S0, $S1, 4
 973     is( $I1, "4", 'index, embedded nulls' )
 974 .end
 975
 976 .sub index_big_strings
 977     set $S0, "a"
 978     repeat $S0, $S0, 10000
 979     set $S1, "a"
 980     repeat $S1, $S1, 500
 981     index $I1, $S0, $S1
 982     is( $I1, "0", 'index, big strings' )
 983
 984     index $I1, $S0, $S1, 1234
 985     is( $I1, "1234", 'index, big strings' )
 986
 987     index $I1, $S0, $S1, 9501
 988     is( $I1, "-1", 'index, big strings' )
 989 .end
 990
 991 # Builds a 24th iteration fibonacci string (approx. 100K)
 992 .sub index_big_hard_to_match_strings
 993     set $S1, "a"
 994     set $S2, "b"
 995     set $I0, 0
 996   LOOP:
 997     set $S3, $S1
 998     concat $S1, $S2, $S3
 999     set $S2, $S3
1000     inc $I0
1001     lt $I0, 24, LOOP
1002     index $I1, $S1, $S2
1003     is( $I1, "46368", 'index, big, hard to match strings' )
1004     index $I1, $S1, $S2, 50000
1005     is( $I1, "-1", 'index, big, hard to match strings' )
1006 .end
1007
1008 .sub index_with_different_charsets
1009     set $S0, "Parrot"
1010     set $S1, "rot"
1011     index $I1, $S0, $S1
1012     is( $I1, "3", 'default - default' )
1013
1014     set $S0, ascii:"Parrot"
1015     set $S1, ascii:"rot"
1016     index $I1, $S0, $S1
1017     is( $I1, "3", 'ascii - ascii')
1018
1019     set $S0, "Parrot"
1020     set $S1, ascii:"rot"
1021     index $I1, $S0, $S1
1022     is( $I1, "3", 'default - ascii' )
1023
1024     set $S0, ascii:"Parrot"
1025     set $S1, "rot"
1026     index $I1, $S0, $S1
1027     is( $I1, "3", 'ascii - default' )
1028
1029     set $S0, binary:"Parrot"
1030     set $S1, binary:"rot"
1031     index $I1, $S0, $S1
1032     is( $I1, 3, 'binary - binary' )
1033 .end
1034
1035 .sub negative_index_bug_35959
1036     index $I1, "u", "t", -123456
1037     is( $I1, "-1", 'negative index #35959' )
1038
1039     index $I1, "u", "t", -123456789
1040     is( $I1, "-1", 'negative index #35959' )
1041 .end
1042
1043 .sub index_multibyte_matching
1044     skip( 3, "Pending rework of creating non-ascii literals" )
1045
1046     # set $S0, "\xAB"
1047     # find_chartype $I0, "8859-1"
1048     # set_chartype $S0, $I0
1049     # find_encoding $I0, "singlebyte"
1050     # set_encoding $S0, $I0
1051     # find_encoding $I0, "utf8"
1052     # find_chartype $I1, "unicode"
1053     # transcode $S1, $S0, $I0, $I1
1054     # is( $S0, $S1, 'equal' );
1055
1056     # index $I0, $S0, $S1
1057     # is( $I0, "0", 'index, multibyte matching' )
1058
1059     # index $I0, $S1, $S0
1060     # is( $I0, "0", 'index, multibyte matching' )
1061 .end
1062
1063 .sub index_multibyte_matching_two
1064     skip( 2, "Pending rework of creating non-ascii literals" )
1065     # set $S0, "\xAB\xBA"
1066     # set $S1, "foo\xAB\xAB\xBAbar"
1067     # find_chartype $I0, "8859-1"
1068     # set_chartype $S0, $I0
1069     # find_encoding $I0, "singlebyte"
1070     # set_encoding $S0, $I0
1071     # find_chartype $I0, "unicode"
1072     # find_encoding $I1, "utf8"
1073     # transcode $S1, $S1, $I1, $I0
1074     # index $I0, $S0, $S1
1075     # is( $I0, "-1", 'index, multibyte matching 2' )
1076     # index $I0, $S1, $S0
1077     # is( $I0, "4", 'index, multibyte matching 2' )
1078 .end
1079
1080 .sub num_to_string
1081     set $N0, 80.43
1082     set $S0, $N0
1083     is( $S0, "80.43", 'num to string' )
1084
1085     set $N0, -1.111111
1086     set $S0, $N0
1087     is( $S0, "-1.111111", 'num to string' )
1088 .end
1089
1090 .sub string_to_int
1091     set $S0, "123"
1092     set $I0, $S0
1093     is( $I0, "123", 'string to int' )
1094
1095     set $S0, " 1"
1096     set $I0, $S0
1097     is( $I0, "1", 'string to int' )
1098
1099     set $S0, "-1"
1100     set $I0, $S0
1101     is( $I0, "-1", 'string to int' )
1102
1103     set     $S0, "Not a number"
1104     set $I0, $S0
1105     is( $I0, "0", 'string to int' )
1106
1107     set $S0, ""
1108     set $I0, $S0
1109     is( $I0, "0", 'string to int' )
1110 .end
1111
1112 .sub string_to_num
1113     set $S0, "6foo"
1114     set $N0, $S0
1115     is( $N0, "6", '6foo to num' )
1116
1117     set $S0, "16foo"
1118     set $N0, $S0
1119     is( $N0, "16", '16foo to num' )
1120 .end
1121
1122 .sub concat_or_substr_cow
1123     set $S0, "<JA"
1124     set $S1, "PH>"
1125     set $S2, ""
1126     concat $S2, $S2, $S0
1127     concat $S2, $S2, $S1
1128     is( $S2, "<JAPH>", 'concat/substr (COW)' )
1129
1130     substr $S0, $S2, 1, 4
1131     is( $S0, "JAPH", 'concat/substr (COW)' )
1132 .end
1133
1134 .sub constant_to_cstring
1135     stringinfo $I0, "\n", 2
1136     stringinfo $I1, "\n", 2
1137     is( $I1, $I0, 'constant to cstring' )
1138
1139     stringinfo $I2, "\n", 2
1140     is( $I2, $I0, 'constant to cstring' )
1141 .end
1142
1143 .sub cow_with_chopn_leaving_original_untouched
1144     set $S0, "ABCD"
1145     clone $S1, $S0
1146     $S0 = chopn $S0, 1
1147     is( $S0, "ABC", 'COW with chopn leaving original untouched' )
1148     is( $S1, "ABCD", 'COW with chopn leaving original untouched' )
1149 .end
1150
1151 .sub check_that_bug_bug_16874_was_fixed
1152     set $S0,  "foo     "
1153     set $S1,  "bar     "
1154     set $S2,  "quux    "
1155     set $S15, ""
1156     concat $S15, $S0
1157     concat $S15, $S1
1158     concat $S15, $S2
1159     is( $S15, "foo     bar     quux    ", 'Check that bug #16874 was fixed' )
1160 .end
1161
1162 .sub stress_concat
1163     set $I0, 1000
1164     set $S0, "michael"
1165   LOOP:
1166     set $S2, $I0
1167     concat $S1, $S0, $S2
1168     concat $S3, "mic", "hael"
1169     concat $S3, $S3, $S2
1170     eq $S1, $S3, BOTTOM
1171     ok(0, 'failed stress concat test')
1172     end
1173
1174   BOTTOM:
1175     sub $I0, $I0, 1
1176     ne $I0, 0, LOOP
1177     ok(1, 'stress concat test')
1178 .end
1179
1180 .sub ord_and_substring_see_bug_17035
1181     set $S0, "abcdef"
1182     substr $S1, $S0, 2, 3
1183     ord $I0, $S0, 2
1184     ord $I1, $S1, 0
1185     ne $I0, $I1, fail
1186     ord $I0, $S0, 3
1187     ord $I1, $S1, 1
1188     ne $I0, $I1, fail
1189     ord $I0, $S0, 4
1190     ord $I1, $S1, 2
1191     ne $I0, $I1, fail
1192     ok(1, 'ord and substring #17035')
1193     goto end
1194   fail:
1195     ok(0, 'failed: ord and substring #17035')
1196   end:
1197 .end
1198
1199 .sub test_sprintf
1200     branch MAIN
1201   NEWARYP:
1202     new $P1, 'ResizablePMCArray'
1203     set $P1[0], $P0
1204     local_return $P4
1205   NEWARYS:
1206     new $P1, 'ResizablePMCArray'
1207     set $P1[0], $S0
1208     local_return $P4
1209   NEWARYI:
1210     new $P1, 'ResizablePMCArray'
1211     set $P1[0], $I0
1212     local_return $P4
1213   NEWARYN:
1214     new $P1, 'ResizablePMCArray'
1215     set $P1[0], $N0
1216     local_return $P4
1217   PRINTF:
1218     sprintf $S2, $S1, $P1
1219     is( $S2, $S99, $S1 )
1220     local_return $P4
1221
1222   MAIN:
1223     new $P4, 'ResizableIntegerArray'
1224     set $S1, "Hello, %s"
1225     set $S0, "Parrot!"
1226     set $S99, "Hello, Parrot!"
1227     local_branch $P4, NEWARYS
1228     local_branch $P4, PRINTF
1229
1230     set $S1, "Hash[0x%x]"
1231     set $I0, 256
1232     set $S99, "Hash[0x100]"
1233     local_branch $P4, NEWARYI
1234     local_branch $P4, PRINTF
1235
1236     set $S1, "Hash[0x%lx]"
1237     set $I0, 256
1238     set $S99, "Hash[0x100]"
1239     local_branch $P4, NEWARYI
1240     local_branch $P4, PRINTF
1241
1242     set $S1, "Hello, %.2s!"
1243     set $S0, "Parrot"
1244     set $S99, "Hello, Pa!"
1245     local_branch $P4, NEWARYS
1246     local_branch $P4, PRINTF
1247
1248     set $S1, "Hello, %Ss"
1249     set $S0, $S2
1250     set $S99, "Hello, Hello, Pa!"
1251     local_branch $P4, NEWARYS
1252     local_branch $P4, PRINTF
1253
1254     set $S1, "1 == %Pd"
1255     new $P0, 'Integer'
1256     set $P0, 1
1257     set $S99, "1 == 1"
1258     local_branch $P4, NEWARYP
1259     local_branch $P4, PRINTF
1260
1261     set $S1, "-255 == %vd"
1262     set $I0, -255
1263     set $S99, "-255 == -255"
1264     local_branch $P4, NEWARYI
1265     local_branch $P4, PRINTF
1266
1267     set $S1, "+123 == %+vd"
1268     set $I0, 123
1269     set $S99, "+123 == +123"
1270     local_branch $P4, NEWARYI
1271     local_branch $P4, PRINTF
1272
1273     set $S1, "256 == %vu"
1274     set $I0, 256
1275     set $S99, "256 == 256"
1276     local_branch $P4, NEWARYI
1277     local_branch $P4, PRINTF
1278
1279     set $S1, "1 == %+vu"
1280     set $I0, 1
1281     set $S99, "1 == 1"
1282     local_branch $P4, NEWARYI
1283     local_branch $P4, PRINTF
1284
1285     set $S1, "001 == %0.3u"
1286     set $I0, 1
1287     set $S99, "001 == 001"
1288     local_branch $P4, NEWARYI
1289     local_branch $P4, PRINTF
1290
1291     set $S1, "001 == %+0.3u"
1292     set $I0, 1
1293     set $S99, "001 == 001"
1294     local_branch $P4, NEWARYI
1295     local_branch $P4, PRINTF
1296
1297     set $S1, "0.500000 == %f"
1298     set $N0, 0.5
1299     set $S99, "0.500000 == 0.500000"
1300     local_branch $P4, NEWARYN
1301     local_branch $P4, PRINTF
1302
1303     set $S1, "0.500 == %5.3f"
1304     set $N0, 0.5
1305     set $S99, "0.500 == 0.500"
1306     local_branch $P4, NEWARYN
1307     local_branch $P4, PRINTF
1308
1309     set $S1, "0.001 == %g"
1310     set $N0, 0.001
1311     set $S99, "0.001 == 0.001"
1312     local_branch $P4, NEWARYN
1313     local_branch $P4, PRINTF
1314
1315     set $S1, "1e+06 == %g"
1316     set $N0, 1.0e6
1317     set $S99, "1e+06 == 1e+06"
1318     local_branch $P4, NEWARYN
1319     local_branch $P4, PRINTF
1320
1321     set $S1, "0.5 == %3.3g"
1322     set $N0, 0.5
1323     set $S99, "0.5 == 0.5"
1324     local_branch $P4, NEWARYN
1325     local_branch $P4, PRINTF
1326
1327     set $S1, "%% == %%"
1328     set $I0, 0
1329     set $S99, "% == %"
1330     local_branch $P4, NEWARYI
1331     local_branch $P4, PRINTF
1332
1333     set $S1, "That's all, %s"
1334     set $S0, "folks!"
1335     set $S99, "That's all, folks!"
1336     local_branch $P4, NEWARYS
1337     local_branch $P4, PRINTF
1338 .end
1339
1340 .sub other_form_of_sprintf_op
1341     new $P4, 'ResizableIntegerArray'
1342     new $P3, 'String'
1343     new $P2, 'String'
1344     set $P2, "15 is %b"
1345     new $P1, 'ResizablePMCArray'
1346     set $P1[0], 15
1347     sprintf $P3, $P2, $P1
1348     is( $P3, "15 is 1111", 'other form of sprintf op' )
1349
1350     new $P2, 'String'
1351     set $P2, "128 is %o"
1352     new $P1, 'ResizablePMCArray'
1353     set $P1[0], 128
1354     sprintf $P3, $P2, $P1
1355     is( $P3, "128 is 200", 'other form of sprintf op' )
1356 .end
1357
1358 .sub sprintf_left_justify
1359     $P0 = new 'ResizablePMCArray'
1360     $P1 = new 'Integer'
1361     $P1 = 10
1362     $P0[0] = $P1
1363     $P1 = new 'String'
1364     $P1 = "foo"
1365     $P0[1] = $P1
1366     $P1 = new 'String'
1367     $P1 = "bar"
1368     $P0[2] = $P1
1369     $S0 = sprintf "%-*s - %s", $P0
1370     is( $S0, "foo        - bar", 'sprintf - left justify' )
1371 .end
1372
1373
1374 .sub correct_precision_for_sprintf_x
1375     .include "iglobals.pasm"
1376
1377     # Create the string via concat
1378     .local pmc interp     # a handle to our interpreter object.
1379     interp = getinterp
1380     .local pmc config
1381     config = interp[.IGLOBALS_CONFIG_HASH]
1382     .local int intvalsize
1383     intvalsize = config['intvalsize']
1384
1385     $S0 = ''
1386     $I0 = 1
1387     $I1 = intvalsize * 2
1388   loop:
1389     concat $S0, 'f'
1390     inc $I0
1391     le $I0, $I1, loop
1392   padding_loop:
1393     concat $S0, ' '
1394     inc $I0
1395     le $I0, 20, padding_loop
1396
1397     # Now see what sprintf comes up with
1398     $P0 = new 'ResizablePMCArray'
1399     $P0[0] = -1
1400     $S1 = sprintf "%-20x", $P0
1401     is( $S1, $S0, 'Correct precision for %x' )
1402 .end
1403
1404 .sub test_find_encoding
1405     skip( 4, "Pending reimplementation of find_encoding" )
1406     # find_encoding $I0, "singlebyte"
1407     # is( $I0, "0", 'find_encoding' )
1408     # find_encoding $I0, "utf8"
1409     # is( $I0, "1", 'find_encoding' )
1410     # find_encoding $I0, "utf16"
1411     # is( $I0, "2", 'find_encoding' )
1412     # find_encoding $I0, "utf32"
1413     # is( $I0, "3", 'find_encoding' )
1414 .end
1415
1416 .sub test_assign
1417     set $S4, "JAPH"
1418     assign  $S5, $S4
1419     is( $S4, "JAPH", 'assign' )
1420     is( $S5, "JAPH", 'assign' )
1421 .end
1422
1423 .sub assign_and_globber
1424     set $S4, "JAPH"
1425     assign  $S5, $S4
1426     assign  $S4, "Parrot"
1427     is( $S4, "Parrot", 'assign & globber' )
1428     is( $S5, "JAPH", 'assign & globber' )
1429 .end
1430
1431 .sub split_on_null_string
1432     .local string s, delim
1433     .local pmc p
1434     .local int i
1435     null s
1436     null delim
1437     split p, s, delim
1438     i = isnull p
1439     is(i, 1, 'split on null string and delim')
1440
1441     s = 'foo'
1442     split p, s, delim
1443     i = isnull p
1444     is(i, 1, 'split on null delim')
1445
1446     null s
1447     delim = 'bar'
1448     split p, s, delim
1449     i = isnull p
1450     is(i, 1, 'split on null string')
1451 .end
1452
1453 .sub split_on_empty_string
1454     split $P1, "", ""
1455     set $I1, $P1
1456     is( $I1, "0", 'split on empty string' )
1457
1458     split $P0, "", "ab"
1459     set $I0, $P0
1460     is( $I0, "2", 'split on empty string' )
1461
1462     set $S0, $P0[0]
1463     is( $S0, "a", 'split on empty string' )
1464
1465     set $S0, $P0[1]
1466     is( $S0, "b", 'split on empty string' )
1467 .end
1468
1469 .sub split_on_non_empty_string
1470     split $P0, "a", "afooabara"
1471     set $I0, $P0
1472     is( $I0, "5", 'split on non-empty string' )
1473
1474     set $S0, $P0[0]
1475     is( $S0, "", 'split on non-empty string' )
1476     set $S0, $P0[1]
1477     is( $S0, "foo", 'split on non-empty string' )
1478     set $S0, $P0[2]
1479     is( $S0, "b", 'split on non-empty string' )
1480     set $S0, $P0[3]
1481     is( $S0, "r", 'split on non-empty string' )
1482     set $S0, $P0[4]
1483     is( $S0, "", 'split on non-empty string' )
1484 .end
1485
1486 .sub test_join
1487     new $P0, 'ResizablePMCArray'
1488     join $S0, "--", $P0
1489     is( $S0, "", 'join' )
1490
1491     push $P0, "a"
1492     join $S0, "--", $P0
1493     is( $S0, "a", 'join' )
1494
1495     new $P0, 'ResizablePMCArray'
1496     push $P0, "a"
1497     push $P0, "b"
1498     join $S0, "--", $P0
1499     is( $S0, "a--b", 'join' )
1500 .end
1501
1502 .sub 'test_join_many'
1503     $P1 = new ['ResizablePMCArray']
1504     $I0 = 0
1505   loop:
1506     unless $I0 < 20000 goto done
1507     $P2 = new ['Integer']
1508     assign $P2, $I0
1509     push $P1, $P2
1510     inc $I0
1511     goto loop
1512   done:
1513     $S0 = join ' ', $P1
1514     ok("Join of many temporary strings doesn't crash")
1515 .end
1516
1517 # join: get_string returns a null string --------
1518 .namespace ["Foo5"]
1519     .sub get_string :vtable :method
1520         .local string ret
1521         null ret
1522         .begin_return
1523         .set_return ret
1524         .end_return
1525     .end
1526 .namespace []   # revert to root for next test
1527 .sub join_get_string_returns_a_null_string
1528     newclass $P0, "Foo5"
1529     new $P0, 'ResizablePMCArray'
1530     $P1 = new "Foo5"
1531     push $P0, $P1
1532     join $S0, "", $P0
1533     is( $S0, "", 'join: get_string returns a null string' )
1534 .end
1535
1536 .sub eq_addr_or_ne_addr
1537     set $S0, "Test"
1538     set $S1, $S0
1539
1540     set $I99, 1
1541     eq_addr $S1, $S0, OK1
1542       set $I99, 0
1543   OK1:
1544     ok($I99, 'eq_addr/ne_addr')
1545
1546     set $S0, $S1
1547     set $I99, 0
1548     ne_addr $S1, $S0, BAD4
1549       set $I99, 1
1550   BAD4:
1551     ok($I99, 'eq_addr/ne_addr')
1552 .end
1553
1554 .sub test_if_null_s_ic
1555     set $S0, "foo"
1556     $I99 = 0
1557     if_null $S0, ERROR
1558       $I99 = 1
1559   ERROR:
1560     ok($I99, 'if_null s_ic' )
1561
1562     null $S0
1563     $I99 = 1
1564     if_null $S0, OK
1565         $I99 = 0
1566   OK:
1567     ok($I99, 'if_null s_ic' )
1568 .end
1569
1570 .sub test_upcase
1571     set $S0, "abCD012yz"
1572     upcase $S1, $S0
1573     is( $S1, "ABCD012YZ", 'upcase' )
1574
1575     push_eh catch1
1576     null $S9
1577     null $S0
1578     upcase $S1, $S0
1579     pop_eh
1580     goto null1
1581 catch1:
1582     .get_results($P9)
1583     $S9 = $P9['message']
1584     pop_eh
1585 null1:
1586     is ($S9, "Can't upcase NULL string", 'upcase null')
1587
1588     push_eh catch2
1589     null $S9
1590     null $S0
1591     $S0 = upcase $S0
1592     pop_eh
1593     goto null2
1594 catch2:
1595     .get_results($P9)
1596     $S9 = $P9['message']
1597     pop_eh
1598 null2:
1599     is ($S9, "Can't upcase NULL string", 'upcase inplace null')
1600 .end
1601
1602 .sub test_downcase
1603     set $S0, "ABcd012YZ"
1604     downcase $S1, $S0
1605     is( $S1, "abcd012yz", 'downcase' )
1606
1607     push_eh catch1
1608     null $S9
1609     null $S0
1610     downcase $S1, $S0
1611     pop_eh
1612     goto null1
1613 catch1:
1614     .get_results($P9)
1615     $S9 = $P9['message']
1616     pop_eh
1617 null1:
1618     is ($S9, "Can't downcase NULL string", 'downcase null')
1619
1620     push_eh catch2
1621     null $S9
1622     null $S0
1623     $S0 = downcase $S0
1624     pop_eh
1625     goto null2
1626 catch2:
1627     .get_results($P9)
1628     $S9 = $P9['message']
1629     pop_eh
1630 null2:
1631     is ($S9, "Can't downcase NULL string", 'downcase inplace null')
1632 .end
1633
1634 .sub test_titlecase
1635     set $S0, "aBcd012YZ"
1636     titlecase $S1, $S0
1637     is( $S1, "Abcd012yz", 'titlecase' )
1638
1639     push_eh catch1
1640     null $S9
1641     null $S0
1642     titlecase $S1, $S0
1643     pop_eh
1644     goto null1
1645 catch1:
1646     .get_results($P9)
1647     $S9 = $P9['message']
1648     pop_eh
1649 null1:
1650     is ($S9, "Can't titlecase NULL string", 'titlecase null')
1651
1652     push_eh catch2
1653     null $S9
1654     null $S0
1655     $S0 = titlecase $S0
1656     pop_eh
1657     goto null2
1658 catch2:
1659     .get_results($P9)
1660     $S9 = $P9['message']
1661     pop_eh
1662 null2:
1663     is ($S9, "Can't titlecase NULL string", 'titlecase inplace null')
1664 .end
1665
1666 .sub three_param_ord_one_character_string_register_i
1667     set $S0,"a"
1668     set $I1, 0
1669     ord $I0,$S0,$I1
1670     is( $I0, "97", '3-param ord, one-character string register, I' )
1671 .end
1672
1673 .sub three_param_ord_multi_character_string_i
1674     set $I1, 1
1675     ord $I0,"ab",$I1
1676     is( $I0, "98", '3-param ord, multi-character string, I' )
1677 .end
1678
1679 .sub three_param_ord_multi_character_string_register_i
1680     set $I1, 1
1681     set $S0,"ab"
1682     ord $I0,$S0,$I1
1683     is( $I0, "98", '3-param ord, multi-character string register, I' )
1684 .end
1685
1686 .sub exception_three_param_ord_multi_character_string_i
1687     push_eh handler
1688     set $I1, 2
1689     ord $I0,"ab",$I1
1690     ok( 0, 'no exception: 3-param ord, multi-character string, I' )
1691   handler:
1692     .exception_is( 'Cannot get character past end of string' )
1693 .end
1694
1695 .sub exception_three_param_ord_multi_character_string_i
1696     push_eh handler
1697     set $I1, 2
1698     set $S0,"ab"
1699     ord $I0,$S0,$I1
1700     ok( 0, 'no exception: 3-param ord, multi-character string, I' )
1701   handler:
1702     .exception_is( 'Cannot get character past end of string' )
1703 .end
1704
1705 .sub three_param_ord_one_character_string_from_end_i
1706     set $I1, -1
1707     ord $I0,"a",$I1
1708     is( $I0, "97", '3-param ord, one-character string, from end, I' )
1709 .end
1710
1711 .sub three_param_ord_one_character_string_register_from_end_i
1712     set $I1, -1
1713     set $S0,"a"
1714     ord $I0,$S0,$I1
1715     is( $I0, "97", '3-param ord, one-character string register, from end, I' )
1716 .end
1717
1718 .sub three_param_ord_multi_character_string_from_end_i
1719     set $I1, -1
1720     ord $I0,"ab",$I1
1721     is( $I0, "98", '3-param ord, multi-character string, from end, I' )
1722 .end
1723
1724 .sub three_param_ord_multi_character_string_register_from_end_i
1725     set $I1, -1
1726     set $S0,"ab"
1727     ord $I0,$S0,$I1
1728     is( $I0, "98", '3-param ord, multi-character string register, from end, I' )
1729 .end
1730
1731 .sub exception_three_param_ord_multi_character_string_register_from_end_oob_i
1732     push_eh handler
1733     set $I1, -3
1734     set $S0,"ab"
1735     ord $I0,$S0,$I1
1736     ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB, I' )
1737   handler:
1738     .exception_is( 'Cannot get character before beginning of string' )
1739 .end
1740
1741 # Utility method for more_string_to_int
1742 .sub 'print_as_integer'
1743     .param string s
1744     .param string answer
1745     $I0 = s
1746     concat $S99, 'string to int: ', s
1747     is( $I0, answer, $S99 )
1748 .end
1749
1750 .sub more_string_to_int
1751     print_as_integer('-4', "-4")
1752     print_as_integer('X-4',"0")
1753     print_as_integer('--4',"0")
1754     print_as_integer('+',"0")
1755     print_as_integer('++',"0")
1756     print_as_integer('+2',"2")
1757     print_as_integer(' +3',"3")
1758     print_as_integer('++4',"0")
1759     print_as_integer('+ 5',"0")
1760     print_as_integer('-',"0")
1761     print_as_integer('--56',"0")
1762     print_as_integer('  -+67',"0")
1763     print_as_integer('+-78',"0")
1764     print_as_integer('  -089xyz',"-89")
1765     print_as_integer('- 89',"0")
1766 .end
1767
1768 # Utility sub for constant_string_and_modify_in_situ_op_rt_bug_60030
1769 .sub doit_sub_for_but_60030
1770     .param string s
1771     $I0 = index s, '::'
1772     is( s, "Foo::Bar", 'bug 60030' )
1773     s = replace s, $I0, 2, "/"
1774     is( s, "Foo/Bar", 'bug 60030' )
1775     collect
1776     is( s, "Foo/Bar", 'bug 60030' )
1777 .end
1778 .sub constant_string_and_modify_in_situ_op_rt_bug_60030
1779
1780     doit_sub_for_but_60030('Foo::Bar')
1781     # repeat to prove that the constant 'Foo4::Bar4' remains unchanged
1782     doit_sub_for_but_60030('Foo::Bar')
1783 .end
1784
1785 .sub corner_cases_of_numification
1786     is( 2147483647.0, "2147483647", 'corner cases of numification' )
1787     is( -2147483648.0, "-2147483648", 'corner cases of numification' )
1788 .end
1789
1790 .sub non_canonical_nan_and_inf
1791     $N0 = 'nan'
1792     is( $N0, "NaN", 'Non canonical nan and inf' )
1793
1794     $N0 = 'iNf'
1795     is( $N0, "Inf", 'Non canonical nan and inf' )
1796
1797     $N0 = 'INFINITY'
1798     is( $N0, "Inf", 'Non canonical nan and inf' )
1799
1800     $N0 = '-INF'
1801     is( $N0, "-Inf", 'Non canonical nan and inf' )
1802
1803     $N0 = '-Infinity'
1804     is( $N0, "-Inf", 'Non canonical nan and inf' )
1805 .end
1806
1807 .HLL 'foohll'
1808 .sub split_hll_mapped
1809     .include 'test_more.pir'
1810
1811     .local pmc RSA, fooRSA
1812     RSA = get_class ['ResizableStringArray']
1813     fooRSA = subclass ['ResizableStringArray'], 'fooRSA'
1814
1815     .local pmc interp
1816     interp = getinterp
1817     interp.'hll_map'(RSA, fooRSA)
1818
1819     .local pmc a
1820     split a, "a", "afooabara"
1821
1822     .local string t
1823     t = typeof a
1824     is( t, 'fooRSA', 'split - hll mapped' )
1825
1826     .local int n, i
1827     n = a
1828     is( n, '5', 'split - hll mapped' )
1829
1830     .local string s
1831     s = a[0]
1832     is( s, '', 'split - hll mapped' )
1833     s = a[1]
1834     is( s, 'foo', 'split - hll mapped' )
1835     s = a[2]
1836     is( s, 'b', 'split - hll mapped' )
1837     s = a[3]
1838     is( s, 'r', 'split - hll mapped' )
1839     s = a[4]
1840     is( s, '', 'split - hll mapped' )
1841 .end
1842
1843 # Local Variables:
1844 #   mode: pir
1845 #   fill-column: 100
1846 # End:
1847 # vim: expandtab shiftwidth=4 ft=pir: