check module and internal function arity before invoking

ChangeLog

@@ -1,3 +1,23 @@
+2026-10-29  Kevin Ushey <kevinushey@gmail.com>
+
+	* src/module.cpp (InternalFunction_invoke): Raise an error when fewer
+	arguments are supplied than the arity stored in the function pointer's
+	tag, instead of reading the missing ones from uninitialized memory
+	(#1521)
+	* inst/include/Rcpp/module/Module.h (Module::get_function): Store the
+	arity of module functions in the pointer tag
+	* inst/include/Rcpp/InternalFunction.h: Idem for InternalFunction
+	* inst/tinytest/cpp/Module.cpp: Add module functions with formals
+	* inst/tinytest/test_module.R: Test calls with too few arguments
+	* inst/tinytest/test_internal_function.R: Idem
+	* inst/tinytest/test_internal_function_cpp11.R: Idem
+
+	* R/00_classes.R (.cppfunction_formals_gets): Find the .External() call
+	in the body of the function instead of assuming it is the second
+	element, which it is not once coverage tools have instrumented the body
+	* R/00_classes.R (.cppfunction_set_external_args): New helper
+	* inst/tinytest/test_module.R: Test it with an instrumented body
+
 2026-10-23  Dirk Eddelbuettel  <edd@debian.org>
 
 	* DESCRIPTION (Version, Date): Roll micro version and date

R/00_classes.R

@@ -117,13 +117,23 @@ setClass( "C++Function",
 	contains = "function"
 )
 
-.cppfunction_formals_gets <- function (fun, envir = environment(fun), value) {
-    bd <- body(fun)
-    b2 <- bd[[2L]]
-    for( i in seq_along(value) ){
-        b2[[3L+i]] <- as.name( names(value)[i] )
+## passes the arguments named in 'names' on from the .External(entry,
+## pointer, ...) call in expr; the call is searched for rather than assumed
+## to be a top-level statement, as coverage tools wrap each statement
+.cppfunction_set_external_args <- function( expr, names ){
+    if( !is.call( expr ) )
+        return( expr )
+    if( identical( expr[[1L]], as.name( ".External" ) ) )
+        return( as.call( c( as.list( expr )[1:3], lapply( names, as.name ) ) ) )
+    for( i in seq_along( expr )[-1L] ){
+        if( is.call( expr[[i]] ) )
+            expr[[i]] <- .cppfunction_set_external_args( expr[[i]], names )
     }
-    bd[[2]] <- b2
+    expr
+}
+
+.cppfunction_formals_gets <- function (fun, envir = environment(fun), value) {
+    bd <- .cppfunction_set_external_args( body(fun), names(value) )
     f <- fun@.Data
     formals(f) <- value
     body(f) <- bd

inst/include/Rcpp/InternalFunction.h

@@ -35,18 +35,24 @@ namespace Rcpp{
 
         RCPP_GENERATE_CTOR_ASSIGN(InternalFunction_Impl)
 
+        // the arity goes in the pointer tag, where InternalFunction_invoke
+        // checks it against the number of supplied arguments
+
         template <typename RESULT_TYPE, typename... Args>
         InternalFunction_Impl(const std::function<RESULT_TYPE(Args...)> &fun) {
+            Shield<SEXP> arity(Rf_ScalarInteger(static_cast<int>(sizeof...(Args))));
             set(
                 XPtr<Rcpp::InternalFunctionWithStdFunction::CppFunctionBaseFromStdFunction<RESULT_TYPE, Args...> >(
                     new Rcpp::InternalFunctionWithStdFunction::CppFunctionBaseFromStdFunction<RESULT_TYPE, Args...>(fun),
-                    false
+                    false,
+                    arity
                     )
                 );
         }
         template <typename RESULT_TYPE, typename... T>
         InternalFunction_Impl(RESULT_TYPE (*fun)(T...)) {
-            set(XPtr<CppFunctionN<RESULT_TYPE, T...> >(new CppFunctionN<RESULT_TYPE, T...>(fun), true));
+            Shield<SEXP> arity(Rf_ScalarInteger(static_cast<int>(sizeof...(T))));
+            set(XPtr<CppFunctionN<RESULT_TYPE, T...> >(new CppFunctionN<RESULT_TYPE, T...>(fun), true, arity));
         }
 
         void update(SEXP){}

inst/include/Rcpp/module/Module.h

@@ -164,8 +164,12 @@ namespace Rcpp {
             }
             std::string sign ;
             fun->signature( sign, name_.data() ) ;
+
+            // checked against the number of supplied arguments by InternalFunction_invoke
+            Shield<SEXP> arity( Rf_ScalarInteger( fun->nargs() ) ) ;
+
             return List::create(
-                XPtr<CppFunction>( fun, false ),
+                XPtr<CppFunction>( fun, false, arity ),
                 fun->is_void(),
                 fun->docstring,
                 sign,

inst/tinytest/cpp/Module.cpp

@@ -166,6 +166,10 @@ RCPP_MODULE(demoModule) {
     function("bla1" , &bla1 );
     function("bla2" , &bla2 );
 
+    // formals with defaults, and formals shorter than the parameter list
+    function("foo_formals", &foo, List::create(_["x"] = 2, _["y"] = 10.0));
+    function("foo_short_formals", &foo, List::create(_["x"] = 2));
+
     function("test_reference", test_reference);
     function("test_const_reference", test_const_reference);
     function("test_const", test_const);

inst/tinytest/test_internal_function.R

@@ -24,6 +24,10 @@ Rcpp::sourceCpp("cpp/InternalFunction.cpp")
 fun <- getAdd()
 expect_equal( fun(10,32), 42 )
 
+## too few arguments raise an error rather than reading the missing ones
+## from uninitialized memory (#1521)
+expect_error( fun(10), "expecting 2, got 1" )
+
 #    test.internal_function_concatenate <- function(){
 fun <- getConcatenate()
 expect_equal( fun("Hello"," World"), "Hello World" )

inst/tinytest/test_internal_function_cpp11.R

@@ -29,3 +29,7 @@ expect_equal( fun(38), 42 )
 #    test.internal_function_concatenate <- function(){
 fun <- getConcatenate()
 expect_equal( fun("Hello"," World"), "Hello World" )
+
+## too few arguments raise an error rather than reading the missing ones
+## from uninitialized memory (#1521)
+expect_error( fun("Hello"), "expecting 2, got 1" )

inst/tinytest/test_module.R

@@ -41,6 +41,21 @@ expect_true(is_void(bla@.Data))
 expect_true(is_void(bla1@.Data))
 expect_true(is_void(bla2@.Data))
 
+## module functions must be called with at least as many arguments as
+## the C++ function takes, rather than reading the missing ones from
+## uninitialized memory (#1521)
+expect_error( foo( 2L ), "expecting 2, got 1" )
+expect_error( bar(), "expecting 1, got 0" )
+expect_equal( foo_formals(), 20.0 )
+expect_equal( foo_formals( y = 3.0 ), 6.0 )
+expect_error( foo_short_formals(), "expecting 2, got 1" )
+
+## formals<- finds the .External() call wherever it is in the body, e.g.
+## inside the block that coverage tools (covr) wrap each statement in
+wrapped <- quote({ if (TRUE) { covr:::count("key"); .External(entry, pointer, ...) } })
+expect_equal( deparse( Rcpp:::.cppfunction_set_external_args( wrapped, c("x", "y") ) ),
+              deparse( quote({ if (TRUE) { covr:::count("key"); .External(entry, pointer, x, y) } }) ) )
+
 w <- new( ModuleWorld )
 expect_equal( w$greet(), "hello" )
 w$set( "hello world" )

src/module.cpp

@@ -119,6 +119,18 @@ BEGIN_RCPP
     SEXP p = CDR(args);
     XP_Function fun(CAR(p)); p = CDR(p);
     UNPACK_EXTERNAL_ARGS(cargs,p)
+
+    // Module::get_function() and InternalFunction store the arity in the
+    // tag; without this check, parameters beyond those supplied would be
+    // read from uninitialized slots of cargs
+    SEXP arity = R_ExternalPtrTag(fun);
+    if (TYPEOF(arity) == INTSXP && Rf_xlength(arity) == 1 && nargs < INTEGER(arity)[0])
+        Rcpp::stop(
+            "incorrect number of arguments: expecting %d, got %d",
+            INTEGER(arity)[0],
+            nargs
+        );
+
     return fun->operator()(cargs);
 END_RCPP
 }