SEXP dotTcl(SEXP args)
{
SEXP ans;
const char *cmd;
Tcl_Obj *val;
const void *vmax = vmaxget();
if(!isValidString(CADR(args)))
error(_("invalid argument"));
cmd = translateChar(STRING_ELT(CADR(args), 0));
val = tk_eval(cmd);
ans = makeRTclObject(val);
vmaxset(vmax);
return ans;
}
double bessel_j(double x, double alpha)
{
long nb, ncalc;
double na, *bj;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_j");
return ML_NAN;
}
na = floor(alpha);
if (alpha < 0) {
/* Using Abramowitz & Stegun 9.1.2
* this may not be quite optimal (CPU and accuracy wise) */
return(bessel_j(x, -alpha) * cos(M_PI * alpha) +
((alpha == na) ? 0 :
bessel_y(x, -alpha) * sin(M_PI * alpha)));
}
nb = 1 + (long)na; /* nb-1 <= alpha < nb */
alpha -= (nb-1);
#ifdef MATHLIB_STANDALONE
bj = (double *) calloc(nb, sizeof(double));
if (!bj) MATHLIB_ERROR("%s", _("bessel_j allocation error"));
#else
vmax = vmaxget();
bj = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
J_bessel(&x, &alpha, &nb, bj, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc < 0)
MATHLIB_WARNING4(_("bessel_j(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else
MATHLIB_WARNING2(_("bessel_j(%g,nu=%g): precision lost in result\n"),
x, alpha+nb-1);
}
x = bj[nb-1];
#ifdef MATHLIB_STANDALONE
free(bj);
#else
vmaxset(vmax);
#endif
return x;
}
SEXP FFI_Call(SEXP recv,SEXP sig,SEXP args) {
void (*FUN)() = NULL;
char *vmax = vmaxget();
void *handle = NULL;
/* Get the function pointer */
switch(TYPEOF(recv)) {
case EXTPTRSXP:
FUN = R_ExternalPtrAddr(recv);
break;
case STRSXP:
if(length(recv)==1) {
FUN = dlsym(NULL,CHAR(STRING_ELT(recv,0)));
if(NULL == FUN)
error("Pointer doesn't point to a function?");
} else {
handle = dlopen(CHAR(STRING_ELT(recv,0)),RTLD_NOW|RTLD_LOCAL);
if(NULL == handle)
error("Unable to load library %s",CHAR(STRING_ELT(recv,0)));
FUN = dlsym(handle,CHAR(STRING_ELT(recv,1)));
}
if(NULL == FUN)
error("Unable to bind symbol %s",CHAR(STRING_ELT(recv,length(recv)-1)));
break;
default:
error("No receiver function address");
break;
}
/* Get the signature for the call */
ffi_cif *cif = R_ExternalPtrAddr(sig);
if(cif->nargs != length(args))
error("this signature specifies %d arguments",cif->nargs);
/* Sort out the arguments */
int i;
void **values = (void**)R_alloc(sizeof(void),length(args));
for(i=0;i<length(args);i++)
values[i] = ffi_make_arg(TYPE_ELT(sig,i),cif->arg_types[i]->type,VECTOR_ELT(args,i));
/* Make the call and return */
ret_value retval;
SEXP rval;
ffi_call(cif,FUN,&retval,values);
PROTECT(rval = ffi_fromType(TYPE_RET(sig),cif->rtype->type,&retval));
setAttrib(rval,install("ffi.args"),args);
vmaxset(vmax);
if(handle != NULL) dlclose(handle);
UNPROTECT(1);
return rval;
}
int attribute_hidden R_TextBufferInit(TextBuffer *txtb, SEXP text)
{
int i, k, l, n;
if (isString(text)) {
// translateChar might allocate
void *vmax = vmaxget();
n = length(text);
l = 0;
for (i = 0; i < n; i++) {
if (STRING_ELT(text, i) != R_NilValue) {
k = int( strlen(translateChar(STRING_ELT(text, i))));
if (k > l)
l = k;
}
}
vmaxset(vmax);
txtb->vmax = vmax;
txtb->buf = static_cast<unsigned char *>(RHO_alloc(l+2, sizeof(char))); /* '\n' and '\0' */
txtb->bufp = txtb->buf;
txtb->text = text;
txtb->ntext = n;
txtb->offset = 0;
transferChars(txtb->buf,
translateChar(STRING_ELT(txtb->text, txtb->offset)));
txtb->offset++;
return 1;
}
else {
txtb->vmax = vmaxget();
txtb->buf = nullptr;
txtb->bufp = nullptr;
txtb->text = R_NilValue;
txtb->ntext = 0;
txtb->offset = 1;
return 0;
}
}
SEXP RTcl_RemoveArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
Tcl_UnsetVar2(RTcl_interp, xstr, istr, 0);
vmaxset(vmax);
return R_NilValue;
}
attribute_hidden
double R_GE_VStrWidth(const char *s, cetype_t enc, const pGEcontext gc, pGEDevDesc dd)
{
double res;
if(!initialized) vfonts_Init();
if(initialized > 0) {
const void *vmax = vmaxget();
const char *str = reEnc(s, enc, CE_LATIN1, 2 /* '.' */);
res = (*routines.GEVStrWidth)(str, gc, dd);
vmaxset(vmax);
return res;
} else {
error(_("Hershey fonts cannot be loaded"));
return 0.0; /* -Wall */
}
}
static void whittle(Array acf, int nlag, Array *A, Array *B, Array p_forward,
Array v_forward, Array p_back, Array v_back)
{
int lag, nser = DIM(acf)[1];
const void *vmax;
Array EA, EB; /* prediction variance */
Array KA, KB; /* partial correlation coefficient */
Array id, tmp;
vmax = vmaxget();
KA = make_zero_matrix(nser, nser);
EA = make_zero_matrix(nser, nser);
KB = make_zero_matrix(nser, nser);
EB = make_zero_matrix(nser, nser);
id = make_identity_matrix(nser);
copy_array(id, subarray(A[0],0));
copy_array(id, subarray(B[0],0));
copy_array(id, subarray(p_forward,0));
copy_array(id, subarray(p_back,0));
for (lag = 1; lag <= nlag; lag++) {
whittle2(acf, A[lag-1], B[lag-1], lag, "forward", A[lag], KA, EB);
whittle2(acf, B[lag-1], A[lag-1], lag, "back", B[lag], KB, EA);
copy_array(EA, subarray(v_forward,lag-1));
copy_array(EB, subarray(v_back,lag-1));
copy_array(KA, subarray(p_forward,lag));
copy_array(KB, subarray(p_back,lag));
}
tmp = make_zero_matrix(nser,nser);
matrix_prod(KB,KA, 1, 1, tmp);
array_op(id, tmp, '-', tmp);
matrix_prod(EA, tmp, 0, 0, subarray(v_forward, nlag));
vmaxset(vmax);
}
static void qr_solve(Array x, Array y, Array coef)
/* Translation of the R function qr.solve into pure C
NB We have to transpose the matrices since the ordering of an array is different in Fortran
NB2 We have to copy x to avoid it being overwritten.
*/
{
int i, info = 0, rank, *pivot, n, p;
const void *vmax;
double tol = 1.0E-7, *qraux, *work;
Array xt, yt, coeft;
assert(NROW(x) == NROW(y));
assert(NCOL(coef) == NCOL(y));
assert(NCOL(x) == NROW(coef));
vmax = vmaxget();
qraux = (double *) R_alloc(NCOL(x), sizeof(double));
pivot = (int *) R_alloc(NCOL(x), sizeof(int));
work = (double *) R_alloc(2*NCOL(x), sizeof(double));
for(i = 0; i < NCOL(x); i++)
pivot[i] = i+1;
xt = make_zero_matrix(NCOL(x), NROW(x));
transpose_matrix(x,xt);
n = NROW(x);
p = NCOL(x);
F77_CALL(dqrdc2)(VECTOR(xt), &n, &n, &p, &tol, &rank,
qraux, pivot, work);
if (rank != p)
error(_("Singular matrix in qr_solve"));
yt = make_zero_matrix(NCOL(y), NROW(y));
coeft = make_zero_matrix(NCOL(coef), NROW(coef));
transpose_matrix(y, yt);
F77_CALL(dqrcf)(VECTOR(xt), &NROW(x), &rank, qraux,
yt.vec, &NCOL(y), coeft.vec, &info);
transpose_matrix(coeft,coef);
vmaxset(vmax);
}
double bessel_k(double x, double alpha, double expo)
{
long nb, ncalc, ize;
double *bk;
#ifndef MATHLIB_STANDALONE
const void *vmax;
#endif
#ifdef IEEE_754
/* NaNs propagated correctly */
if (ISNAN(x) || ISNAN(alpha)) return x + alpha;
#endif
if (x < 0) {
ML_ERROR(ME_RANGE, "bessel_k");
return ML_NAN;
}
ize = (long)expo;
if(alpha < 0)
alpha = -alpha;
nb = 1+ (long)floor(alpha);/* nb-1 <= |alpha| < nb */
alpha -= (double)(nb-1);
#ifdef MATHLIB_STANDALONE
bk = (double *) calloc(nb, sizeof(double));
if (!bk) MATHLIB_ERROR("%s", _("bessel_k allocation error"));
#else
vmax = vmaxget();
bk = (double *) R_alloc((size_t) nb, sizeof(double));
#endif
K_bessel(&x, &alpha, &nb, &ize, bk, &ncalc);
if(ncalc != nb) {/* error input */
if(ncalc < 0)
MATHLIB_WARNING4(_("bessel_k(%g): ncalc (=%ld) != nb (=%ld); alpha=%g. Arg. out of range?\n"),
x, ncalc, nb, alpha);
else
MATHLIB_WARNING2(_("bessel_k(%g,nu=%g): precision lost in result\n"),
x, alpha+(double)nb-1);
}
x = bk[nb-1];
#ifdef MATHLIB_STANDALONE
free(bk);
#else
vmaxset(vmax);
#endif
return x;
}
SEXP _gregexpr(SEXP _pattern, SEXP _text, SEXP _subpattern)
{
SEXP ans;
pcre *re_pcre;
pcre_extra *re_pe;
int erroffset;
const char *errorptr;
//int options = 0;
const unsigned char* tables = pcre_maketables();
const char* spat = as_string(_pattern);
re_pcre = pcre_compile(spat, 0, &errorptr, &erroffset, tables);
if (!re_pcre)
{
if (errorptr)
Rprintf("PCRE pattern compilation error\n\t'%s'\n\tat '%s'\n",
errorptr, spat+erroffset);
Rprintf("invalid regular expression '%s'\n", spat);
}
re_pe = pcre_study(re_pcre, 0, &errorptr);
int n = LENGTH(_text);
SEXP elt;
PROTECT(ans = allocVector(VECSXP, n));
const void *vmax = vmaxget();
for (int i = 0 ; i < n ; i++) {
if (STRING_ELT(_text, i) == NA_STRING) {
elt = gregexpr_NAInputAns();
} else {
const char* s = as_string(_text,i);
elt = _pcre(spat, s, re_pcre, re_pe, *REAL(_subpattern));
}
SET_VECTOR_ELT(ans, i, elt);
vmaxset(vmax);
}
if (re_pe) pcre_free(re_pe);
pcre_free(re_pcre);
pcre_free((void *)tables);
UNPROTECT(1);
return ans;
}
SEXP RTcl_SetArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
Tcl_Obj *value;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
value = (Tcl_Obj *) R_ExternalPtrAddr(CADDDR(args));
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
Tcl_SetVar2Ex(RTcl_interp, xstr, istr, value, 0);
vmaxset(vmax);
return R_NilValue;
}
/* based on EncodeEnvironment in printutils.c */
static void PrintEnvironment(SEXP x)
{
const void *vmax = vmaxget();
if (x == R_GlobalEnv)
Rprintf("<R_GlobalEnv>");
else if (x == R_BaseEnv)
Rprintf("<base>");
else if (x == R_EmptyEnv)
Rprintf("<R_EmptyEnv>");
else if (R_IsPackageEnv(x))
Rprintf("<%s>",
translateChar(STRING_ELT(R_PackageEnvName(x), 0)));
else if (R_IsNamespaceEnv(x))
Rprintf("<namespace:%s>",
translateChar(STRING_ELT(R_NamespaceEnvSpec(x), 0)));
else Rprintf("<%p>", (void *)x);
vmaxset(vmax);
}
SEXP addhistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP stamp;
const void *vmax = vmaxget();
args = CDR(args);
stamp = CAR(args);
if (!isString(stamp))
errorcall(call, _("invalid timestamp"));
if (CharacterMode == RGui) {
for (int i = 0; i < LENGTH(stamp); i++)
wgl_histadd(wtransChar(STRING_ELT(stamp, i)));
} else if (R_Interactive && CharacterMode == RTerm) {
for (int i = 0; i < LENGTH(stamp); i++)
gl_histadd(translateChar(STRING_ELT(stamp, i)));
}
vmaxset(vmax);
return R_NilValue;
}
int attribute_hidden R_TextBufferGetc(TextBuffer *txtb)
{
if (txtb->buf == nullptr)
return EOF;
if (*(txtb->bufp) == '\0') {
if (txtb->offset == txtb->ntext) {
txtb->buf = nullptr;
return EOF;
} else {
const void *vmax = vmaxget();
transferChars(txtb->buf,
translateChar(STRING_ELT(txtb->text, txtb->offset)));
txtb->bufp = txtb->buf;
txtb->offset++;
vmaxset(vmax);
}
}
return *txtb->bufp++;
}
SEXP RTcl_ObjFromCharVector(SEXP args)
{
char *s;
Tcl_DString s_ds;
int count;
Tcl_Obj *tclobj, *elem;
int i;
SEXP val, drop;
Tcl_Encoding encoding;
const void *vmax = vmaxget();
val = CADR(args);
drop = CADDR(args);
tclobj = Tcl_NewObj();
count = length(val);
encoding = Tcl_GetEncoding(RTcl_interp, "utf-8");
if (count == 1 && LOGICAL(drop)[0]) {
Tcl_DStringInit(&s_ds);
s = Tcl_ExternalToUtfDString(encoding,
translateCharUTF8(STRING_ELT(val, 0)),
-1, &s_ds);
Tcl_SetStringObj(tclobj, s, -1);
Tcl_DStringFree(&s_ds);
} else
for ( i = 0 ; i < count ; i++) {
elem = Tcl_NewObj();
Tcl_DStringInit(&s_ds);
s = Tcl_ExternalToUtfDString(encoding,
translateCharUTF8(STRING_ELT(val, i)),
-1, &s_ds);
Tcl_SetStringObj(elem, s, -1);
Tcl_DStringFree(&s_ds);
Tcl_ListObjAppendElement(RTcl_interp, tclobj, elem);
}
Tcl_FreeEncoding(encoding);
SEXP res = makeRTclObject(tclobj);
vmaxset(vmax);
return res;
}
SEXP RTcl_GetArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
Tcl_Obj *tclobj;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
tclobj = Tcl_GetVar2Ex(RTcl_interp, xstr, istr, 0);
vmaxset(vmax);
if (tclobj == NULL)
return R_NilValue;
else
return makeRTclObject(tclobj);
}
/* pull(): auxiliary routine for Qn and Sn
* ====== ======== ---------------------
*/
double pull(double *a_in, int n, int k)
{
/* Finds the k-th order statistic of an array a[] of length n
* --------------------
*/
int j;
double *a, ax;
char* vmax = vmaxget();
a = (double *)R_alloc(n, sizeof(double));
/* Copy a[] and use copy since it will be re-shuffled: */
for (j = 0; j < n; j++)
a[j] = a_in[j];
k--; /* 0-indexing */
rPsort(a, n, k);
ax = a[k];
vmaxset(vmax);
return ax;
} /* pull */
static char *R_completion_generator(const char *text, int state)
{
static int list_index, ncomp;
static char **compstrings;
/* If this is a new word to complete, initialize now. This
involves saving 'text' to somewhere R can get at it, calling
completeToken(), and retrieving the completions. */
if (!state) {
int i;
SEXP completions,
assignCall = PROTECT(lang2(RComp_assignTokenSym, mkString(text))),
completionCall = PROTECT(lang1(RComp_completeTokenSym)),
retrieveCall = PROTECT(lang1(RComp_retrieveCompsSym));
const void *vmax = vmaxget();
eval(assignCall, rcompgen_rho);
eval(completionCall, rcompgen_rho);
PROTECT(completions = eval(retrieveCall, rcompgen_rho));
list_index = 0;
ncomp = length(completions);
if (ncomp > 0) {
compstrings = (char **) malloc(ncomp * sizeof(char*));
if (!compstrings) return (char *)NULL;
for (i = 0; i < ncomp; i++)
compstrings[i] = strdup(translateChar(STRING_ELT(completions, i)));
}
UNPROTECT(4);
vmaxset(vmax);
}
if (list_index < ncomp)
return compstrings[list_index++];
else {
/* nothing matched or remaining, so return NULL. */
if (ncomp > 0) free(compstrings);
}
return (char *)NULL;
}
attribute_hidden
void Rcons_vprintf(const char *format, va_list arg)
{
char buf[R_BUFSIZE], *p = buf;
int res;
const void *vmax = vmaxget();
int usedRalloc = FALSE, usedVasprintf = FALSE;
va_list aq;
va_copy(aq, arg);
res = vsnprintf(buf, R_BUFSIZE, format, aq);
va_end(aq);
#ifdef HAVE_VASPRINTF
if(res >= R_BUFSIZE || res < 0) {
res = vasprintf(&p, format, arg);
if (res < 0) {
p = buf;
buf[R_BUFSIZE - 1] = '\0';
warning("printing of extremely long output is truncated");
} else usedVasprintf = TRUE;
}
#else
if(res >= R_BUFSIZE) { /* res is the desired output length */
usedRalloc = TRUE;
p = R_alloc(res+1, sizeof(char));
vsprintf(p, format, arg);
} else if(res < 0) { /* just a failure indication */
usedRalloc = TRUE;
p = R_alloc(10*R_BUFSIZE, sizeof(char));
res = vsnprintf(p, 10*R_BUFSIZE, format, arg);
if (res < 0) {
*(p + 10*R_BUFSIZE - 1) = '\0';
warning("printing of extremely long output is truncated");
}
}
#endif /* HAVE_VASPRINTF */
R_WriteConsole(p, (int) strlen(p));
if(usedRalloc) vmaxset(vmax);
if(usedVasprintf) free(p);
}
static void transpose_matrix(Array mat, Array ans)
{
int i,j;
const void *vmax;
Array tmp;
tmp = init_array();
assert(DIM_LENGTH(mat) == 2 && DIM_LENGTH(ans) == 2);
assert(NCOL(mat) == NROW(ans));
assert(NROW(mat) == NCOL(ans));
vmax = vmaxget();
tmp = make_zero_matrix(NROW(ans), NCOL(ans));
for(i = 0; i < NROW(mat); i++)
for(j = 0; j < NCOL(mat); j++)
MATRIX(tmp)[j][i] = MATRIX(mat)[i][j];
copy_array(tmp, ans);
vmaxset(vmax);
}
static double ldet(Array x)
/* Log determinant of square matrix */
{
int i, rank, *pivot, n, p;
const void *vmax;
double ll, tol = 1.0E-7, *qraux, *work;
Array xtmp;
assert(DIM_LENGTH(x) == 2); /* is x a matrix? */
assert(NROW(x) == NCOL(x)); /* is x square? */
vmax = vmaxget();
qraux = (double *) R_alloc(NCOL(x), sizeof(double));
pivot = (int *) R_alloc(NCOL(x), sizeof(int));
work = (double *) R_alloc(2*NCOL(x), sizeof(double));
xtmp = make_zero_matrix(NROW(x), NCOL(x));
copy_array(x, xtmp);
for(i = 0; i < NCOL(x); i++)
pivot[i] = i+1;
p = n = NROW(x);
F77_CALL(dqrdc2)(VECTOR(xtmp), &n, &n, &p, &tol, &rank,
qraux, pivot, work);
if (rank != p)
error(_("Singular matrix in ldet"));
for (i = 0, ll=0.0; i < rank; i++) {
ll += log(fabs(MATRIX(xtmp)[i][i]));
}
vmaxset(vmax);
return ll;
}
SEXP attribute_hidden do_abbrev(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
R_xlen_t i, len;
int minlen;
Rboolean warn = FALSE;
const char *s;
const void *vmax;
checkArity(op,args);
x = CAR(args);
if (!isString(x))
error(_("the first argument must be a character vector"));
len = XLENGTH(x);
PROTECT(ans = allocVector(STRSXP, len));
minlen = asInteger(CADR(args));
vmax = vmaxget();
for (i = 0 ; i < len ; i++) {
if (STRING_ELT(x, i) == NA_STRING)
SET_STRING_ELT(ans, i, NA_STRING);
else {
s = translateChar(STRING_ELT(x, i));
if(strlen(s) > minlen) {
warn = warn | !strIsASCII(s);
R_AllocStringBuffer(strlen(s), &cbuff);
SET_STRING_ELT(ans, i, stripchars(s, minlen));
} else SET_STRING_ELT(ans, i, mkChar(s));
}
vmaxset(vmax);
}
if (warn) warning(_("abbreviate used with non-ASCII chars"));
DUPLICATE_ATTRIB(ans, x);
/* This copied the class, if any */
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return(ans);
}
attribute_hidden
const char *EncodeEnvironment(SEXP x)
{
const void *vmax = vmaxget();
static char ch[1000];
if (x == R_GlobalEnv)
sprintf(ch, "<environment: R_GlobalEnv>");
else if (x == R_BaseEnv)
sprintf(ch, "<environment: base>");
else if (x == R_EmptyEnv)
sprintf(ch, "<environment: R_EmptyEnv>");
else if (R_IsPackageEnv(x))
snprintf(ch, 1000, "<environment: %s>",
translateChar(STRING_ELT(R_PackageEnvName(x), 0)));
else if (R_IsNamespaceEnv(x))
snprintf(ch, 1000, "<environment: namespace:%s>",
translateChar(STRING_ELT(R_NamespaceEnvSpec(x), 0)));
else snprintf(ch, 1000, "<environment: %p>", (void *)x);
vmaxset(vmax);
return ch;
}
/* Are these are always native charset? */
Rboolean pmatch(SEXP formal, SEXP tag, Rboolean exact)
{
const char *f, *t;
const void *vmax = vmaxget();
switch (TYPEOF(formal)) {
case SYMSXP:
f = CHAR(PRINTNAME(formal));
break;
case CHARSXP:
f = CHAR(formal);
break;
case STRSXP:
f = translateChar(STRING_ELT(formal, 0));
break;
default:
goto fail;
}
switch(TYPEOF(tag)) {
case SYMSXP:
t = CHAR(PRINTNAME(tag));
break;
case CHARSXP:
t = CHAR(tag);
break;
case STRSXP:
t = translateChar(STRING_ELT(tag, 0));
break;
default:
goto fail;
}
Rboolean res = psmatch(f, t, exact);
vmaxset(vmax);
return res;
fail:
error(_("invalid partial string match"));
return FALSE;/* for -Wall */
}
/* utils::shortPathName */
SEXP in_shortpath(SEXP paths)
{
SEXP ans, el;
int i, n = LENGTH(paths);
char tmp[MAX_PATH];
wchar_t wtmp[32768];
DWORD res;
const void *vmax = vmaxget();
if(!isString(paths)) error(_("'path' must be a character vector"));
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
el = STRING_ELT(paths, i);
if(getCharCE(el) == CE_UTF8) {
res = GetShortPathNameW(filenameToWchar(el, FALSE), wtmp, 32768);
if (res && res <= 32768)
wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
else
strcpy(tmp, translateChar(el));
/* documented to return paths using \, which the API call does
not necessarily do */
R_fixbackslash(tmp);
SET_STRING_ELT(ans, i, mkCharCE(tmp, CE_UTF8));
} else {
res = GetShortPathName(translateChar(el), tmp, MAX_PATH);
if (res == 0 || res > MAX_PATH) strcpy(tmp, translateChar(el));
/* documented to return paths using \, which the API call does
not necessarily do */
R_fixbackslash(tmp);
SET_STRING_ELT(ans, i, mkChar(tmp));
}
}
UNPROTECT(1);
vmaxset(vmax);
return ans;
}
// formerly in src/main/platform.c
SEXP fileedit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP fn, ti, ed;
const char **f, **title, *editor;
int i, n;
const void *vmax = vmaxget();
args = CDR(args);
fn = CAR(args); args = CDR(args);
ti = CAR(args); args = CDR(args);
ed = CAR(args);
n = length(fn);
if (!isString(ed) || length(ed) != 1)
error(_("invalid '%s' specification"), "editor");
if (n > 0) {
if (!isString(fn))
error(_("invalid '%s' specification"), "filename");
f = (const char**) R_alloc(n, sizeof(char*));
title = (const char**) R_alloc(n, sizeof(char*));
/* FIXME convert to UTF-8 on Windows */
for (i = 0; i < n; i++) {
SEXP el = STRING_ELT(fn, 0);
if (!isNull(el))
#ifdef Win32
f[i] = acopy_string(reEnc(CHAR(el), getCharCE(el), CE_UTF8, 1));
#else
f[i] = acopy_string(translateChar(el));
#endif
else
f[i] = "";
if (!isNull(STRING_ELT(ti, i)))
title[i] = acopy_string(translateChar(STRING_ELT(ti, i)));
else
title[i] = "";
}
}
static void R_cpolyroot(double *opr, double *opi, int *degree,
double *zeror, double *zeroi, Rboolean *fail)
{
static const double smalno = DBL_MIN;
static const double base = (double)FLT_RADIX;
static int d_n, i, i1, i2;
static double zi, zr, xx, yy;
static double bnd, xxx;
Rboolean conv;
int d1;
double *tmp;
static const double cosr =/* cos 94 */ -0.06975647374412529990;
static const double sinr =/* sin 94 */ 0.99756405025982424767;
xx = M_SQRT1_2;/* 1/sqrt(2) = 0.707.... */
yy = -xx;
*fail = FALSE;
nn = *degree;
d1 = nn - 1;
/* algorithm fails if the leading coefficient is zero. */
if (opr[0] == 0. && opi[0] == 0.) {
*fail = TRUE;
return;
}
/* remove the zeros at the origin if any. */
while (opr[nn] == 0. && opi[nn] == 0.) {
d_n = d1-nn+1;
zeror[d_n] = 0.;
zeroi[d_n] = 0.;
nn--;
}
nn++;
/*-- Now, global var. nn := #{coefficients} = (relevant degree)+1 */
if (nn == 1) return;
/* Use a single allocation as these as small */
const void *vmax = vmaxget();
tmp = (double *) R_alloc((size_t) (10*nn), sizeof(double));
pr = tmp; pi = tmp + nn; hr = tmp + 2*nn; hi = tmp + 3*nn;
qpr = tmp + 4*nn; qpi = tmp + 5*nn; qhr = tmp + 6*nn; qhi = tmp + 7*nn;
shr = tmp + 8*nn; shi = tmp + 9*nn;
/* make a copy of the coefficients and shr[] = | p[] | */
for (i = 0; i < nn; i++) {
pr[i] = opr[i];
pi[i] = opi[i];
shr[i] = hypot(pr[i], pi[i]);
}
/* scale the polynomial with factor 'bnd'. */
bnd = cpoly_scale(nn, shr, eta, infin, smalno, base);
if (bnd != 1.) {
for (i=0; i < nn; i++) {
pr[i] *= bnd;
pi[i] *= bnd;
}
}
/* start the algorithm for one zero */
while (nn > 2) {
/* calculate bnd, a lower bound on the modulus of the zeros. */
for (i=0 ; i < nn ; i++)
shr[i] = hypot(pr[i], pi[i]);
bnd = cpoly_cauchy(nn, shr, shi);
/* outer loop to control 2 major passes */
/* with different sequences of shifts */
for (i1 = 1; i1 <= 2; i1++) {
/* first stage calculation, no shift */
noshft(5);
/* inner loop to select a shift */
for (i2 = 1; i2 <= 9; i2++) {
/* shift is chosen with modulus bnd */
/* and amplitude rotated by 94 degrees */
/* from the previous shift */
xxx= cosr * xx - sinr * yy;
yy = sinr * xx + cosr * yy;
xx = xxx;
sr = bnd * xx;
si = bnd * yy;
/* second stage calculation, fixed shift */
conv = fxshft(i2 * 10, &zr, &zi);
if (conv)
goto L10;
}
}
/* the zerofinder has failed on two major passes */
/* return empty handed */
*fail = TRUE;
vmaxset(vmax);
return;
/* the second stage jumps directly to the third stage iteration.
* if successful, the zero is stored and the polynomial deflated.
*/
L10:
d_n = d1+2 - nn;
zeror[d_n] = zr;
zeroi[d_n] = zi;
--nn;
for (i=0; i < nn ; i++) {
pr[i] = qpr[i];
pi[i] = qpi[i];
}
}/*while*/
/* calculate the final zero and return */
cdivid(-pr[1], -pi[1], pr[0], pi[0], &zeror[d1], &zeroi[d1]);
vmaxset(vmax);
return;
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
SEXP attribute_hidden do_makenames(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP arg, ans;
R_xlen_t i, n;
int l, allow_;
char *p, *tmp = NULL, *cbuf;
const char *This;
Rboolean need_prefix;
const void *vmax;
checkArity(op ,args);
arg = CAR(args);
if (!isString(arg))
error(_("non-character names"));
n = XLENGTH(arg);
allow_ = asLogical(CADR(args));
if (allow_ == NA_LOGICAL)
error(_("invalid '%s' value"), "allow_");
PROTECT(ans = allocVector(STRSXP, n));
vmax = vmaxget();
for (i = 0 ; i < n ; i++) {
This = translateChar(STRING_ELT(arg, i));
l = (int) strlen(This);
/* need to prefix names not beginning with alpha or ., as
well as . followed by a number */
need_prefix = FALSE;
if (mbcslocale && This[0]) {
int nc = l, used;
wchar_t wc;
mbstate_t mb_st;
const char *pp = This;
mbs_init(&mb_st);
used = (int) Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
pp += used; nc -= used;
if (wc == L'.') {
if (nc > 0) {
Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
if (iswdigit(wc)) need_prefix = TRUE;
}
} else if (!iswalpha(wc)) need_prefix = TRUE;
} else {
if (This[0] == '.') {
if (l >= 1 && isdigit(0xff & (int) This[1])) need_prefix = TRUE;
} else if (!isalpha(0xff & (int) This[0])) need_prefix = TRUE;
}
if (need_prefix) {
tmp = Calloc(l+2, char);
strcpy(tmp, "X");
strcat(tmp, translateChar(STRING_ELT(arg, i)));
} else {
tmp = Calloc(l+1, char);
strcpy(tmp, translateChar(STRING_ELT(arg, i)));
}
if (mbcslocale) {
/* This cannot lengthen the string, so safe to overwrite it.
Would also be possible a char at a time.
*/
int nc = (int) mbstowcs(NULL, tmp, 0);
wchar_t *wstr = Calloc(nc+1, wchar_t), *wc;
if (nc >= 0) {
mbstowcs(wstr, tmp, nc+1);
for (wc = wstr; *wc; wc++) {
if (*wc == L'.' || (allow_ && *wc == L'_'))
/* leave alone */;
else if (!iswalnum((int)*wc)) *wc = L'.';
/* If it changes into dot here,
* length will become short on mbcs.
* The name which became short will contain garbage.
* cf.
* > make.names(c("\u30fb"))
* [1] "X.\0"
*/
}
wcstombs(tmp, wstr, strlen(tmp)+1);
Free(wstr);
} else error(_("invalid multibyte string %d"), i+1);
} else {
for (p = tmp; *p; p++) {
SEXP attribute_hidden do_substrgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, value, el, v_el;
R_xlen_t i, len;
int start, stop, k, l, v;
size_t slen;
cetype_t ienc, venc;
const char *ss, *v_ss;
char *buf;
const void *vmax;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
value = CADDDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("replacing substrings in a non-character object"));
len = LENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
v = LENGTH(value);
if (!isString(value) || v == 0) error(_("invalid value"));
vmax = vmaxget();
for (i = 0; i < len; i++) {
el = STRING_ELT(x, i);
v_el = STRING_ELT(value, i % v);
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
if (el == NA_STRING || v_el == NA_STRING ||
start == NA_INTEGER || stop == NA_INTEGER) {
SET_STRING_ELT(s, i, NA_STRING);
continue;
}
ienc = getCharCE(el);
ss = CHAR(el);
slen = strlen(ss);
if (start < 1) start = 1;
if (stop > slen) stop = (int) slen; /* SBCS optimization */
if (start > stop) {
/* just copy element across */
SET_STRING_ELT(s, i, STRING_ELT(x, i));
} else {
int ienc2 = ienc;
v_ss = CHAR(v_el);
/* is the value in the same encoding?
FIXME: could prefer UTF-8 here
*/
venc = getCharCE(v_el);
if (venc != ienc && !strIsASCII(v_ss)) {
ss = translateChar(el);
slen = strlen(ss);
v_ss = translateChar(v_el);
ienc2 = CE_NATIVE;
}
/* might expand under MBCS */
buf = R_AllocStringBuffer(slen+strlen(v_ss), &cbuff);
strcpy(buf, ss);
substrset(buf, v_ss, ienc2, start, stop);
SET_STRING_ELT(s, i, mkCharCE(buf, ienc2));
}
vmaxset(vmax);
}
R_FreeStringBufferL(&cbuff);
}
UNPROTECT(1);
return s;
}
