=pod

framework for tail recursion in pure perl


In order to implement the tail recursion optimization to
a function call, the stack must be completely unwound, replacing
and the destination of the return value is passed as part of
the arguments, so it may be passed in turn to deeper recursions.

perl 5.8.7 does not implement tail recursion optimizations:

# perl -wle 'sub tr_test{$x = shift; return tr_test($x)}; tr_test(4)'
Deep recursion on subroutine "main::tr_test" at -e line 1.
Out of memory!
# perl -wle 'sub tr_test{ return tr_test()}; tr_test(4)'              
Deep recursion on subroutine "main::tr_test" at -e line 1.
Out of memory!
# perl -wle 'sub tr_test{ $x++; tr_test() }; tr_test(4)' 
Name "main::x" used only once: possible typo at -e line 1.
Deep recursion on subroutine "main::tr_test" at -e line 1.
Out of memory!

if it did, the above one-liners would all simply be stuck in
loops, instead of leaking. 

=cut

# A trivial recursive function:

sub count {  # inefficient floor function
	$_[0]>=1 or return $_[1];
        return count($_[0]-1, $_[1]+1)
};

print "expect 21: ",count(21.999),"\n" ;



# that is recursive.  How to make it tail_recursive within
# the context of pure perl?  a dispatch function.
use Carp;
sub tr_dispatch{
	wantarray and croak " array context not supported at this time";
	my %args = @_;
	$args{TARGET} and croak "don't set the TARGET arg, silly";
	my $sub = $args{SUB} or croak "SUB arg is required, must be a subref";
	my $fargs = $args{ARGS}; # function arguments arrayref
	if ($args{ARGC}){
		push @$fargs, undef while @$fargs < $args{ARGC};

	};

	while (!exists $args{TARGET}){
		$sub->($args{TARGET}, @$fargs) # see perlfaq4
	};

	return $args{TARGET};
	
};

# rewriting the simple floor function to use the dispatcher
# requires the following:

# the eventual lvalue that the result will be assigned to
# is passed in as the first argument; declare the final
# case by assigning to @_[0]

# instead of recursing, the arguments beyond the first one
# must be modified in their place in @_

# NO SHIFTING!  if you must have names for things, do something
# like  my ($foo_ref, $bar_ref, $baz_ref) = \(@_[1..$#_])
# and double the sygils to use the arguments


sub trcount {  # inefficient floor function for tr-dispatch
	my ($countee, $counter) = \(@_[1,2]);
	$$countee>=1 or $_[0]=$$counter;
        $$countee--; $$counter++;
	return; #not needed at the bottom, but this function is trivial
};

print 	"expect 21: ",
	scalar(tr_dispatch(SUB => \&trcount,ARGS => [21.87,undef])),
	"\n" ;

print 	"expect 21: ",
	scalar(tr_dispatch(
		SUB => \&trcount,
		ARGS => [21.87],
		ARGC => 2

	)),"\n" ;

print "entering endless loop: expect spin-hang w/o OOM error\n";

print 	"expect 21: ",
	scalar(tr_dispatch(
		SUB => sub{$x++},
		ARGS => [1..9]

	)),"\n" ;