t/oo/objects.t

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