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

[svn:parrot] r33643 - in branches/assign: . languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/classes languages/perl6/src/pmc

From:
pmichaud
Date:
December 7, 2008 19:46
Subject:
[svn:parrot] r33643 - in branches/assign: . languages/perl6/config/makefiles languages/perl6/src/builtins languages/perl6/src/classes languages/perl6/src/pmc
Message ID:
20081208034629.1B63DCB9AF@x12.develooper.com
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;



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