mirror of
https://github.com/perlbot/perlbuut
synced 2025-06-08 11:55:40 -04:00
301 lines
7.1 KiB
Perl
301 lines
7.1 KiB
Perl
package Math::Farnsworth::FunctionDispatch;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Data::Dumper;
|
|
|
|
use Math::Farnsworth::Variables;
|
|
use Math::Farnsworth::Value::Array;
|
|
use Math::Farnsworth::Error;
|
|
|
|
use Carp;
|
|
|
|
sub new
|
|
{
|
|
my $self = {};
|
|
bless $self, (shift);
|
|
}
|
|
|
|
sub addfunc
|
|
{
|
|
my $self = shift;
|
|
my $name = shift;
|
|
my $args = shift;
|
|
my $value = shift;
|
|
my $scope = shift;
|
|
|
|
#i should really have some error checking here
|
|
$self->{funcs}{$name} = {name=>$name, args=>$args, value=>$value, parentscope=>$scope};
|
|
}
|
|
|
|
sub getfunc
|
|
{
|
|
my $self = shift;
|
|
my $name = shift; #which one to get, we return the hashref
|
|
return $self->{funcs}{$name};
|
|
}
|
|
|
|
sub isfunc
|
|
{
|
|
my $self = shift;
|
|
my $name = shift;
|
|
|
|
return exists($self->{funcs}{$name});
|
|
}
|
|
|
|
sub setupargs
|
|
{
|
|
my $self = shift;
|
|
my $eval = shift;
|
|
my $args = shift;
|
|
my $argtypes = shift;
|
|
my $name = shift; #name to display
|
|
#my $branch = shift;
|
|
|
|
my $vars = $eval->{vars}; #get the scope we need
|
|
|
|
ARG:for my $argc (0..$#$argtypes)
|
|
{
|
|
my $n = $argtypes->[$argc][0]; #the rest are defaults and constraints
|
|
my $v = $args->getarrayref()->[$argc];
|
|
|
|
my $const = $argtypes->[$argc][2];
|
|
|
|
if (ref($const) eq "VarArg")
|
|
{
|
|
warn "Working around bug in lambdas!";
|
|
$const = "VarArg";
|
|
}
|
|
|
|
if (!defined($v))# || ($v->{dimen}{dimen}{"undef"})) #uncomment for undef== default value
|
|
{
|
|
#i need a default value!
|
|
if (!defined($argtypes->[$argc][1]) && defined($argtypes->[$argc][0]) && (defined($const) && ref($const) !~ /Math::Farnsworth::Value/ && $const ne "VarArg"))
|
|
{
|
|
die "Required argument $argc to function $name\[\] missing\n";
|
|
}
|
|
|
|
$v = $argtypes->[$argc][1];
|
|
}
|
|
|
|
if (defined($const) && ref($const) =~ /Math::Farnsworth::Value/)
|
|
{
|
|
#we have a constraint
|
|
if (!$v->conforms($const))
|
|
{
|
|
die "Constraint not met on argument $argc to $name\[\]\n";
|
|
}
|
|
}
|
|
elsif (defined($const) && $const eq "VarArg")
|
|
{
|
|
#we've got a variable argument, it needs to slurp all the rest of the arguments into an array!
|
|
my $last = $#{$args->getarrayref()};
|
|
my @vargs = @{$args->getarrayref()}[$argc..$last];
|
|
my $v = new Math::Farnsworth::Value::Array(\@vargs);
|
|
$vars->declare($n, $v); #set the variable
|
|
last ARG; #don't parse ANY more arguments
|
|
}
|
|
|
|
if (defined $n) #happens when no arguments! so we check if the name is defined
|
|
{
|
|
#print "SETVAR $n: ";
|
|
#print Dumper($argtypes->[$argc]);
|
|
#print Dumper($vars->{vars});
|
|
if (!$argtypes->[$argc][3]) #make sure that it shouldn't be byref
|
|
{
|
|
$vars->declare($n, $v);
|
|
}
|
|
else
|
|
{
|
|
#it should be by ref
|
|
if ($v->getref())
|
|
{
|
|
$vars->setref($n, $v->getref());
|
|
}
|
|
else
|
|
{
|
|
error "Can't get reference from expression for argument $argc";
|
|
}
|
|
}
|
|
|
|
#print Dumper($vars->{vars});
|
|
}
|
|
}
|
|
}
|
|
|
|
#should i really have this here? or should i have it in evaluate.pm?
|
|
sub callfunc
|
|
{
|
|
my $self = shift;
|
|
my $eval = shift;
|
|
my $name = shift;
|
|
my $args = shift;
|
|
my $branches = shift;
|
|
|
|
my $argtypes = $self->{funcs}{$name}{args};
|
|
|
|
my $fval = $self->{funcs}{$name}{value};
|
|
|
|
#print "-------------ATTEMPTING TO CALL FUNCTION!-------------\n";
|
|
#print "FUNCTION NAME : $name\n";
|
|
#print "Dumper of func: ".Dumper($fval);
|
|
#print "--------------------THAT IS ALL\n";
|
|
|
|
die "Function $name is not defined\n" unless defined($fval);
|
|
die "Number of arguments not correct to $name\[\]\n" unless $self->checkparams($args, $argtypes); #this should check....
|
|
|
|
# print Dumper($args);
|
|
|
|
my $neval;
|
|
|
|
if (defined $self->{funcs}{$name}{parentscope})
|
|
{
|
|
$neval = $self->{funcs}{$name}{parentscope};
|
|
|
|
my $nvars = new Math::Farnsworth::Variables($neval->{vars});
|
|
|
|
my %nopts = (vars => $nvars, funcs => $self, units => $neval->{units}, parser => $neval->{parser});
|
|
$neval = $neval->new(%nopts);
|
|
}
|
|
else
|
|
{
|
|
#this should get scrapped once i fix the other modules!
|
|
carp "SETTING UP PARENT SCOPE OUT OF NO WHERE!";
|
|
my $nvars = new Math::Farnsworth::Variables($eval->{vars});
|
|
|
|
my %nopts = (vars => $nvars, funcs => $self, units => $eval->{units}, parser => $eval->{parser});
|
|
$neval = $eval->new(%nopts);
|
|
# $self->{funcs}{$name}{parentscope} = $neval; #store it for later!
|
|
}
|
|
|
|
#print "NEWSCOPE! ".$neval->{vars}."\n";
|
|
|
|
#eval #just for fucks sake!
|
|
#{
|
|
# my $facts = $neval->{vars}->getvar("facts");
|
|
# print "FACTS!\n";
|
|
# print Dumper($facts, "$facts");
|
|
#};
|
|
|
|
#carp "$@" if $@;
|
|
|
|
$self->setupargs($neval, $args, $argtypes, $name, $branches); #setup the arguments
|
|
|
|
if (ref($fval) ne "CODE")
|
|
{
|
|
return $self->callbranch($neval, $fval, $name);
|
|
}
|
|
else
|
|
{
|
|
#we have a code ref, so we need to call it
|
|
return $fval->($args, $neval, $branches, $eval);
|
|
}
|
|
}
|
|
|
|
sub calllambda
|
|
{
|
|
my $self = shift;
|
|
my $lambda = shift;
|
|
my $args = shift;
|
|
# my $refscope = shift;
|
|
# my $branch = shift; #new for lambdas!
|
|
|
|
my $argtypes = $lambda->getargs();
|
|
my $fval = $lambda->getcode();
|
|
my $eval = $lambda->getscope();
|
|
|
|
#print "LAMBDA---------------\n";
|
|
#print Dumper($argtypes, $args, $fval);
|
|
|
|
my $nvars = new Math::Farnsworth::Variables($eval->{vars});
|
|
|
|
my %nopts = (vars => $nvars, funcs => $self, units => $eval->{units}, parser => $eval->{parser});
|
|
my $neval = $eval->new(%nopts);
|
|
|
|
die "Number of arguments not correct to lambda\n" unless $self->checkparams($args, $argtypes); #this shoul
|
|
|
|
$self->setupargs($neval, $args, $argtypes, "lambda");
|
|
return $self->callbranch($neval, $fval);
|
|
}
|
|
|
|
sub callbranch
|
|
{
|
|
my $self = shift;
|
|
my $eval = shift;
|
|
my $branches = shift;
|
|
my $name = shift;
|
|
|
|
|
|
# print "CALLBRANCHES :: ";
|
|
# print $name if defined $name;
|
|
# print " :: $eval\n";
|
|
|
|
return $eval->evalbranch($branches);
|
|
}
|
|
|
|
#this was supposed to be the checks for types and such, but now its something else entirely, mostly
|
|
sub checkparams
|
|
{
|
|
my $self = shift;
|
|
my $args = shift;
|
|
my $argtypes = shift;
|
|
|
|
my $vararg = 0;
|
|
|
|
my $neededargs = 0;
|
|
my $badargs = 0;
|
|
|
|
for my $argt (@$argtypes)
|
|
{
|
|
$neededargs++ unless (defined($argt->[1]) || !defined($argt->[0]));
|
|
$badargs++ if (!defined($argt->[0]));
|
|
}
|
|
|
|
#might want to change the !~ to something else?
|
|
#warn "Strange bug here to investigate, lambdas produce blessed array refs for vararg... wtf";
|
|
$vararg = 1 if (grep {defined($_->[2]) && ref($_->[2]) !~ /Math::Farnsworth::Value/ && (($_->[2] eq "VarArg") || (ref($_->[2]) eq "VarArg"))} @{$argtypes}); #find out if there is a vararg arg
|
|
|
|
#print "NEEDED: $neededargs :: $vararg\n";
|
|
#print Data::Dumper->Dump([$argtypes, $args->getarrayref()], [qw(argtypes args)]);
|
|
|
|
return 1 if ($vararg || ($args->getarray() <= (@{$argtypes}-$badargs) && $args->getarray() >= $neededargs));
|
|
|
|
#return 0 unless (ref($args) eq "Math::Farnsworth::Value") && ($args->{dimen}->compare({dimen=>{array=>1}}));
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub getref
|
|
{
|
|
my $self = shift;
|
|
my $argc = shift;
|
|
my $branch = shift;
|
|
my $name = shift;
|
|
|
|
#print "\n\nGETREF\n";
|
|
#print Dumper($branch);
|
|
|
|
if (ref $branch->[1] ne "Array")
|
|
{
|
|
#this should add support for some other stuff
|
|
error "Cannot get a reference if function/lambda is called without []";
|
|
}
|
|
|
|
my $argexpr = $branch->[1][$argc];
|
|
|
|
#print Dumper($argbranches->[$argc]);
|
|
|
|
if (ref $argexpr ne "Fetch")
|
|
{
|
|
error "Argument $argc to $name\[\] is not referencable";
|
|
}
|
|
|
|
my $ref = $self->{funcs}{$name}->{scope}{vars}->getref($argexpr->[0]);
|
|
|
|
print Dumper($argexpr, $ref);
|
|
|
|
return $ref;
|
|
}
|
|
|
|
1;
|