develooper Front page | perl.cvs.parrot | Postings from December 2008

[svn:parrot] r33699 - in trunk: . compilers/pct/src/PAST languages/perl6 languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/classes languages/perl6/src/parser languages/perl6/src/pmc languages/perl6/t runtime/parrot/library

From:
pmichaud
Date:
December 8, 2008 22:50
Subject:
[svn:parrot] r33699 - in trunk: . compilers/pct/src/PAST languages/perl6 languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/classes languages/perl6/src/parser languages/perl6/src/pmc languages/perl6/t runtime/parrot/library
Message ID:
20081209065039.F0E87CB9AF@x12.develooper.com
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>,



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About