rewrite of eapply without memory allocation for return values (for calling functions just for side effects)

eapply.c

/* ################################################################################
 * BEGIN UTILITY FUNCTIONS
################################################################################ */

#define NONEMPTY_(_FRAME_) \
    CHAR(PRINTNAME(TAG(_FRAME_)))[0] != '.' && CAR(_FRAME_) != R_UnboundValue

static int FrameSize(SEXP frame, int all)
{
    int count = 0;
    if (all) {
	while (frame != R_NilValue) {
	    count += 1;
	    frame = CDR(frame);
	}
    } else {
	while (frame != R_NilValue) {
	    if (NONEMPTY_(frame))
		count += 1;
	    frame = CDR(frame);
	}
    }
    return count;
}


#define CHECK_HASH_TABLE(table) do {		\
	if (TYPEOF(table) != VECSXP)		\
	    error("bad hash table contents");	\
    } while (0)

static int HashTableSize(SEXP table, int all)
{
    CHECK_HASH_TABLE(table);
    int count = 0;
    int n = length(table);
    int i;
    for (i = 0; i < n; i++)
	count += FrameSize(VECTOR_ELT(table, i), all);
    return count;
}

static void FrameValues(SEXP frame, int all, SEXP values, int *indx)
{
    if (all) {
	while (frame != R_NilValue) {
#         define DO_FrameValues						\
	    SEXP value = CAR(frame);					\
	    if (TYPEOF(value) == PROMSXP) {				\
		PROTECT(value);						\
		value = eval(value, R_GlobalEnv);			\
		UNPROTECT(1);						\
	    }								\
	    SET_VECTOR_ELT(values, *indx, lazy_duplicate(value));	\
	    (*indx)++

	    DO_FrameValues;
	    frame = CDR(frame);
	}
    } else {
	while (frame != R_NilValue) {
	    if (NONEMPTY_(frame)) {
		DO_FrameValues;
	    }
	    frame = CDR(frame);
	}
    }
}
#undef DO_FrameValues

static void HashTableValues(SEXP table, int all, SEXP values, int *indx)
{
    CHECK_HASH_TABLE(table);
    int n = length(table);
    int i;
    for (i = 0; i < n; i++)
	FrameValues(VECTOR_ELT(table, i), all, values, indx);
}

/* ################################################################################
 * END UTILITY FUNCTIONS
################################################################################ */


/* ################################################################################
 * call: a language object generated by match.call(expand.dots = FALSE)
 * rho: the environment in which the call was executed
################################################################################ */

SEXP hash_apply(SEXP call, SEXP rho){

  /* advance to 2nd element (CAR) of call pairlist; 1st element is just the eapply3 function */
  SEXP args = CDR(call);

  /* get environment (2nd element) and advance to 3rd element */
  SEXP envSymbol = install("X");
  args = CDR(args);

  /* get function (3rd element) and advance to 4th element */
  SEXP funSymbol = install("FUN");
  args = CDR(args);

  /* env is the hash table */
  SEXP env = PROTECT(eval(envSymbol,rho));
  int n = HashTableSize(HASHTAB(env), 0);

  /* get the values out of the hash table as vector/list: vals */
  SEXP vals;
  PROTECT(vals = allocVector(VECSXP,n));
  int ix = 0;
  HashTableValues(HASHTAB(env), 0, vals, &ix);

  /* make the bit of the function call that indexes over the values in the hash table */
  SEXP tmp;
  PROTECT(tmp = LCONS(R_Bracket2Symbol, LCONS(envSymbol, R_NilValue)));

  /* make the f(X[[i]],...) bit of the function call (tmp is the indexing) */
  SEXP R_fcall;
  PROTECT(R_fcall = LCONS(funSymbol, LCONS(tmp , LCONS(R_DotsSymbol,R_NilValue))));

  /* map the function(...) over the hash table */
  for(int j=0; j<n; j++){
    printf("j: %i\n",j);
    SETCADR(R_fcall, VECTOR_ELT(vals, j));
    R_forceAndCall(R_fcall, 1, rho);
  };

  UNPROTECT(4);
  return R_NilValue;
}