t/pmc/objects.t

   1 #! parrot
   2 # Copyright (C) 2001-2009, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/pmc/objects.t - Objects
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/pmc/objects.t
  12
  13 =head1 DESCRIPTION
  14
  15 Tests the object/class subsystem.
  16
  17 =cut
  18
  19 .sub main :main
  20     .include 'test_more.pir'
  21     .include "iglobals.pasm"
  22     .include "interpinfo.pasm"
  23
  24     plan(194)
  25
  26     get_classname_from_class()
  27     test_get_class()
  28     test_isa()
  29     does_scalar()
  30     does_array()
  31     new_object()
  32     new_object__isa_test()
  33     new_object__classname()
  34     isa_subclass()
  35     isa_subclass__objects()
  36     test_addmethod()
  37     test_addattribute()
  38     addattribute_subclass()
  39     addattribute_subclass__same_name()
  40     set_and_get_object_attribs()
  41     set_and_get_multiple_object_attribs()
  42     attribute_values_are_specific_to_objects()
  43     attribute_values_and_subclassing()
  44     attribute_values_and_subclassing_2()
  45     PMC_as_classes__overridden_mmd_methods()
  46     typeof_class()
  47     typeof_objects()
  48     multiple_inheritance__with_attributes()
  49     attributes_two_levels_of_inheritance()
  50     class_op_test()
  51     anon_subclass_has_no_name()
  52     get_attrib_by_name()
  53     get_attrib_by_name_subclass()
  54     set_attrib_by_name_subclass()
  55     PMC_as_classes()
  56     PMC_as_classes__subclass()
  57     PMC_as_classes__instantiate()
  58     PMC_as_classes__methods()
  59     PMC_as_classes__mmd_methods()
  60     PMC_as_classes__derived_1()
  61     PMC_as_classes__derived_2()
  62     PMC_as_classes__derived_3()
  63     subclassing_Class()
  64     namespace_vs_name()
  65     multiple_anon_classes()
  66     subclassed_Integer_bug()
  67     equality_of_subclassed_Integer()
  68     short_name_attributes()
  69     init_with_and_without_arg()
  70     newclass_bracket_parsing()
  71     verify_namespace_types()
  72     verify_data_type()
  73     new_keyed()
  74     new_keyed_2()
  75     new_keyed_3()
  76     subclass_keyed()
  77     test_class_name_multipart_name()
  78     test_get_class_multipart_name()
  79     isa_bug()
  80     new_nested_ordering()
  81     vtable_override_once_removed()
  82     vtable_fails_for_subclasses_of_core_classes()
  83     super___init_called_twice()
  84     using_class_object_from_typeof_op_with_new()
  85     setting_non_existent_attribute()
  86     setting_non_existent_attribute_by_name()
  87     getting_null_attribute()
  88     getting_non_existent_attribute()
  89     addparent_exceptions_1()
  90     addparent_exceptions_2()
  91     subclassing_a_non_existent_class()
  92     anon_subclass_of_non_existent_class()
  93     addattribute_duplicate()
  94     wrong_way_to_create_new_objects()
  95     attribute_values__subclassing_access_meths()
  96     attribute_values__inherited_access_meths()
  97
  98     # END_OF_TESTS
  99 .end
 100
 101 .sub get_classname_from_class
 102     newclass $P1, "Foo5"
 103     set $S0, $P1
 104     is( $S0, "Foo5", "got classname Foo5" )
 105
 106     subclass $P2, $P1, "Bar5"
 107     set $S1, $P2
 108     is( $S1, "Bar5", "got subclass Bar5" )
 109
 110     subclass $P3, "Foo5", "Baz5"
 111     set $S2, $P3
 112     is( $S2, "Baz5", "got subclass Baz5" )
 113 .end
 114
 115 .sub test_get_class
 116     newclass $P1, "Foo6"
 117     get_class $P2, "Foo6"
 118     set $S2, $P2
 119     is( $S2, "Foo6", 'get_class for Foo6' )
 120
 121     subclass $P3, $P1, "FooBar6"
 122     get_class $P4, "FooBar6"
 123     set $S4, $P4
 124     is( $S4, 'FooBar6', 'get_class for FooBar6' )
 125
 126     get_class $P3, "NoSuch6"
 127     isnull $I0, $P3
 128     ok( $I0, "no class for 'NoSuch6'" )
 129 .end
 130
 131 .sub test_isa
 132     new $P1, ['Boolean']
 133
 134     isa $I0, $P1, "Boolean"
 135     is( $I0, 1, 'Boolean isa Boolean' )
 136
 137     isa $I0, $P1, "Bool"
 138     is( $I0, 0, 'Boolean !isa Bool' )
 139
 140     isa $I0, $P1, "scalar"
 141     is( $I0, 1, 'Boolean isa scalar' )
 142
 143     isa $I0, $P1, "calar"
 144     is( $I0, 0, 'Boolean !isa calar' )
 145
 146     isa $I0, $P1, "Integer"
 147     is( $I0, 1, 'Boolean isa Integer' )
 148
 149     isa $I0, $P1, "Integ"
 150     is( $I0, 0, 'Boolean !isa Integ' )
 151
 152     isa $I0, $P1, "eger"
 153     is( $I0, 0, 'Boolean !isa eger' )
 154
 155     isa $I0, $P1, " "
 156     is( $I0, 0, 'Boolean !isa " "' )
 157
 158     isa $I0, $P1, ""
 159     is( $I0, 0, 'Boolean !isa ""' )
 160
 161     null $S0
 162     isa $I0, $P1, $S0
 163     is( $I0, 0, 'Boolean !isa null $S0' )
 164
 165     set $S0, "scalar"
 166     isa $I0, $P1, $S0
 167     is( $I0, 1, 'Boolean isa scalar $S0' )
 168 .end
 169
 170 .sub does_scalar
 171     new $P1, ['Boolean']
 172
 173     does $I0, $P1, "Boolean"
 174     is( $I0, 0, 'Boolean !does Boolean' )
 175
 176     does $I0, $P1, "Bool"
 177     is( $I0, 0, 'Boolean !does Bool' )
 178
 179     does $I0, $P1, "scalar"
 180     is( $I0, 1, 'Boolean does scalar' )
 181 .end
 182
 183 .sub does_array
 184     new $P1, ['OrderedHash']
 185
 186     does $I0, $P1, "Boolean"
 187     is( $I0, 0, 'OrderedHash !does Boolean' )
 188
 189     does $I0, $P1, "Bool"
 190     is( $I0, 0, 'OrderedHash !does Bool' )
 191
 192     does $I0, $P1, "hash"
 193     is( $I0, 1, 'OrderedHash does hash' )
 194
 195     does $I0, $P1, "array"
 196     is( $I0, 1, 'OrderedHash does array' )
 197 .end
 198
 199 .sub new_object
 200     newclass $P1, "Foo7"
 201     new $P2, "Foo7"
 202     ok( 1, 'created new object from Foo7 class' )
 203 .end
 204
 205 .sub new_object__isa_test
 206     newclass $P1, "Foo8"
 207     new $P2, $P1
 208     ok( 1, 'created new object from Foo8 class' )
 209
 210     isa $I0, $P2, "Foo8"
 211     ok( $I0, 'new object isa Foo8' )
 212 .end
 213
 214 .sub new_object__classname
 215     newclass $P1, "Foo9"
 216     new $P2, $P1
 217     set $S0, $P1    # class
 218     is( $S0, "Foo9", 'new object from Foo9 class as a string is Foo9' )
 219
 220     typeof $S0, $P2 # object
 221     is( $S0, 'Foo9', 'typeof obj is Foo9' )
 222
 223     class $P3, $P1
 224     set $S0, $P1    # class
 225     is( $S0, 'Foo9', 'class of obj is Foo9' )
 226
 227     typeof $S0, $P2 # object
 228     is( $S0, 'Foo9', 'typeof obj is Foo9' )
 229
 230 .end
 231
 232 .sub isa_subclass
 233     newclass $P1, "Foo10"
 234     subclass $P2, $P1, "Bar10"
 235
 236     isa_ok( $P2, "Foo10", 'newclass isa Foo10' )
 237     isa_ok( $P2, "Bar10", 'new subclass isa Bar10' )
 238     isa_ok( $P2, "Foo10", 'new subclass isa parent' )
 239     isa_ok( $P2, "Class", 'new subclass isa Class' )
 240
 241     isa $I0, $P2, "Object"
 242     is( $I0, 0, 'new subclass !isa Object' )
 243 .end
 244
 245 .sub isa_subclass__objects
 246     newclass $P3, "Foo30"
 247     subclass $P4, $P3, "Bar30"
 248     $P1 = $P3.'new'()
 249     $P2 = $P4.'new'()
 250
 251     isa_ok( $P1, "Foo30",  'obj isa its class' )
 252     isa_ok( $P2, "Bar30",  'obj isa its class' )
 253     isa_ok( $P2, "Foo30",  'obj isa its parent class' )
 254     isa_ok( $P2, "Object", 'obj isa Object' )
 255     isa_ok( $P2, "Class",  'obj isa Class' )
 256 .end
 257
 258 .sub test_addmethod
 259     newclass $P0, 'Foo31'
 260     $P2 = get_hll_global 'sayFoo31'
 261
 262     # add a method BEFORE creating a Foo object
 263     addmethod $P0, 'foo31', $P2
 264     $P1 = new 'Foo31'
 265     $P1.'foo31'()
 266
 267     # get a method from some other namespace
 268     $P2 = get_hll_global ['Bar31'], 'sayBar31'
 269
 270     # add a method AFTER creating the object
 271     addmethod $P0, 'bar31', $P2
 272     $P1.'bar31'()
 273 .end
 274
 275 .sub sayFoo31
 276     ok( 1, 'called method added before creating obj' )
 277 .end
 278
 279 .namespace ['Bar31']
 280 .sub sayBar31
 281     ok( 1, 'called method added after created obj' )
 282 .end
 283
 284 .namespace [] # Reset to root namespace for next test
 285
 286 .sub test_addattribute
 287     newclass $P1, "Foo11"
 288
 289     addattribute $P1, "foo_i"
 290     ok( 1, 'addattribute did not blow up' )
 291
 292     set $S0, $P1
 293     is( $S0, "Foo11", '$P1 is still the same class as PMC' )
 294
 295     # Check that we can add multiple attributes
 296     set $I0, 0
 297 l1:
 298     set $S0, $I0
 299     addattribute $P1, $S0
 300     inc $I0
 301     lt $I0, 1000, l1
 302     ok( 1, 'addattribute 1000x without blow up' )
 303 .end
 304
 305 .sub addattribute_subclass
 306     newclass $P1, "Foo12"
 307     addattribute $P1, "foo_i"
 308     ok( 1, 'addattribute to Foo12' )
 309
 310     subclass $P2, $P1, "Bar12"
 311     addattribute $P2, "bar_i"
 312     ok( 1, 'addattribute to subclass of Foo12' )
 313 .end
 314
 315 .sub addattribute_subclass__same_name
 316     newclass $P1, "Foo32"
 317     addattribute $P1, "i"
 318     addattribute $P1, "j"
 319
 320     subclass $P2, $P1, "Bar32"
 321     addattribute $P2, "j"
 322     addattribute $P2, "k"
 323
 324     ok( 1, 'created class and subclass and added attributes' )
 325
 326     .local pmc o
 327     o = $P2.'new'()
 328     $P0 = getattribute o, 'i'
 329     is( $P0, 'Foo32.i', 'parent attrib initialized in init' )
 330     $P0 = getattribute o, ['Foo32'], 'j'
 331     is( $P0, 'Foo32.j', 'parent attrib initialized in init' )
 332     $P0 = getattribute o, ['Bar32'], 'j'
 333     is( $P0, 'Bar32.j', 'subclass attrib initialized in init' )
 334     $P0 = getattribute o, 'k'
 335     is( $P0, 'Bar32.k', 'subclass attrib initialized in init' )
 336
 337     $P0 = getattribute o, 'i'
 338     is( $P0, 'Foo32.i', 'parent attrib init-ed' )
 339     $P0 = getattribute o, ['Foo32'], "j"
 340     is( $P0, 'Foo32.j', 'parent attrib init-ed' )
 341     $P0 = getattribute o, 'j'
 342     is( $P0, 'Bar32.j', 'subclass attrib returned over parent' )
 343     $P0 = getattribute o, 'k'
 344     is( $P0, 'Bar32.k', 'subclass attrib init-ed' )
 345 .end
 346
 347 .namespace ['Bar32']
 348
 349 .sub init :vtable :method
 350     $P0 = new ['String']
 351     $P0 = 'Foo32.i'
 352     setattribute self, ['Foo32'], "i", $P0
 353     $P0 = new ['String']
 354     $P0 = 'Foo32.j'
 355     setattribute self, ["Foo32"], "j", $P0
 356     $P0 = new ['String']
 357     $P0 = 'Bar32.j'
 358     setattribute self, ["Bar32"], "j", $P0
 359     $P0 = new ['String']
 360     $P0 = 'Bar32.k'
 361     setattribute self, ["Bar32"], "k", $P0
 362 .end
 363
 364 .namespace []       # Reset to root namespace for next test
 365
 366 .sub set_and_get_object_attribs
 367     newclass $P1, "Foo13"
 368     addattribute $P1, "i"
 369     new $P2, $P1
 370
 371     new $P3, ['Integer']
 372     set $P3, 1024
 373     setattribute $P2, "i", $P3
 374
 375     new $P4, ['Integer']
 376     getattribute $P4, $P2, "i"
 377
 378     is( $P4, 1024, 'set/get Integer attribute' )
 379 .end
 380
 381 .sub set_and_get_multiple_object_attribs
 382     newclass $P1, "Foo14"
 383     addattribute $P1, "i"
 384     addattribute $P1, "j"
 385     new $P2, "Foo14"
 386
 387     new $P3, ['Integer']
 388     set $P3, 4201
 389     new $P4, ['Hash']
 390     set $P4["Key"], "Value"
 391
 392     setattribute $P2, "i", $P3
 393     setattribute $P2, "j", $P4
 394
 395     getattribute $P5, $P2, "i"
 396     is( $P5, '4201', 'set/get Integer attribute' )
 397
 398     getattribute $P6, $P2, "j"
 399     set $S0, $P6["Key"]
 400     is( $S0, 'Value', 'set/get Hash attribute on same obj' )
 401 .end
 402
 403 .sub attribute_values_are_specific_to_objects
 404     newclass $P1, "Foo15"
 405     addattribute $P1, "i"
 406     new $P2, $P1
 407     new $P3, $P1
 408
 409     new $P4, ['Integer']
 410     set $P4, 100
 411     setattribute $P2, "i", $P4
 412     new $P5, ['String']
 413     set $P5, "One hundred"
 414     setattribute $P3, "i", $P5
 415
 416     getattribute $P6, $P2, "i"
 417     is( $P6, 100, 'attribute value on 1st object is specific to obj' )
 418
 419     getattribute $P6, $P3, "i"
 420     is( $P6, 'One hundred', 'attribute value on 2nd obj is specific to obj' )
 421 .end
 422
 423 .sub attribute_values_and_subclassing
 424     newclass $P1, "Foo16"
 425     addattribute $P1, "i"
 426     addattribute $P1, "j"
 427     subclass $P2, $P1, "Bar16"
 428     addattribute $P2, "k"
 429     addattribute $P2, "l"
 430
 431     new $P2, "Bar16"
 432     new $P3, "Bar16"
 433
 434     # Note that setattribute holds the actual PMC, not a copy, so
 435     # in this test both attributes get the PMC from $P4, and should
 436     # both have the same value, despite the C<inc>.
 437     new $P4, ['Integer']
 438     set $P4, 10
 439     setattribute $P2, "i", $P4
 440     inc $P4
 441     setattribute $P2, "j", $P4
 442
 443     new $P5, ['Integer']
 444     set $P5, 100
 445     setattribute $P3, "i", $P5
 446     inc $P5
 447     setattribute $P3, "j", $P5
 448
 449     getattribute $P6, $P2, "i"
 450     is( $P6, 11, 'setattrib with a PMC holds actual PMC not copy' )
 451
 452     getattribute $P6, $P2, "j"
 453     is( $P6, 11, '...so changes to the PMC appear through the attrib' )
 454
 455     getattribute $P6, $P3, "i"
 456     is( $P6, 101, '...and second test on new objects' )
 457
 458     getattribute $P6, $P3, "j"
 459     is( $P6, 101, '...should have same result' )
 460 .end
 461
 462 .sub attribute_values_and_subclassing_2
 463     newclass $P1, "Foo17"
 464     # must add attributes before object instantiation
 465     addattribute $P1, ".i"
 466     addattribute $P1, ".j"
 467
 468     subclass $P2, $P1, "Bar17"
 469     addattribute $P2, ".k"
 470     addattribute $P2, ".l"
 471
 472     # subclass is preferred for the SI case over
 473     #   newclass $P2, "Bar"
 474     #   addattrib ...
 475     #   addparent $P2, $P1
 476     # which is suitable for adding multiple parents to one class
 477
 478     # instantiate a Bar object
 479     new $P3, "Bar17"
 480
 481     # Set the attribute values
 482     new $P10, ['String']           # set attribute values
 483     set $P10, "i"                # attribute slots have reference semantics
 484     setattribute $P3, ".i", $P10  # so always put new PMCs in
 485                                 # if you have unique values
 486     new $P10, ['String']
 487     set $P10, "j"
 488     setattribute $P3, ".j", $P10
 489
 490     new $P10, ['String']
 491     set $P10, "k"
 492     setattribute $P3, ".k", $P10
 493
 494     new $P10, ['String']
 495     set $P10, "l"
 496     setattribute $P3, ".l", $P10
 497
 498     # retrieve attribs
 499     getattribute $P11, $P3, ".i"
 500     is( $P11, "i", 'string attribute get/set on parent' )
 501
 502     getattribute $P11, $P3, ".j"
 503     is( $P11, "j", 'string attribute get/set on parent' )
 504
 505     getattribute $P11, $P3, ".k"
 506     is( $P11, "k", 'string attribute get/set on subclass' )
 507
 508     getattribute $P11, $P3, ".l"
 509     is( $P11, "l", 'string attribute get/set on subclass' )
 510 .end
 511
 512 .sub PMC_as_classes__overridden_mmd_methods
 513     .local pmc myint, i, j, k
 514
 515     get_class $P0, "Integer"
 516     subclass myint, $P0, "MyInt1"
 517
 518     i = new 'MyInt1'
 519     j = new 'MyInt1'
 520     k = new 'MyInt1'
 521     i = 6
 522     j = 7
 523     k = i + j
 524
 525     is( k, 13, 'added two MyInt1' )
 526
 527     j = new ['Integer']
 528     j = 100
 529     k = i + j
 530
 531     is( k, 106, 'added MyInt1 and an Integer' )
 532 .end
 533
 534 .namespace ["MyInt1"]
 535
 536 .sub add :multi(MyInt1, MyInt1, MyInt1)
 537     .param pmc self
 538     .param pmc right
 539     .param pmc dest
 540     ok( 1, 'in the add method' )
 541     $P0 = getattribute self, ['Integer'], "proxy"
 542     $I0 = $P0
 543     $I1 = right
 544     $I2 = $I0 + $I1
 545     dest = $I2
 546     .return(dest)
 547 .end
 548
 549 .namespace []       # Reset to root namespace for next test
 550
 551 .sub typeof_class
 552     newclass $P0, "Foo21"
 553     typeof $S0, $P0
 554     is( $S0, "Class", 'typeof for a Class PMC is "Class"' )
 555 .end
 556
 557 .sub typeof_objects
 558     newclass $P0, "A"
 559     newclass $P1, "B"
 560
 561     new $P0, ['A']
 562     new $P1, ['B']
 563
 564     typeof $S0, $P0
 565     typeof $S1, $P1
 566
 567     is( $S0, 'A', 'typeof object of class A is "A"' )
 568     is( $S1, 'B', 'typeof object of class B is "B"' )
 569 .end
 570
 571 .sub multiple_inheritance__with_attributes
 572     newclass $P1, "Star"
 573     addattribute $P1, "Spectral Type"
 574
 575     newclass $P2, "Company"
 576     addattribute $P2, "Annual Profit"
 577
 578     subclass $P3, $P1, "Sun"
 579     addparent $P3, $P2
 580
 581     new $P4, ['Sun']
 582
 583     new $P5, ['String']
 584     set $P5, "G"
 585     setattribute $P4, "Spectral Type", $P5
 586
 587     new $P6, ['String']
 588     set $P6, "$100,000,000"
 589     setattribute $P4, "Annual Profit", $P6
 590
 591     getattribute $P7, $P4, "Spectral Type"
 592     is( $P7, 'G', 'direct parents attribute' )
 593
 594     getattribute $P8, $P4, "Annual Profit"
 595     is( $P8, '$100,000,000', "addparent's attribute" )
 596 .end
 597
 598 .sub attributes_two_levels_of_inheritance
 599     newclass $P0, "Astronomical Object"
 600     addattribute $P0, "Location"
 601
 602     subclass $P1, $P0, "Star2"
 603     addattribute $P1, "Spectral Type"
 604
 605     newclass $P2, "Sun2"
 606     addparent $P2, $P1
 607     addparent $P2, $P0
 608
 609     new $P4, "Sun2"
 610
 611     new $P5, ['String']
 612     set $P5, "Taurus"
 613     setattribute $P4, "Location", $P5
 614     getattribute $P6, $P4, "Location"
 615     is( $P6, 'Taurus', 'attributes with two levels of inheritance' )
 616 .end
 617
 618 .sub class_op_test
 619     newclass $P0, "City1"
 620     new $P1, "City1"
 621
 622     class $P2, $P1
 623     set $S0, $P2
 624     is( $S0, 'City1', 'class op works' )
 625 .end
 626
 627 .sub anon_subclass_has_no_name
 628     newclass $P0, "City2"
 629     subclass $P1, $P0
 630     set $S0, $P1
 631     is( $S0, '', 'anonymous subclass has no name' )
 632 .end
 633
 634 .sub get_attrib_by_name
 635     newclass $P1, "Foo18"
 636     addattribute $P1, "i"
 637     new $P2, "Foo18"
 638     new $P3, ['String']
 639     set $P3, "ok"
 640     setattribute $P2, "i", $P3
 641
 642     getattribute $P4, $P2, ["Foo18"], "i"
 643     is( $P4, 'ok', 'get attrib by name' )
 644 .end
 645
 646 .sub get_attrib_by_name_subclass
 647     newclass $P0, "Bar19"
 648     addattribute $P0, "j"
 649
 650     subclass $P1, $P0, "Foo19"
 651     addattribute $P1, "i"
 652
 653     new $P2, "Foo19"
 654
 655     new $P3, ['String']
 656     set $P3, "foo i"
 657     setattribute $P2, "i", $P3
 658
 659     new $P3, ['String']
 660     set $P3, "bar j"
 661     setattribute $P2, "j", $P3
 662
 663     getattribute $P4, $P2, ["Foo19"], "i"
 664     is( $P4, 'foo i', 'attribute from subclass get by name' )
 665
 666     getattribute $P4, $P2, ["Bar19"], "j"
 667     is( $P4, 'bar j', 'attribute from parent class get by name' )
 668 .end
 669
 670 .sub set_attrib_by_name_subclass
 671     newclass $P0, "Bar20"
 672     addattribute $P0, "j"
 673
 674     subclass $P1, $P0, "Foo20"
 675     addattribute $P1, "i"
 676
 677     new $P2, "Foo20"
 678
 679     new $P3, ['String']
 680     set $P3, "foo i"
 681     setattribute $P2, ["Foo20"], "i", $P3
 682
 683     new $P3, ['String']
 684     set $P3, "bar j"
 685     setattribute $P2, ["Bar20"], "j", $P3
 686
 687     getattribute $P4, $P2, "i"
 688     is( $P4, 'foo i', 'attribute from subclass set by name' )
 689
 690     getattribute $P4, $P2, "j"
 691     is( $P4, 'bar j', 'attribute from parent class set by name' )
 692 .end
 693
 694 .sub PMC_as_classes
 695     get_class $P0, "Integer"
 696     ok( 1, "get_class of Integer did't croak" )
 697
 698     get_class $P0, "Integer"
 699     ok( 1, "get_class of Integer did't croak second time" )
 700
 701     typeof $S0, $P0
 702     is( $S0, 'PMCProxy', 'typeof PMCProxy' )
 703 .end
 704
 705 .sub PMC_as_classes__subclass
 706     .local pmc MyInt3
 707     get_class $P0, "Integer"
 708     ok( 1, "get_class on Integer didn't blow up" )
 709
 710     subclass MyInt3, $P0, "MyInt3"
 711     ok( 1, "subclassing didn't blow up" )
 712
 713     $S0 = typeof MyInt3
 714     is( $S0, 'Class', 'new subclass is typeof Class' )
 715
 716     $I0 = isa MyInt3, "MyInt3"
 717     ok( $I0, 'new subclass isa MyInt' )
 718
 719     $I0 = isa MyInt3, "Integer"
 720     ok( $I0, 'new subclass isa parent class' )
 721 .end
 722
 723 .sub PMC_as_classes__instantiate
 724     .local pmc MyInt4
 725     get_class $P0, "Integer"
 726     ok( 1, 'able to get_class of Integer' )
 727
 728     subclass MyInt4, $P0, "MyInt4"
 729     addattribute MyInt4, ".i"
 730     ok( 1, 'able to addattribute to subclass' )
 731
 732     .local pmc i
 733     i = new "MyInt4"
 734     ok( 1, 'able to instantiate obj of subclass w/ attribute' )
 735 .end
 736
 737 .sub PMC_as_classes__methods
 738     .local pmc MyInt5
 739     get_class $P0, "Integer"
 740
 741     subclass MyInt5, $P0, "MyInt5"
 742     addattribute MyInt5, "intval"
 743
 744     .local pmc i, i2
 745     i = new "MyInt5"
 746     i2 = new ['Integer']
 747     i2 = 43
 748
 749     i = 42    # set_integer is inherited from Integer
 750     ok( 1, 'able to assign int to MyInt' )
 751
 752     $I0 = i   # get_integer is overridden below
 753     is( $I0, 42, 'get_integer is overridden for MyInt5' )
 754
 755     $S0 = i   # get_string is overridden below
 756     is( $S0, 'MyInt5(42)', 'get_string is overridden for MyInt5' )
 757 .end
 758
 759 .namespace ["MyInt5"]
 760
 761 .sub set_integer_native :vtable :method
 762    .param int new_value
 763    $P1 = new ['Integer']
 764    $P1 = new_value
 765    setattribute self, "intval", $P1
 766 .end
 767
 768 .sub get_integer :vtable :method
 769    $P0 = getattribute self, "intval"
 770    $I0 = $P0
 771    .return ($I0)
 772 .end
 773
 774 .sub get_string :vtable :method
 775    $P0 = getattribute self, "intval"
 776    $I0 = $P0
 777    $S1 = $I0
 778    $S0 = "MyInt5("
 779    $S0 .= $S1
 780    $S0 .= ")"
 781    .return ($S0)
 782 .end
 783
 784 .namespace []       # Reset to root namespace for next test
 785
 786 .sub PMC_as_classes__mmd_methods
 787   .local pmc MyInt6
 788   get_class $P0, "Integer"
 789   subclass MyInt6, $P0, "MyInt6"
 790   .local pmc i
 791   .local pmc j
 792   .local pmc k
 793   i = new "MyInt6"
 794   j = new "MyInt6"
 795   k = new "MyInt6"
 796   i = 6
 797   j = 7
 798   k = i * j
 799   $I0 = k
 800   is( $I0, 42, 'MyInt6 defaults to Integer class for mult' )
 801
 802   $S0 = k   # get_string is overridden below
 803   is( $S0, 'MyInt6(42)', 'get_string is overridden for MyInt6' )
 804 .end
 805
 806 .namespace ["MyInt6"]
 807
 808 .sub get_string :vtable :method
 809    $I0 = self   # get_integer is not overridden
 810    $S1 = $I0
 811    $S0 = "MyInt6("
 812    $S0 .= $S1
 813    $S0 .= ")"
 814    .return ($S0)
 815 .end
 816
 817 .namespace []       # Reset to root namespace for next test
 818
 819 .sub PMC_as_classes__derived_1
 820   .local pmc MyInt8
 821   .local pmc MyInt8_2
 822   get_class $P0, "Integer"
 823
 824   subclass MyInt8, $P0, "MyInt8"
 825   addattribute MyInt8, 'intval'
 826   get_class $P1, "MyInt8"
 827   subclass MyInt8_2, $P1, "MyInt8_2"
 828
 829   .local pmc i
 830   i = new "MyInt8_2"
 831   $I0 = isa i, "Integer"
 832   ok( $I0, 'obj isa grandparent (Integer)' )
 833
 834   $I0 = isa i, "MyInt8"
 835   ok( $I0, 'obj isa parent (MyInt8)' )
 836
 837   $I0 = isa i, "MyInt8_2"
 838   ok( $I0, 'obj isa its class (MyInt8_2)' )
 839
 840   i = 42    # set_integer is overridden below
 841   $I0 = i   # get_integer is overridden below
 842   is( $I0, 42, 'set/get_integer overridden' )
 843
 844   $S0 = i   # get_string is overridden below
 845   is( $S0, 'MyInt8_2(42)', 'set/get_string overridden' )
 846 .end
 847
 848 .namespace ["MyInt8"]
 849 .sub 'set_integer_native' :vtable :method
 850     .param int val
 851     $P1 = new ['Integer']
 852     $P1 = val
 853     setattribute self, "intval", $P1
 854     .return ()
 855 .end
 856 .sub get_integer :vtable :method
 857    $P0 = getattribute self, 'intval'
 858    $I0 = $P0
 859    .return ($I0)
 860 .end
 861 .sub get_string :vtable :method
 862    $P0 = getattribute self, 'intval'
 863    $I0 = $P0
 864    $S1 = $I0
 865    $S0 = typeof self
 866    $S0 .= "("
 867    $S0 .= $S1
 868    $S0 .= ")"
 869    .return ($S0)
 870 .end
 871
 872 .namespace []       # Reset to root namespace for next test
 873
 874 .sub PMC_as_classes__derived_2
 875   .local pmc MyInt9
 876   .local pmc MyInt9_2
 877   get_class $P0, "Integer"
 878
 879   subclass MyInt9, $P0, "MyInt9"
 880   addattribute MyInt9, 'intval'
 881   get_class $P1, "MyInt9"
 882   subclass MyInt9_2, $P1, "MyInt9_2"
 883
 884   .local pmc i
 885   i = new "MyInt9_2"
 886   $I0 = isa i, "Integer"
 887   ok( $I0, 'obj isa grandparent (Integer)' )
 888   $I0 = isa i, "MyInt9"
 889   ok( $I0, 'obj isa parent (MyInt9)' )
 890   $I0 = isa i, "MyInt9_2"
 891   ok( $I0, 'obj isa its class (MyInt9_2)' )
 892
 893   i = 42    # set_integer is overridden below
 894   $I0 = i   # get_integer is overridden below
 895   is( $I0, 43, 'set/get_integer overridden' )
 896
 897   $S0 = i   # get_string is overridden below
 898   is( $S0, 'MyInt9_2(42)', 'set/get_string overridden' )
 899 .end
 900
 901 .namespace ["MyInt9_2"]
 902 # subclassing methods from MyInt9 is ok
 903 # this one changes the value a bit
 904 .sub get_integer :vtable :method
 905    $P0 = getattribute self, 'intval'
 906    $I0 = $P0
 907    inc $I0            # <<<<<
 908    .return ($I0)
 909 .end
 910 .namespace ["MyInt9"]
 911 .sub 'set_integer_native' :vtable :method
 912     .param int val
 913     $P1 = new ['Integer']
 914     $P1 = val
 915     setattribute self, "intval", $P1
 916     .return ()
 917 .end
 918 .sub get_integer :vtable :method
 919    $P0 = getattribute self, 'intval'
 920    $I0 = $P0
 921    .return ($I0)
 922 .end
 923 .sub get_string :vtable :method
 924    $P0 = getattribute self, 'intval'
 925    $I0 = $P0
 926    $S1 = $I0
 927    $S0 = typeof self
 928    $S0 .= "("
 929    $S0 .= $S1
 930    $S0 .= ")"
 931    .return ($S0)
 932 .end
 933
 934 .namespace []       # Reset to root namespace for next test
 935
 936 .sub PMC_as_classes__derived_3
 937     .local pmc MyInt10
 938     .local pmc MyInt10_2
 939     get_class $P0, "Integer"
 940
 941     subclass MyInt10, $P0, "MyInt10"
 942     addattribute MyInt10, 'intval'
 943     get_class $P1, "MyInt10"
 944     subclass MyInt10_2, $P1, "MyInt10_2"
 945
 946     .local pmc i
 947     i = new "MyInt10_2"
 948     $I0 = isa i, "Integer"
 949     ok( $I0, 'obj isa grandparent (Integer)' )
 950     $I0 = isa i, "MyInt10"
 951     ok( $I0, 'obj isa parent (MyInt10)' )
 952     $I0 = isa i, "MyInt10_2"
 953     ok( $I0, 'obj isa its class (MyInt102)' )
 954
 955     i = 42    # set_integer is overridden below
 956     $I0 = i   # get_integer is overridden below
 957     is( $I0, 42, 'set/get_integer overridden' )
 958
 959     $S0 = i   # get_string is overridden below
 960     is( $S0, 'MyInt10_2(42)', 'set/get_string overridden' )
 961 .end
 962
 963 .namespace ["MyInt10_2"]
 964 .sub get_integer :vtable :method
 965     $P0 = getattribute self, 'intval'
 966     $I0 = $P0
 967     .return ($I0)
 968 .end
 969 .sub get_string :vtable :method
 970     $P0 = getattribute self, 'intval'
 971     $I0 = $P0
 972     $S1 = $I0
 973     $S0 = typeof self
 974     $S0 .= "("
 975     $S0 .= $S1
 976     $S0 .= ")"
 977     .return ($S0)
 978 .end
 979 .namespace ['MyInt10']
 980 .sub 'set_integer_native' :vtable :method
 981     .param int val
 982     $P1 = new ['Integer']
 983     $P1 = val
 984     setattribute self, "intval", $P1
 985     .return ()
 986 .end
 987
 988 .namespace []       # Reset to root namespace for next test
 989
 990 .sub subclassing_Class
 991     .local pmc cl
 992     .local pmc parent
 993     parent = get_class "Class"
 994     cl = subclass parent, "Foo33"
 995     ok( 1, 'able to subclass Class' )
 996
 997     .local pmc o
 998     o = new "Foo33"
 999     ok( 1, 'able to instantiate subclass of Class' )
