From 10e5b5698f8c4c1f8323ee15dd632326d88f664a Mon Sep 17 00:00:00 2001
From: Jonathan Worthington <jnthn@jnthn.net>
Date: Thu, 18 Feb 2010 20:10:25 +0100
Subject: [PATCH] First cut of binding a signature against the return values of
 a function. Kinda works. :-)

---
 src/Perl6/Compiler/Signature.pm | 20 ++++++-
 src/Perl6/Grammar.pm            |  1 +
 src/builtins/Signature.pir      | 93 ++++++++++++++++++++++++++++++++-
 3 files changed, 110 insertions(+), 4 deletions(-)

diff --git a/src/Perl6/Compiler/Signature.pm b/src/Perl6/Compiler/Signature.pm
index 29158b17ea9..9189a442b16 100644
--- a/src/Perl6/Compiler/Signature.pm
+++ b/src/Perl6/Compiler/Signature.pm
@@ -13,6 +13,14 @@ class Perl6::Compiler::Signature;
 
 has $!entries;
 has $!default_type;
+has $!bind_target;
+
+
+# Accessor for $!bind_target.
+method bind_target($bind_target?) {
+    if $bind_target { $!bind_target := $bind_target }
+    $!bind_target
+}
 
 
 # Adds a parameter to the signature.
@@ -320,12 +328,20 @@ method ast($low_level?) {
         ));
     }
     else {
-        $ast.push(PAST::Op.new(
+        my $node := PAST::Op.new(
             :pasttype('callmethod'),
             :name('new'),
             PAST::Var.new( :name('Signature'),, :scope('package') ),
             PAST::Var.new( :name($sig_var.name()), :scope('register'), :named('ll_sig') )
-        ));
+        );
+        if self.bind_target() eq 'lexical' {
+            $node.push(PAST::Op.new(
+                :named('bind_target'),
+                :inline('    %r = getinterp',
+                        '    %r = %r["lexpad"]')
+            ));
+        }
+        $ast.push($node);
     }
 
     return $ast;
diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm
index e48becba007..5cec6473275 100644
--- a/src/Perl6/Grammar.pm
+++ b/src/Perl6/Grammar.pm
@@ -1162,6 +1162,7 @@ method bindish_check($/) {
     # than the list.
     if pir::defined__IP($/[0].ast()<signature_from_declarator>) {
         $/[0] := $/[0].ast()<signature_from_declarator>;
+        $/[0].bind_target('lexical');
     }
 }
 
diff --git a/src/builtins/Signature.pir b/src/builtins/Signature.pir
index 1aa3fef5783..34a56f8c3cb 100644
--- a/src/builtins/Signature.pir
+++ b/src/builtins/Signature.pir
@@ -16,7 +16,7 @@ P6LowLevelSig and provides higher level access to it.
 .sub 'onload' :anon :init :load
     .local pmc p6meta
     p6meta = get_hll_global ['Mu'], '$!P6META'
-    p6meta.'new_class'('Signature', 'parent'=>'Any', 'attr'=>'$!ll_sig $!param_cache')
+    p6meta.'new_class'('Signature', 'parent'=>'Any', 'attr'=>'$!ll_sig $!param_cache $!try_bind_sub $!bind_target')
 .end
 
 
@@ -129,7 +129,96 @@ Binds the signature into the given bind target.
 
 .sub '!BIND' :method
     .param pmc capture
-    '&die'('!BIND on signature NYI')
+    .param pmc adverbs :named :slurpy
+
+    # Get hold of the bind testing sub.
+    $P0 = getattribute self, '$!try_bind_sub'
+    $I0 = defined $P0
+    if $I0 goto have_try_bind_sub
+    $P0 = self.'!make_try_bind_sub'()
+  have_try_bind_sub:
+
+    # Attempt to bind and get back a hash of the bound variables.
+    .local pmc bound
+    bound = $P0(capture)
+
+    # Update the target.
+    .local pmc target, bound_it
+    target = getattribute self, '$!bind_target'
+    $I0 = defined target
+    unless $I0 goto done
+    bound_it = iter bound
+  bound_it_loop:
+    unless bound_it goto bound_it_loop_end
+    $S0 = shift bound_it
+    $P0 = bound[$S0]
+    target[$S0] = $P0
+    goto bound_it_loop
+  bound_it_loop_end:
+
+  done:
+    .return (bound)
+.end
+
+
+=item !make_try_bind_sub
+
+This is terrifying. To try binding a signature, we want to have a sub so we
+have a proper lex pad to bind against, and constraints will work. However,
+it can't be the actual sub the signature is attached to, and we won't always
+need it, So, we'll "just" manufacture one on demand.
+
+=cut
+
+.sub '!make_try_bind_sub' :method
+    .local pmc params, param_it
+    .local string pir
+
+    # Opening.
+    pir = <<'PIR'
+.sub ''
+    .param pmc capture
+PIR
+
+    # Emit bound variables.
+    $I0 = 1
+    params = self.'params'()
+    param_it = iter params
+  it_loop:
+    unless param_it goto it_loop_end
+    $P0 = shift param_it
+    $S0 = $P0.'name'()
+    if null $S0 goto it_loop
+    if $S0 == '' goto it_loop
+    concat pir, '    $P'
+    $S1 = $I0
+    concat pir, $S1
+    concat pir, " = new ['Perl6Scalar']\n    .lex '"
+    concat pir, $S0
+    concat pir, "', $P"
+    concat pir, $S1
+    concat pir, "\n"
+    inc $I0
+    goto it_loop
+  it_loop_end:
+
+    # Ending.
+    pir = concat <<'PIR'
+    bind_signature capture
+    $P0 = getinterp
+    $P0 = $P0['lexpad']
+    .return ($P0)
+.end
+PIR
+    
+    # Compile and return.
+    $P0 = compreg 'PIR'
+    $P0 = $P0(pir)
+    $P0 = $P0[0]
+    $P1 = getattribute self, '$!ll_sig'
+    $P1 = descalarref $P1
+    setprop $P0, '$!signature', $P1
+    .return ($P0)
 .end
 
 =back