SEXP matrix_to_vector( SEXP x, int size ) {
SEXP out;
switch( TYPEOF(x) ) {
case INTSXP: {
PROTECT( out = allocVector(INTSXP, size) );
int* mat_ptr = INTEGER(x);
int* out_ptr = INTEGER(out);
for( int i=0; i < size; ++i ) {
out_ptr[i] = mat_ptr[i];
}
UNPROTECT(1);
return out;
}
case REALSXP: {
PROTECT( out = allocVector(REALSXP, size) );
double* mat_ptr = REAL(x);
double* out_ptr = REAL(out);
for( int i=0; i < size; ++i ) {
out_ptr[i] = mat_ptr[i];
}
UNPROTECT(1);
return out;
}
case LGLSXP: {
PROTECT( out = allocVector(LGLSXP, size) );
int* mat_ptr = LOGICAL(x);
int* out_ptr = LOGICAL(out);
for( int i=0; i < size; ++i ) {
out_ptr[i] = mat_ptr[i];
}
UNPROTECT(1);
return out;
}
case STRSXP: {
PROTECT( out = allocVector( STRSXP, size ) );
SEXP* mat_ptr = STRING_PTR(x);
SEXP* out_ptr = STRING_PTR(out);
for( int i=0; i < size; ++i ) {
out_ptr[i] = mat_ptr[i];
}
UNPROTECT(1);
return out;
}
default: {
return R_NilValue;
}
}
}
/* EncodeElement is called by cat(), write.table() and deparsing. */
const char *EncodeElement(SEXP x, int indx, int quote, char dec)
{
int w, d, e, wi, di, ei;
const char *res;
switch(TYPEOF(x)) {
case LGLSXP:
formatLogical(&LOGICAL(x)[indx], 1, &w);
res = EncodeLogical(LOGICAL(x)[indx], w);
break;
case INTSXP:
formatInteger(&INTEGER(x)[indx], 1, &w);
res = EncodeInteger(INTEGER(x)[indx], w);
break;
case REALSXP:
formatReal(&REAL(x)[indx], 1, &w, &d, &e, 0);
res = EncodeReal(REAL(x)[indx], w, d, e, dec);
break;
case STRSXP:
formatString(&STRING_PTR(x)[indx], 1, &w, quote);
res = EncodeString(STRING_ELT(x, indx), w, quote, Rprt_adj_left);
break;
case CPLXSXP:
formatComplex(&COMPLEX(x)[indx], 1, &w, &d, &e, &wi, &di, &ei, 0);
res = EncodeComplex(COMPLEX(x)[indx], w, d, e, wi, di, ei, dec);
break;
case RAWSXP:
res = EncodeRaw(RAW(x)[indx]);
break;
default:
res = NULL; /* -Wall */
UNIMPLEMENTED_TYPE("EncodeElement", x);
}
return res;
}
void printVector(SEXP x, int indx, int quote)
{
/* print R vector x[]; if(indx) print indices; if(quote) quote strings */
R_xlen_t n;
if ((n = XLENGTH(x)) != 0) {
R_xlen_t n_pr = (n <= R_print.max +1) ? n : R_print.max;
/* '...max +1' ==> will omit at least 2 ==> plural in msg below */
switch (TYPEOF(x)) {
case LGLSXP:
printLogicalVector(LOGICAL(x), n_pr, indx);
break;
case INTSXP:
printIntegerVector(INTEGER(x), n_pr, indx);
break;
case REALSXP:
printRealVector(REAL(x), n_pr, indx);
break;
case STRSXP:
if (quote)
printStringVector(STRING_PTR(x), n_pr, '"', indx);
else
printStringVector(STRING_PTR(x), n_pr, 0, indx);
break;
case CPLXSXP:
printComplexVector(COMPLEX(x), n_pr, indx);
break;
case RAWSXP:
printRawVector(RAW(x), n_pr, indx);
break;
}
if(n_pr < n)
Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
n - n_pr);
}
else
#define PRINT_V_0 \
switch (TYPEOF(x)) { \
case LGLSXP: Rprintf("logical(0)\n"); break; \
case INTSXP: Rprintf("integer(0)\n"); break; \
case REALSXP: Rprintf("numeric(0)\n"); break; \
case CPLXSXP: Rprintf("complex(0)\n"); break; \
case STRSXP: Rprintf("character(0)\n"); break; \
case RAWSXP: Rprintf("raw(0)\n"); break; \
}
PRINT_V_0;
}
SEXP rep_row_names( SEXP x, int times ) {
SEXP out;
int len = length(x);
int counter = 0;
PROTECT( out = allocVector( STRSXP, len*times ) );
SEXP* x_ptr = STRING_PTR(x);
SEXP* out_ptr = STRING_PTR(out);
for( int i=0; i < times; ++i ) {
for( int j=0; j < len; ++j ) {
out_ptr[counter] = x_ptr[j];
//SET_STRING_ELT( out, counter, STRING_ELT(x, j) );
++counter;
}
}
UNPROTECT(1);
return out;
}
SEXP rep_col_names( SEXP x, int each ) {
SEXP out;
int len = length(x);
PROTECT( out = allocVector( STRSXP, len*each ) );
int counter=0;
SEXP* ptr = STRING_PTR(x);
SEXP* out_ptr = STRING_PTR(out);
for( int i=0; i < len; ++i ) {
for( int j=0; j < each; j++ ) {
out_ptr[counter] = ptr[i];
//SET_STRING_ELT( out, counter, ptr[i] );
++counter;
}
}
UNPROTECT(1);
return out;
}
// a function that operates like R's 'rep(..., each=each)',
// but only works for characters
SEXP rep_each_char( SEXP x, SEXP id_ind_, int each ) {
SEXP out;
int* id_ind = INTEGER(id_ind_);
int len = length(id_ind_);
PROTECT( out = allocVector( STRSXP, len*each ) );
int counter=0;
SEXP* ptr = STRING_PTR(x);
SEXP* out_ptr = STRING_PTR(out);
for( int i=0; i < len; ++i ) {
for( int j=0; j < each; ++j ) {
out_ptr[counter] = ptr[ id_ind[i] ];
++counter;
}
}
UNPROTECT(1);
return out;
}
object_t *kernel_require(static_context_t *this_context, object_t *self, object_t *filename_obj)
{
object_t *filename_str = coerce_to_s(this_context, filename_obj);
char *filename = STRING_PTR(filename_str);
int i;
for (i = 0; i < ARRAY_LEN(load_path); i++) {
char *path = STRING_PTR(coerce_to_s(this_context, ARRAY_PTR(load_path)[i]));
char buf[strlen(path) + STRING_LEN(filename_str) + 10];
sprintf(buf, "%s/%s.rb", path, filename);
FILE *file = fopen(buf, "rb");
if (!file)
continue;
fclose(file);
/* we've found the file */
kernel_load(this_context, self, string_new_cstr(buf));
return Qnil;
}
raise(LoadError, "no such file to load -- %s", filename);
}
SEXP dbConnect(SEXP dbType_sexp,
SEXP connection_string_sexp,
SEXP user_sexp,
SEXP pass_sexp,
SEXP host_sexp,
SEXP port_sexp,
SEXP tty_sexp,
SEXP dbName_sexp,
SEXP options_sexp) {
SEXP dbi_conn_sexp;
DatabaseConnection* conn = NULL;
const char* dbType = CHAR(STRING_PTR(dbType_sexp)[0]);
const char* connection_string = (connection_string_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(connection_string_sexp)[0]);
const char* user = (user_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(user_sexp)[0]);
const char* pass = (pass_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(pass_sexp)[0]);
const char* host = (host_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(host_sexp)[0]);
const char* port = (port_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(port_sexp)[0]);
const char* tty = (tty_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(tty_sexp)[0]);
const char* dbName = (dbName_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(dbName_sexp)[0]);
const char* options = (options_sexp == R_NilValue) ? NULL : CHAR(STRING_PTR(options_sexp)[0]);
// this test is to check whether the package was compiled with support
// for this specific dbType
try {
conn = DatabaseConnection::init(dbType);
} catch (DriverNotSupported& e) {
REprintf("%s\n",e.what());
return R_NilValue;
}
// if we succeed then return a wrapped connection, otherwise return null
try {
// if user provides connection_string, then use it, otherwise try traditional args
if(connection_string) {
conn->connect(connection_string);
} else {
conn->connect(user,pass,host,port,tty,dbName,options);
}
} catch(BadDatabaseConnection& e) {
REprintf("%s\n",e.what());
return R_NilValue;
}
PROTECT(dbi_conn_sexp = R_MakeExternalPtr(reinterpret_cast<void*>(conn),install("DBI_conn_pointer"),R_NilValue));
R_RegisterCFinalizerEx(dbi_conn_sexp, connFinalizer, TRUE);
UNPROTECT(1);
return dbi_conn_sexp;
}
static void printStringMatrix(SEXP sx, int offset, int r_pr, int r, int c,
int quote, int right, SEXP rl, SEXP cl,
const char *rn, const char *cn)
{
_PRINT_INIT_rl_rn;
SEXP *x = STRING_PTR(sx)+offset;
for (j = 0; j < c; j++) {
formatString(&x[j * r], (R_xlen_t) r, &w[j], quote);
_PRINT_SET_clabw;
if (w[j] < clabw)
w[j] = clabw;
}
_PRINT_DEAL_c_eq_0;
while (jmin < c) {
width = rlabw;
do {
width += w[jmax] + R_print.gap;
jmax++;
}
while (jmax < c && width + w[jmax] + R_print.gap < R_print.width);
_PRINT_ROW_LAB;
if (right) {
for (j = jmin; j < jmax ; j++)
RightMatrixColumnLabel(cl, j, w[j]);
}
else {
for (j = jmin; j < jmax ; j++)
LeftMatrixColumnLabel(cl, j, w[j]);
}
for (i = 0; i < r_pr; i++) {
MatrixRowLabel(rl, i, rlabw, lbloff);
for (j = jmin; j < jmax; j++) {
Rprintf("%*s%s", R_print.gap, "",
EncodeString(x[i + j * r], w[j], quote, right));
}
}
Rprintf("\n");
jmin = jmax;
}
}
object_t *kernel_load(static_context_t *this_context, object_t *self, object_t *filename_obj)
{
object_t *filename_str = coerce_to_s(this_context, filename_obj);
char *filename = STRING_PTR(filename_str);
/* sanitized version of the filename to use for the symbol */
int len = strlen(filename);
char buf1[len + 10];
char *p = buf1 + 5, *q = filename;
strcpy(buf1, "Init_");
while (*q) {
if ((*q >= 'a' && *q <= 'z') ||
(*q >= 'A' && *q <= 'Z') ||
(*q >= '0' && *q <= '9') ||
*q == '_')
*p++ = *q++;
else {
*p++ = '_';
*q++;
}
}
*p++ = 0;
/* output filename */
char buf2[len + 10];
sprintf(buf2, "%s.so", filename);
/* we'll let the ruby compiler to do the job */
char buf3[len * 3 + 50];
sprintf(buf3, "ruby compiler.rb %s %s %s", filename, buf2, buf1);
if (system(buf3))
raise(ScriptError, "error compiling file - %s", filename);
/* everything's ok */
char abspath[PATH_MAX + 1];
realpath(buf2, abspath);
dlhandle_t *dl = dlopen(abspath, RTLD_NOW | RTLD_GLOBAL);
if (!dl)
raise(ScriptError, "error loading file - %s", dlerror());
object_t *(*entry_point)(static_context_t *this_context, object_t *self);
entry_point = dlsym(dl, buf1);
if (!entry_point)
raise(ScriptError, "error loading file - %s", dlerror());
(*entry_point)(this_context, g_main);
return Qnil;
}
SEXP dbSendQuery(SEXP dbi_conn_sexp, SEXP qry_sexp) {
if(TYPEOF(dbi_conn_sexp) != EXTPTRSXP || dbi_conn_sexp == R_NilValue) {
return R_NilValue;
}
SEXP dbi_query_results_sexp;
DatabaseConnection* conn = reinterpret_cast<DatabaseConnection*>(R_ExternalPtrAddr(dbi_conn_sexp));
if(!conn) {
// throw bad_connection_object
return R_NilValue;
}
const char* qry = CHAR(STRING_PTR(qry_sexp)[0]);
QueryResults* query_results = conn->sendQuery(qry);
//query_results->getStatus();
PROTECT(dbi_query_results_sexp = R_MakeExternalPtr(reinterpret_cast<void*>(query_results),install("DBI_results_pointer"),R_NilValue));
R_RegisterCFinalizerEx(dbi_query_results_sexp, queryResultsFinalizer, TRUE);
UNPROTECT(1);
return dbi_query_results_sexp;
}
// [[Rcpp::register]]
SEXP* get_string_ptr(SEXP x){
return STRING_PTR(x) ;
}
SEXP melt_dataframe( SEXP x, SEXP id_ind_, SEXP val_ind_, SEXP variable_name, SEXP value_name ) {
if (length(x) == 0) {
error("Can't melt a data.frame with 0 columns");
}
if (length(VECTOR_ELT(x, 0)) == 0) {
error("Can't melt a data.frame with 0 rows");
}
int* id_ind = INTEGER(id_ind_);
int* val_ind = INTEGER(val_ind_);
int nColStack = length(id_ind_);
int nColRep = length(val_ind_);
int nRow = length( VECTOR_ELT(x, 0) );
int out_nRow = nRow * nColRep;
int out_nCol = nColStack + 2;
char mt = max_type(x, val_ind_);
if (mt > STRSXP) {
error("Error: cannot melt data.frames w/ elements of type '%s'", CHAR(type2str(mt)));
}
if (diff_types(x, val_ind_)) {
warning("Coercing type of 'value' variables to '%s'", CHAR(type2str(mt)));
}
SEXP out;
PROTECT(out = allocVector( VECSXP, out_nCol ));
// populate the value array
SEXP value_SEXP;
#define HANDLE_CASE( RTYPE, CTYPE ) \
case RTYPE: { \
PROTECT( value_SEXP = allocVector( RTYPE, value_len ) ); \
SEXP tmp; \
for( int i=0; i < nColRep; ++i ) { \
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { \
tmp = PROTECT( coerceVector( VECTOR_ELT(x, val_ind[i]), mt ) ); \
} else { \
tmp = VECTOR_ELT(x, val_ind[i]); \
} \
memcpy( \
(char*) DATAPTR(value_SEXP) + (i*nRow*sizeof(CTYPE)), \
(char*) DATAPTR(tmp), \
nRow * sizeof(CTYPE) \
); \
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { \
UNPROTECT(1); \
} \
} \
break; \
} \
int value_len = nColRep * nRow;
int value_type = mt;
switch( value_type ) {
HANDLE_CASE( INTSXP, int );
HANDLE_CASE( REALSXP, double );
HANDLE_CASE( LGLSXP, int );
case STRSXP: {
int counter = 0;
SEXP* curr_str_vec_ptr;
SEXP tmp;
PROTECT( value_SEXP = allocVector( STRSXP, value_len ) );
for( int i=0; i < nColRep; ++i ) {
#define curr_str_vec (VECTOR_ELT(x, val_ind[i]))
if (TYPEOF(curr_str_vec) != STRSXP) {
if (isFactor(curr_str_vec)) {
PROTECT(tmp = asCharacterFactor(curr_str_vec));
} else {
PROTECT(tmp = coerceVector(curr_str_vec, STRSXP));
}
curr_str_vec_ptr = STRING_PTR(tmp);
} else {
curr_str_vec_ptr = STRING_PTR(curr_str_vec);
}
#undef curr_str_vec
SEXP* value_SEXP_ptr = STRING_PTR( value_SEXP );
for( int j=0; j < nRow; ++j ) {
value_SEXP_ptr[counter] = curr_str_vec_ptr[j];
++counter;
}
if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) {
UNPROTECT(1);
}
}
break;
}
default:
error("Unsupported RTYPE encountered");
}
#undef HANDLE_CASE
// generate the id variables, and assign them on generation
// we need to convert factors if necessary
for( int i=0; i < nColStack; ++i ) {
SET_VECTOR_ELT( out, i, stack_vector( VECTOR_ELT( x, id_ind[i] ), nColRep ));
if (isFactor( VECTOR_ELT(x, id_ind[i]) )) {
setAttrib( VECTOR_ELT(out, i), R_ClassSymbol, mkString("factor") );
setAttrib( VECTOR_ELT(out, i), R_LevelsSymbol, getAttrib( VECTOR_ELT(x, id_ind[i]), R_LevelsSymbol ) );
}
}
// assign the names, values
SET_VECTOR_ELT( out, nColStack, rep_each_char( getAttrib( x, R_NamesSymbol ), val_ind_, nRow ) );
SET_VECTOR_ELT( out, nColStack+1, value_SEXP );
UNPROTECT(1); // value_SEXP
// set the row names
SEXP row_names;
PROTECT( row_names = allocVector(INTSXP, out_nRow) );
int* row_names_ptr = INTEGER(row_names);
for( int i=0; i < out_nRow; ++i ) {
row_names_ptr[i] = i+1;
}
setAttrib( out, R_RowNamesSymbol, row_names );
UNPROTECT(1); // row_names
// set the class to data.frame
setAttrib(out, R_ClassSymbol, mkString("data.frame"));
// set the names
SEXP names = getAttrib(x, R_NamesSymbol);
SEXP names_out;
PROTECT(names_out = allocVector( STRSXP, out_nCol ));
SEXP* names_ptr = STRING_PTR(names);
SEXP* names_out_ptr = STRING_PTR(names_out);
for (int i=0; i < nColStack; ++i) {
names_out_ptr[i] = names_ptr[ id_ind[i] ];
}
SET_STRING_ELT( names_out, nColStack, STRING_ELT(variable_name, 0) );
SET_STRING_ELT( names_out, nColStack+1, STRING_ELT(value_name, 0) );
setAttrib( out, R_NamesSymbol, names_out );
UNPROTECT(1); // names_out
UNPROTECT(1); // out
return out;
}
object_t *kernel_eval(static_context_t *this_context, object_t *self, int argc, object_t **argv)
{
if (!this_context->parent)
return Qnil;
/* i could just make eval arity -2, and not handle this here. breaks with ruby though,
* where c functions neverr have neg arity < -1
*/
if (!argc)
raise(ArgumentError, "wrong number of arguments (0 for 1)");
char *code = STRING_PTR(coerce_to_s(this_context, argv[0]));
char filename[256];
static int eval_counter = 0;
char entry_point[256];
char so_file[256];
eval_counter++;
sprintf(filename, "temp_eval-%04d.rb", eval_counter);
sprintf(so_file, "temp_eval-%04d.rb.so", eval_counter);
sprintf(entry_point, "Init_temp_eval_%04d_rb", eval_counter);
context_t *context;
/* allow given binding to override */
if (argc > 1) {
/* TODO: TypeError: wrong argument type Fixnum (expected Proc/Binding) */
binding_t *binding = (binding_t *)argv[1];
/* a binding's context shouldn't need promoting */
context = binding->data.context;
// printf("context -> %p (%d)\n", context, context->locals.tally);
self = binding->data.self;
}
else
context = (context_t *)context_promote(this_context->parent->context);
this_context->context = context;
FILE *file = fopen(filename, "wb");
if (!file)
return Qnil;
fprintf(file, "* Context data\n");
while (context) {
int i;
for (i = 0; i < context->locals->tally; i++)
/* we push strings here, instead of symbols (1.8 style) */
fprintf(file, "%c - %s\n", i ? ' ' : '-', ((symbol_t *)context->locals->keys[i])->string);
context = context->parent;
}
fprintf(file, "* Code\n");
fprintf(file, "%s", code);
fclose(file);
/* we'll let the ruby compiler to do the job */
char buf3[1024];
sprintf(buf3, "ruby compiler.rb --eval %s %s %s", filename, so_file, entry_point);
if (system(buf3))
raise(ScriptError, "error compiling file - %s", filename);
char abspath[PATH_MAX + 1];
realpath(so_file, abspath);
dlhandle_t *dl = dlopen(abspath, RTLD_NOW | RTLD_GLOBAL);
if (!dl)
raise(ScriptError, "error loading file - %s", dlerror());
object_t *(*entry_point_ptr)(static_context_t *this_context, object_t *self);
entry_point_ptr = dlsym(dl, entry_point);
if (!entry_point_ptr)
raise(ScriptError, "error loading file - %s", dlerror());
return (*entry_point_ptr)(this_context, self);
}
int main(int argc, char **argv){
/* R embedded arguments, and optional arguments to be picked via cmdline switches */
char *R_argv[] = {(char*)programName, "--gui=none", "--no-restore", "--no-save", "--no-readline", "--silent", "", ""};
char *R_argv_opt[] = {"--vanilla", "--slave"};
int R_argc = (sizeof(R_argv) - sizeof(R_argv_opt) ) / sizeof(R_argv[0]);
int i, nargv, c, optpos=0, vanilla=0, quick=0, interactive=0, datastdin=0;
char *evalstr = NULL;
char *libstr = NULL;
char *libpathstr = NULL;
SEXP s_argv;
structRstart Rst;
char *datastdincmd = "X <- read.csv(file(\"stdin\"), stringsAsFactors=FALSE);";
static struct option optargs[] = {
{"help", no_argument, NULL, 'h'},
{"usage", no_argument, 0, 0},
{"version", no_argument, NULL, 'V'},
{"vanilla", no_argument, NULL, 'v'},
{"eval", required_argument, NULL, 'e'},
{"packages", required_argument, NULL, 'l'},
{"verbose", no_argument, NULL, 'p'},
{"rtemp", no_argument, NULL, 't'},
{"quick", no_argument, NULL, 'q'},
{"interactive", no_argument, NULL, 'i'},
{"datastdin", no_argument, NULL, 'd'},
{"libpath", required_argument, NULL, 'L'},
{0, 0, 0, 0}
};
while ((c = getopt_long(argc, argv, "+hVve:npl:L:tqid", optargs, &optpos)) != -1) {
switch (c) {
case 0: /* numeric 0 is code for a long option */
/* printf ("Got option %s %d", optargs[optpos].name, optpos);*/
switch (optpos) { /* so switch on the position in the optargs struct */
/* cases 0, 2, and 3 can't happen as they are covered by the '-h', */
/* '-V', and '-v' equivalences */
case 1:
showUsageAndExit();
break; /* never reached */
case 5:
verbose = 1;
break;
default:
printf("Uncovered option position '%d'. Try `%s --help' for help\n",
optpos, programName);
exit(-1);
}
break;
case 'h': /* -h is the sole short option, cf getopt_long() call */
showHelpAndExit();
break; /* never reached */
case 'e':
evalstr = optarg;
break;
case 'l':
libstr = optarg;
break;
case 'v':
vanilla=1;
break;
case 'p':
verbose=1;
break;
case 'V':
showVersionAndExit();
break; /* never reached */
case 't':
perSessionTempDir=TRUE;
break;
case 'q':
quick=1;
break;
case 'i':
interactive=1;
break;
case 'd':
datastdin=1;
break;
case 'L':
libpathstr = optarg;
break;
default:
printf("Unknown option '%c'. Try `%s --help' for help\n",(char)c, programName);
exit(-1);
}
}
if (vanilla) {
R_argv[R_argc++] = R_argv_opt[0];
}
if (!verbose) {
R_argv[R_argc++] = R_argv_opt[1];
}
#ifdef DEBUG
printf("R_argc %d sizeof(R_argv) \n", R_argc, sizeof(R_argv));
for (i=0; i<7; i++) {
printf("R_argv[%d] = %s\n", i, R_argv[i]);
}
printf("optind %d, argc %d\n", optind, argc);
for (i=0; i<argc; i++) {
printf("argv[%d] = %s\n", i, argv[i]);
}
#endif
/* Now, argv[optind] could be a file we want to source -- if we're
* in the 'shebang' case -- or it could be an expression from stdin.
* So call stat(1) on it, and if its a file we will treat it as such.
*/
struct stat sbuf;
if (optind < argc && evalstr==NULL) {
if ((strcmp(argv[optind],"-") != 0) && (stat(argv[optind],&sbuf) != 0)) {
perror(argv[optind]);
exit(1);
}
}
/* Setenv R_* env vars: insert or replace into environment. */
for (i = 0; R_VARS[i] != NULL; i+= 2){
if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
perror("ERROR: couldn't set/replace an R environment variable");
exit(1);
}
}
/* We don't require() default packages upon startup; rather, we
* set up delayedAssign's instead. see autoloads().
*/
if (setenv("R_DEFAULT_PACKAGES","NULL",1) != 0) {
perror("ERROR: couldn't set/replace R_DEFAULT_PACKAGES");
exit(1);
}
R_SignalHandlers = 0; /* Don't let R set up its own signal handlers */
#ifdef CSTACK_DEFNS
R_CStackLimit = (uintptr_t)-1; /* Don't do any stack checking, see R Exts, '8.1.5 Threading issues' */
#endif
littler_InitTempDir(); /* Set up temporary directoy */
Rf_initEmbeddedR(R_argc, R_argv); /* Initialize the embedded R interpreter */
R_ReplDLLinit(); /* this is to populate the repl console buffers */
if (!interactive) { /* new in littler 0.1.3 */
R_DefParams(&Rst);
Rst.R_Interactive = 0; /* sets interactive() to eval to false */
R_SetParams(&Rst);
}
ptr_R_CleanUp = littler_CleanUp; /* R Exts, '8.1.2 Setting R callbacks */
if (quick != 1) { /* Unless user chose not to load libraries */
autoloads(); /* Force all default package to be dynamically required */
}
/* Place any argv arguments into argv vector in Global Environment */
/* if we have an evalstr supplied from -e|--eval, correct for it */
if ((argc - optind - (evalstr==NULL)) >= 1) {
int offset = (evalstr==NULL) + (strcmp(argv[optind],"-") == 0);
/* Build string vector */
nargv = argc - optind - offset;
PROTECT(s_argv = allocVector(STRSXP,nargv));
for (i = 0; i <nargv; i++){
STRING_PTR(s_argv)[i] = mkChar(argv[i+offset+optind]);
#ifdef DEBUG
printf("Passing %s to R\n", argv[i+offset+optind]);
#endif
}
UNPROTECT(1);
setVar(install("argv"),s_argv,R_GlobalEnv);
} else {
setVar(install("argv"),R_NilValue,R_GlobalEnv);
}
init_rand(); /* for tempfile() to work correctly */
if (!vanilla) {
FILE *fp;
char rprofilesite[128];
snprintf(rprofilesite, 110, "%s/etc/Rprofile.site", getenv("R_HOME"));
if (fp = fopen(rprofilesite, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", rprofilesite);
#endif
source(rprofilesite);
}
char dotrprofile[128];
snprintf(dotrprofile, 110, "%s/.Rprofile", getenv("HOME"));
if (fp = fopen(dotrprofile, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", dotrprofile);
#endif
source(dotrprofile);
}
char *etclittler = "/etc/littler.r"; /* load /etc/litter.r if it exists */
if (fp = fopen(etclittler, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", etclittler);
#endif
source(etclittler);
}
char dotlittler[128]; /* load ~/.litter.r if it exists */
snprintf(dotlittler, 110, "%s/.littler.r", getenv("HOME"));
if (fp = fopen(dotlittler, "r")) {
fclose(fp); /* don't actually need it */
#ifdef DEBUG
printf("Sourcing %s\n", dotlittler);
#endif
source(dotlittler);
}
}
if (libpathstr != NULL) { /* if requested by user, set libPaths */
char buf[128];
membuf_t pb = init_membuf(512);
snprintf(buf, 127 - 12 - strlen(libpathstr), ".libPaths(\"%s\");", libpathstr);
parse_eval(&pb, buf, 1);
destroy_membuf(pb);
}
if (libstr != NULL) { /* if requested by user, load libraries */
char *ptr, *token, *strptr;
char buf[128];
ptr = token = libstr;
membuf_t pb = init_membuf(512);
while (token != NULL) {
token = strtok_r(ptr, ",", &strptr);
ptr = NULL; /* after initial call strtok expects NULL */
if (token != NULL) {
snprintf(buf, 127 - 27 - strlen(token), "suppressMessages(library(%s));", token);
parse_eval(&pb, buf, 1);
}
}
destroy_membuf(pb);
}
if (datastdin) { /* if req. by user, read 'dat' from stdin */
membuf_t pb = init_membuf(512);
parse_eval(&pb, datastdincmd, 1);
destroy_membuf(pb);
}
/* Now determine which R code to evaluate */
int exit_val = 0;
if (evalstr != NULL) {
/* we have a command line expression to evaluate */
membuf_t pb = init_membuf(1024);
exit_val = parse_eval(&pb, evalstr, 1);
destroy_membuf(pb);
} else if (optind < argc && (strcmp(argv[optind],"-") != 0)) {
/* call R function source(filename) */
exit_val = source(argv[optind]);
} else {
/* Or read from stdin */
membuf_t lb = init_membuf(1024);
membuf_t pb = init_membuf(1024);
int lineno = 1;
while(readline_stdin(&lb)){
exit_val = parse_eval(&pb,(char*)lb->buf,lineno++);
if (exit_val) break;
}
destroy_membuf(lb);
destroy_membuf(pb);
}
littler_CleanUp(SA_NOSAVE, exit_val, 0);
return(0); /* not reached, but making -Wall happy */
}
