Perl中能否根据子程序参数使用情况从栈中弹出元素？

问题描述 #

请问在Perl中，能否以pop(@stack)作为参数调用子程序，且仅在子程序实际使用该参数时才从栈中弹出对应元素？例如：printok子程序不弹出任何栈元素，check子程序弹出1个栈元素，compare子程序弹出2个栈元素。

实际应用场景：程序中的操作名称存储于哈希表中，不同操作所需的参数数量不同，希望能根据哈希中的操作码调用对应函数，同时满足以下要求：

1. 不希望在子程序内部操作栈
2. 希望用单行代码调用每个子程序（尽量少用条件语句），例如$opcodes{$op}->(pop(@stack),pop(@stack),$n);
   部分子程序仅需要1个栈元素，部分需要2个，还有的需要额外的整数参数。

附上原始Perl脚本：

#!/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,
    '/'    => \&divide,
    '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);
} 

解决方案 #

直接传递pop(@stack)会导致参数在调用前就被弹出，无法实现“按需弹出”。我们可以通过绑定操作的栈参数数量，统一处理弹出逻辑，再将参数传给子程序，完美满足需求：

1. 重构操作码哈希 #

将%opcodes改为存储哈希引用，包含子程序和所需栈参数数量：

my %opcodes = (
    '+'    => { code => \&add, stack_args => 2 },
    '-'    => { code => \&subtract, stack_args => 2 },
    '*'    => { code => \&multi, stack_args => 2 },
    '/'    => { code => \&divide, stack_args => 2 },
    'neg'  => { code => \&negate, stack_args => 1 },
    'conj' => { code => \&conjugate, stack_args => 1 },
    'abs'  => { code => \&absolute, stack_args => 1 },
    'sqrt' => { code => \&squarert, stack_args => 1 },
    'drop' => { code => \&drop, stack_args => 1 },
    'dup'  => { code => \&dup, stack_args => 1 },
    'swap' => { code => \&swap, stack_args => 2 },
    'rot'  => { code => \&rot, stack_args => 0 }, # rot无需栈参数，用额外传入的$n