Fix fcase() segfault (#6452)

NEWS.md

@@ -10,6 +10,8 @@
 
 1. Using `print.data.table()` with character truncation using `datatable.prettyprint.char` no longer errors with `NA` entries, [#6441](https://github.com/Rdatatable/data.table/issues/6441). Thanks to @r2evans for the bug report, and @joshhwuu for the fix.
 
+2. Fixed a segfault in `fcase()`, [#6448](https://github.com/Rdatatable/data.table/issues/6448). Thanks @ethanbsmith for reporting with reprex, @aitap for finding the root cause, and @MichaelChirico for the PR.
+
 ## NOTES
 
 1. Tests run again when some Suggests packages are missing, [#6411](https://github.com/Rdatatable/data.table/issues/6411). Thanks @aadler for the note and @MichaelChirico for the fix.

inst/tests/tests.Rraw

@@ -19059,3 +19059,14 @@ test(2280.1, internal_error("broken"), error="Internal error.*broken")
 test(2280.2, internal_error("broken %d%s", 1, "2"), error="Internal error.*broken 12")
 foo = function(...) internal_error("broken")
 test(2280.3, foo(), error="Internal error in foo: broken")
+
+# ensure proper PROTECT() within fcase, #6448
+x <- 1:3
+test(2281,
+     fcase(
+       x<2, structure(list(1), class = "foo"),
+       x<3, structure(list(2), class = "foo"),
+       # Force gc() and some allocations which have a good chance at landing in the region that was earlier left unprotected
+       { gc(full = TRUE); replicate(10, FALSE); x<4 },
+       `attr<-`(list(3), "class", "foo")),
+     structure(list(1, 2, 3), class = "foo"))

src/fifelse.c

@@ -210,13 +210,15 @@ SEXP fcaseR(SEXP rho, SEXP args) {
   }
   int nprotect=0, l;
   int64_t n_ans=0, n_this_arg=0, n_undecided=0;
-  SEXP ans=R_NilValue, value0=R_NilValue, tracker=R_NilValue, whens=R_NilValue, thens=R_NilValue;
+  SEXP ans=R_NilValue, tracker=R_NilValue, whens=R_NilValue, thens=R_NilValue;
+  SEXP ans_class, ans_levels;
   PROTECT_INDEX Iwhens, Ithens;
   PROTECT_WITH_INDEX(whens, &Iwhens); nprotect++;
   PROTECT_WITH_INDEX(thens, &Ithens); nprotect++;
   SEXPTYPE ans_type=NILSXP;
   // naout means if the output is scalar logic na
   bool imask = true, naout = false, idefault = false;
+  bool ans_is_factor;
   int *restrict p = NULL;
   const int n = narg/2;
   for (int i=0; i<n; ++i) {
@@ -235,7 +237,11 @@ SEXP fcaseR(SEXP rho, SEXP args) {
       n_ans = xlength(whens);
       n_undecided = n_ans;
       ans_type = TYPEOF(thens);
-      value0 = thens;
+      ans_class = PROTECT(getAttrib(thens, R_ClassSymbol)); nprotect++;
+      ans_is_factor = isFactor(thens);
+      if (ans_is_factor) {
+        ans_levels = PROTECT(getAttrib(thens, R_LevelsSymbol)); nprotect++;
+      }
       ans = PROTECT(allocVector(ans_type, n_ans)); nprotect++;
       copyMostAttrib(thens, ans);
       tracker = PROTECT(allocVector(INTSXP, n_ans)); nprotect++;
@@ -260,7 +266,7 @@ SEXP fcaseR(SEXP rho, SEXP args) {
         }
       }
       if (!naout) {
-        if (!R_compute_identical(PROTECT(getAttrib(value0, R_ClassSymbol)),  PROTECT(getAttrib(thens, R_ClassSymbol)), 0)) {
+        if (!R_compute_identical(ans_class,  PROTECT(getAttrib(thens, R_ClassSymbol)), 0)) {
           if (idefault) {
             error(_("Resulting value has different class than 'default'. "
                     "Please make sure that both arguments have the same class."));
@@ -269,17 +275,17 @@ SEXP fcaseR(SEXP rho, SEXP args) {
                     "Please make sure all output values have the same class."), i*2+2);
           }
         }
-        UNPROTECT(2); // class(value0), class(thens)
+        UNPROTECT(1); // class(thens)
       }
-      if (!naout && isFactor(value0)) {
-        if (!R_compute_identical(PROTECT(getAttrib(value0, R_LevelsSymbol)),  PROTECT(getAttrib(thens, R_LevelsSymbol)), 0)) {
+      if (!naout && ans_is_factor) {
+        if (!R_compute_identical(ans_levels,  PROTECT(getAttrib(thens, R_LevelsSymbol)), 0)) {
           if (idefault) {
             error(_("Resulting value and 'default' are both type factor but their levels are different."));
           } else {
             error(_("Argument #2 and argument #%d are both factor but their levels are different."), i*2+2);
           }
         }
-        UNPROTECT(2); // levels(value0), levels(thens)
+        UNPROTECT(1); // levels(thens)
       }
     }
     n_this_arg = xlength(thens);