HRESULT
R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *ids, int numNamedArgs, int *namedArgPositions)
{
HRESULT hr;
int numArgs = Rf_length(args), i, ctr;
if(numArgs == 0)
return(S_OK);
#ifdef RDCOM_VERBOSE
errorLog("Converting arguments (# %d, # %d named)\n", numArgs, numNamedArgs);
#endif
parms->rgvarg = (VARIANT *) S_alloc(numArgs, sizeof(VARIANT));
parms->cArgs = numArgs;
/* If there are named arguments, then put these at the beginning of the
rgvarg*/
if(numNamedArgs > 0) {
int namedArgCtr = 0;
VARIANT *var;
SEXP el;
SEXP names = GET_NAMES(args);
parms->rgdispidNamedArgs = (DISPID *) S_alloc(numNamedArgs, sizeof(DISPID));
parms->cNamedArgs = numNamedArgs;
for(i = 0, ctr = numArgs-1; i < numArgs ; i++) {
if(strcmp(CHAR(STRING_ELT(names, i)), "") != 0) {
var = &(parms->rgvarg[namedArgCtr]);
parms->rgdispidNamedArgs[namedArgCtr] = ids[namedArgCtr + 1];
#ifdef RDCOM_VERBOSE
errorLog("Putting named argument %d into %d\n", i+1, namedArgCtr);
Rf_PrintValue(VECTOR_ELT(args, i));
#endif
namedArgCtr++;
} else {
var = &(parms->rgvarg[ctr]);
ctr--;
}
el = VECTOR_ELT(args, i);
VariantInit(var);
hr = R_convertRObjectToDCOM(el, var);
}
} else {
parms->cNamedArgs = 0;
parms->rgdispidNamedArgs = NULL;
for(i = 0, ctr = numArgs-1; i < numArgs; i++, ctr--) {
SEXP el = VECTOR_ELT(args, i);
VariantInit(&parms->rgvarg[ctr]);
hr = R_convertRObjectToDCOM(el, &(parms->rgvarg[ctr]));
}
}
return(S_OK);
}
SEXP
R_setVariant(SEXP svar, SEXP value, SEXP type)
{
VARIANT *var;
var = (VARIANT *)R_ExternalPtrAddr(GET_SLOT(svar, Rf_install("ref")));
if(!var) {
PROBLEM "Null VARIANT value passed to R_setVariant. Was this saved in another session\n"
ERROR;
}
HRESULT hr;
hr = R_convertRObjectToDCOM(value, var);
SEXP ans;
ans = NEW_LOGICAL(1);
LOGICAL_DATA(ans)[0] = hr == S_OK ? TRUE : FALSE;
return(ans);
}
SAFEARRAY*
createRDCOMArray(SEXP obj, VARIANT *var)
{
VARTYPE type;
unsigned int cDims = 1, len;
SAFEARRAYBOUND bounds[1];
SAFEARRAY *arr;
void *data;
len = Rf_length(obj);
bounds[0].lLbound = 0;
bounds[0].cElements = len;
type = getDCOMType(obj);
arr = SafeArrayCreate(type, cDims, bounds);
HRESULT hr = SafeArrayAccessData(arr, (void**) &data);
if(hr != S_OK) {
//std::cerr <<"Problems accessing data" << std::endl;
REprintf("Problems accessing data\n");
SafeArrayDestroy(arr);
return(NULL);
}
switch(TYPEOF(obj)) {
case REALSXP:
memcpy(data, REAL(obj), sizeof(double) * len);
break;
case INTSXP:
memcpy(data, INTEGER(obj), sizeof(LOGICAL(obj)[0]) * len);
break;
case LGLSXP:
for(unsigned int i = 0 ; i < len ; i++)
((bool *) data)[i] = LOGICAL(obj)[i];
break;
case STRSXP:
for(unsigned int i = 0 ; i < len ; i++)
((BSTR *) data)[i] = AsBstr(getRString(obj, i));
break;
case VECSXP:
for(unsigned int i = 0 ; i < len ; i++) {
VARIANT *v = &(((VARIANT *) data)[i]);
VariantInit(v);
R_convertRObjectToDCOM(VECTOR_ELT(obj, i), v);
}
break;
default:
//std::cerr <<"Array case not handled yet for R type " << TYPEOF(obj) << std::endl;
REprintf("Array case not handled yet for R type %d\n", TYPEOF(obj));
break;
}
SafeArrayUnaccessData(arr);
if(var) {
V_VT(var) = VT_ARRAY | type;
V_ARRAY(var) = arr;
}
return(arr);
}
