File Coverage

blib/lib/Amb.pm

Criterion	Covered	Total	%
statement	94	135	69.6
branch	25	74	33.7
condition	4	15	26.6
subroutine	12	14	85.7
pod	2	7	28.5
total	137	245	55.9

# $Id: Amb.pm,v 1.7 2008/09/03 12:56:14 dk Exp $
package Amb;
use strict;

require Exporter;
require DynaLoader;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
@ISA = qw(Exporter DynaLoader);
$VERSION = '0.02';
@EXPORT = qw(amb);
@EXPORT_OK = qw(angelic demonic);

bootstrap Amb $VERSION;

use B::Generate 1.13;
use Carp qw(confess croak);
use PadWalker;

BEGIN { *CORE::GLOBAL::die = \&dier } ;

my (%patched, %cv, @stack, $charged, $debug);
$debug = $ENV{AMB_DEBUG}||0;

sub dier
{
	CORE::die(@_) if $^S; # eval

AGAIN:
	my $c = pop @stack;
	unless ( $c) {
		my @c = caller;
		push @_, " at $c[1] line $c[2]\n" unless join('', @_) =~ /\n/;
		CORE::die @_;
	}

	if ( $c-> {angelic}) {
		$charged = $c;
		print "angelic/die in branch # $c->{state} at $c->{label}\n" if $debug;
		$c-> {state}++;
		goto $c-> {label};
	} else {
		print "demonic/die in branch # $c->{state} at $c->{label}\n" if $debug;
		$c-> {state} = 0;
		goto AGAIN; # that means die again
	}
}

sub after
{
	my $c = pop @stack;
	if ( $c) {
		if ( $c-> {angelic}) {
			print "angelic/after\n" if $debug;
			$c-> {state} = 0;
		} else {
			print "demonic/after\n" if $debug;
			$c-> {state}++;
			$charged = $c;
			goto $c-> {label};
		}
	}
	undef $charged;
}

sub fail($)
{
	local $Carp::CarpLevel = 3 unless $debug;
	confess "Can't call $_[0]\(\) that way";
}

sub patch
{
	my ($name, $xop, $cv, $upcontext) = @_;

	printf("$name: patch at COP( 0x%x)\n", $$xop) if $debug;

	my $cv_frame = $cv ? B::svref_2object($cv) : B::main_cv;

	# enter other CV's padlist
	my $savecp = B::cv_pad;
	B::cv_pad( $cv_frame);

	my $psm = B::GVOP-> new( 'gv', 0, \&after);

       # calling ops
	my $gc2 = B::UNOP-> new( 'null', 0, $psm);
	my $gc3 = B::UNOP-> new( 'entersub', 0, $gc2);
	my $cop = B::COP-> new( 0, '', 0); # this line appears as a calling point for after()
	# this is the COP we put $cop after
	my $gs  = $xop-> sibling-> sibling;
	if ( ref($gs) eq 'B::NULL') {
		# there's no COP -- it was last already
		# create an artificial cop then
		$gs = B::COP-> new( 1, '', 0);
		$xop-> sibling-> sibling( $gs);
	} elsif ( ref($gs) ne 'B::COP') {
		fail $name;
	}

	my $gss = $gs-> sibling;
	my $gsn = $gs-> next;

	$gs->  next($cop);
	$cop-> next($psm);
	$psm-> next($gc2);
	$gc2-> next($gc3);
	$gc3-> next($gsn);

	$gs->  sibling($cop);
	$cop-> sibling($gc3);
	$gc3-> sibling($gss);

	# create COP with label and put it before the entry COP
	my $id  = sprintf "$name\:\:0x%x/0x%x", $$xop, $upcontext;
	my $lab = B::COP-> new( 0, $id, 0);
	$lab-> sibling( $xop-> sibling);
	$xop-> sibling( $lab);
	$lab-> next( $xop-> next);
	$xop-> next($lab);

	# restore padlist
	B::cv_pad( $savecp);

	if ( $debug > 1) {
		no strict;
		local $SIG{__WARN__};
		eval "*B::CV::NAME      = sub { 'fake' };" unless exists ${'B::CV'}{NAME};
		eval "*B::NV::int_value = sub { '0.0' };"  unless exists ${'B::NV'}{int_value};

		require B::Concise;
		my $walker = B::Concise::compile('-terse',($cv?$cv:()));
		$walker->();
	}

	return $id;

}

sub find_ctx
{
	# get the COP that is right before the call of amb()
	my $what = shift;
	my $up  = PadWalker::_upcontext(1);
	fail $what unless $up;
	my $op  = Amb::caller_op($up);
	fail $what unless $op and ref($op) eq 'B::COP';

	# ensure that the call is inside if(...) statement
	my $x = $op-> sibling;
	fail $what unless $x and ref($x) eq 'B::UNOP';
	$x = $x-> first;
	fail $what unless $x and ref($x) eq 'B::LOGOP' and $x-> name =~ /^(cond_expr|and)$/;

	# get the cv frame that has called
	my $upper = PadWalker::_upcontext(2);
	my $cx;
	if ( $upper) {
		$cx = Amb::context_cv($upper);
		fail $what unless $cx and ref($cx) eq 'CODE';
	}

	return $op, $cx, $up;
}

sub amb
{
	croak "format: amb(arg1,arg2)" if 1 != $#_;

	my $c;
	unless ( $charged) {
		my ($op, $cx, $up) = find_ctx('amb');
		printf("amb: 1st call at %x\n", $$op) if $debug;

		my $id;
		unless ( exists $patched{$$op}) {
			$id = patch( 'amb', $op, $cx, $up);
			$patched{$$op} = {
				angelic => 1,
				label   => $id,
			}
		}
		$c = $patched{$$op};
		$c-> {state} = 0;
	} else {
		$c = $charged;
		undef $charged;
		print "amb: jump from $c->{label}\n" if $debug;
	}

	die "amb: all branches fail" if $c-> {state} > $#_;

	push @stack, $c;
	return $_[ $c-> {state} ];
}

*angelic = \&amb;

sub demonic
{
	croak "format: demonic(arg1,arg2)" if 1 != $#_;

	my $c;
	unless ( $charged) {
		my ($op, $cx, $up) = find_ctx('demonic');
		printf("demonic: 1st call at %x\n", $op) if $debug;

		my $id;
		unless ( exists $patched{$$op}) {
			$id = patch( 'demonic', $op, $cx, $up);
			$patched{$$op} = {
				angelic => 0,
				label   => $id,
			}
		}
		$c = $patched{$$op};
		$c-> {state} = 0;
	} else {
		$c = $charged;
		undef $charged;
		print "demonic: jump from $c->{label}\n" if $debug;
	}

	die "demonic: all branches succeed" if $c-> {state} > $#_;

	push @stack, $c;
	return $_[ $c-> {state} ];
}

1;

__DATA__