languages/perl6/src/classes/Object.pir

   1 ## $Id$
   2
   3 =head1 TITLE
   4
   5 Object - Perl 6 Object class
   6
   7 =head1 DESCRIPTION
   8
   9 This file sets up the base classes and methods for Perl 6's
  10 object system.  Differences (and conflicts) between Parrot's
  11 object model and the Perl 6 model means we have to do a little
  12 name and method trickery here and there, and this file takes
  13 care of much of that.
  14
  15 =head2 Functions
  16
  17 =over
  18
  19 =item onload()
  20
  21 Perform initializations and create the base classes.
  22
  23 =cut
  24
  25 .namespace []
  26 .sub 'onload' :anon :init :load
  27     .local pmc p6meta
  28     load_bytecode 'P6object.pbc'
  29     $P0 = get_root_global ['parrot'], 'P6metaclass'
  30     $P0.'new_class'('Perl6Object', 'name'=>'Object')
  31     p6meta = $P0.'HOW'()
  32     set_hll_global ['Perl6Object'], '$!P6META', p6meta
  33 .end
  34
  35 =item infix:=(source)  (assignment method)
  36
  37 Assigns C<source> to C<target>.  We use the 'item' method to allow Lists
  38 and Mappings to be converted into Array(ref) and Hash(ref).
  39
  40 =cut
  41
  42 .namespace ['Perl6Object']
  43 .sub 'infix:=' :method
  44     .param pmc source
  45     $I0 = can source, 'item'
  46     unless $I0 goto have_source
  47     source = source.'item'()
  48   have_source:
  49
  50     $I0 = isa self, 'Mutable'
  51     unless $I0 goto copy
  52     assign self, source
  53     goto end
  54
  55   copy:
  56     .local pmc type
  57     getprop type, 'type', self
  58     if null type goto do_assign
  59     $I0 = type.'ACCEPTS'(source)
  60     if $I0 goto do_assign
  61     die "Type mismatch in assignment."
  62
  63   do_assign:
  64     eq_addr self, source, end
  65     copy self, source
  66   end:
  67     .return (self)
  68 .end
  69
  70
  71 =back
  72
  73 =head2 Object methods
  74
  75 =over 4
  76
  77 =item hash()
  78
  79 Return the scalar as a Hash.
  80
  81 =cut
  82
  83 .namespace ['Perl6Object']
  84
  85 .sub 'hash' :method
  86     $P0 = self.'list'()
  87     .return $P0.'hash'()
  88 .end
  89
  90 =item item()
  91
  92 Return the scalar component of the invocant.  For most objects,
  93 this is simply the invocant itself.
  94
  95 =cut
  96
  97 .namespace []
  98 .sub 'item'
  99     .param pmc x               :slurpy
 100     $I0 = elements x
 101     unless $I0 == 1 goto have_x
 102     x = shift x
 103   have_x:
 104     $I0 = can x, 'item'
 105     unless $I0 goto have_item
 106     x = x.'item'()
 107   have_item:
 108     .return (x)
 109 .end
 110
 111 .namespace ['Perl6Object']
 112 .sub 'item' :method
 113     .return (self)
 114 .end
 115
 116
 117 =item list()
 118
 119 Return the list component of the invocant.  For most (Scalar)
 120 objects, we create a List containing the invocant.
 121
 122 =cut
 123
 124 .sub 'list' :method
 125     $P0 = new 'List'
 126     push $P0, self
 127     .return ($P0)
 128 .end
 129
 130
 131 =item defined()
 132
 133 Return true if the object is defined.
 134
 135 =cut
 136
 137 .sub 'defined' :method
 138     $P0 = get_hll_global ['Bool'], 'True'
 139     .return ($P0)
 140 .end
 141
 142 .sub '' :method :vtable('defined')
 143     $I0 = self.'defined'()
 144     .return ($I0)
 145 .end
 146
 147
 148 =item new()
 149
 150 Create a new object having the same class as the invocant.
 151
 152 =cut
 153
 154 .sub 'new' :method
 155     .param pmc init_parents :slurpy
 156     .param pmc init_this    :named :slurpy
 157
 158     # Instantiate.
 159     .local pmc p6meta
 160     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
 161     $P0 = p6meta.get_parrotclass(self)
 162     $P1 = new $P0
 163
 164     # If this proto object has a WHENCE auto-vivification, we should use
 165     # put any values it contains but that init_this does not into init_this.
 166     .local pmc whence
 167     whence = self.'WHENCE'()
 168     unless whence goto no_whence
 169     .local pmc this_whence_iter
 170     this_whence_iter = new 'Iterator', whence
 171   this_whence_iter_loop:
 172     unless this_whence_iter goto no_whence
 173     $S0 = shift this_whence_iter
 174     $I0 = exists init_this[$S0]
 175     if $I0 goto this_whence_iter_loop
 176     $P2 = whence[$S0]
 177     init_this[$S0] = $P2
 178     goto this_whence_iter_loop
 179   no_whence:
 180
 181     # Now we will initialize each attribute in the class itself and it's
 182     # parents with an Undef or the specified initialization value. Note that
 183     # the all_parents list includes ourself.
 184     .local pmc all_parents, class_iter
 185     all_parents = inspect $P0, "all_parents"
 186     class_iter = new 'Iterator', all_parents
 187   class_iter_loop:
 188     unless class_iter goto class_iter_loop_end
 189     .local pmc cur_class
 190     cur_class = shift class_iter
 191
 192     # If it's PMCProxy, then skip over it, since it's attribute is the delegate
 193     # instance of a parent PMC class, which we should not change to Undef.
 194     .local int is_pmc_proxy
 195     is_pmc_proxy = isa cur_class, "PMCProxy"
 196     if is_pmc_proxy goto class_iter_loop_end
 197
 198     # If this the current class?
 199     .local pmc init_attribs
 200     eq_addr cur_class, $P0, current_class
 201
 202     # If it's not the current class, need to see if we have any attributes.
 203     # Go through the provided init_parents to see if we have anything that
 204     # matches.
 205     .local pmc ip_iter, cur_ip
 206     ip_iter = new 'Iterator', init_parents
 207   ip_iter_loop:
 208     unless ip_iter goto ip_iter_loop_end
 209     cur_ip = shift ip_iter
 210
 211     # We will check if their HOW matches.
 212     $P2 = p6meta.'get_parrotclass'(cur_ip)
 213     eq_addr cur_class, $P2, found_parent_init
 214
 215     goto found_init_attribs
 216   ip_iter_loop_end:
 217
 218     # If we get here, found nothing.
 219     init_attribs = new 'Hash'
 220     goto parent_init_search_done
 221
 222     # We found some parent init data, potentially.
 223   found_parent_init:
 224     init_attribs = cur_ip.WHENCE()
 225     $I0 = 'defined'(init_attribs)
 226     if $I0 goto parent_init_search_done
 227     init_attribs = new 'Hash'
 228   parent_init_search_done:
 229     goto found_init_attribs
 230
 231     # If it's the current class, we will take the init_this hash.
 232   current_class:
 233     init_attribs = init_this
 234   found_init_attribs:
 235
 236     # Now go through attributes of the current class and iternate over them.
 237     .local pmc attribs, iter
 238     attribs = inspect cur_class, "attributes"
 239     iter = new 'Iterator', attribs
 240   iter_loop:
 241     unless iter goto iter_end
 242     $S0 = shift iter
 243
 244     # See if we have an init value; use Undef if not.
 245     .local int got_init_value
 246     $S1 = substr $S0, 2
 247     got_init_value = exists init_attribs[$S1]
 248     if got_init_value goto have_init_value
 249     $P2 = new 'Undef'
 250     goto init_done
 251   have_init_value:
 252     $P2 = init_attribs[$S1]
 253     delete init_attribs[$S1]
 254   init_done:
 255
 256     # Is it a scalar? If so, want a scalar container with the type set on it.
 257     .local string sigil
 258     sigil = substr $S0, 0, 1
 259     if sigil != '$' goto no_scalar
 260     .local pmc attr_info, type
 261     attr_info = attribs[$S0]
 262     if null attr_info goto set_attrib
 263     type = attr_info['type']
 264     if null type goto set_attrib
 265     if got_init_value goto no_proto_init
 266     $I0 = isa type, 'P6protoobject'
 267     unless $I0 goto no_proto_init
 268     set $P2, type
 269   no_proto_init:
 270     $P2 = new 'Perl6Scalar', $P2
 271     setprop $P2, 'type', type
 272     goto set_attrib
 273   no_scalar:
 274
 275     # Is it an array? If so, initialize to Perl6Array.
 276     if sigil != '@' goto no_array
 277     $P2 = new 'Perl6Array'
 278     goto set_attrib
 279   no_array:
 280
 281     # Is it a Hash? If so, initialize to Perl6Hash.
 282     if sigil != '%' goto no_hash
 283     $P2 = new 'Perl6Hash'
 284     goto set_attrib
 285   no_hash:
 286
 287   set_attrib:
 288     push_eh set_attrib_eh
 289     setattribute $P1, cur_class, $S0, $P2
 290   set_attrib_eh:
 291     goto iter_loop
 292   iter_end:
 293
 294     # Do we have anything left in the hash? If so, unknown.
 295     $I0 = elements init_attribs
 296     if $I0 == 0 goto init_attribs_ok
 297     'die'("You passed an initialization parameter that does not have a matching attribute.")
 298   init_attribs_ok:
 299
 300     # Next class.
 301     goto class_iter_loop
 302   class_iter_loop_end:
 303
 304     .return ($P1)
 305 .end
 306
 307 =item WHENCE()
 308
 309 Return the invocant's auto-vivification closure.
 310
 311 =cut
 312
 313 .sub 'WHENCE' :method
 314     $P0 = self.'WHAT'()
 315     $P1 = $P0.'WHENCE'()
 316     .return ($P1)
 317 .end
 318
 319 =item REJECTS(topic)
 320
 321 Define REJECTS methods for objects (this would normally
 322 be part of the Pattern role, but we put it here for now
 323 until we get roles).
 324
 325 =cut
 326
 327 .sub 'REJECTS' :method
 328     .param pmc topic
 329     $P0 = self.'ACCEPTS'(topic)
 330     n_not $P0, $P0
 331     .return ($P0)
 332 .end
 333
 334 =item true()
 335
 336 Defines the .true method on all objects via C<prefix:?>.
 337
 338 =cut
 339
 340 .sub 'true' :method
 341  .return 'prefix:?'(self)
 342 .end
 343
 344 =item get_bool (vtable)
 345
 346 Returns true if the object is defined, false otherwise.
 347
 348 =cut
 349
 350 .sub '' :vtable('get_bool')
 351     $I0 = 'defined'(self)
 352     .return ($I0)
 353 .end
 354
 355 =item print()
 356
 357 =item say()
 358
 359 Print the object
 360
 361 =cut
 362
 363 .sub 'print' :method
 364     $P0 = get_hll_global 'print'
 365     .return $P0(self)
 366 .end
 367
 368 .sub 'say' :method
 369     $P0 = get_hll_global 'say'
 370     .return $P0(self)
 371 .end
 372
 373 =item WHERE
 374
 375 Gets the memory address of the object.
 376
 377 =cut
 378
 379 .sub 'WHERE' :method
 380     $I0 = get_addr self
 381     .return ($I0)
 382 .end
 383
 384 =item WHICH
 385
 386 Gets the object's identity value
 387
 388 =cut
 389
 390 .sub 'WHICH' :method
 391     # For normal objects, this can just be the memory address.
 392     .return self.'WHERE'()
 393 .end
 394
 395 =back
 396
 397 =head2 Private methods
 398
 399 =over 4
 400
 401 =item !cloneattr(attrlist)
 402
 403 Create a clone of self, also cloning the attributes given by attrlist.
 404
 405 =cut
 406
 407 .sub '!cloneattr' :method
 408     .param string attrlist
 409     .local pmc p6meta, result
 410     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
 411     $P0 = p6meta.'get_parrotclass'(self)
 412     result = new $P0
 413
 414     .local pmc attr_it
 415     attr_it = split ' ', attrlist
 416   attr_loop:
 417     unless attr_it goto attr_end
 418     $S0 = shift attr_it
 419     unless $S0 goto attr_loop
 420     $P1 = getattribute self, $S0
 421     $P1 = clone $P1
 422     setattribute result, $S0, $P1
 423     goto attr_loop
 424   attr_end:
 425     .return (result)
 426 .end
 427
 428
 429 .sub '!.?' :method
 430     .param string method_name
 431     .param pmc pos_args     :slurpy
 432     .param pmc named_args   :slurpy :named
 433
 434     # For now we won't worry about signature, just if a method exists.
 435     $I0 = can self, method_name
 436     if $I0 goto invoke
 437     $P0 = get_hll_global 'Failure'
 438     .return ($P0)
 439
 440     # If we do have a method, call it.
 441   invoke:
 442     .return self.method_name(pos_args :flat, named_args :named :flat)
 443 .end
 444
 445
 446 .sub '!.*' :method
 447     .param string method_name
 448     .param pmc pos_args     :slurpy
 449     .param pmc named_args   :slurpy :named
 450
 451     # Return an empty list if no methods exist at all.
 452     $I0 = can self, method_name
 453     if $I0 goto invoke
 454     .return 'list'()
 455
 456     # Now find all methods and call them - since we know there are methods,
 457     # we just pass on to infix:.+.
 458   invoke:
 459     .return self.'!.+'(method_name, pos_args :flat, named_args :named :flat)
 460 .end
 461
 462
 463 .sub '!.+' :method
 464     .param string method_name
 465     .param pmc pos_args     :slurpy
 466     .param pmc named_args   :slurpy :named
 467
 468     # We need to find all methods we could call with the right name.
 469     .local pmc p6meta, result_list, class, mro, it, cap_class, failure_class
 470     result_list = 'list'()
 471     p6meta = get_hll_global ['Perl6Object'], '$!P6META'
 472     class = self.'HOW'()
 473     class = p6meta.get_parrotclass(class)
 474     mro = inspect class, 'all_parents'
 475     it = iter mro
 476     cap_class = get_hll_global 'Capture'
 477     failure_class = get_hll_global 'Failure'
 478   mro_loop:
 479     unless it goto mro_loop_end
 480     .local pmc cur_class, meths, cur_meth
 481     cur_class = shift it
 482     meths = inspect cur_class, 'methods'
 483     cur_meth = meths[method_name]
 484     if null cur_meth goto mro_loop
 485
 486     # If we're here, found a method. Invoke it and add capture of the results
 487     # to the result list.
 488     .local pmc pos_res, named_res, cap
 489     (pos_res :slurpy, named_res :named :slurpy) = cur_meth(self, pos_args :flat, named_args :named :flat)
 490     cap = 'prefix:\\'(pos_res :flat, named_res :flat :named)
 491     push result_list, cap
 492     goto mro_loop
 493   mro_loop_end:
 494
 495     # Make sure we got some elements, or we have to die.
 496     $I0 = elements result_list
 497     if $I0 == 0 goto failure
 498     .return (result_list)
 499   failure:
 500     $S0 = "Could not invoke method '"
 501     concat $S0, method_name
 502     concat $S0, "' on invocant of type '"
 503     $S1 = self.WHAT()
 504     concat $S0, $S1
 505     concat $S0, "'"
 506     'die'($S0)
 507 .end
 508
 509
 510 .sub '!.^' :method
 511     .param string method_name
 512     .param pmc pos_args     :slurpy
 513     .param pmc named_args   :slurpy :named
 514
 515     # Get the HOW or the object and do the call on that.
 516     .local pmc how
 517     how = self.'HOW'()
 518     .return how.method_name(self, pos_args :flat, named_args :flat :named)
 519 .end
 520
 521
 522 .namespace ['P6protoobject']
 523
 524 =back
 525
 526 =head2 Methods on P6protoobject
 527
 528 =over
 529
 530 =item WHENCE()
 531
 532 Returns the protoobject's autovivification closure.
 533
 534 =cut
 535
 536 .sub 'WHENCE' :method
 537     .local pmc props, whence
 538     props = getattribute self, '%!properties'
 539     if null props goto ret_undef
 540     whence = props['WHENCE']
 541     if null whence goto ret_undef
 542     .return (whence)
 543   ret_undef:
 544     whence = new 'Undef'
 545     .return (whence)
 546 .end
 547
 548
 549 =item defined()
 550
 551 =cut
 552
 553 .sub 'defined' :method
 554     $P0 = get_hll_global ['Bool'], 'False'
 555     .return ($P0)
 556 .end
 557
 558
 559 =item item()
 560
 561 Returns itself in item context.
 562
 563 =cut
 564
 565 .sub 'item' :method
 566     .return (self)
 567 .end
 568
 569
 570 =item list()
 571
 572 Returns a list containing itself in list context.
 573
 574 =cut
 575
 576 .sub 'list' :method
 577     .return 'list'(self)
 578 .end
 579
 580
 581 =item get_pmc_keyed(key)    (vtable method)
 582
 583 Returns a proto-object with an autovivification closure attached to it.
 584
 585 =cut
 586
 587 .sub get_pmc_keyed :vtable :method
 588     .param pmc what
 589
 590     # We'll build auto-vivification hash of values.
 591     .local pmc WHENCE, key, val
 592     WHENCE = new 'Hash'
 593
 594     # What is it?
 595     $S0 = what.'WHAT'()
 596     if $S0 == 'Pair' goto from_pair
 597     if $S0 == 'List' goto from_list
 598     'die'("Auto-vivification closure did not contain a Pair")
 599
 600   from_pair:
 601     # Just a pair.
 602     key = what.'key'()
 603     val = what.'value'()
 604     WHENCE[key] = val
 605     goto done_whence
 606
 607   from_list:
 608     # List.
 609     .local pmc list_iter, cur_pair
 610     list_iter = new 'Iterator', what
 611   list_iter_loop:
 612     unless list_iter goto done_whence
 613     cur_pair = shift list_iter
 614     key = cur_pair.'key'()
 615     val = cur_pair.'value'()
 616     WHENCE[key] = val
 617     goto list_iter_loop
 618   done_whence:
 619
 620     # Now create a clone of the protoobject.
 621     .local pmc protoclass, res, props, tmp
 622     protoclass = class self
 623     res = new protoclass
 624
 625     # Attach the WHENCE property.
 626     props = getattribute self, '%!properties'
 627     unless null props goto have_props
 628     props = new 'Hash'
 629   have_props:
 630     props['WHENCE'] = WHENCE
 631     setattribute res, '%!properties', props
 632
 633     .return (res)
 634 .end
 635
 636 =back
 637
 638 =cut
 639
 640 # Local Variables:
 641 #   mode: pir
 642 #   fill-column: 100
 643 # End:
 644 # vim: expandtab shiftwidth=4 ft=pir: