Author: pmichaud
Date: Sun Dec 7 19:46:27 2008
New Revision: 33643
Added:
branches/assign/languages/perl6/src/classes/Protoobject.pir (contents,
props changed)
Modified:
branches/assign/MANIFEST
branches/assign/languages/perl6/config/makefiles/root.in
branches/assign/languages/perl6/src/builtins/assign.pir
branches/assign/languages/perl6/src/classes/Array.pir
branches/assign/languages/perl6/src/classes/List.pir
branches/assign/languages/perl6/src/classes/Object.pir
branches/assign/languages/perl6/src/pmc/objectref_pmc.template
Log:
[rakudo]: Initial assignment refactors.
* set infix:= to be a :multi.
* clean up array assignment.
* clean up lots of list/array methods.
* move Protoobject methods into a separate .pir file
* reorder class methods for some classes
Modified: branches/assign/MANIFEST
==============================================================================
--- branches/assign/MANIFEST (original)
+++ branches/assign/MANIFEST Sun Dec 7 19:46:27 2008
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Sun Dec 7 15:38:53 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Mon Dec 8 03:44:20 2008 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -2148,6 +2148,7 @@
languages/perl6/src/classes/Object.pir [perl6]
languages/perl6/src/classes/Order.pir [perl6]
languages/perl6/src/classes/Pair.pir [perl6]
+languages/perl6/src/classes/Protoobject.pir [perl6]
languages/perl6/src/classes/Range.pir [perl6]
languages/perl6/src/classes/Role.pir [perl6]
languages/perl6/src/classes/Routine.pir [perl6]
Modified: branches/assign/languages/perl6/config/makefiles/root.in
==============================================================================
--- branches/assign/languages/perl6/config/makefiles/root.in (original)
+++ branches/assign/languages/perl6/config/makefiles/root.in Sun Dec 7
19:46:27 2008
@@ -34,7 +34,7 @@
#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X
compilation/linking
#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
-all: perl6.pbc Test.pir
+all: perl6.pbc
xmas: perl6$(EXE)
@@ -51,6 +51,7 @@
BUILTINS_PIR = \
src/classes/Object.pir \
+ src/classes/Protoobject.pir \
src/classes/Any.pir \
src/classes/Bool.pir \
src/classes/Str.pir \
@@ -203,13 +204,13 @@
HARNESS_WITH_FUDGE = $(PERL) t/harness --fudge --keep-exit-code
HARNESS_WITH_FUDGE_JOBS = $(HARNESS_WITH_FUDGE) --jobs
-spectest_full: all t/spec
+spectest_full: all Test.pir t/spec
-cd t/spec && svn up
$(HARNESS_WITH_FUDGE_JOBS) t/spec
# Run the spectests that we know work.
spectest_regression: spectest
-spectest: all t/spec t/spectest.data
+spectest: all Test.pir t/spec t/spectest.data
-cd t/spec && svn up
$(HARNESS_WITH_FUDGE_JOBS) --tests-from-file=t/spectest.data
Modified: branches/assign/languages/perl6/src/builtins/assign.pir
==============================================================================
--- branches/assign/languages/perl6/src/builtins/assign.pir (original)
+++ branches/assign/languages/perl6/src/builtins/assign.pir Sun Dec 7
19:46:27 2008
@@ -10,25 +10,12 @@
=cut
-.namespace []
-
-## assignment
-## TODO: infix::= infix:::= infix:.=
-## -- these will likely be handled by compiler translation --Pm
-
-.sub 'infix:='
+.namespace []
+.sub 'infix:=' :multi(_,_)
.param pmc cont
.param pmc source
- $I0 = isa cont, 'ObjectRef'
- if $I0 goto cont_scalar
- $I0 = isa cont, 'Perl6Array'
- if $I0 goto cont_array
- $I0 = isa cont, 'Perl6Hash'
- if $I0 goto cont_hash
-
- cont_scalar:
$I0 = isa source, 'ObjectRef'
if $I0 goto have_source
$I0 = can source, 'Scalar'
@@ -59,13 +46,46 @@
copy cont, source
skip_copy:
.return (cont)
+.end
+
+.sub 'infix:=' :multi(['Perl6Array'], _)
+ .param pmc cont
+ .param pmc source
+ $I0 = isa cont, 'ObjectRef'
+ unless $I0 goto cont_array
+ # FIXME: use a :subid to directly lookup and call infix:=(_,_) above
+ $P0 = get_hll_global 'Object'
+ setref cont, $P0
+ .tailcall 'infix:='(cont, source)
cont_array:
- $P0 = get_hll_global 'list'
- $P0 = $P0(source)
- $I0 = elements cont
- splice cont, $P0, 0, $I0
+ .local pmc list, it
+ ## empty the array
+ assign cont, 0
+ source = source.'list'()
+ source.'!flatten'()
+ it = iter source
+ array_loop:
+ unless it goto array_done
+ $P0 = shift it
+ $P0 = $P0.'Scalar'()
+ $P0 = clone $P0
+ push cont, $P0
+ goto array_loop
+ array_done:
.return (cont)
+.end
+
+
+.sub 'infix:=' :multi(['Perl6Hash'], _)
+ .param pmc cont
+ .param pmc source
+ $I0 = isa cont, 'ObjectRef'
+ unless $I0 goto cont_hash
+ # FIXME: use a :subid to directly lookup and call infix:=(_,_) above
+ $P0 = get_hll_global 'Object'
+ setref cont, $P0
+ .tailcall 'infix:='(cont, source)
cont_hash:
$P0 = source.'hash'()
Modified: branches/assign/languages/perl6/src/classes/Array.pir
==============================================================================
--- branches/assign/languages/perl6/src/classes/Array.pir (original)
+++ branches/assign/languages/perl6/src/classes/Array.pir Sun Dec 7
19:46:27 2008
@@ -4,92 +4,22 @@
src/classes/Array.pir - Perl 6 Array class and related functions
-=head2 Object Methods
-
=cut
-.sub 'onload' :anon :load :init
+.namespace []
+.sub '' :anon :load :init
.local pmc p6meta, arrayproto
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
arrayproto = p6meta.'new_class'('Perl6Array', 'parent'=>'List',
'name'=>'Array')
arrayproto.'!MUTABLE'()
$P0 = get_hll_namespace ['Perl6Array']
- '!EXPORT'('delete exists pop push shift unshift', 'from'=>$P0)
-.end
-
-
-.namespace []
-.sub 'circumfix:[ ]'
- .param pmc values :slurpy
- $P0 = new 'Perl6Array'
- $I0 = elements values
- splice $P0, values, 0, $I0
- $P0.'!flatten'()
- $P1 = new 'ObjectRef', $P0
- .return ($P1)
-.end
-
-
-=head2 Array methods
-
-=over 4
-
-=cut
-
-.namespace ['Perl6Array']
-.sub 'delete' :method :multi(Perl6Array)
- .param pmc indices :slurpy
- .local pmc result
- result = new 'List'
- null $P99
-
- indices.'!flatten'()
- indices_loop:
- unless indices goto indices_end
- $I0 = shift indices
- $P0 = self[$I0]
- push result, $P0
- self[$I0] = $P99
-
- shorten:
- $I0 = self.'elems'()
- dec $I0
- shorten_loop:
- if $I0 < 0 goto shorten_end
- $P0 = self[$I0]
- unless null $P0 goto shorten_end
- delete self[$I0]
- dec $I0
- goto shorten_loop
- shorten_end:
- goto indices_loop
-
- indices_end:
- .return (result)
+ '!EXPORT'('pop push shift unshift', 'from'=>$P0)
.end
+=head2 Context methods
-=item exists(indices :slurpy)
-
-Return true if the elements at C<indices> have been assigned to.
-
-=cut
-
-.sub 'exists' :method :multi(Perl6Array)
- .param pmc indices :slurpy
- .local int test
-
- test = 0
- indices_loop:
- unless indices goto indices_end
- $I0 = shift indices
- test = exists self[$I0]
- if test goto indices_loop
- indices_end:
- .tailcall 'prefix:?'(test)
-.end
-
+=over
=item item()
@@ -97,21 +27,26 @@
=cut
+.namespace ['Perl6Array']
.sub 'item' :method
.return (self)
.end
+=back
-=item list()
+=head2 Coercion methods
-Return Array as a List (i.e., values)
+=over
-=cut
+=item Array
-.sub 'list' :method
- .tailcall self.'values'()
+.sub 'Array' :method
+ .return (self)
.end
+=back
+
+=head2 Methods
=item pop()
@@ -177,20 +112,24 @@
.tailcall self.'elems'()
.end
+=back
+
+=head2 Operators
-=item values()
+=over
-Return the values of the Array as a List.
+=item circumfix:[]
+
+Create an array.
=cut
-.sub 'values' :method
- $P0 = new 'List'
- splice $P0, self, 0, 0
- .return ($P0)
+.namespace []
+.sub 'circumfix:[ ]'
+ .param pmc values :slurpy
+ .tailcall values.'Array'()
.end
-
# Local Variables:
# mode: pir
# fill-column: 100
Modified: branches/assign/languages/perl6/src/classes/List.pir
==============================================================================
--- branches/assign/languages/perl6/src/classes/List.pir (original)
+++ branches/assign/languages/perl6/src/classes/List.pir Sun Dec 7
19:46:27 2008
@@ -4,73 +4,70 @@
src/classes/List.pir - Perl 6 List class and related functions
-=head2 Object Methods
-
-=over 4
-
=cut
-.sub 'onload' :anon :load :init
+.namespace []
+.sub '' :anon :load :init
.local pmc p6meta, listproto
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
listproto = p6meta.'new_class'('List', 'parent'=>'ResizablePMCArray Any')
p6meta.'register'('ResizablePMCArray', 'parent'=>listproto,
'protoobject'=>listproto)
$P0 = get_hll_namespace ['List']
- '!EXPORT'('first grep keys kv map pairs reduce values', $P0)
+# '!EXPORT'('first grep keys kv map pairs reduce values', $P0)
.end
+=head2 Context methods
-=item Scalar
+=over
+
+=item list
-When we're going to be stored as an item, become an Array and then return
-ourself in a ObjectRef.
+A List in list context returns itself.
=cut
.namespace ['List']
-.sub 'Scalar' :method
- # promote the list to an Array and return its VALUE
- $P0 = self.'item'()
- .tailcall $P0.'Scalar'()
+.sub 'list' :method
+ .return (self)
.end
+=back
+
+=head2 Coercion methods
-=item clone() (vtable method)
+=over
-Return a clone of this list. (Clones its elements also.)
+=item Iterator
=cut
-.namespace ['List']
-.sub 'clone' :vtable :method
- .local pmc p6meta, result, iter
- $P0 = typeof self
- result = new $P0
- iter = self.'iterator'()
- iter_loop:
- unless iter goto iter_end
- $P0 = shift iter
- $P0 = clone $P0
- push result, $P0
- goto iter_loop
- iter_end:
- .return (result)
+.sub 'Iterator' :method
+ self.'!flatten'()
+ $P0 = new 'Iterator', self
+ .return ($P0)
.end
-=item get_string() (vtable method)
+=item Scalar
-Return the elements of the list joined by spaces.
+A list in Scalar context becomes an Array ObjectRef.
=cut
-.sub 'get_string' :vtable :method
+.sub 'Scalar' :method
+ $P0 = self.'Array'()
+ $P0 = new 'ObjectRef', $P0
+ .return ($P0)
+.end
+
+# FIXME: :vtable('get_string') is wrong here.
+.sub 'Str' :method :vtable('get_string')
+ self.'!flatten'()
$S0 = join ' ', self
.return ($S0)
.end
-
-
+
=item hash()
Return the List invocant as a Hash.
@@ -118,20 +115,6 @@
.end
-=item item()
-
-Return the List invocant in scalar context (i.e., an Array).
-
-=cut
-
-.namespace ['List']
-.sub 'item' :method
- $P0 = new 'Perl6Array'
- splice $P0, self, 0, 0
- .return ($P0)
-.end
-
-
=item list()
Return the List as a list.
@@ -150,11 +133,6 @@
.return (self)
.end
-.namespace ['List']
-.sub 'list' :method
- .return (self)
-.end
-
=item perl()
Modified: branches/assign/languages/perl6/src/classes/Object.pir
==============================================================================
--- branches/assign/languages/perl6/src/classes/Object.pir (original)
+++ branches/assign/languages/perl6/src/classes/Object.pir Sun Dec 7
19:46:27 2008
@@ -12,7 +12,7 @@
name and method trickery here and there, and this file takes
care of much of that.
-=head2 Functions
+=head2 Initializers
=over
@@ -23,7 +23,7 @@
=cut
.namespace []
-.sub 'onload' :anon :init :load
+.sub '' :anon :init :load
.local pmc p6meta
load_bytecode 'PCT.pbc'
$P0 = get_root_global ['parrot'], 'P6metaclass'
@@ -32,103 +32,92 @@
set_hll_global ['Perl6Object'], '$!P6META', p6meta
.end
-
=back
-=head2 Object methods
+=head2 Context methods
=over 4
-=item Scalar()
+=item item
-Default implementation gives reference type semantics, and returns an object
-reference, unless the thing already is one.
+Return invocant in item context. Default is to return self.
=cut
.namespace ['Perl6Object']
-.sub 'Scalar' :method
- $I0 = isa self, 'ObjectRef'
- unless $I0 goto not_ref
+.sub 'item' :method
.return (self)
- not_ref:
- $P0 = new 'ObjectRef', self
- .return ($P0)
.end
+=item list
-=item hash()
-
-Return a hash representation of ourself.
+Return invocant in list context. Default is to return a List containing self.
=cut
-.sub 'hash' :method
- $P0 = self.'list'()
- .tailcall $P0.'hash'()
+.sub 'list' :method
+ $P0 = new 'List'
+ push $P0, self
+ .return ($P0)
.end
-=item item()
+=item hash
-Return the scalar component of the invocant. For most objects,
-this is simply the invocant itself.
+Return invocant in hash context. Default is to build a Hash from C<.list>.
=cut
-.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
-
.namespace ['Perl6Object']
-.sub 'item' :method
- .return (self)
+.sub 'hash' :method
+ $P0 = self.'list'()
+ .tailcall $P0.'hash'()
.end
+=back
+
+=head2 Coercion methods
-=item list()
+=over 4
-Return the list component of the invocant. For most (Scalar)
-objects, we create a List containing the invocant.
+=item Array()
=cut
-.sub 'list' :method
- $P0 = new 'List'
- push $P0, self
+.sub 'Array' :method
+ $P0 = new 'Perl6Array'
+ 'infix:='($P0, self)
.return ($P0)
.end
+=item Iterator()
-=item defined()
+=cut
-Return true if the object is defined.
+.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
-.sub 'defined' :method
- $P0 = get_hll_global ['Bool'], 'True'
+.sub 'Scalar' :method
+ $I0 = isa self, 'ObjectRef'
+ unless $I0 goto not_ref
+ .return (self)
+ not_ref:
+ $P0 = new 'ObjectRef', self
.return ($P0)
.end
-.sub '' :method :vtable('defined')
- $I0 = self.'defined'()
- .return ($I0)
-.end
-
-
=item Str()
-Return a string representation of the object
+Return a string representation of the invocant. Default is
+the object's type and address.
=cut
@@ -142,36 +131,56 @@
.return ($S0)
.end
-.sub '' :method :vtable('get_string')
- $S0 = self.'Str'()
- .return ($S0)
+=back
+
+=head2 Methods
+
+=over 4
+
+=item defined()
+
+Return true if the object is defined.
+
+=cut
+
+.sub 'defined' :method
+ $P0 = get_hll_global ['Bool'], 'True'
+ .return ($P0)
.end
+=item print()
+
+Print the object.
+
+=cut
+
+.sub 'print' :method
+ $P0 = get_hll_global 'print'
+ .tailcall $P0(self)
+.end
-=item increment
+=item say()
-Override increment in Objects to use 'succ' method.
+Print the object, followed by a newline.
=cut
-.sub '' :method :vtable('increment')
- $P0 = self.'succ'()
- 'infix:='(self, $P0)
- .return(self)
+.sub 'say' :method
+ $P0 = get_hll_global 'say'
+ .tailcall $P0(self)
.end
-=item decrement
+=item true()
-Override decrement in Objects to use 'pred' method.
+Boolean value of object -- defaults to C<.defined> (S02).
=cut
-.sub '' :method :vtable('decrement')
- $P0 = self.'pred'()
- 'infix:='(self, $P0)
- .return(self)
+.sub 'true' :method
+ .tailcall self.'defined'()
.end
+=item Special methods
=item new()
@@ -347,18 +356,29 @@
.return ($P1)
.end
-=item WHENCE()
+=item 'PARROT'
-Return the invocant's auto-vivification closure.
+Report the object's true nature.
=cut
-.sub 'WHENCE' :method
- $P0 = self.'WHAT'()
- $P1 = $P0.'WHENCE'()
- .return ($P1)
+.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)
.end
+
=item REJECTS(topic)
Define REJECTS methods for objects (this would normally
@@ -374,44 +394,19 @@
.return ($P0)
.end
-=item true()
-
-Defines the .true method on all objects via C<prefix:?>.
-
-=cut
-
-.sub 'true' :method
- .tailcall 'prefix:?'(self)
-.end
-
-=item get_bool (vtable)
-
-Returns true if the object is defined, false otherwise.
-
-=cut
-
-.sub '' :vtable('get_bool')
- $I0 = 'defined'(self)
- .return ($I0)
-.end
-
-=item print()
-=item say()
+=item WHENCE()
-Print the object
+Return the invocant's auto-vivification closure.
=cut
-.sub 'print' :method
- $P0 = get_hll_global 'print'
- .tailcall $P0(self)
+.sub 'WHENCE' :method
+ $P0 = self.'WHAT'()
+ $P1 = $P0.'WHENCE'()
+ .return ($P1)
.end
-.sub 'say' :method
- $P0 = get_hll_global 'say'
- .tailcall $P0(self)
-.end
=item WHERE
@@ -424,6 +419,7 @@
.return ($I0)
.end
+
=item WHICH
Gets the object's identity value
@@ -435,29 +431,6 @@
.tailcall self.'WHERE'()
.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)
-.end
-
-
=back
=head2 Private methods
@@ -493,6 +466,13 @@
.return (result)
.end
+=item !.? Invoke one method if it exists
+
+=item !.* Invoke any methods that exist
+
+=item !.+ Invoke all methods that exist (at least one)
+
+=cut
.sub '!.?' :method
.param string method_name
@@ -573,6 +553,9 @@
'die'($S0)
.end
+=item !.^ Invoke a method on invocant's metaclass
+
+=cut
.sub '!.^' :method
.param string method_name
@@ -585,156 +568,42 @@
.tailcall how.method_name(self, pos_args :flat, named_args :flat :named)
.end
-
-.namespace ['P6protoobject']
-
=back
-=head2 Methods on P6protoobject
-
-=over
-
-=item WHENCE()
-
-Returns the protoobject's autovivification closure.
+=head2 Vtable functions
=cut
-.sub 'WHENCE' :method
- .local pmc props, whence
- props = getattribute self, '%!properties'
- if null props goto ret_undef
- whence = props['WHENCE']
- if null whence goto ret_undef
- .return (whence)
- ret_undef:
- whence = new 'Undef'
- .return (whence)
-.end
-
-
-=item defined()
-
-=cut
-
-.sub 'defined' :method
- $P0 = get_hll_global ['Bool'], 'False'
- .return ($P0)
-.end
-
-
-=item item()
-
-Returns itself in item context.
-
-=cut
-
-.sub 'item' :method
- .return (self)
-.end
-
-
-=item list()
-
-Returns a list containing itself in list context.
-
-=cut
-
-.sub 'list' :method
- $P0 = get_hll_global 'list'
- .tailcall $P0(self)
+.sub '' :vtable('decrement') :method
+ $P0 = self.'pred'()
+ 'infix:='(self, $P0)
+ .return(self)
.end
-
-=item get_pmc_keyed(key) (vtable method)
-
-Returns a proto-object with an autovivification closure attached to it.
-
-=cut
-
-.sub get_pmc_keyed :vtable :method
- .param pmc what
-
- # We'll build auto-vivification hash of values.
- .local pmc WHENCE, key, val
- WHENCE = new 'Hash'
-
- # What is it?
- $S0 = what.'WHAT'()
- if $S0 == 'Pair' goto from_pair
- if $S0 == 'List' goto from_list
- 'die'("Auto-vivification closure did not contain a Pair")
-
- from_pair:
- # Just a pair.
- key = what.'key'()
- val = what.'value'()
- WHENCE[key] = val
- goto done_whence
-
- from_list:
- # List.
- .local pmc list_iter, cur_pair
- list_iter = new 'Iterator', what
- list_iter_loop:
- unless list_iter goto done_whence
- cur_pair = shift list_iter
- key = cur_pair.'key'()
- val = cur_pair.'value'()
- WHENCE[key] = val
- goto list_iter_loop
- done_whence:
-
- # Now create a clone of the protoobject.
- .local pmc protoclass, res, props, tmp
- protoclass = class self
- res = new protoclass
-
- # Attach the WHENCE property.
- props = getattribute self, '%!properties'
- unless null props goto have_props
- props = new 'Hash'
- have_props:
- props['WHENCE'] = WHENCE
- setattribute res, '%!properties', props
-
- .return (res)
+.sub '' :vtable('defined') :method
+ $I0 = self.'defined'()
+ .return ($I0)
.end
-=item !IMMUTABLE()
-
-=item !MUTABLE()
-
-Indicate that objects in the class are mutable or immutable.
-
-=cut
-
-.sub '!IMMUTABLE' :method
- $P0 = get_hll_global ['Int'], 'Scalar'
- $P1 = self.'HOW'()
- $P1.'add_method'('Scalar', $P0, 'to'=>self)
+.sub '' :vtable('get_bool') :method
+ $I0 = self.'true'()
+ .return ($I0)
.end
-.sub '!MUTABLE' :method
- $P0 = get_hll_global ['Perl6Object'], 'Scalar'
- $P1 = self.'HOW'()
- $P1.'add_method'('Scalar', $P0, 'to'=>self)
+.sub '' :vtable('get_iter') :method
+ .tailcall self.'Iterator'()
.end
-=item perl()
-
-Returns a Perl representation of itself.
-
-=cut
-
-.sub 'perl' :method
- $S0 = self
+.sub '' :vtable('get_string') :method
+ $S0 = self.'Str'()
.return ($S0)
.end
-=back
-
-=cut
+.sub '' :vtable('increment') :method
+ $P0 = self.'succ'()
+ 'infix:='(self, $P0)
+ .return(self)
+.end
# Local Variables:
# mode: pir
Added: branches/assign/languages/perl6/src/classes/Protoobject.pir
==============================================================================
--- (empty file)
+++ branches/assign/languages/perl6/src/classes/Protoobject.pir Sun Dec 7
19:46:27 2008
@@ -0,0 +1,149 @@
+## $Id$
+
+=head1 TITLE
+
+Protoobject - methods on Protoobjects
+
+=head1 DESCRIPTION
+
+=head2 Methods on P6protoobject
+
+=over
+
+=item defined()
+
+=cut
+
+.sub 'defined' :method
+ $P0 = get_hll_global ['Bool'], 'False'
+ .return ($P0)
+.end
+
+
+=item perl()
+
+Returns a Perl representation of itself.
+
+=cut
+
+.sub 'perl' :method
+ $S0 = self
+ .return ($S0)
+.end
+
+=item WHENCE()
+
+Returns the protoobject's autovivification closure.
+
+=cut
+
+.namespace ['P6protoobject']
+.sub 'WHENCE' :method
+ .local pmc props, whence
+ props = getattribute self, '%!properties'
+ if null props goto ret_undef
+ whence = props['WHENCE']
+ if null whence goto ret_undef
+ .return (whence)
+ ret_undef:
+ whence = new 'Undef'
+ .return (whence)
+.end
+
+=back
+
+=head2 Private methods
+
+=over
+
+=item !IMMUTABLE()
+
+=item !MUTABLE()
+
+Indicate that objects in the class are mutable or immutable.
+
+=cut
+
+.sub '!IMMUTABLE' :method
+ $P0 = get_hll_global ['Int'], 'Scalar'
+ $P1 = self.'HOW'()
+ $P1.'add_method'('Scalar', $P0, 'to'=>self)
+.end
+
+.sub '!MUTABLE' :method
+ $P0 = get_hll_global ['Perl6Object'], 'Scalar'
+ $P1 = self.'HOW'()
+ $P1.'add_method'('Scalar', $P0, 'to'=>self)
+.end
+
+
+=back
+
+=head2 Vtable functions
+
+=over
+
+=item get_pmc_keyed(key) (vtable method)
+
+Returns a proto-object with an autovivification closure attached to it.
+
+=cut
+
+.sub get_pmc_keyed :vtable :method
+ .param pmc what
+
+ # We'll build auto-vivification hash of values.
+ .local pmc WHENCE, key, val
+ WHENCE = new 'Hash'
+
+ # What is it?
+ $S0 = what.'WHAT'()
+ if $S0 == 'Pair' goto from_pair
+ if $S0 == 'List' goto from_list
+ 'die'("Auto-vivification closure did not contain a Pair")
+
+ from_pair:
+ # Just a pair.
+ key = what.'key'()
+ val = what.'value'()
+ WHENCE[key] = val
+ goto done_whence
+
+ from_list:
+ # List.
+ .local pmc list_iter, cur_pair
+ list_iter = new 'Iterator', what
+ list_iter_loop:
+ unless list_iter goto done_whence
+ cur_pair = shift list_iter
+ key = cur_pair.'key'()
+ val = cur_pair.'value'()
+ WHENCE[key] = val
+ goto list_iter_loop
+ done_whence:
+
+ # Now create a clone of the protoobject.
+ .local pmc protoclass, res, props, tmp
+ protoclass = class self
+ res = new protoclass
+
+ # Attach the WHENCE property.
+ props = getattribute self, '%!properties'
+ unless null props goto have_props
+ props = new 'Hash'
+ have_props:
+ props['WHENCE'] = WHENCE
+ setattribute res, '%!properties', props
+
+ .return (res)
+.end
+
+=back
+
+=cut
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Modified: branches/assign/languages/perl6/src/pmc/objectref_pmc.template
==============================================================================
--- branches/assign/languages/perl6/src/pmc/objectref_pmc.template
(original)
+++ branches/assign/languages/perl6/src/pmc/objectref_pmc.template Sun Dec
7 19:46:27 2008
@@ -62,6 +62,10 @@
return value;
}
+ VTABLE void set_pmc(PMC *value) {
+ SET_ATTR_value(INTERP, SELF, value);
+ }
+
VTABLE INTVAL isa_pmc(PMC *lookup) {
PMC * value;
if (SUPER(lookup)) return 1;
