Refactor method-dispatch.c (RConsortium#483)

* Refactor `method-dispatch.c`

* (try to) run rchk in CI

* refactor `method_call_`

* rewrite rchk action

* remove unused `is_missing()` C function.

* print rchk.log in CI

* pass generic dispatch args as named arg to methods

* use `APPEND_NODE` helper

* use `CALLDEF` macro

* remove `PRCODE` and `SET_PRVALUE` usage

* add `class_missing` dispatch tests

* copyedit comment

* avoid unnecessary allocation

* fix/enable commented test case

* add tests

* minor edits

* swap arg order in `APPEND_NODE()` helper

* convert `expect_error()` test to `expect_snapshot()`

* add snapshot varient for R version < 4.3

Author: t-kalinowski

.github/workflows/rchk.yml

@@ -0,0 +1,38 @@
+name: rchk
+
+on:
+  workflow_dispatch:
+
+
+jobs:
+  rchk:
+    runs-on: ubuntu-latest
+    steps:
+
+    - uses: actions/checkout@v4
+
+    - uses: r-lib/actions/setup-pandoc@v2
+    - uses: r-lib/actions/setup-r@v2
+    - uses: r-lib/actions/setup-r-dependencies@v2
+
+    - run: R CMD build .
+
+    - run: docker pull kalibera/rchk:latest
+
+    - name: run rchk
+      run: |
+          pkgtar=$(ls S7_*.tar.gz)
+          mkdir -p rchk/packages
+          mv $pkgtar rchk/packages/
+          cd rchk
+          docker run -v `pwd`/packages:/rchk/packages kalibera/rchk:latest /rchk/packages/$pkgtar > rchk.log 2>&1
+          cat rchk.log
+
+    - run: cat rchk.log
+      working-directory: rchk
+
+    - name: upload rchk log
+      uses: actions/upload-artifact@v4
+      with:
+        name: rchk-log
+        path: rchk/rchk.log

R/method-dispatch.R

@@ -20,6 +20,5 @@ method_lookup_error_message <- function(name, types) {
 #' @order 2
 #' @export
 S7_dispatch <- function() {
-  S7_dispatched_call <- .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1))
-  eval(S7_dispatched_call, envir = sys.frame(-1))
+  .External2(method_call_, sys.function(-1L), sys.frame(-1L))
 }

src/init.c

@@ -5,18 +5,25 @@
 
 /* .Call calls */
 extern SEXP method_(SEXP, SEXP, SEXP, SEXP);
-extern SEXP method_call_(SEXP, SEXP, SEXP);
+extern SEXP method_call_(SEXP, SEXP, SEXP, SEXP);
+extern SEXP test_call_(SEXP, SEXP, SEXP, SEXP);
 extern SEXP S7_class_(SEXP, SEXP);
 extern SEXP S7_object_(void);
 extern SEXP prop_(SEXP, SEXP);
 extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP);
 
+#define CALLDEF(name, n)  {#name, (DL_FUNC) &name, n}
+
 static const R_CallMethodDef CallEntries[] = {
-    {"method_", (DL_FUNC) &method_, 4},
-    {"method_call_", (DL_FUNC) &method_call_, 3},
-    {"S7_object_", (DL_FUNC) &S7_object_, 0},
-    {"prop_", (DL_FUNC) &prop_, 2},
-    {"prop_set_", (DL_FUNC) &prop_set_, 4},
+    CALLDEF(method_, 4),
+    CALLDEF(S7_object_, 0),
+    CALLDEF(prop_, 2),
+    CALLDEF(prop_set_, 4),
+    {NULL, NULL, 0}
+};
+
+static const R_ExternalMethodDef ExternalEntries[] = {
+    CALLDEF(method_call_, 2),
     {NULL, NULL, 0}
 };
 
@@ -35,19 +42,25 @@ SEXP sym_getter;
 SEXP sym_dot_should_validate;
 SEXP sym_dot_getting_prop;
 SEXP sym_dot_setting_prop;
+SEXP sym_obj_dispatch;
+SEXP sym_dispatch_args;
+SEXP sym_methods;
 
 SEXP fn_base_quote;
+SEXP fn_base_missing;
 
 SEXP ns_S7;
 
+SEXP R_TRUE, R_FALSE;
+
 
 void R_init_S7(DllInfo *dll)
 {
-    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
+    R_registerRoutines(dll, NULL, CallEntries, NULL, ExternalEntries);
     R_useDynamicSymbols(dll, FALSE);
+
     sym_ANY = Rf_install("ANY");
     sym_S7_class = Rf_install("S7_class");
-
     sym_name = Rf_install("name");
     sym_parent = Rf_install("parent");
     sym_package = Rf_install("package");
@@ -59,8 +72,14 @@ void R_init_S7(DllInfo *dll)
     sym_dot_should_validate = Rf_install(".should_validate");
     sym_dot_getting_prop = Rf_install(".getting_prop");
     sym_dot_setting_prop = Rf_install(".setting_prop");
+    sym_obj_dispatch = Rf_install("obj_dispatch");
+    sym_dispatch_args = Rf_install("dispatch_args");
+    sym_methods = Rf_install("methods");
 
     fn_base_quote = Rf_eval(Rf_install("quote"), R_BaseEnv);
+    fn_base_missing = Rf_eval(Rf_install("missing"), R_BaseEnv);
 
-    ns_S7 = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7"));
+    ns_S7 = Rf_eval(Rf_install("S7"), R_NamespaceRegistry);
+    R_PreserveObject(R_TRUE = Rf_ScalarLogical(1));
+    R_PreserveObject(R_FALSE = Rf_ScalarLogical(0));
 }