edit: included my perl script
Is there a way to call a subroutine by providing the parameters as pop(@stack) and the values only to be poped from the stack if they are used in the subroutine. In the following example I would like: the "printok" subroutine to pop 0 elements from the stack. the "check" subroutine to pop 1 element from the stack. the "compare" subroutine to pop 2 elements from the stack.
sub compare{
my ($v1,$v2) = @_;
if ($v1 < $v2){
return $v1;
}
else{
return $v2;
}
}
sub check{
my $v = $_[0];
if ($v > 0){
return "ckeck done\n";
}
else{
exit;
}
}
sub printok{
return "ok\n";
}
print printok(pop(@stack),pop(@stack)),"\n";
print check(pop(@stack),pop(@stack)),"\n";
print compare(pop(@stack),pop(@stack)),"\n";
print join(" ",@stack), "\n";
My actual use case is in a program where operation names are in a hash and some operations require more arguments than others. I want to be able to call the functions depending on the operation codes listed in the hash.
I do not want to work with the stack from inside of subroutines.
I wish to be able to call each subroutine with a single line. (or use as little conditional statements as possible)
$opcodes{$op}->(pop(@stack),pop(@stack),$n);
Some subroutines require only one element from the stack, other require 2, other require an additional integer.
My script:
#!/usr/bin/perl
use strict;
use warnings;
#regex for numbers
my $regN = qr/[-+]?(?:\d+(?:\.\d+)?|\.\d+)(?:[eE][-+]?\d+)?/;
#creating the stack
my @stack;
#creating the hash table for the opcodes
my %opcodes = (
'+' => \&add,
'-' => \&subtract,
'*' => \&multi,
'/' => \÷,
'neg' => \&negate,
'conj' => \&conjugate,
'abs' => \&absolute,
'sqrt' => \&squarert,
'drop' => \&drop,
'dup' => \&dup,
'swap' => \&swap,
'rot' => \&rot,
);
#declaration of the n variable used in the rot N function
my $n;
#realisation of the + function
sub add{
die "Error: The + function requires at least 2 elements in the stack"
if 2 > scalar @stack;
my @q;
my ($q2, $q1) = (pop(@stack),pop(@stack));
#adding the elements of the quaternions
@q[0] = @$q1[0] + @$q2[0];
@q[1] = @$q1[1] + @$q2[1];
@q[2] = @$q1[2] + @$q2[2];
@q[3] = @$q1[3] + @$q2[3];
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
};
#realisation of the - function
sub subtract{
die "Error: The - function requires at least 2 elements in the stack"
if 2 > scalar @stack;
my @q;
my ($q2, $q1) = (pop(@stack),pop(@stack));
#subtracting the elements of the quaternions
@q[0] = @$q1[0] - @$q2[0];
@q[1] = @$q1[1] - @$q2[1];
@q[2] = @$q1[2] - @$q2[2];
@q[3] = @$q1[3] - @$q2[3];
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
};
#realisation of the * function
sub multi{
die "Error: The * function requires at least 2 elements in the stack"
if 2 > scalar @stack;
my @q;
my ($q2, $q1) = (pop(@stack),pop(@stack));
#https://www.euclideanspace.com/maths/algebra/
#realNormedAlgebra/quaternions/arithmetic/
@q[0] = (@$q1[0] * @$q2[0] - @$q1[1] * @$q2[1] -
@$q1[2] * @$q2[2] - @$q1[3] * @$q2[3]);
@q[1] = (@$q1[1] * @$q2[0] + @$q1[0] * @$q2[1] +
@$q1[2] * @$q2[3] - @$q1[3] * @$q2[2]);
@q[2] = (@$q1[0] * @$q2[2] - @$q1[1] * @$q2[3] +
@$q1[2] * @$q2[0] + @$q1[3] * @$q2[1]);
@q[3] = (@$q1[0] * @$q2[3] + @$q1[1] * @$q2[2] -
@$q1[2] * @$q2[1] + @$q1[3] * @$q2[0]);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
};
#realisation of the / function
sub divide{
die "Error: The / function requires at least 2 elements in the stack"
if 2 > scalar @stack;
my @q;
my ($q2, $q1) = (pop(@stack),pop(@stack));
#https://www.mathworks.com/help/aeroblks/quaterniondivision.html
@q[0] = (@$q1[0] * @$q2[0] + @$q1[1] * @$q2[1] +
@$q1[2] * @$q2[2] + @$q1[3] * @$q2[3])/
(@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
@q[1] = (@$q1[0] * @$q2[1] - @$q1[1] * @$q2[0] -
@$q1[2] * @$q2[3] + @$q1[3] * @$q2[2])/
(@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
@q[2] = (@$q1[0] * @$q2[2] + @$q1[1] * @$q2[3] -
@$q1[2] * @$q2[0] - @$q1[3] * @$q2[1])/
(@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
@q[3] = (@$q1[0] * @$q2[3] - @$q1[1] * @$q2[2] +
@$q1[2] * @$q2[1] - @$q1[3] * @$q2[0])/
(@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}
#realisation of the neg function
sub negate{
die "Error: The neg function requires at least 1 elements in the stack"
if 0 == scalar @stack;
my @q;
my $q1 = pop(@stack);
@q[0] = @$q1[0] * -1;
@q[1] = @$q1[1] * -1;
@q[2] = @$q1[2] * -1;
@q[3] = @$q1[3] * -1;
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}
#realisation of the conj function
sub conjugate{
die "Error: The conj function requires at least 1 element in the stack"
if 0 == scalar @stack;
my @q;
my $q1 = pop(@stack);
@q[0] = @$q1[0];
@q[1] = @$q1[1] * -1;
@q[2] = @$q1[2] * -1;
@q[3] = @$q1[3] * -1;
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}
#realisation of the abs function
sub absolute{
die "Error: The abs function requires at least 1 element in the stack"
if 0 == scalar @stack;
my @q;
my $q1 = pop(@stack);
#finding absolute values of each individual component
@q[0] = abs(@$q1[0]);
@q[1] = abs(@$q1[1]);
@q[2] = abs(@$q1[2]);
@q[3] = abs(@$q1[3]);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}
#realisation of the sqrt function
sub squarert{
die "Error: The sqrt function requires at least 1 element in the stack"
if 0 == scalar @stack;
my @q;
my $q1 = pop(@stack);
#https://www.johndcook.com/blog/2021/01/06/quaternion-square-roots/
#finding the magnitude of the quaternion
my $magnitude = sqrt(@$q1[0]**2 + @$q1[1]**2 + @$q1[2]**2 + @$q1[3]**2);
my $theta = atan2(sqrt(1 - (@$q1[0] / $magnitude)**2), @$q1[0] / $magnitude);
@q[0] = cos($theta/2);
@q[1] = sin($theta/2) * (@$q1[1] / $magnitude);
@q[2] = sin($theta/2) * (@$q1[2] / $magnitude);
@q[3] = sin($theta/2) * (@$q1[3] / $magnitude);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
conjugate();
}
#realisation of the exp function
sub drop{
die "Error: The drop function requires at least 1 element in the stack"
if 0 == scalar @stack;
pop(@stack);
}
#realisation of the dup function
sub dup{
die "Error: The dup function requires at least 1 element in the stack"
if 0 == scalar @stack;
my @q;
my $q1 = pop(@stack);
@q = @$q1;
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}
#realisation of the swap function
sub swap{
die "Error: The swap function requires at least 2 elements in the stack"
if 2 > scalar @stack;
my @q1 = @{pop(@stack)};
my @q2 = @{pop(@stack)};
push(@stack,[$q1[0], $q1[1], $q1[2], $q1[3]]);
push(@stack,[$q2[0], $q2[1], $q2[2], $q2[3]]);
}
#realisation of the rot function
sub rot{
die "Error: N (in rot N) cannot be 0" if $n == 0;
die "Error: N (in rot N) cannot be greater than
the amount of elements in the stack"
if abs($n) > scalar @stack;
my @q ;
if ($n > 0) {
print "positive\n";
@q = @{pop(@stack)};
splice (@stack, $n-1, 0, [$q[0], $q[1], $q[2], $q[3]]);
}
elsif ($n < 0) {
print "negative\n";
@q = @{$stack[$n-1]};
splice (@stack, $n-1, 1);
push(@stack,[$q[0], $q[1], $q[2], $q[3]]);
}
}
while(<>){
chomp;
next if /^\s*$/;
if (/^\s*#@/){
die "Error: The column line is not of the right format"
unless (/^\s*#@\s*1\s*i\s*j\s*k\s*$/);
}
next if /^\s*#/;
if (/^\s*($regN)\s+($regN)\s+($regN)\s+($regN)\s*$/){
my $quat = [$1,$2,$3,$4];
push(@stack,[$1,$2,$3,$4]);
#print join("; ",@{$stack[0]}),"\n";
}
elsif (/^\s*$regN(\s+$regN)*\s*$/){
die "Error: Number of input number components is not 4";
}
elsif (/^\s*(\S+)([\s,[\d,-]*]?)\s*$/){
my $op = $1 ;
$n = $2 ;
die "Error: Unknown operation '$op'"
unless exists $opcodes{$op};
$opcodes{$op}->();
#print pop(@stack), "\n" ;
#print pop(@stack), "\n"
# foreach my $qr(@stack){
# print join("; ",@{$qr}),"\n";
# }
# print "\n";
}
}
warn "Warning: Extra values left in the stack at the end of the",
" program"
if scalar @stack > 1;
die "Error: Not enough values on the stack
for printing at the end of the program"
if scalar @stack == 0;
print "#@ 1 i j k\n";
my @ans = @{pop(@stack)};
if (grep {$_ eq "NaN"} @ans){
print "NaN\n";
}
elsif (grep {$_ eq "Inf"} @ans){
print "+Inf\n";
}
elsif (grep {$_ eq "-Inf"} @ans){
print "-Inf\n";
}
else{
print join ("; ",@ans);
}
No, however here are some ideas you may be interested in.
You could pass a reference to the stack to the functions, and let them pop arguments off themselves.
use v5.10;
sub compare {
my $v1 = pop @{ $_[0] };
my $v2 = pop @{ $_[0] };
if ( $v1 < $v2 ) {
return $v1;
}
else {
return $v2;
}
}
sub check {
my $v = pop @{ $_[0] };
if ( $v > 0 ) {
return "check done";
}
else {
exit;
}
}
sub printok {
return "ok";
}
say printok( \@stack );
say check( \@stack );
say compare( \@stack );
say join( " ", @stack );
This is simple, but does require that the functions need to know about the existence of the stack.
You could keep metadata on each function so you know how many arguments it takes, then use a utility function to retrieve precisely that many arguments from the stack and call the function with it.
use v5.10;
use Sub::Talisman qw( ArgCount );
sub compare :ArgCount(2) {
my ( $v1, $v2 ) = @_;
if ( $v1 < $v2 ) {
return $v1;
}
else {
return $v2;
}
}
sub check :ArgCount(1) {
my $v = shift;
if ( $v > 0 ) {
return "check done";
}
else {
exit;
}
}
sub printok :ArgCount(0) {
return "ok";
}
sub call_with_stack {
my ( $function, $stack, @extra_args ) = @_;
my $coderef = ref( $function )
? $function
: __PACKAGE__->can( $function );
my $count = Sub::Talisman
->get_attribute_parameters( $coderef, 'ArgCount' )
->[0];
$count -= scalar @extra_args;
my @args = ();
if ( $count > 0 ) {
push @args, pop @$stack for 1 .. $count;
}
$coderef->( @args, @extra_args );
}
say call_with_stack printok => \@stack;
say call_with_stack check => \@stack;
say call_with_stack compare => \@stack;
say join( " ", @stack );
This allows the body of the function to have no knowledge of the stack, but requires the caller of the function to wrap the call in call_with_stack.
Basically, one solution requires special knowledge in the functions, and the other requires special knowledge in the caller.
The second solution seems to be the one which works best with the additional requirement that an extra $n can be passed which doesn't come from the stack, though in this example it's hardcoding the assumption that any extra non-stack arguments will always be at the end of the argument list.