自学教程：C++ vmaxget函数代码示例

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_hiddendouble 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_hiddenvoid 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_hiddenconst 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.cSEXP 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)//.........这里部分代码省略.........

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);//.........这里部分代码省略.........

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;}