[svn:parrot] r35861 - in trunk/languages/perl6/src: builtins classes

Author: jonathan
Date: Wed Jan 21 05:18:29 2009
New Revision: 35861

Modified:
   trunk/languages/perl6/src/builtins/guts.pir
   trunk/languages/perl6/src/classes/ClassHOW.pir

Log:
[rakudo] Make 'handles' trait verb handle pairs, classes, roles and smartmatching on anything else.

Modified: trunk/languages/perl6/src/builtins/guts.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/guts.pir	(original)
+++ trunk/languages/perl6/src/builtins/guts.pir	Wed Jan 21 05:18:29 2009
@@ -631,19 +631,54 @@
     trait = shift it
     $S0 = trait[0]
     if $S0 != 'trait_verb:handles' goto traitlist_loop
+
+    # For the handles trait verb, we may have got a name or a list of names.
+    # If so, just generate methods with those names. Otherwise, need to store
+    # them as a property on the metaclass, so the dispatcher can smart-match
+    # against them later.
     .local pmc handles_it
     $P0 = trait[1]
+    $I0 = isa $P0, 'Str'
+    if $I0 goto simple_handles
+    $I0 = isa $P0, 'List'
+    if $I0 goto simple_handles
+    $I0 = isa $P0, 'Perl6Pair'
+    if $I0 goto simple_handles
+
+    .local pmc class_handles_list, handles_hash
+    class_handles_list = getprop '@!handles_dispatchers', metaclass
+    unless null class_handles_list goto have_class_handles_list
+    class_handles_list = new 'ResizablePMCArray'
+    setprop metaclass, '@!handles_dispatchers', class_handles_list
+  have_class_handles_list:
+    handles_hash = new 'Hash'
+    handles_hash['attrname'] = name
+    handles_hash['match_against'] = $P0
+    push class_handles_list, handles_hash
+    goto traitlist_loop
+
+  simple_handles:
     $P0 = 'list'($P0)
     handles_it = iter $P0
   handles_loop:
+    .local string visible_name
+    .local pmc orig_name
     unless handles_it goto handles_done
     $P0 = clone handles
     $P1 = box name
     setprop $P0, 'attrname', $P1
     $P1 = shift handles_it
-    setprop $P0, 'methodname', $P1
-    $S1 = $P1
-    metaclass.'add_method'($S1, $P0)
+    $I0 = isa $P1, 'Perl6Pair'
+    if $I0 goto handles_pair
+    visible_name = $P1
+    orig_name = $P1
+    goto naming_done
+  handles_pair:
+    visible_name = $P1.'key'()
+    orig_name = $P1.'value'()
+  naming_done:
+    setprop $P0, 'methodname', orig_name
+    metaclass.'add_method'(visible_name, $P0)
     goto handles_loop
   handles_done:
     goto traitlist_loop

Modified: trunk/languages/perl6/src/classes/ClassHOW.pir
==============================================================================
--- trunk/languages/perl6/src/classes/ClassHOW.pir	(original)
+++ trunk/languages/perl6/src/classes/ClassHOW.pir	Wed Jan 21 05:18:29 2009
@@ -72,14 +72,49 @@
   submethod_check_done:
 
     # Got a method that we can call. XXX Set up exception handlers for if we
-    # have to do auto-threading of junctional arguments, additionally if we
     # get a control expection for callsame or nextsame etc. Won't be able to
     # be tailcall then...
     .tailcall obj.candidate(pos_args :flat, name_args :flat :named)
 
   check_handles:
-    # XXX This is where we will insert logic to run any regex or more complex
-    # 'handles' things to try and find a handler.
+    # See if we have any complex handles to check.
+    .local pmc handles_list, handles_it, handles_hash, attr
+    handles_list = getprop '@!handles_dispatchers', cur_class
+    if null handles_list goto mro_loop
+    handles_it = iter handles_list
+  handles_loop:
+    unless handles_it goto handles_loop_end
+    handles_hash = shift handles_it
+    $S0 = handles_hash['attrname']
+    attr = getattribute obj, $S0
+    if null attr goto handles_loop
+    $P0 = handles_hash['match_against']
+
+    # If we have a class or role, should get its method list and check if it
+    # .can do that. Otherwise, smart-match against method name.
+    $I0 = isa $P0, 'P6protoobject'
+    if $I0 goto handles_proto
+    $I0 = isa $P0, 'Perl6Role'
+    if $I0 goto handles_role
+    $I0 = isa $P0, 'Role'
+    if $I0 goto handles_parrotrole
+    $P1 = $P0.'ACCEPTS'(name)
+    unless $P1 goto handles_loop
+    .tailcall attr.name(pos_args :flat, name_args :flat :named)
+
+  handles_proto:
+    $P1 = get_hll_global ['Perl6Object'], '$!P6META'
+    $P0 = $P1.'get_parrotclass'($P0)
+    goto handles_have_pc
+  handles_role:
+    $P0 = $P0.'!select'()
+  handles_parrotrole:
+  handles_have_pc:
+    $P1 = $P0.'methods'()
+    $I0 = exists $P1[name]
+    unless $I0 goto handles_loop
+    .tailcall attr.name(pos_args :flat, name_args :flat :named)
+  handles_loop_end:
     goto mro_loop
 
   pmc_proxy: