From 8c249e7aa60489b353658c934b0668a045d7fa0c Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 24 May 2023 00:00:42 -0700
Subject: lib: fix issue uncovered by recent vm CALL insn change.

The functions funcall1 through funcall4, when invoking a VM
function, are not defending against the case when there
are more arguments than the function can take.

As a result, some :mass-delegate tests in tests/012/oop.tl
are failing. They expect an :error result, but the calls
are succeeding in spite of passing too many parameters
via the delegate interface.

The tests/012/lambda.tl suite should catch this, but
it has unfortunate weaknesses.

* lib.c (funcall1, funcall2, funcall3, funcall4):
When dispatching the general VM case via
vm_execute_closure, check that if the closure has
fewer fixed parameters than arguments we are passing,
it must be variadic, or else there is an error.

* tests/012/lambda.tl (call-lambda-fixed): New function.
Unlike call-lambda, which uses the apply dot syntax,
this switches on the argument list shape and dispatches
direct calls. These compile to the CALL instruction
cases with four arguments or less which will exercise
funcall, funcall1, ... funcall4. Also, adding some missing
test cases that probe behavior with excess arguments.
---
 lib.c               | 18 +++++++++++++-----
 tests/012/lambda.tl | 27 +++++++++++++++++++++++++--
 2 files changed, 38 insertions(+), 7 deletions(-)

diff --git a/lib.c b/lib.c
index d8293a23..11581b33 100644
--- a/lib.c
+++ b/lib.c
@@ -8525,7 +8525,9 @@ val funcall1(val fun, val arg)
     case 4:
       return vm_funcall4(fun, z(arg), colon_k, colon_k, colon_k);
     default:
-      {
+      if (!fun->f.variadic && fun->f.fixparam == 0) {
+        wrongargs(fun);
+      } else {
         args_decl_constsize(args, ARGS_MIN);
         args_add(args, arg);
         return vm_execute_closure(fun, args);
@@ -8604,7 +8606,9 @@ val funcall2(val fun, val arg1, val arg2)
     case 4:
       return vm_funcall4(fun, z(arg1), z(arg2), colon_k, colon_k);
     default:
-      {
+      if (!fun->f.variadic && fun->f.fixparam < 2) {
+        wrongargs(fun);
+      } else {
         args_decl_constsize(args, ARGS_MIN);
         args_add2(args, arg1, arg2);
         return vm_execute_closure(fun, args);
@@ -8685,7 +8689,9 @@ val funcall3(val fun, val arg1, val arg2, val arg3)
     case 4:
       return vm_funcall4(fun, z(arg1), z(arg2), z(arg3), colon_k);
     default:
-      {
+      if (!fun->f.variadic && fun->f.fixparam < 3) {
+        wrongargs(fun);
+      } else {
         args_decl_constsize(args, ARGS_MIN);
         args_add3(args, arg1, arg2, arg3);
         return vm_execute_closure(fun, args);
@@ -8761,12 +8767,14 @@ val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
     wrongargs(fun);
 
   if (fun->f.functype == FVM) {
-    if (fun->f.fixparam == 4)
+    if (fun->f.fixparam == 4) {
       return vm_funcall4(fun, z(arg1), z(arg2), z(arg3), z(arg4));
-    else {
+    } else if (fun->f.variadic || fun->f.fixparam > 4) {
       args_decl(args, ARGS_MIN);
       args_add4(args, arg1, arg2, arg3, arg4);
       return vm_execute_closure(fun, args);
+    } else {
+      wrongargs(fun);
     }
   }
 
diff --git a/tests/012/lambda.tl b/tests/012/lambda.tl
index ec3b2cae..811dbcfc 100644
--- a/tests/012/lambda.tl
+++ b/tests/012/lambda.tl
@@ -3,12 +3,28 @@
 (defun call-lambda (fn . args)
   [fn . args])
 
+(defun call-lambda-fixed (fn . args)
+  (tree-case args
+    (() [fn])
+    ((a1) [fn a1])
+    ((a1 a2) [fn a1 a2])
+    ((a1 a2 a3) [fn a1 a2 a3])
+    ((a1 a2 a3 a4) [fn a1 a2 a3 a4])
+    ((a1 a2 a3 a4 a5) [fn a1 a2 a3 a4 a5])
+    ((a1 . r) [fn a1 . r])
+    ((a1 a2 . r) [fn a1 a2 . r])
+    ((a1 a2 a3 . r) [fn a1 a2 a3 . r])
+    ((a1 a2 a3 a4 . r) [fn a1 a2 a3 a4 . r])
+    ((a1 a2 a3 a4 a5 . r) [fn a1 a2 a3 a4 a5 . r])
+    (r [fn . r])))
+
 (defmacro ltest (:match :form f)
   (([(lambda . @rest) . @args] @expected)
    (if *compile-test*
      ^(progn
         (test [(lambda ,*rest) ,*args] ,expected)
-        (test (call-lambda (lambda ,*rest) ,*args) ,expected))
+        (test (call-lambda (lambda ,*rest) ,*args) ,expected)
+        (test (call-lambda-fixed (lambda ,*rest) ,*args) ,expected))
      ^(test [(lambda ,*rest) ,*args] ,expected)))
   ((@else . rest) (compile-error f "bad syntax")))
 
@@ -17,17 +33,22 @@
 
 (mltest
   [(lambda ())] nil
+  [(lambda ()) 1] :error
   [(lambda (a) a)] :error
   [(lambda (a) a) 1] 1
+  [(lambda (a) a) 1 2] :error
   [(lambda (a b) (list a b)) 1] :error
   [(lambda (a b) (list a b)) 1 2] (1 2)
+  [(lambda (a b) (list a b)) 1 2 3] :error
   [(lambda (a b c) (list a b c)) 1 2] :error
-  [(lambda (a b c) (list a b c)) 1 2 3] (1 2 3))
+  [(lambda (a b c) (list a b c)) 1 2 3] (1 2 3)
+  [(lambda (a b c) (list a b c)) 1 2 3 4] :error)
 
 (mltest
   [(lambda (: a) a)] nil
   [(lambda (: (a 1)) a)] 1
   [(lambda (: (a 1)) a) 2] 2
+  [(lambda (: (a 1)) a) 2 3] :error
   [(lambda (: (a 1 a-p)) (list a a-p))] (1 nil)
   [(lambda (: (a 1 a-p)) (list a a-p)) 2] (2 t))
 
@@ -35,6 +56,8 @@
   [(lambda (x : a) (list x a))] :error
   [(lambda (x : (a 1)) (list x a))] :error
   [(lambda (x : (a 1)) (list x a)) 2] (2 1)
+  [(lambda (x : (a 1)) (list x a)) 2 3] (2 3)
+  [(lambda (x : (a 1)) (list x a)) 2 3 4] :error
   [(lambda (x : (a 1 a-p)) (list x a a-p))] :error
   [(lambda (x : (a 1 a-p)) (list x a a-p)) 2] (2 1 nil))
 
-- 
cgit v1.2.3