1000
1001     $S0 = typeof o
1002     is( $S0, 'Foo33', 'object returns correct class' )
1003 .end
1004
1005 .sub namespace_vs_name
1006     .local pmc o, cl, f
1007     newclass cl, "Foo34"
1008     o = new "Foo34"
1009     is( o, 'Foo34::get_string', 'found Foo34 namespace' )
1010
1011     o = Foo34()
1012     is( o, 'Foo34', 'found global Foo34' )
1013
1014     f = get_global "Foo34"
1015     o = f()
1016     is( o, 'Foo34', 'found global Foo34 explicitly' )
1017
1018     f = get_global ["Foo34"], "Foo34"
1019     o = f()
1020     is( o, 'Foo34::Foo34', 'found method in Foo34 namespace' )
1021 .end
1022
1023 .sub Foo34
1024     .return("Foo34")
1025 .end
1026
1027 .namespace [ "Foo34" ]
1028
1029 .sub get_string :vtable :method
1030     .return("Foo34::get_string")
1031 .end
1032
1033 .sub Foo34
1034     .return("Foo34::Foo34")
1035 .end
1036
1037 .namespace []       # Reset to root namespace for next test
1038
1039 #RT #33103
1040 .sub multiple_anon_classes
1041      newclass $P0, "City3"
1042      subclass $P1, $P0
1043      newclass $P2, "State3"
1044      subclass $P3, $P2
1045      ok( 1,  "multiple anon classes didn't croak (bug #33103)" )
1046 .end
1047
1048 .sub subclassed_Integer_bug
1049    .local pmc class
1050    .local pmc a
1051    .local pmc b
1052
1053     subclass class, "Integer", "LispInteger1"
1054
1055     a = new "LispInteger1"
1056     b = new "LispInteger1"
1057
1058     a = 1
1059     b = 1
1060
1061     set $S0, a
1062     is( $S0, '1', 'subclassed Integer is 1' )
1063     set $S0, b
1064     is( $S0, '1', 'subclassed Integer is 1' )
1065
1066     a = a * b
1067     set $S0, a
1068     is( $S0, '1', 'multip and reasign to subclassed Integer is 1' )
1069 .end
1070
1071 .sub equality_of_subclassed_Integer
1072   .local pmc class
1073   class = subclass "Integer", "LispInteger2"
1074
1075   .local pmc a
1076   a = new 'LispInteger2'
1077   a = 123
1078
1079   .local pmc b
1080   b = new 'LispInteger2'
1081   b = 123
1082
1083   $I0 = a == b
1084   ok( $I0, '123 is equal to 123' )
1085
1086 .end
1087
1088 .sub short_name_attributes
1089     newclass $P1, "Foo22"
1090     addattribute $P1, "i"
1091     addattribute $P1, "j"
1092
1093     subclass $P2, $P1, "Bar22"
1094     addattribute $P2, "k"
1095     addattribute $P2, "l"
1096
1097     new $P2, "Bar22"
1098
1099     # set a bunch of attribs
1100     new $P4, ['Integer']
1101     set $P4, 10
1102     setattribute $P2, "i", $P4
1103
1104     new $P4, ['Integer']
1105     set $P4, 11
1106     setattribute $P2, "j", $P4
1107
1108     new $P4, ['Integer']
1109     set $P4, 20
1110     setattribute $P2, "k", $P4
1111
1112     new $P4, ['Integer']
1113     set $P4, 21
1114     setattribute $P2, "l", $P4
1115
1116     getattribute $P6, $P2, "i"
1117     is( $P6, 10, '"i" getattribute on parent class attrib' )
1118     getattribute $P6, $P2, "j"
1119     is( $P6, 11, '"j" getattribute on parent class attrib' )
1120
1121     getattribute $P6, $P2, "k"
1122     is( $P6, 20, '"k" getattribute on subclass attrib' )
1123     getattribute $P6, $P2, "l"
1124     is( $P6, 21, '"l" getattribute on subclass attrib' )
1125
1126     getattribute $P6, $P2, ["Foo22"], "i"
1127     is( $P6, 10, '["Foo22"], "i" getattribute on parent class attrib' )
1128     getattribute $P6, $P2, ["Bar22"], "k"
1129     is( $P6, 20, '["Bar22"], "k" getattribute on subclass attrib' )
1130 .end
1131
1132 .sub init_with_and_without_arg
1133     .local pmc cl, o, h, a
1134     cl = newclass "Foo35"
1135     addattribute cl, "a"
1136     o = cl.'new'()
1137     a = getattribute o, "a"
1138     is( a, 'ok 1', 'init without an arg' )
1139
1140     h = new ['Hash']
1141     $P0 = new ['String']
1142     $P0 = "ok 2"
1143     h['a'] = $P0
1144     o  = new cl, h
1145     a = getattribute o, "a"
1146     is( a, 'ok 2', 'init with an arg' )
1147 .end
1148
1149 .namespace ["Foo35"]
1150 .sub init_pmc :vtable :method
1151     .param pmc args
1152     $P0 = args['a']
1153     setattribute self, 'a', $P0
1154     .return()
1155 .end
1156 .sub init :vtable :method
1157     $P0 = new ['String']
1158     $P0 = "ok 1"
1159     setattribute self, 'a', $P0
1160 .end
1161
1162 .namespace []       # Reset to root namespace for next test
1163
1164 .sub newclass_bracket_parsing
1165     newclass $P0, ['Foo23';'Bar23']
1166     ok( 1, 'newclass  created with brackets' )
1167 .end
1168
1169 .sub verify_namespace_types
1170     newclass $P0, ['Foo24';'Bar24']
1171     getinterp $P0
1172     set $P1, $P0[.IGLOBALS_CLASSNAME_HASH]
1173     typeof $S0, $P1
1174     is( $S0, 'NameSpace', 'namespace verified' )
1175
1176     set $P2, $P1['Foo24']
1177     typeof $S0, $P2
1178     is( $S0, 'NameSpace', 'namespace verified' )
1179 .end
1180
1181 .sub verify_data_type
1182     newclass $P0, ['Foo25';'Bar25']
1183     getinterp $P0
1184     set $P1, $P0[.IGLOBALS_CLASSNAME_HASH]
1185     set $P2, $P1['Foo25']
1186     set $P3, $P2['Bar25']
1187
1188     set $I0, $P3
1189     isgt $I0, $I0, 0
1190     ok( $I0, 'verified datatype > 0' )
1191 .end
1192
1193 # Puts init in a namespace
1194 .sub new_keyed
1195     .local pmc cl, o, p
1196     cl = newclass ['Foo36';'Bar36']
1197     addattribute cl, "init_check"
1198     o = cl.'new'()
1199     ok( 1, 'obj successfully created' )
1200
1201     p = getattribute o, "init_check"
1202     is( p, 999, "overridden init called")
1203 .end
1204
1205 .namespace ['Foo36';'Bar36']
1206
1207 .sub init :vtable :method
1208     .local pmc p
1209     p = new ['Integer']
1210     p = 999
1211     setattribute self, "init_check", p
1212 .end
1213
1214 .namespace []   # revert to root for next test
1215
1216 .sub new_keyed_2
1217     .local pmc c1, c2, o1, o2
1218     c1 = newclass ['Foo37';'Bar37']
1219     c2 = newclass ['Foo37';'Fuz37']
1220     o1 = c1.'new'()
1221     o2 = c2.'new'()
1222     ok( 1, 'objects created successfully' )
1223 .end
1224
1225 .namespace ['Foo37';'Bar37']
1226
1227 .sub init :vtable :method
1228     ok( 1, '__init Bar37' )
1229 .end
1230
1231 .namespace ['Foo37';'Fuz37']
1232
1233 .sub init :vtable :method
1234     ok( 1, '__init Fuz37' )
1235 .end
1236
1237 .namespace []   # revert to root for next test
1238
1239 .sub new_keyed_3
1240     .local pmc c1, c2, c3, o1, o2, o3
1241     c1 = newclass ['Foo38';'Bar38']
1242     c2 = newclass ['Foo38';'Buz38']
1243     c3 = newclass 'Foo38'
1244     o1 = new      ['Foo38';'Bar38']
1245     o2 = new      ['Foo38';'Buz38']
1246     o3 = new      'Foo38'
1247     ok( 1, 'objects created successfully' )
1248 .end
1249
1250 .namespace ['Foo38';'Bar38']
1251
1252 .sub init :vtable :method
1253     ok( 1, '__init Bar38' )
1254 .end
1255
1256 .namespace ['Foo38';'Buz38']
1257
1258 .sub init :vtable :method
1259     ok( 1, '__init Buz38' )
1260 .end
1261
1262 .namespace ['Foo38']
1263
1264 .sub init :vtable :method
1265     ok( 1, '__init Foo38' )
1266 .end
1267
1268 .namespace []   # revert to root for next test
1269
1270 .sub subclass_keyed
1271     .local pmc base, o1, o2
1272     base = subclass 'Hash', ['Perl6-3'; 'PAST'; 'Node']
1273     addattribute base, '$.source'                  # original source
1274     addattribute base, '$.pos'                     # offset position
1275
1276     $P0 = subclass base, ['Perl6-3'; 'PAST'; 'Sub']
1277     $P0 = subclass base, ['Perl6-3'; 'PAST'; 'Stmt']
1278     ok( 1, 'ok 1\n' )
1279
1280     o1 = new   ['Perl6-3'; 'PAST'; 'Sub']
1281     o2 = new   ['Perl6-3'; 'PAST'; 'Stmt']
1282     ok( 1, 'objects created successfully' )
1283 .end
1284
1285 .namespace ['Perl6-3'; 'PAST'; 'Stmt']
1286
1287 .sub init :vtable :method
1288     ok( 1, '__init Stmt' )
1289 .end
1290
1291 .namespace ['Perl6-3'; 'PAST'; 'Sub']
1292
1293 .sub init :vtable :method
1294     ok( 1, '__init Sub' )
1295 .end
1296
1297 .namespace []   # revert to root for next test
1298
1299 .sub test_class_name_multipart_name
1300     .local pmc base, o1
1301     base = subclass 'Hash', ['Perl6'; 'PAST'; 'Node']
1302     o1 = new base
1303     $S0 = typeof o1
1304     is( $S0, "Perl6;PAST;Node", "typeof returns object's class name" )
1305 .end
1306
1307 .sub test_get_class_multipart_name
1308     .local pmc base, o1
1309     base = subclass 'Hash', ['Perl6a'; 'PAST'; 'Node']
1310     $P0 = get_class ['Perl6a'; 'PAST'; 'Node']
1311     o1 = new $P0
1312     $S0 = typeof o1
1313     is( $S0, 'Perl6a;PAST;Node', 'typeof returns objects created from get_class' )
1314 .end
1315
1316 #RT #39045
1317 .sub isa_bug
1318     .local pmc base, o1, o2
1319     base = subclass 'Hash', ['Perl6b'; 'PAST'; 'Node']
1320     $P0 = new [ 'Perl6b'; 'PAST'; 'Node' ]
1321
1322     $I0 = isa $P0, [ 'Perl6b'; 'PAST'; 'Node']
1323     is( $I0, 1, 'obj isa the full class name' )
1324
1325     $I0 = isa $P0, 'Hash'
1326     is( $I0, 1, 'obj isa the parent class' )
1327
1328     $I0 = isa $P0, 'Perl6b'
1329     is( $I0, 0, 'obj !isa the first part of the class name' )
1330 .end
1331
1332 .sub new_nested_ordering
1333     .local pmc c1, c2, o
1334     c1 = newclass ['Foo39']
1335     c2 = newclass ['Foo39';'Bar39']
1336     o = c2.'new'()
1337     ok( 1, 'objects created successfully' )
1338 .end
1339
1340 .namespace ['Foo39']
1341
1342 .sub init :vtable :method
1343     ok( 0, '__init Foo39' )     # shouldn't be called
1344 .end
1345
1346 .namespace ['Foo39';'Bar39']
1347
1348 .sub init :vtable :method
1349     ok( 1, '__init Bar39' )     # should be called
1350 .end
1351
1352 .namespace []   # revert to root for next test
1353
1354 #RT #39056
1355 .sub vtable_override_once_removed
1356     .local pmc base
1357     $P0 = get_class 'Integer'
1358     base = subclass $P0, 'Foo40'      # create subclass 'Foo40'
1359     addattribute base, '@!capt'
1360
1361     $P0 = subclass 'Foo40', 'Bar40'   # create subclass 'Bar40'
1362     $P1 = new 'Bar40'                 # create an instance of 'Bar40'
1363
1364     $S1 = $P1                         # get its string representation
1365     is( $S1, 'ok bar', 'get_string overridden' )
1366 .end
1367
1368 .namespace [ 'Bar40' ]
1369
1370 .sub 'get_string' :vtable :method
1371     $S0 = 'ok bar'
1372     .return ($S0)
1373 .end
1374
1375 .namespace []   # revert to root for next test
1376
1377 #RT #40626
1378 .sub vtable_fails_for_subclasses_of_core_classes
1379     $P0 = subclass 'Hash', 'Foo41'
1380     $P0 = subclass 'Hash', 'Bar41'
1381
1382     $P1 = new 'Foo41'
1383     $S1 = $P1
1384     is( $S1, 'Hello world', 'get_string method' )
1385
1386     $P1 = new 'Bar41'
1387     $S1 = $P1
1388     is( $S1, 'Hello world', 'vtable method get_string' )
1389 .end
1390
1391 .namespace [ 'Foo41' ]
1392
1393 .sub 'get_string' :vtable :method
1394     .return('Hello world')
1395 .end
1396
1397 .namespace [ 'Bar41' ]
1398
1399 .sub 'get_string' :method :vtable
1400     .return('Hello world')
1401 .end
1402
1403 .namespace []   # revert to root for next test
1404
1405 #RT #3901
1406 .sub super___init_called_twice
1407     $P0 = newclass 'Foo42'
1408     $P1 = subclass $P0, 'Bar42'
1409     addattribute $P1, 'i'
1410
1411     $P2 = $P1.'new'()
1412 .end
1413
1414 .namespace [ 'Foo42' ]
1415
1416 .sub 'init' :vtable :method
1417     $P0 = getattribute self, 'i'
1418     isnull $I1, $P0
1419     ok( $I1, 'should be null' )
1420
1421     $P1 = new ['Integer']
1422     setattribute self, "i", $P1  # i won't be null if init called again
1423     .return ()
1424 .end
1425
1426 .namespace []   # revert to root for next test
1427
1428 .sub using_class_object_from_typeof_op_with_new
1429     $P0 = newclass [ "Monkey" ; "Banana" ]
1430     $P0 = $P0.'new'()
1431     $S0 = $P0."ook"()
1432     is( $S0, "Ook!", 'obj created from .new() class method' )
1433
1434     $P2 = typeof $P0
1435     $P3 = new $P2
1436     $S0 = $P3."ook"()
1437     is( $S0, "Ook!", 'obj created from "new" called on result of typeof' )
1438 .end
1439
1440 .namespace [ "Monkey" ; "Banana" ]
1441 .sub ook :method
1442     $S1 = "Ook!"
1443     .return ($S1)
1444 .end
1445
1446 .namespace []   # revert to root for next test
1447
1448 .macro exception_is ( M )
1449     .local pmc exception
1450     .local string message
1451     .get_results (exception)
1452
1453     message = exception['message']
1454     is( message, .M, .M )
1455 .endm
1456
1457 .sub setting_non_existent_attribute
1458     newclass $P1, "Foo45"
1459     new $P2, $P1
1460
1461     new $P3, ['Integer']
1462     push_eh handler
1463         setattribute $P2, "bar", $P3
1464     pop_eh
1465     ok(0, "'No such attribute' exception not thrown")
1466     goto end
1467 handler:
1468     .exception_is( "No such attribute 'bar'" )
1469 end:
1470 .end
1471
1472 .sub setting_non_existent_attribute_by_name
1473     newclass $P1, "Foo47"
1474     new $P2, $P1
1475
1476     new $P3, ['Integer']
1477     push_eh handler
1478         setattribute $P2, ["Foo47"], "no_such", $P3
1479     pop_eh
1480     ok(0, "'No such attribute' exception not thrown")
1481     goto end
1482 handler:
1483     .exception_is( "No such attribute 'no_such' in class 'Foo47'" )
1484 end:
1485 .end
1486
1487 # RT #46845
1488 .sub getting_null_attribute
1489     newclass $P1, "Foo51"
1490     addattribute $P1, "i"
1491     new $P2, "Foo51"
1492
1493     getattribute $P3, $P2, "i"
1494     isnull $I0, $P3
1495     is($I0, 1, "null attribute is null")
1496 .end
1497
1498 .sub getting_non_existent_attribute
1499     newclass $P1, "Foo52"
1500     $P2 = $P1.'new'()
1501
1502     push_eh handler
1503         getattribute $P3, $P2, "bar"
1504     pop_eh
1505     ok(0, "'No such attribute' exception not thrown")
1506     goto end
1507 handler:
1508     .exception_is( "No such attribute 'bar'" )
1509 end:
1510 .end
1511
1512 .sub addparent_exceptions_1
1513     newclass $P0, "Astronomical Object 2"
1514     new $P1, ['String']
1515     set $P1, "Not a class"
1516     push_eh handler
1517         addparent $P0, $P1
1518     pop_eh
1519     ok(0, "'Parent isn\'t a Class' exception not thrown")
1520     goto end
1521 handler:
1522     .exception_is( "Parent isn't a Class." )
1523 end:
1524 .end
1525
1526 .sub addparent_exceptions_2
1527     new $P0, ['Hash']
1528     newclass $P1, "Trashcan"
1529     push_eh handler
1530         addparent $P0, $P1
1531     pop_eh
1532     ok(0, "'Only classes can be subclassed' exception not thrown")
1533     goto end
1534 handler:
1535     .exception_is( "Only classes can be subclassed" )
1536 end:
1537 .end
1538
1539 .sub subclassing_a_non_existent_class
1540     push_eh handler
1541         subclass $P1, "Character", "Nemo"
1542     pop_eh
1543     ok(0, "nonexistent class exception not thrown")
1544     goto end
1545 handler:
1546     .exception_is( "Class 'Character' doesn't exist" )
1547 end:
1548 .end
1549
1550 .sub anon_subclass_of_non_existent_class
1551     push_eh handler
1552         subclass $P1, "Character"
1553     pop_eh
1554     ok(0, "nonexistent class exception not thrown")
1555     goto end
1556 handler:
1557     .exception_is( "Class 'Character' doesn't exist" )
1558 end:
1559 .end
1560
1561 .sub addattribute_duplicate
1562     newclass $P1, "Foo53"
1563     addattribute $P1, "i"
1564     addattribute $P1, "j"
1565     push_eh handler
1566         addattribute $P1, "i"
1567     pop_eh
1568     ok(0, "attribute already exists exception not thrown")
1569     goto end
1570 handler:
1571     .exception_is( "Attribute 'i' already exists in 'Foo53'." )
1572 end:
1573 .end
1574
1575 .sub wrong_way_to_create_new_objects
1576     push_eh handler
1577         new $P0, ['Object']
1578     pop_eh
1579     ok(0, "object instantiation exception not thrown")
1580     goto end
1581 handler:
1582     .exception_is( "Object must be created by a class." )
1583 end:
1584 .end
1585
1586 .sub attribute_values__subclassing_access_meths
1587     newclass $P1, "Foo54"
1588     # must add attributes before object instantiation
1589     addattribute $P1, "i"
1590     addattribute $P1, "j"
1591     # define attrib access functions in Foo54 namespace
1592     get_global $P5, "Foo54__set"
1593     addmethod $P1, "Foo54__set", $P5
1594     get_global $P5, "Foo54__get"
1595     addmethod $P1, "Foo54__get", $P5
1596
1597     subclass $P2, $P1, "Bar54"
1598     addattribute $P2, "k"
1599     addattribute $P2, "l"
1600     get_global $P5, "Bar54__set"
1601     addmethod $P2, "Bar54__set", $P5
1602     get_global $P5, "Bar54__get"
1603     addmethod $P2, "Bar54__get", $P5
1604
1605     # instantiate a Bar54 object
1606     new $P13, "Bar54"
1607
1608     # Foo54 and Bar54 have attribute accessor methods
1609     new $P5, ['String']        # set attribute values
1610     set $P5, "i"       # attribute slots have reference semantics
1611     set_args "0,0", $P5, "i"
1612     get_results ""
1613     callmethodcc $P13, "Foo54__set"
1614
1615     new $P5, ['String']
1616     set $P5, "j"
1617     set_args "0,0", $P5, "j"
1618     get_results ""
1619     callmethodcc  $P13,"Foo54__set"
1620
1621     new $P5, ['String']
1622     set $P5, "k"
1623     set_args "0,0", $P5, "k"
1624     get_results ""
1625     callmethodcc  $P13,"Bar54__set"
1626
1627     new $P5, ['String']
1628     set $P5, "l"
1629     set_args "0,0", $P5, "l"
1630     get_results ""
1631     callmethodcc  $P13,"Bar54__set"
1632
1633     # now retrieve attributes
1634     set_args "0",  "i"
1635     get_results "0", $P5
1636     callmethodcc  $P13,"Foo54__get"
1637     is( $P5, "i", 'got attrib i from Bar54->Foo54__get' )
1638
1639     set_args "0",  "j"
1640     get_results "0", $P5
1641     callmethodcc  $P13,"Foo54__get"
1642     is( $P5, "j", 'got attrib j from Bar54->Foo54__get' )
1643
1644     set_args "0",  "k"
1645     get_results "0", $P5
1646     callmethodcc  $P13,"Bar54__get"
1647     is( $P5, "k", 'got attrib k from Bar54->Bar54__get' )
1648
1649     set_args "0",  "l"
1650     get_results "0", $P5
1651     callmethodcc  $P13,"Bar54__get"
1652     is( $P5, "l", 'got attrib l from Bar54->Bar54__get' )
1653 .end
1654
1655 # set(obj: Pvalue, Iattr_idx)
1656 .sub Foo54__set
1657     get_params "0,0", $P5, $S4
1658     ok( 1, "in Foo54__set" )
1659     interpinfo $P2, .INTERPINFO_CURRENT_OBJECT
1660     setattribute $P2, $S4, $P5
1661     set_returns ""
1662     returncc
1663 .end
1664
1665 # Pattr = get(obj: Iattr_idx)
1666 .sub Foo54__get
1667     get_params "0", $S4
1668     ok( 1, "in Foo54__get" )
1669     interpinfo $P2, .INTERPINFO_CURRENT_OBJECT
1670     getattribute $P5, $P2, $S4
1671     set_returns "0", $P5
1672     returncc
1673 .end
1674
1675 .sub Bar54__set
1676     get_params "0,0", $P5, $S4
1677     interpinfo $P2, .INTERPINFO_CURRENT_OBJECT
1678     ok( 1, "in Bar54__set" )
1679     setattribute $P2, $S4, $P5
1680     set_returns ""
1681     returncc
1682 .end
1683
1684 .sub Bar54__get
1685     get_params "0", $S4
1686     ok( 1, "in Bar54__get" )
1687     interpinfo $P2, .INTERPINFO_CURRENT_OBJECT
1688     getattribute $P5, $P2, $S4
1689     set_returns "0", $P5
1690     returncc
1691 .end
1692
1693 .sub attribute_values__inherited_access_meths
1694     newclass $P1, "Foo56"
1695     # must add attributes before object instantiation
1696     addattribute $P1, "i"
1697     addattribute $P1, "j"
1698     # define attrib access functions
1699     get_global $P5, "set"
1700     addmethod $P1, "set", $P5
1701     get_global $P5, "get"
1702     addmethod $P1, "get", $P5
1703
1704     subclass $P2, $P1, "Bar56"
1705     addattribute $P2, "k"
1706     addattribute $P2, "l"
1707     addattribute $P2, "m"
1708
1709     # subclass is preferred for the SI case over
1710     #   newclass $P2, "Bar56"
1711     #   addattrib ...
1712     #   addparent $P2, $P1
1713     # which is suitable for adding multiple parents to one class
1714
1715     # instantiate a Bar56 object
1716     new $P2, "Bar56"
1717
1718     # Foo56 and Bar56 have attribute accessor methods
1719     new $P5, ['String']        # set attribute values
1720     set $P5, "i"       # attribute slots have reference semantics
1721     set_args "0,0,0", $P5, "Foo56", "i"
1722     get_results ""
1723     callmethodcc $P2, "set"
1724
1725     new $P5, ['String']
1726     set $P5, "j"
1727     set_args "0,0,0", $P5, "Foo56", "j"
1728     get_results ""
1729     callmethodcc $P2, "set"
1730
1731     new $P5, ['String']
1732     set $P5, "k"
1733     set_args "0,0,0", $P5, "Bar56", "k"
1734     get_results ""
1735     callmethodcc $P2, "set"
1736
1737     new $P5, ['String']
1738     set $P5, "l"
1739     set_args "0,0,0", $P5, "Bar56", "l"
1740     get_results ""
1741     callmethodcc $P2, "set"
1742
1743     new $P5, ['String']
1744     set $P5, "m"
1745     set_args "0,0,0", $P5, "Bar56", "m"
1746     get_results ""
1747     callmethodcc $P2, "set"
1748
1749     # now retrieve attributes
1750     set_args "0,0", "Foo56", "i"
1751     get_results "0", $P5
1752     callmethodcc $P2, "get"
1753     is( $P5, 'i', 'got attrib i from subclass through parent method' )
1754
1755     set_args "0,0", "Foo56", "j"
1756     get_results "0", $P5
1757     callmethodcc $P2, "get"
1758     is( $P5, "j", 'got attrib i from subclass through parent method' )
1759
1760     set_args "0,0", "Bar56", "k"
1761     get_results "0", $P5
1762     callmethodcc $P2, "get"
1763     is( $P5, "k", 'got attrib i from subclass through parent method' )
1764
1765     set_args "0,0", "Bar56", "l"
1766     get_results "0", $P5
1767     callmethodcc $P2, "get"
1768     is( $P5, "l", 'got attrib i from subclass through parent method' )
1769
1770     set_args "0,0", "Bar56", "m"
1771     get_results "0", $P5
1772     callmethodcc $P2, "get"
1773     is( $P5, "m", 'got attrib i from subclass through parent method' )
1774 .end
1775
1776 # Foo56 provides accessor functions which Bar56 inherits
1777 # they take an additional classname argument SClass
1778
1779 # set(obj: Pvalue, SClass, Sattr)
1780 .sub set
1781     get_params "0,0,0", $P5, $S4, $S5
1782     interpinfo $P2, .INTERPINFO_CURRENT_OBJECT
1783     setattribute $P2, $S5, $P5
1784     set_returns ""
1785     returncc
1786 .end
1787
1788 # Pattr = get(obj: SClass, Sattr)
1789 .sub get
1790     get_params "0,0", $S4, $S5
1791     interpinfo $P2, .INTERPINFO_CURRENT_OBJECT
1792     getattribute $P5, $P2, $S5
1793     set_returns "0", $P5
1794     returncc
1795 .end
1796
1797
1798 # Local Variables:
1799 #   mode: cperl
1800 #   cperl-indent-level: 4
1801 #   fill-column: 100
1802 # End:
1803 # vim: expandtab shiftwidth=4 filetype=pir: