Front page | perl.cvs.parrot |
Postings from December 2008
[svn:parrot] r34707 - in trunk/languages/pipp/src: classes common pct
From:
bernhard
Date:
December 31, 2008 08:09
Subject:
[svn:parrot] r34707 - in trunk/languages/pipp/src: classes common pct
Message ID:
20081231160945.5A68ECB9FA@x12.develooper.com
Author: bernhard
Date: Wed Dec 31 08:09:44 2008
New Revision: 34707
Added:
trunk/languages/pipp/src/classes/
trunk/languages/pipp/src/classes/Object.pir (contents, props changed)
- copied, changed from r34704, /trunk/languages/perl6/src/classes/Object.pir
Modified:
trunk/languages/pipp/src/common/builtins.pir
trunk/languages/pipp/src/common/guts.pir
trunk/languages/pipp/src/pct/actions.pm
Log:
[Pipp] start on src/classes/Object.pir
Register a proto for newly generated classes.
Call !PROTOINIT on the registered proto.
Copied: trunk/languages/pipp/src/classes/Object.pir (from r34704, /trunk/languages/perl6/src/classes/Object.pir)
==============================================================================
--- /trunk/languages/perl6/src/classes/Object.pir (original)
+++ trunk/languages/pipp/src/classes/Object.pir Wed Dec 31 08:09:44 2008
@@ -2,493 +2,37 @@
=head1 TITLE
-Object - Perl 6 Object class
+Object - Pipp Object class
=head1 DESCRIPTION
-This file sets up the base classes and methods for Perl 6's
+This file sets up the base classes and methods for Pipp's
object system. Differences (and conflicts) between Parrot's
-object model and the Perl 6 model means we have to do a little
+object model and the PHP model means we have to do a little
name and method trickery here and there, and this file takes
care of much of that.
+This is heavily based on Rakudo's Object.pir
+
=cut
.namespace []
.sub '' :anon :init :load
- .local pmc p6meta
load_bytecode 'PCT.pbc'
- $P0 = get_root_global ['parrot'], 'P6metaclass'
- $P0.'new_class'('Perl6Object', 'name'=>'Object')
- p6meta = $P0.'HOW'()
- set_hll_global ['Perl6Object'], '$!P6META', p6meta
-.end
-
-=head2 Methods
-
-=over 4
-
-=item clone()
-
-Returns a copy of the object.
-
-NOTE: Don't copy what this method does; it's a tad inside-out. We should be
-overriding the clone vtable method to call .clone() really. But if we do that,
-we can't current get at the Object PMC's clone method, so for now we do it
-like this.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'clone' :method
- .param pmc new_attrs :slurpy :named
-
- # Make a clone.
- .local pmc result
- $I0 = isa self, 'ObjectRef'
- unless $I0 goto do_clone
- self = deref self
- do_clone:
- result = clone self
-
- # Set any new attributes.
- .local pmc it
- it = iter new_attrs
- it_loop:
- unless it goto it_loop_end
- $S0 = shift it
- $P0 = new_attrs[$S0]
- $S0 = concat '!', $S0
- $P1 = result.$S0()
- 'infix:='($P1, $P0)
- goto it_loop
- it_loop_end:
-
- .return (result)
-.end
-
-
-=item defined()
-
-Return true if the object is defined.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'defined' :method
- $P0 = get_hll_global ['Bool'], 'True'
- .return ($P0)
-.end
-
-
-=item hash
-
-Return invocant in hash context.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'hash' :method
- .tailcall self.'Hash'()
-.end
-
-.namespace []
-.sub 'hash'
- .param pmc values :slurpy
- .tailcall values.'Hash'()
-.end
-
-=item item
-
-Return invocant in item context. Default is to return self.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'item' :method
- .return (self)
-.end
-
-.namespace []
-.sub 'item'
- .param pmc x :slurpy
- $I0 = elements x
- unless $I0 == 1 goto have_x
- x = shift x
- have_x:
- $I0 = can x, 'item'
- unless $I0 goto have_item
- x = x.'item'()
- have_item:
- .return (x)
-.end
-
-
-=item iterator
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'iterator' :method
- $P0 = self.'list'()
- .tailcall $P0.'iterator'()
-.end
-
-
-=item list
-
-Return invocant in list context. Default is to return a List containing self.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'list' :method
- $P0 = new 'List'
- push $P0, self
- .return ($P0)
-.end
-
-=item print()
-
-Print the object.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'print' :method
- $P0 = get_hll_global 'print'
- .tailcall $P0(self)
-.end
-
-=item say()
-
-Print the object, followed by a newline.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'say' :method
- $P0 = get_hll_global 'say'
- .tailcall $P0(self)
-.end
-
-=item true()
-
-Boolean value of object -- defaults to C<.defined> (S02).
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'true' :method
- .tailcall self.'defined'()
-.end
-
-=back
-
-=head2 Coercion methods
-
-=over 4
-
-=item Array()
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'Array' :method
- $P0 = new 'Perl6Array'
- $P0.'!STORE'(self)
- .return ($P0)
-.end
-
-=item Hash()
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'Hash' :method
- $P0 = new 'Perl6Hash'
- $P0.'!STORE'(self)
- .return ($P0)
-.end
-
-=item Iterator()
-
-=cut
-
-.sub 'Iterator' :method
- $P0 = self.'list'()
- .tailcall $P0.'Iterator'()
-.end
-
-=item Scalar()
-
-Default Scalar() gives reference type semantics, returning
-an object reference (unless the invocant already is one).
-
-=cut
-
-.namespace ['Perl6Object']
-.sub '' :method('Scalar') :anon
- $I0 = isa self, 'ObjectRef'
- unless $I0 goto not_ref
- .return (self)
- not_ref:
- $P0 = new 'ObjectRef', self
- .return ($P0)
-.end
-.namespace []
-.sub 'Scalar'
- .param pmc source
- $I0 = isa source, 'ObjectRef'
- if $I0 goto done
- $I0 = can source, 'Scalar'
- if $I0 goto can_scalar
- $I0 = does source, 'scalar'
- source = new 'ObjectRef', source
- done:
- .return (source)
- can_scalar:
- .tailcall source.'Scalar'()
-.end
-
-=item Str()
-
-Return a string representation of the invocant. Default is
-the object's type and address.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'Str' :method
- $P0 = new 'ResizableStringArray'
- $P1 = self.'WHAT'()
- push $P0, $P1
- $I0 = get_addr self
- push $P0, $I0
- $S0 = sprintf "%s<0x%x>", $P0
- .return ($S0)
-.end
-
-=back
-
-=head2 Special methods
-
-=over 4
-
-=item new()
-
-Create a new object having the same class as the invocant.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub 'new' :method
- .param pmc init_parents :slurpy
- .param pmc init_this :named :slurpy
+ $P0 = get_root_global ['parrot'], 'P6metaclass'
+ $P0.'new_class'('PippObject', 'name'=>'Object')
- # Instantiate.
.local pmc p6meta
- p6meta = get_hll_global ['Perl6Object'], '$!P6META'
- $P0 = p6meta.'get_parrotclass'(self)
- $P1 = new $P0
-
- # If this proto object has a WHENCE auto-vivification, we should use
- # put any values it contains but that init_this does not into init_this.
- .local pmc whence
- whence = self.'WHENCE'()
- unless whence goto no_whence
- .local pmc this_whence_iter
- this_whence_iter = iter whence
- this_whence_iter_loop:
- unless this_whence_iter goto no_whence
- $S0 = shift this_whence_iter
- $I0 = exists init_this[$S0]
- if $I0 goto this_whence_iter_loop
- $P2 = whence[$S0]
- init_this[$S0] = $P2
- goto this_whence_iter_loop
- no_whence:
-
- # Now we will initialize each attribute in the class itself and it's
- # parents with an Undef or the specified initialization value. Note that
- # the all_parents list includes ourself.
- .local pmc all_parents, class_iter
- all_parents = inspect $P0, "all_parents"
- class_iter = iter all_parents
- class_iter_loop:
- unless class_iter goto class_iter_loop_end
- .local pmc cur_class
- cur_class = shift class_iter
-
- # If it's PMCProxy, then skip over it, since it's attribute is the delegate
- # instance of a parent PMC class, which we should not change to Undef.
- .local int is_pmc_proxy
- is_pmc_proxy = isa cur_class, "PMCProxy"
- if is_pmc_proxy goto class_iter_loop_end
-
- # If this the current class?
- .local pmc init_attribs
- eq_addr cur_class, $P0, current_class
-
- # If it's not the current class, need to see if we have any attributes.
- # Go through the provided init_parents to see if we have anything that
- # matches.
- .local pmc ip_iter, cur_ip
- ip_iter = iter init_parents
- ip_iter_loop:
- unless ip_iter goto ip_iter_loop_end
- cur_ip = shift ip_iter
-
- # We will check if their HOW matches.
- $P2 = p6meta.'get_parrotclass'(cur_ip)
- eq_addr cur_class, $P2, found_parent_init
-
- goto found_init_attribs
- ip_iter_loop_end:
-
- # If we get here, found nothing.
- init_attribs = new 'Hash'
- goto parent_init_search_done
-
- # We found some parent init data, potentially.
- found_parent_init:
- init_attribs = cur_ip.'WHENCE'()
- $I0 = 'defined'(init_attribs)
- if $I0 goto parent_init_search_done
- init_attribs = new 'Hash'
- parent_init_search_done:
- goto found_init_attribs
-
- # If it's the current class, we will take the init_this hash.
- current_class:
- init_attribs = init_this
- found_init_attribs:
-
- # Now go through attributes of the current class and iternate over them.
- .local pmc attribs, it
- attribs = inspect cur_class, "attributes"
- it = iter attribs
- iter_loop:
- unless it goto iter_end
- $S0 = shift it
-
- # See if we have an init value; use Undef if not.
- .local int got_init_value
- $S1 = substr $S0, 2
- got_init_value = exists init_attribs[$S1]
- if got_init_value goto have_init_value
- $P2 = new 'Undef'
- goto init_done
- have_init_value:
- $P2 = init_attribs[$S1]
- delete init_attribs[$S1]
- init_done:
-
- # Is it a scalar? If so, want a scalar container with the type set on it.
- .local string sigil
- sigil = substr $S0, 0, 1
- if sigil != '$' goto no_scalar
- .local pmc attr_info, type
- attr_info = attribs[$S0]
- if null attr_info goto set_attrib
- type = attr_info['type']
- if null type goto set_attrib
- if got_init_value goto no_proto_init
- $I0 = isa type, 'P6protoobject'
- unless $I0 goto no_proto_init
- set $P2, type
- no_proto_init:
- $P2 = new 'Perl6Scalar', $P2
- setprop $P2, 'type', type
- goto set_attrib
- no_scalar:
-
- # Is it an array? If so, initialize to Perl6Array.
- if sigil != '@' goto no_array
- $P3 = new 'Perl6Array'
- $I0 = defined $P2
- if $I0 goto have_array_value
- set $P2, $P3
- goto set_attrib
- have_array_value:
- 'infix:='($P3, $P2)
- set $P2, $P3
- goto set_attrib
- no_array:
-
- # Is it a Hash? If so, initialize to Perl6Hash.
- if sigil != '%' goto no_hash
- $P3 = new 'Perl6Hash'
- $I0 = defined $P2
- if $I0 goto have_hash_value
- set $P2, $P3
- goto set_attrib
- have_hash_value:
- 'infix:='($P3, $P2)
- set $P2, $P3
- goto set_attrib
- no_hash:
-
- set_attrib:
- push_eh set_attrib_eh
- setattribute $P1, cur_class, $S0, $P2
- set_attrib_eh:
- pop_eh
- goto iter_loop
- iter_end:
-
- # Do we have anything left in the hash? If so, unknown.
- $I0 = elements init_attribs
- if $I0 == 0 goto init_attribs_ok
- 'die'("You passed an initialization parameter that does not have a matching attribute.")
- init_attribs_ok:
-
- # Next class.
- goto class_iter_loop
- class_iter_loop_end:
-
- .return ($P1)
-.end
-
-=item 'PARROT'
-
-Report the object's true nature.
-
-=cut
-
-.sub 'PARROT' :method
- .local pmc obj
- .local string result
- obj = self
- result = ''
- $I0 = isa obj, 'ObjectRef'
- unless $I0 goto have_obj
- result = 'ObjectRef->'
- obj = deref obj
- have_obj:
- $P0 = typeof obj
- $S0 = $P0
- result .= $S0
- .return (result)
+ p6meta = $P0.'HOW'()
+ set_hll_global ['PippObject'], '$!P6META', p6meta
.end
+.namespace ['PippObject']
-=item REJECTS(topic)
-
-Define REJECTS methods for objects (this would normally
-be part of the Pattern role, but we put it here for now
-until we get roles).
-
-=cut
-
-.sub 'REJECTS' :method
- .param pmc topic
- $P0 = self.'ACCEPTS'(topic)
- n_not $P0, $P0
- .return ($P0)
-.end
+=head2 Methods
+=over 4
=item WHENCE()
@@ -502,266 +46,19 @@
.return ($P1)
.end
-
-=item WHERE
-
-Gets the memory address of the object.
-
-=cut
-
-.sub 'WHERE' :method
- $I0 = get_addr self
- .return ($I0)
-.end
-
-
-=item WHICH
-
-Gets the object's identity value
-
-=cut
-
-.sub 'WHICH' :method
- # For normal objects, this can just be the memory address.
- .tailcall self.'WHERE'()
-.end
-
=back
=head2 Private methods
=over 4
-=item !cloneattr(attrlist)
-
-Create a clone of self, also cloning the attributes given by attrlist.
-
-=cut
-
-.namespace ['Perl6Object']
-.sub '!cloneattr' :method
- .param string attrlist
- .local pmc p6meta, result
- p6meta = get_hll_global ['Perl6Object'], '$!P6META'
- $P0 = p6meta.'get_parrotclass'(self)
- result = new $P0
-
- .local pmc attr_it
- attr_it = split ' ', attrlist
- attr_loop:
- unless attr_it goto attr_end
- $S0 = shift attr_it
- unless $S0 goto attr_loop
- $P1 = getattribute self, $S0
- if null $P1 goto null_attr
- $P1 = clone $P1
- null_attr:
- setattribute result, $S0, $P1
- goto attr_loop
- attr_end:
- .return (result)
-.end
-
-=item !.?
-
-Helper method for implementing the .? operator. Calls at most one matching
-method, and returns undef if there are none.
-
-=cut
-
-.sub '!.?' :method
- .param string method_name
- .param pmc pos_args :slurpy
- .param pmc named_args :slurpy :named
-
- # Get all possible methods.
- .local pmc methods
- methods = self.'!MANY_DISPATCH_HELPER'(method_name, pos_args, named_args)
-
- # Do we have any?
- $I0 = elements methods
- if $I0 goto invoke
- .tailcall '!FAIL'('Undefined value returned by invocation of undefined method')
-
- # If we do have a method, call it.
- invoke:
- $P0 = methods[0]
- .tailcall self.$P0(pos_args :flat, named_args :named :flat)
-.end
-
-=item !.*
-
-Helper method for implementing the .* operator. Calls one or more matching
-methods.
-
-=cut
-
-.sub '!.*' :method
- .param string method_name
- .param pmc pos_args :slurpy
- .param pmc named_args :slurpy :named
-
- # Get all possible methods.
- .local pmc methods
- methods = self.'!MANY_DISPATCH_HELPER'(method_name, pos_args, named_args)
-
- # Build result capture list.
- .local pmc pos_res, named_res, cap, result_list, it, cur_meth
- $P0 = get_hll_global 'list'
- result_list = $P0()
- it = iter methods
- it_loop:
- unless it goto it_loop_end
- cur_meth = shift it
- (pos_res :slurpy, named_res :named :slurpy) = cur_meth(self, pos_args :flat, named_args :named :flat)
- cap = 'prefix:\\'(pos_res :flat, named_res :flat :named)
- push result_list, cap
- goto it_loop
- it_loop_end:
-
- .return (result_list)
-.end
-
-
-=item !.+
-
-Helper method for implementing the .+ operator. Calls one or more matching
-methods, dies if there are none.
-
-=cut
-
-.sub '!.+' :method
- .param string method_name
- .param pmc pos_args :slurpy
- .param pmc named_args :slurpy :named
-
- # Use !.* to produce a (possibly empty) list of result captures.
- .local pmc result_list
- result_list = self.'!.*'(method_name, pos_args :flat, named_args :flat :named)
-
- # If we got no elements at this point, we must die.
- $I0 = elements result_list
- if $I0 == 0 goto failure
- .return (result_list)
- failure:
- $S0 = "Could not invoke method '"
- concat $S0, method_name
- concat $S0, "' on invocant of type '"
- $S1 = self.'WHAT'()
- concat $S0, $S1
- concat $S0, "'"
- 'die'($S0)
-.end
-
-
-=item !MANY_DISPATCH_HELPER
-
-This is a helper for implementing .+, .? and .*. In the future, it may well be
-the basis of WALK also. It returns all methods we could possible call.
-
-=cut
-
-.sub '!MANY_DISPATCH_HELPER' :method
- .param string method_name
- .param pmc pos_args
- .param pmc named_args
-
- # We need to find all methods we could call with the right name.
- .local pmc p6meta, result_list, class, mro, it
- $P0 = get_hll_global 'list'
- result_list = $P0()
- p6meta = get_hll_global ['Perl6Object'], '$!P6META'
- class = self.'WHAT'()
- class = p6meta.'get_parrotclass'(class)
- mro = inspect class, 'all_parents'
- it = iter mro
- mro_loop:
- unless it goto mro_loop_end
- .local pmc cur_class, meths, cur_meth
- cur_class = shift it
- meths = inspect cur_class, 'methods'
- cur_meth = meths[method_name]
- if null cur_meth goto mro_loop
-
- # If we're here, found a method. But is it a multi?
- $I0 = isa cur_meth, "Perl6MultiSub"
- if $I0 goto multi_dispatch
-
- # Single dispatch - add to the result list.
- push result_list, cur_meth
- goto mro_loop
-
- # Multiple dispatch; get all applicable candidates.
- multi_dispatch:
- .local pmc possibles, possibles_it
- possibles = cur_meth.'find_possible_candidates'(self, pos_args :flat)
- possibles_it = iter possibles
- possibles_it_loop:
- unless possibles_it goto possibles_it_loop_end
- cur_meth = shift possibles_it
- push result_list, cur_meth
- goto possibles_it_loop
- possibles_it_loop_end:
- goto mro_loop
- mro_loop_end:
-
- .return (result_list)
-.end
-
-=item !.^
-
-Helper for doing calls on the metaclass.
-
-=cut
-
-.sub '!.^' :method
- .param string method_name
- .param pmc pos_args :slurpy
- .param pmc named_args :slurpy :named
-
- # Get the HOW or the object and do the call on that.
- .local pmc how
- how = self.'HOW'()
- .tailcall how.method_name(self, pos_args :flat, named_args :flat :named)
-.end
-
=back
=head2 Vtable functions
=cut
-.namespace ['Perl6Object']
-.sub '' :vtable('decrement') :method
- $P0 = self.'pred'()
- 'infix:='(self, $P0)
- .return(self)
-.end
-
-.sub '' :vtable('defined') :method
- $I0 = self.'defined'()
- .return ($I0)
-.end
-
-.sub '' :vtable('get_bool') :method
- $I0 = self.'true'()
- .return ($I0)
-.end
-
-.sub '' :vtable('get_iter') :method
- .tailcall self.'Iterator'()
-.end
-
-.sub '' :vtable('get_string') :method
- $S0 = self.'Str'()
- .return ($S0)
-.end
-
-.sub '' :vtable('increment') :method
- $P0 = self.'succ'()
- 'infix:='(self, $P0)
- .return(self)
-.end
+.namespace ['PippObject']
# Local Variables:
# mode: pir
Modified: trunk/languages/pipp/src/common/builtins.pir
==============================================================================
--- trunk/languages/pipp/src/common/builtins.pir (original)
+++ trunk/languages/pipp/src/common/builtins.pir Wed Dec 31 08:09:44 2008
@@ -6,6 +6,7 @@
.include 'languages/pipp/src/common/php_MACRO.pir'
.include 'languages/pipp/src/common/guts.pir'
+.include 'languages/pipp/src/classes/Object.pir'
.include 'languages/pipp/src/common/eval.pir'
# steal builtins from Perl6
Modified: trunk/languages/pipp/src/common/guts.pir
==============================================================================
--- trunk/languages/pipp/src/common/guts.pir (original)
+++ trunk/languages/pipp/src/common/guts.pir Wed Dec 31 08:09:44 2008
@@ -111,6 +111,28 @@
.end
+=item !PROTOINIT
+
+Called after a new proto-object has been made for a new class or grammar. It
+finds any WHENCE data that we may need to add.
+
+=cut
+
+.sub '!PROTOINIT'
+ .param pmc proto
+
+ # See if there's any attribute initializers.
+ .local pmc p6meta, WHENCE
+ p6meta = get_hll_global ['PippObject'], '$!P6META'
+ $P0 = p6meta.'get_parrotclass'(proto)
+ WHENCE = getprop '%!WHENCE', $P0
+ if null WHENCE goto no_whence
+
+ setprop proto, '%!WHENCE', WHENCE
+ no_whence:
+ .return (proto)
+.end
+
=back
Modified: trunk/languages/pipp/src/pct/actions.pm
==============================================================================
--- trunk/languages/pipp/src/pct/actions.pm (original)
+++ trunk/languages/pipp/src/pct/actions.pm Wed Dec 31 08:09:44 2008
@@ -638,6 +638,27 @@
)
);
+ # It's a new class definition. Make proto-object.
+ $block.push(
+ PAST::Op.new(
+ :pasttype('call'),
+ :name('!PROTOINIT'),
+ PAST::Op.new(
+ :pasttype('callmethod'),
+ :name('register'),
+ PAST::Var.new(
+ :scope('package'),
+ :name('$!P6META'),
+ :namespace('PippObject')
+ ),
+ PAST::Var.new(
+ :scope('register'),
+ :name('def')
+ )
+ )
+ )
+ );
+
# nothing to do for $<const_definition,
# setup of class constants is done in the 'loadinit' node
for $<class_constant_definition> {
-
[svn:parrot] r34707 - in trunk/languages/pipp/src: classes common pct
by bernhard