Author: pmichaud
Date: Mon Dec 8 22:50:38 2008
New Revision: 33699
Added:
trunk/languages/perl6/src/classes/Nil.pir
- copied unchanged from r33698,
/branches/assign/languages/perl6/src/classes/Nil.pir
trunk/languages/perl6/src/classes/Positional.pir
- copied unchanged from r33698,
/branches/assign/languages/perl6/src/classes/Positional.pir
trunk/languages/perl6/src/classes/Protoobject.pir
- copied unchanged from r33698,
/branches/assign/languages/perl6/src/classes/Protoobject.pir
Modified:
trunk/MANIFEST
trunk/MANIFEST.SKIP
trunk/compilers/pct/src/PAST/Node.pir
trunk/languages/perl6/Test.pm
trunk/languages/perl6/config/makefiles/root.in
trunk/languages/perl6/src/builtins/assign.pir
trunk/languages/perl6/src/classes/Array.pir
trunk/languages/perl6/src/classes/Failure.pir
trunk/languages/perl6/src/classes/List.pir
trunk/languages/perl6/src/classes/Match.pir
trunk/languages/perl6/src/classes/Object.pir
trunk/languages/perl6/src/parser/actions.pm
trunk/languages/perl6/src/pmc/objectref_pmc.template
trunk/languages/perl6/t/spectest.data
trunk/runtime/parrot/library/P6object.pir
Log:
Merge rakudo's 'assign' branch back into trunk.
List slicing and list assignment now (mostly) work,
although we temporarily lose array element binding and
correct array lengths.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Mon Dec 8 22:50:38 2008
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Mon Dec 8 16:51:06 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Tue Dec 9 06:24:54 2008 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -2142,10 +2142,13 @@
languages/perl6/src/classes/Match.pir [perl6]
languages/perl6/src/classes/Method.pir [perl6]
languages/perl6/src/classes/Module.pir [perl6]
+languages/perl6/src/classes/Nil.pir [perl6]
languages/perl6/src/classes/Num.pir [perl6]
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/Positional.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: trunk/MANIFEST.SKIP
==============================================================================
--- trunk/MANIFEST.SKIP (original)
+++ trunk/MANIFEST.SKIP Mon Dec 8 22:50:38 2008
@@ -1,6 +1,6 @@
# ex: set ro:
# $Id$
-# generated by tools/dev/mk_manifest_and_skip.pl Sat Dec 6 05:46:39 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Tue Dec 9 06:24:54 2008 UT
#
# This file should contain a transcript of the svn:ignore properties
# of the directories in the Parrot subversion repository. (Needed for
Modified: trunk/compilers/pct/src/PAST/Node.pir
==============================================================================
--- trunk/compilers/pct/src/PAST/Node.pir (original)
+++ trunk/compilers/pct/src/PAST/Node.pir Mon Dec 8 22:50:38 2008
@@ -109,6 +109,20 @@
.end
+=item lvalue([flag])
+
+Get/set the C<lvalue> attribute, which indicates whether this
+variable is being used in an lvalue context.
+
+=cut
+
+.sub 'lvalue' :method
+ .param pmc value :optional
+ .param int has_value :opt_flag
+ .tailcall self.'attr'('lvalue', value, has_value)
+.end
+
+
=back
=head2 PAST::Val
@@ -133,6 +147,22 @@
.tailcall self.'attr'('value', value, has_value)
.end
+=item lvalue([value])
+
+Throw an exception if we try to make a PAST::Val into an lvalue.
+
+=cut
+
+.sub 'lvalue' :method
+ .param pmc value :optional
+ .param int has_value :opt_flag
+ unless has_value goto normal
+ unless value goto normal
+ die "Unable to set lvalue on PAST::Val node"
+ normal:
+ .tailcall self.'attr'('value', value, has_value)
+.end
+
=back
=head2 PAST::Var
@@ -178,20 +208,6 @@
.end
-=item lvalue([flag])
-
-Get/set the C<lvalue> attribute, which indicates whether this
-variable is being used in an lvalue context.
-
-=cut
-
-.sub 'lvalue' :method
- .param pmc value :optional
- .param int has_value :opt_flag
- .tailcall self.'attr'('lvalue', value, has_value)
-.end
-
-
=item namespace([namespace])
Get/set the variable's namespace attribute to the array of strings
Modified: trunk/languages/perl6/Test.pm
==============================================================================
--- trunk/languages/perl6/Test.pm (original)
+++ trunk/languages/perl6/Test.pm Mon Dec 8 22:50:38 2008
@@ -11,6 +11,8 @@
our $todo_upto_test_num = 0;
our $todo_reason = '';
+our $*WARNINGS = 0;
+
# for running the test suite multiple times in the same process
our $testing_started;
Modified: trunk/languages/perl6/config/makefiles/root.in
==============================================================================
--- trunk/languages/perl6/config/makefiles/root.in (original)
+++ trunk/languages/perl6/config/makefiles/root.in Mon Dec 8 22:50:38 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,8 @@
BUILTINS_PIR = \
src/classes/Object.pir \
+ src/classes/Protoobject.pir \
+ src/classes/Positional.pir \
src/classes/Any.pir \
src/classes/Bool.pir \
src/classes/Str.pir \
@@ -71,6 +73,7 @@
src/classes/Method.pir \
src/classes/Junction.pir \
src/classes/Failure.pir \
+ src/classes/Nil.pir \
src/classes/Role.pir \
src/classes/Pair.pir \
src/classes/Whatever.pir \
@@ -132,7 +135,7 @@
$(PARROT) $(PARROT_ARGS) $(NQP) --output=src/gen_actions.pir \
--encoding=fixed_8 --target=pir src/parser/actions.pm
-src/gen_builtins.pir: build/gen_builtins_pir.pl
+src/gen_builtins.pir: build/gen_builtins_pir.pl Makefile
$(PERL) build/gen_builtins_pir.pl $(BUILTINS_PIR) > src/gen_builtins.pir
src/gen_metaop.pir: build/gen_metaop_pir.pl
@@ -203,13 +206,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
@@ -229,7 +232,7 @@
@$(HARNESS_WITH_FUDGE_JOBS) $(TESTFILES)
# Run a single test
-t/*.t t/*/*.t t/*/*/*.t: all
+t/*.t t/*/*.t t/*/*/*.t: all Test.pir
@$(HARNESS_WITH_FUDGE) --verbosity=1 $@
t/localtest.data:
Modified: trunk/languages/perl6/src/builtins/assign.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/assign.pir (original)
+++ trunk/languages/perl6/src/builtins/assign.pir Mon Dec 8 22:50:38 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,47 @@
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)
+ .local pmc list, it, array
+ ## empty the array
+ array = new 'ResizablePMCArray'
+ source = 'list'(source)
+ it = iter source
+ array_loop:
+ unless it goto array_done
+ $P0 = shift it
+ $P0 = $P0.'Scalar'()
+ $P0 = clone $P0
+ push array, $P0
+ goto array_loop
+ array_done:
$I0 = elements cont
- splice cont, $P0, 0, $I0
+ splice cont, array, 0, $I0
.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'()
@@ -74,6 +95,70 @@
.end
+.sub 'infix:=' :multi(['List'], _)
+ .param pmc list
+ .param pmc source
+
+ ## get the list of containers and sources
+ source = source.'list'()
+ source.'!flatten'()
+
+ ## first, temporarily mark each container with a property
+ ## so we can clone it in source if needed
+ .local pmc it, true
+ it = iter list
+ true = box 1
+ mark_loop:
+ unless it goto mark_done
+ $P0 = shift it
+ setprop $P0, 'target', true
+ goto mark_loop
+ mark_done:
+
+ ## now build our 'real' source list, cloning any targets we encounter
+ .local pmc slist
+ slist = new 'List'
+ it = iter source
+ source_loop:
+ unless it goto source_done
+ $P0 = shift it
+ $P1 = getprop 'target', $P0
+ if null $P1 goto source_next
+ $P0 = clone $P0
+ source_next:
+ push slist, $P0
+ goto source_loop
+ source_done:
+
+ ## now perform the assignments, clearing targets as we go
+ .local pmc pmcnull
+ null pmcnull
+ it = iter list
+ assign_loop:
+ unless it goto assign_done
+ .local pmc cont
+ cont = shift it
+ setprop cont, 'target', pmcnull
+ $I0 = isa cont, 'ObjectRef'
+ if $I0 goto assign_scalar
+ $I0 = isa cont, 'Perl6Array'
+ if $I0 goto assign_array
+ $I0 = isa cont, 'Perl6Hash'
+ if $I0 goto assign_hash
+ assign_scalar:
+ $P0 = shift slist
+ 'infix:='(cont, $P0)
+ goto assign_loop
+ assign_array:
+ assign_hash:
+ 'infix:='(cont, slist)
+ slist = new 'Nil'
+ goto assign_loop
+ assign_done:
+ .return (list)
+.end
+
+
.sub '!REDUCEMETAOP'
.param string opname
.param pmc identity
Modified: trunk/languages/perl6/src/classes/Array.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Array.pir (original)
+++ trunk/languages/perl6/src/classes/Array.pir Mon Dec 8 22:50:38 2008
@@ -4,11 +4,10 @@
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')
@@ -18,22 +17,13 @@
'!EXPORT'('delete exists pop push shift unshift', 'from'=>$P0)
.end
+=head2 Methods
-.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
-
+=over
-=head2 Array methods
+=item delete
-=over 4
+Remove items from an array.
=cut
@@ -97,17 +87,19 @@
=cut
+.namespace ['Perl6Array']
.sub 'item' :method
.return (self)
.end
-=item list()
+=item list
-Return Array as a List (i.e., values)
+Return invocant as a List.
=cut
+.namespace ['Perl6Array']
.sub 'list' :method
.tailcall self.'values'()
.end
@@ -177,19 +169,54 @@
.tailcall self.'elems'()
.end
-
=item values()
-Return the values of the Array as a List.
+Return Array as a List of its values.
=cut
+.namespace ['Perl6Array']
.sub 'values' :method
$P0 = new 'List'
splice $P0, self, 0, 0
.return ($P0)
.end
+=back
+
+=head2 Operators
+
+=over
+
+=item circumfix:[]
+
+Create an array.
+
+=cut
+
+.namespace []
+.sub 'circumfix:[ ]'
+ .param pmc values :slurpy
+ .tailcall values.'Scalar'()
+.end
+
+=back
+
+=head2 Coercion methods
+
+=over
+
+=item Array
+
+=cut
+
+.sub 'Array' :method
+ .return (self)
+.end
+
+=back
+
+=cut
# Local Variables:
# mode: pir
Modified: trunk/languages/perl6/src/classes/Failure.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Failure.pir (original)
+++ trunk/languages/perl6/src/classes/Failure.pir Mon Dec 8 22:50:38 2008
@@ -9,6 +9,9 @@
p6meta.'register'('Undef', 'parent'=>failureproto,
'protoobject'=>failureproto)
exceptionproto = p6meta.'new_class'('Perl6Exception', 'parent'=>'Any',
'attr'=>'$!exception')
p6meta.'register'('Exception', 'protoobject'=>exceptionproto)
+
+ $P0 = box 1
+ set_hll_global '$WARNINGS', $P0
.end
@@ -46,6 +49,8 @@
.sub '!throw_unhandled' :method
$I0 = self.'handled'()
if $I0 goto done
+ $P0 = get_hll_global '$WARNINGS'
+ unless $P0 goto done
$P0 = self.'!exception'()
$S0 = $P0['message']
$S0 = concat $S0, "\n"
Modified: trunk/languages/perl6/src/classes/List.pir
==============================================================================
--- trunk/languages/perl6/src/classes/List.pir (original)
+++ trunk/languages/perl6/src/classes/List.pir Mon Dec 8 22:50:38 2008
@@ -4,72 +4,108 @@
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')
+ $P0 = get_hll_global 'Positional'
+ p6meta.'add_role'($P0, 'to'=>listproto)
p6meta.'register'('ResizablePMCArray', 'parent'=>listproto,
'protoobject'=>listproto)
$P0 = get_hll_namespace ['List']
'!EXPORT'('first grep keys kv map pairs reduce values', $P0)
.end
+=head2 Methods
-=item Scalar
+=over
+
+=item item
-When we're going to be stored as an item, become an Array and then return
-ourself in a ObjectRef.
+A List in item context becomes an Array.
=cut
.namespace ['List']
-.sub 'Scalar' :method
- # promote the list to an Array and return its VALUE
- $P0 = self.'item'()
- .tailcall $P0.'Scalar'()
+.sub 'item' :method
+ .tailcall self.'Array'()
+.end
+
+=item list
+
+A List in list context returns itself.
+
+=cut
+
+.namespace ['List']
+.sub 'list' :method
+ .return (self)
+.end
+
+.namespace []
+.sub 'list'
+ .param pmc values :slurpy
+ .tailcall values.'!flatten'()
.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 ResizablePMCArray.list
+
+This version of list morphs a ResizablePMCArray into a List.
+
+=cut
+
+.namespace ['ResizablePMCArray']
+.sub 'list' :method
+ ## this code morphs a ResizablePMCArray into a List
+ ## without causing a clone of any of the elements
+ $P0 = new 'ResizablePMCArray'
+ splice $P0, self, 0, 0
+ $P1 = new 'List'
+ copy self, $P1
+ splice self, $P0, 0, 0
+ .return (self)
+.end
+
=item hash()
@@ -77,6 +113,7 @@
=cut
+.namespace ['List']
.sub 'hash' :method
.local pmc result, iter
result = new 'Perl6Hash'
@@ -118,44 +155,24 @@
.end
-=item item()
-
-Return the List invocant in scalar context (i.e., an Array).
-
-=cut
+=back
-.namespace ['List']
-.sub 'item' :method
- $P0 = new 'Perl6Array'
- splice $P0, self, 0, 0
- .return ($P0)
-.end
+=head2 Methods
+=over
-=item list()
+=item elems()
-Return the List as a list.
+Return the number of elements in the list.
=cut
-.namespace ['ResizablePMCArray']
-.sub 'list' :method
- ## this code morphs a ResizablePMCArray into a List
- ## without causing a clone of any of the elements
- $P0 = new 'ResizablePMCArray'
- splice $P0, self, 0, 0
- $P1 = new 'List'
- copy self, $P1
- splice self, $P0, 0, 0
- .return (self)
-.end
-
-.namespace ['List']
-.sub 'list' :method
- .return (self)
+.sub 'elems' :method :multi('ResizablePMCArray') :vtable('get_number')
+ self.'!flatten'()
+ $I0 = elements self
+ .return ($I0)
.end
-
=item perl()
Returns a Perl representation of a List.
@@ -184,7 +201,7 @@
=back
-=head2 List methods
+=head2 Private methods
=over 4
@@ -240,18 +257,6 @@
.end
-=item elems()
-
-Return the number of elements in the list.
-
-=cut
-
-.sub 'elems' :method :multi('ResizablePMCArray') :vtable('get_number')
- self.'!flatten'()
- $I0 = elements self
- .return ($I0)
-.end
-
=item first(...)
@@ -657,27 +662,16 @@
=over 4
-=item C<list(...)>
-
-Build a List from its arguments.
-
-=cut
-
-.namespace []
-.sub 'list'
- .param pmc values :slurpy
- .tailcall values.'!flatten'()
-.end
-
=item C<infix:,(...)>
Operator form for building a list from its arguments.
=cut
+.namespace []
.sub 'infix:,'
.param pmc args :slurpy
- .tailcall args.'!flatten'()
+ .tailcall args.'list'()
.end
Modified: trunk/languages/perl6/src/classes/Match.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Match.pir (original)
+++ trunk/languages/perl6/src/classes/Match.pir Mon Dec 8 22:50:38 2008
@@ -31,6 +31,11 @@
# Also install Match proto in our HLL namespace.
set_hll_global 'Match', $P0
+
+ .local pmc p6meta
+ p6meta = get_hll_global ['Perl6Object'], '$!P6META'
+ $P1 = get_hll_global 'Positional'
+ p6meta.'add_role'($P1, 'to'=>$P0)
.end
#
Modified: trunk/languages/perl6/src/classes/Object.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Object.pir (original)
+++ trunk/languages/perl6/src/classes/Object.pir Mon Dec 8 22:50:38 2008
@@ -12,18 +12,10 @@
name and method trickery here and there, and this file takes
care of much of that.
-=head2 Functions
-
-=over
-
-=item onload()
-
-Perform initializations and create the base classes.
-
=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,49 +24,46 @@
set_hll_global ['Perl6Object'], '$!P6META', p6meta
.end
-
-=back
-
-=head2 Object methods
+=head2 Methods
=over 4
-=item Scalar()
+=item defined()
-Default implementation gives reference type semantics, and returns an object
-reference, unless the thing already is one.
+Return true if the object is defined.
=cut
.namespace ['Perl6Object']
-.sub 'Scalar' :method
- $I0 = isa self, 'ObjectRef'
- unless $I0 goto not_ref
- .return (self)
- not_ref:
- $P0 = new 'ObjectRef', self
+.sub 'defined' :method
+ $P0 = get_hll_global ['Bool'], 'True'
.return ($P0)
.end
-=item hash()
+=item hash
-Return a hash representation of ourself.
+Return invocant in hash context. Default is to build a Hash from C<.list>.
=cut
+.namespace ['Perl6Object']
.sub 'hash' :method
$P0 = self.'list'()
.tailcall $P0.'hash'()
.end
-=item item()
+=item item
-Return the scalar component of the invocant. For most objects,
-this is simply the invocant itself.
+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
@@ -89,89 +78,119 @@
.return (x)
.end
-.namespace ['Perl6Object']
-.sub 'item' :method
- .return (self)
-.end
-
-=item list()
+=item list
-Return the list component of the invocant. For most (Scalar)
-objects, we create a List containing the invocant.
+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()
-=item defined()
+Print the object.
-Return true if the object is defined.
+=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
-.sub 'defined' :method
- $P0 = get_hll_global ['Bool'], 'True'
- .return ($P0)
+.namespace ['Perl6Object']
+.sub 'say' :method
+ $P0 = get_hll_global 'say'
+ .tailcall $P0(self)
.end
-.sub '' :method :vtable('defined')
- $I0 = self.'defined'()
- .return ($I0)
+=item true()
+
+Boolean value of object -- defaults to C<.defined> (S02).
+
+=cut
+
+.namespace ['Perl6Object']
+.sub 'true' :method
+ .tailcall self.'defined'()
.end
+=back
-=item Str()
+=head2 Coercion methods
-Return a string representation of the object
+=over 4
+
+=item Array()
=cut
-.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)
+.namespace ['Perl6Object']
+.sub 'Array' :method
+ $P0 = new 'Perl6Array'
+ 'infix:='($P0, self)
+ .return ($P0)
.end
-.sub '' :method :vtable('get_string')
- $S0 = self.'Str'()
- .return ($S0)
-.end
+=item Iterator()
+
+=cut
+.sub 'Iterator' :method
+ $P0 = self.'list'()
+ .tailcall $P0.'Iterator'()
+.end
-=item increment
+=item Scalar()
-Override increment in Objects to use 'succ' method.
+Default Scalar() gives reference type semantics, returning
+an object reference (unless the invocant already is one).
=cut
-.sub '' :method :vtable('increment')
- $P0 = self.'succ'()
- 'infix:='(self, $P0)
- .return(self)
+.sub 'Scalar' :method
+ $I0 = isa self, 'ObjectRef'
+ unless $I0 goto not_ref
+ .return (self)
+ not_ref:
+ $P0 = new 'ObjectRef', self
+ .return ($P0)
.end
-=item decrement
+=item Str()
-Override decrement in Objects to use 'pred' method.
+Return a string representation of the invocant. Default is
+the object's type and address.
=cut
-.sub '' :method :vtable('decrement')
- $P0 = self.'pred'()
- 'infix:='(self, $P0)
- .return(self)
+.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()
@@ -179,6 +198,7 @@
=cut
+.namespace ['Perl6Object']
.sub 'new' :method
.param pmc init_parents :slurpy
.param pmc init_this :named :slurpy
@@ -347,18 +367,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 +405,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 +430,7 @@
.return ($I0)
.end
+
=item WHICH
Gets the object's identity value
@@ -435,29 +442,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
@@ -470,6 +454,7 @@
=cut
+.namespace ['Perl6Object']
.sub '!cloneattr' :method
.param string attrlist
.local pmc p6meta, result
@@ -493,7 +478,6 @@
.return (result)
.end
-
=item !.?
Helper method for implementing the .? operator. Calls at most one matching
@@ -521,7 +505,6 @@
.tailcall self.$P0(pos_args :flat, named_args :named :flat)
.end
-
=item !.*
Helper method for implementing the .* operator. Calls one or more matching
@@ -641,7 +624,6 @@
.return (result_list)
.end
-
=item !.^
Helper for doing calls on the metaclass.
@@ -659,156 +641,43 @@
.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)
+.namespace ['Perl6Object']
+.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
Modified: trunk/languages/perl6/src/parser/actions.pm
==============================================================================
--- trunk/languages/perl6/src/parser/actions.pm (original)
+++ trunk/languages/perl6/src/parser/actions.pm Mon Dec 8 22:50:38 2008
@@ -1495,13 +1495,10 @@
method postcircumfix($/, $key) {
my $past;
if $key eq '[ ]' {
- $past := PAST::Var.new(
- $( $<semilist> ),
- :scope('keyed_int'),
- :vivibase('Perl6Array'),
- :viviself('Failure'),
- :node( $/ )
- );
+ $past := build_call( $( $<semilist> ) );
+ $past.node($/);
+ $past.name('postcircumfix:[ ]');
+ $past.pasttype('callmethod');
}
elsif $key eq '( )' {
$past := build_call( $( $<semilist> ) );
Modified: trunk/languages/perl6/src/pmc/objectref_pmc.template
==============================================================================
--- trunk/languages/perl6/src/pmc/objectref_pmc.template (original)
+++ trunk/languages/perl6/src/pmc/objectref_pmc.template Mon Dec 8
22:50:38 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;
Modified: trunk/languages/perl6/t/spectest.data
==============================================================================
--- trunk/languages/perl6/t/spectest.data (original)
+++ trunk/languages/perl6/t/spectest.data Mon Dec 8 22:50:38 2008
@@ -53,7 +53,6 @@
S03-operators/assign.t
S03-operators/autoincrement.t
S03-operators/autovivification.t
-S03-operators/binding-arrays.t
S03-operators/binding-closure.t
S03-operators/binding-hashes.t
S03-operators/binding-scalars.t
@@ -178,7 +177,6 @@
S12-role/namespaced.t
S12-subset/multi-dispatch.t
S12-subset/subtypes.t
-S16-filehandles/io_in_while_loops.t
S16-io/say.t
S29-any/cmp.t
S29-array/delete.t
Modified: trunk/runtime/parrot/library/P6object.pir
==============================================================================
--- trunk/runtime/parrot/library/P6object.pir (original)
+++ trunk/runtime/parrot/library/P6object.pir Mon Dec 8 22:50:38 2008
@@ -252,6 +252,26 @@
.end
+=item add_role(role, [, 'to'=>parrotclass])
+
+Add C<role> to C<parrotclass>.
+
+=cut
+
+.sub 'add_role' :method
+ .param pmc role
+ .param pmc options :slurpy :named
+
+ $P0 = options['to']
+ unless null $P0 goto have_to
+ $P0 = self
+ have_to:
+ .local pmc parrotclass
+ parrotclass = self.'get_parrotclass'($P0)
+ parrotclass.'add_role'(role)
+.end
+
+
=item register(parrotclass [, 'name'=>name] [, 'protoobject'=>proto] [,
'parent'=>parentclass] [, 'hll'=>hll])
Sets objects of type C<parrotclass> to use C<protoobject>,
