diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm index 667827fba27..2810070c718 100644 --- a/src/Perl6/Actions.pm +++ b/src/Perl6/Actions.pm @@ -1104,7 +1104,13 @@ class Perl6::Actions is HLL::Actions { add_signature_binding_code($block, $signature); # Create code object. - my $code := $*ST.create_code_object($block, 'Sub', $signature); + my $code := $*ST.create_code_object($block, 'Sub', $signature, + $*MULTINESS eq 'proto'); + + # If we're a multi-dispatch entry point, add code object reference. + if $block { + $block.push($*ST.get_object_sc_ref_past($code)); + } my $past; if $ { @@ -1118,13 +1124,30 @@ class Perl6::Actions is HLL::Actions { my $outer := $*ST.cur_lexpad(); $outer[0].push($block); - # Install. - if $*SCOPE eq '' || $*SCOPE eq 'my' { - $*ST.install_lexical_symbol($outer, $name, $code); + # If it's a multi, need to associate it with the surrounding + # proto. + # XXX Also need to auto-multi things with a proto in scope. + if $*MULTINESS eq 'multi' { + # Locate the proto - or what we hope will be it. + my %proto_sym := $outer.symbol($name); + unless %proto_sym { + $/.CURSOR.panic("proto and dispatch auto-generation for multis not yet implemented"); + } + my $proto := %proto_sym; + # XXX ensure it's actuall a proto or dispatch... + + # Install the candidate. + $*ST.add_dispatchee_to_proto($proto, $code); } - # XXX our ... else { - $/.CURSOR.panic("Cannot use '$*SCOPE' scope with a sub"); + # Install. + if $*SCOPE eq '' || $*SCOPE eq 'my' { + $*ST.install_lexical_symbol($outer, $name, $code); + } + # XXX our ... + else { + $/.CURSOR.panic("Cannot use '$*SCOPE' scope with a sub"); + } } # Evaluate to a ref to the code. @@ -1168,11 +1191,12 @@ class Perl6::Actions is HLL::Actions { # Create code object. my $type := $*METHODTYPE eq 'submethod' ?? 'Submethod' !! 'Method'; - my $code := $*ST.create_code_object($past, $type, $signature); + my $code := $*ST.create_code_object($past, $type, $signature, + $*MULTINESS eq 'proto'); # If we're a multi-dispatch entry point, add code object reference. if $past { - $past.push($*ST.get_object_sc_ref_past($code)); + $past.push($*ST.get_object_sc_ref_past($code)); } # Install method. diff --git a/src/Perl6/SymbolTable.pm b/src/Perl6/SymbolTable.pm index 617b5f0e498..d630da4664e 100644 --- a/src/Perl6/SymbolTable.pm +++ b/src/Perl6/SymbolTable.pm @@ -278,7 +278,7 @@ class Perl6::SymbolTable is HLL::Compiler::SerializationContextBuilder { # body at fixup time; during the deserialize we just set the already compiled # output right into place. If we get a request to run the code before we did # really compiling it, we can do that - we just dynamically compile it. - method create_code_object($code_past, $type, $signature) { + method create_code_object($code_past, $type, $signature, $is_dispatcher = 0) { my $fixups := PAST::Stmts.new(); my $des := PAST::Stmts.new(); @@ -314,10 +314,36 @@ class Perl6::SymbolTable is HLL::Compiler::SerializationContextBuilder { pir::setattribute__vPPsP($code, $code_type, '$!signature', $signature); $des.push(self.set_attribute($code, $code_type, '$!signature', self.get_object_sc_ref_past($signature))); + # If this is a dispatcher, install dispatchee list that we can + # add the candidates too. + if $is_dispatcher { + pir::setattribute__vPPsP($code, $code_type, '$!dispatchees', []); + $des.push(self.set_attribute($code, $code_type, '$!dispatchees', + PAST::Op.new( :pasttype('list') ))); + } + self.add_event(:deserialize_past($des), :fixup_past($fixups)); $code; } + # Adds a multi candidate to a proto/dispatch. + method add_dispatchee_to_proto($proto, $candidate) { + # Add it to the list. + my $code_type := self.find_symbol(['Code']); + pir::getattribute__PPPs($proto, $code_type, '$!dispatchees').push($candidate); + + # Deserializatin code to add it. + self.add_event(:deserialize_past(PAST::Op.new( + :pirop('push vPP'), + PAST::Var.new( + :scope('attribute_6model'), :name('$!dispatchees'), + self.get_object_sc_ref_past($proto), + self.get_object_sc_ref_past($code_type) + ), + self.get_object_sc_ref_past($candidate) + ))); + } + # Helper to make PAST for setting an attribute to a value. Value should # be a PAST tree. method set_attribute($obj, $class, $name, $value_past) {