handle subroutine reference special cases

fglock · Oct 22, 2024 · 0100f52 · 0100f52
1 parent 722d0f4
commit 0100f52
Show file tree

Hide file tree

Showing 2 changed files with 87 additions and 13 deletions.
diff --git a/src/main/java/org/perlonjava/parser/Parser.java b/src/main/java/org/perlonjava/parser/Parser.java
@@ -692,15 +692,7 @@ public Node parsePrimary() {
                     case "*":
                         return parseVariable(token.text);
                     case "&":
-                        parsingForLoopVariable = true;  // allow parentheses after variable: &$sub(...)
-                        Node node = parseVariable(token.text);
-                        parsingForLoopVariable = false;
-                        // Handle auto-call: transform `&subr` to `&subr(@_)`
-                        if (!TokenUtils.peek(this).text.equals("(") && !parsingTakeReference) {
-                            Node list = new OperatorNode("@", new IdentifierNode("_", tokenIndex), tokenIndex);
-                            return new BinaryOperatorNode("(", node, list, tokenIndex);
-                        }
-                        return node;
+                        return parseCoderefVariable(token);
                     case "!":
                     case "~":
                     case "+":
@@ -742,6 +734,49 @@ public Node parsePrimary() {
         throw new PerlCompilerException(tokenIndex, "Unexpected token: " + token, ctx.errorUtil);
     }
 
+    private Node parseCoderefVariable(LexerToken token) {
+        parsingForLoopVariable = true;  // allow parentheses after variable: &$sub(...)
+        Node node = parseVariable(token.text);
+        parsingForLoopVariable = false;
+        if (parsingTakeReference) {
+            // Parsing \&sub, don't add parameters
+            return node;
+        }
+        this.ctx.logDebug("parse & node: " + node);
+        if (node instanceof OperatorNode operatorNode) {
+            if (operatorNode.operand instanceof BinaryOperatorNode binaryOperatorNode) {
+                // Handle `&$subr(@_)`
+                if (binaryOperatorNode.operator.equals("(")) {
+                    return binaryOperatorNode;
+                }
+            }
+        }
+        Node list;
+        if (!TokenUtils.peek(this).text.equals("(")) {
+            // Handle auto-call: transform `&subr` to `&subr(@_)`
+            list = new OperatorNode("@", new IdentifierNode("_", tokenIndex), tokenIndex);
+        } else {
+            list = ListParser.parseZeroOrMoreList(this,
+                    0,
+                    false,
+                    true,
+                    false,
+                    false);
+        }
+        if (node instanceof OperatorNode operatorNode) {
+            // Handle &$sub(), &{$sub}()
+            if (operatorNode.operand instanceof OperatorNode) {
+                // &$sub becomes $sub(@_)
+                node = operatorNode.operand;
+            } else if (operatorNode.operand instanceof BlockNode blockNode) {
+                // &{$sub} becomes $sub(@_)
+                node = blockNode;
+            }
+        }
+        // Handle &sub()
+        return new BinaryOperatorNode("(", node, list, tokenIndex);
+    }
+
     /**
      * Parses a variable from the given lexer token.
      *

diff --git a/src/test/resources/subroutine.pl b/src/test/resources/subroutine.pl
@@ -1,5 +1,6 @@
 use v5.38.0;
 use Symbol;
+use strict;
 
 ############################
 #  Subroutines
@@ -30,7 +31,6 @@
 eval ' $result = B::A(123) ';
 print "not " if $result ne "<123>"; say "ok # named subroutine with Symbol returned '$result'";
 
-
 # named subroutine
 
 sub modify_argument { $_[0]++ }
@@ -47,8 +47,8 @@
 $v = CONST . "2";
 print "not " if $v ne "VALUE2"; say "ok # constant subroutine returned $v";
 
-$v = CONST => "2";
-print "not " if $v ne "CONST"; say "ok # constant subroutine returned $v";
+$v = CONST;
+print "not " if $v ne "VALUE"; say "ok # constant subroutine returned $v";
 
 package Other {
     sub CONST () { "OTHER" }
@@ -62,11 +62,50 @@ package Other {
 $v = no_proto . "2";
 print "not" if $v ne "VALUE2"; say "ok # subroutine without prototype returned $v";
 
-$v = no_proto or "2";
+$v = no_proto;
 print "not" if $v ne "VALUE"; say "ok # subroutine without prototype returned $v";
 
 # return from odd places
 
 sub return_odd { $_[0] ? (2, return 3, 4) : (5) }
 
 print "not" if return_odd(1) != 4; say "ok # return from inside list works";
+
+# Additional test cases for & subroutine sigil
+
+sub example { return "<@_>" }
+my $sub_ref = \&example;
+
+# Direct calls
+$result = &example(789);
+print "not " if $result ne "<789>"; say "ok # direct call with &example(789) returned '$result'";
+
+@_ = ("test", "values");  # Initialize @_ with values
+$result = &example;
+print "not " if $result ne "<test values>"; say "ok # direct call with &example reused @_ and returned '$result'";
+
+# Indirect calls using subroutine reference
+$result = $sub_ref->(101);
+print "not " if $result ne "<101>"; say "ok # indirect call with sub_ref->(101) returned '$result'";
+
+@_ = ("another", "test");
+$result = &$sub_ref;
+print "not " if $result ne "<another test>"; say "ok # indirect call with &$sub_ref reused @_ and returned '$result'";
+
+# Using block syntax
+$result = &{$sub_ref}(303);
+print "not " if $result ne "<303>"; say "ok # block syntax with &{$sub_ref}(303) returned '$result'";
+
+@_ = ("block", "syntax");
+$result = &{$sub_ref};
+print "not " if $result ne "<block syntax>"; say "ok # block syntax with &{$sub_ref} reused @_ and returned '$result'";
+
+# Reference to subroutine
+my $ref_to_sub = \&example;
+$result = &$ref_to_sub(404);
+print "not " if $result ne "<404>"; say "ok # reference to subroutine with &$ref_to_sub(404) returned '$result'";
+
+@_ = ("reference", "test");
+$result = &$ref_to_sub;
+print "not " if $result ne "<reference test>"; say "ok # reference to subroutine with &$ref_to_sub reused @_ and returned '$result'";
+