示例#1
0
文件: expand.c 项目: Card1nal/guile
static SCM
expand_letstar (SCM expr, SCM env SCM_UNUSED)
{
  const SCM cdr_expr = CDR (expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);

  return expand_letstar_clause (CADR (expr), CDDR (expr), env);
}
示例#2
0
文件: builtin.c 项目: o-/Rexperiments
/* vector(mode="logical", length=0) */
SEXP attribute_hidden do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    R_xlen_t len;
    SEXP s;
    SEXPTYPE mode;
    checkArity(op, args);
    if (length(CADR(args)) != 1) error(_("invalid '%s' argument"), "length");
    len = asVecSize(CADR(args));
    if (len < 0) error(_("invalid '%s' argument"), "length");
    s = coerceVector(CAR(args), STRSXP);
    if (length(s) != 1) error(_("invalid '%s' argument"), "mode");
    mode = str2type(CHAR(STRING_ELT(s, 0))); /* ASCII */
    if (mode == -1 && streql(CHAR(STRING_ELT(s, 0)), "double"))
	mode = REALSXP;
    switch (mode) {
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case EXPRSXP:
    case VECSXP:
    case RAWSXP:
	s = allocVector(mode, len);
	break;
    case LISTSXP:
	if (len > INT_MAX) error("too long for a pairlist");
	s = allocList((int) len);
	break;
    default:
	error(_("vector: cannot make a vector of mode '%s'."),
	      translateChar(STRING_ELT(s, 0))); /* should be ASCII */
    }
    if (mode == INTSXP || mode == LGLSXP)
	Memzero(INTEGER(s), len);
    else if (mode == REALSXP)
	Memzero(REAL(s), len);
    else if (mode == CPLXSXP)
	Memzero(COMPLEX(s), len);
    else if (mode == RAWSXP)
	Memzero(RAW(s), len);
    /* other cases: list/expression have "NULL", ok */
    return s;
}
示例#3
0
文件: eval.c 项目: grouzen/fflisp
struct lispobj *eval_let(struct lispobj *exps, struct lispobj *env)
{
    struct lispobj *binds, *body, *vars, *vals, *lambda, *ret, *evals;

    binds = CAR(exps);
    body = CDR(exps);

    if(length(binds) > 0) {
        struct lispobj *tvars, *tvals;
        
        vars = heap_grab(NEW_CONS(NULL, NULL));
        vals = heap_grab(NEW_CONS(NULL, NULL));
        tvars = vars; tvals = vals;
        
        while(binds != NULL) {
            struct lispobj *bind = CAR(binds);

            if(length(bind) != 2) {
                ret = NEW_ERROR("Bad binding in the let exp.\n");
                goto exit;
            }
            
            CAR(tvars) = heap_grab(CAR(bind));
            CAR(tvals) = heap_grab(CADR(bind));
            CDR(tvars) = heap_grab(NEW_CONS(NULL, NULL));
            CDR(tvals) = heap_grab(NEW_CONS(NULL, NULL));
            
            tvars = CDR(tvars);
            tvals = CDR(tvals);
            binds = CDR(binds);
        }

        tvars = NULL;
        tvals = NULL;
    } else {
        return NEW_ERROR("Empty bindgings in the let exp.\n");
    }

    lambda = heap_grab(env_proc_make(vars, body, env));
    
    evals = heap_grab(env_val_list(vals, env));
    if(evals != NULL && OBJ_TYPE(evals) == ERROR) {
        ret = evals;
    } else {
        ret = apply(lambda, evals);
        heap_release(evals);
    }

    heap_release(lambda);
    
    exit:
    heap_release(vals);
    heap_release(vars);

    return ret;
}
示例#4
0
/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP in = CAR(args), out = CADR(args);
    SET_ATTRIB(out, ATTRIB(in));
    IS_S4_OBJECT(in) ?  SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
    SET_OBJECT(out, OBJECT(in));
    return out;
}
示例#5
0
文件: apply.cpp 项目: csilles/cxxr
/* This is a special .Internal, so has unevaluated arguments.  It is
   called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP R_fcall, ans, names, X, XX, FUN;
    R_xlen_t i, n;
    PROTECT_INDEX px;

    checkArity(op, args);
    PROTECT_WITH_INDEX(X = CAR(args), &px);
    PROTECT(XX = eval(CAR(args), rho));
    FUN = CADR(args);  /* must be unevaluated for use in e.g. bquote */
    n = xlength(XX);
    if (n == NA_INTEGER) error(_("invalid length"));
    Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);

    PROTECT(ans = allocVector(VECSXP, n));
    names = getAttrib(XX, R_NamesSymbol);
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);

    /* The R level code has ensured that XX is a vector.
       If it is atomic we can speed things up slightly by
       using the evaluated version.
    */
    {
	SEXP ind, tmp;
	/* Build call: FUN(XX[[<ind>]], ...) */

	/* Notice that it is OK to have one arg to LCONS do memory
	   allocation and not PROTECT the result (LCONS does memory
	   protection of its args internally), but not both of them,
	   since the computation of one may destroy the other */

	PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
	if(isVectorAtomic(XX))
	    PROTECT(tmp = LCONS(R_Bracket2Symbol,
				CONS(XX, CONS(ind, R_NilValue))));
	else
	    PROTECT(tmp = LCONS(R_Bracket2Symbol,
				CONS(X, CONS(ind, R_NilValue))));
	PROTECT(R_fcall = LCONS(FUN,
				CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));

	for(i = 0; i < n; i++) {
	    if (realIndx) REAL(ind)[0] = double(i + 1);
	    else INTEGER(ind)[0] = int(i + 1);
	    tmp = eval(R_fcall, rho);
	    if (NAMED(tmp))
		tmp = duplicate(tmp);
	    SET_VECTOR_ELT(ans, i, tmp);
	}
	UNPROTECT(3);
    }

    UNPROTECT(3); /* X, XX, ans */
    return ans;
}
示例#6
0
SEXP attribute_hidden complex_math2(SEXP call, SEXP op, SEXP args, SEXP env)
{
    R_xlen_t i, n, na, nb;
    Rcomplex ai, bi, *a, *b, *y;
    SEXP sa, sb, sy;
    Rboolean naflag = FALSE;
    cm2_fun f;

    switch (PRIMVAL(op)) {
    case 0: /* atan2 */
	f = z_atan2; break;
    case 10001: /* round */
	f = z_rround; break;
    case 2: /* passed from do_log1arg */
    case 10:
    case 10003: /* passed from do_log */
	f = z_logbase; break;
    case 10004: /* signif */
	f = z_prec; break;
    default:
	errorcall_return(call, _("unimplemented complex function"));
    }

    PROTECT(sa = coerceVector(CAR(args), CPLXSXP));
    PROTECT(sb = coerceVector(CADR(args), CPLXSXP));
    na = XLENGTH(sa); nb = XLENGTH(sb);
    if ((na == 0) || (nb == 0)) {
        UNPROTECT(2);
        return(allocVector(CPLXSXP, 0));
    }
    n = (na < nb) ? nb : na;
    PROTECT(sy = allocVector(CPLXSXP, n));
    a = COMPLEX(sa); b = COMPLEX(sb); y = COMPLEX(sy);
    for (i = 0; i < n; i++) {
	ai = a[i % na]; bi = b[i % nb];
	if(ISNA(ai.r) && ISNA(ai.i) &&
	   ISNA(bi.r) && ISNA(bi.i)) {
	    y[i].r = NA_REAL; y[i].i = NA_REAL;
	} else {
	    f(&y[i], &ai, &bi);
	    if ( (ISNAN(y[i].r) || ISNAN(y[i].i)) &&
		 !(ISNAN(ai.r) || ISNAN(ai.i) || ISNAN(bi.r) || ISNAN(bi.i)) )
		naflag = TRUE;
	}
    }
    if (naflag)
	warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
    if(n == na) {
	DUPLICATE_ATTRIB(sy, sa);
    } else if(n == nb) {
	DUPLICATE_ATTRIB(sy, sb);
    }
    UNPROTECT(3);
    return sy;
}
示例#7
0
static void fcn(int n, const double x[], double *f, function_info
		*state)
{
    SEXP s, R_fcall;
    ftable *Ftable;
    double *g = (double *) 0, *h = (double *) 0;
    int i;

    R_fcall = state->R_fcall;
    Ftable = state->Ftable;
    if ((i = FT_lookup(n, x, state)) >= 0) {
	*f = Ftable[i].fval;
	return;
    }
				/* calculate for a new value of x */
    s = CADR(R_fcall);
    for (i = 0; i < n; i++) {
	if (!R_FINITE(x[i])) error(_("non-finite value supplied by 'nlm'"));
	REAL(s)[i] = x[i];
    }
    s = PROTECT(eval(state->R_fcall, state->R_env));
    switch(TYPEOF(s)) {
    case INTSXP:
	if (length(s) != 1) goto badvalue;
	if (INTEGER(s)[0] == NA_INTEGER) {
	    warning(_("NA replaced by maximum positive value"));
	    *f = DBL_MAX;
	}
	else *f = INTEGER(s)[0];
	break;
    case REALSXP:
	if (length(s) != 1) goto badvalue;
	if (!R_FINITE(REAL(s)[0])) {
	    warning(_("NA/Inf replaced by maximum positive value"));
	    *f = DBL_MAX;
	}
	else *f = REAL(s)[0];
	break;
    default:
	goto badvalue;
    }
    if (state->have_gradient) {
	g = REAL(PROTECT(coerceVector(getAttrib(s, install("gradient")), REALSXP)));
	if (state->have_hessian) {
	    h = REAL(PROTECT(coerceVector(getAttrib(s, install("hessian")), REALSXP)));
	}
    }
    FT_store(n, *f, x, g, h, state);
    UNPROTECT(1 + state->have_gradient + state->have_hessian);
    return;

 badvalue:
    error(_("invalid function value in 'nlm' optimizer"));
}
示例#8
0
文件: seq.c 项目: kalibera/rexp
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    SEXP s = CAR(args), ncopy = CADR(args);
    R_xlen_t nc;
    SEXP a;

    if (!isVector(ncopy))
	error(_("incorrect type for second argument"));

    if (!isVector(s) && s != R_NilValue)
	error(_("attempt to replicate an object of type '%s'"), 
	      type2char(TYPEOF(s)));

    nc = xlength(ncopy); // might be 0
    if (nc == xlength(s)) 
	PROTECT(a = rep2(s, ncopy));
    else {
	if (nc != 1) error(_("invalid '%s' value"), "times");
	
#ifdef LONG_VECTOR_SUPPORT
	double snc = asReal(ncopy);
	if (!R_FINITE(snc) || snc < 0)
	    error(_("invalid '%s' value"), "times");
	nc = (R_xlen_t) snc;
#else
	if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
	    error(_("invalid '%s' value"), "times");
#endif
	R_xlen_t ns = xlength(s);
	PROTECT(a = rep3(s, ns, nc * ns));
    }

#ifdef _S4_rep_keepClass
    if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
	setAttrib(a, R_ClassSymbol, getClassAttrib(s));
	SET_S4_OBJECT(a);
    }
#endif

    if (inheritsCharSXP(s, R_FactorCharSXP)) {
	SEXP tmp;
	if(inheritsCharSXP(s, R_OrderedCharSXP)) {
	    PROTECT(tmp = allocVector(STRSXP, 2));
	    SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
	    SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
	} else PROTECT(tmp = mkString("factor"));
	setAttrib(a, R_ClassSymbol, tmp);
	UNPROTECT(1);
	setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
    }
    UNPROTECT(1);
    return a;
}
示例#9
0
文件: tcltk.c 项目: kmillar/rho
SEXP RTcl_AssignObjToVar(SEXP args)
{
    const void *vmax = vmaxget();
    Tcl_SetVar2Ex(RTcl_interp,
		  translateChar(STRING_ELT(CADR(args), 0)),
		  NULL,
		  (Tcl_Obj *) R_ExternalPtrAddr(CADDR(args)),
		  0);
    vmaxset(vmax);
    return R_NilValue;
}
示例#10
0
文件: print.c 项目: jaw0/jlisp
int prnfunc(Obj a, Obj stream, int how){
	char n;

	if( NNULLP( CADR(a))){
		if( how) return prn_func_macr(a, stream, "closure");
		else writestr(stream, "#<closure>");
	}else{
		if( how) return prn_func_macr(a, stream, "lambda");
		else writestr(stream, "#<lambda>");
	}
	return 1;
}
示例#11
0
/* && || */
SEXP attribute_hidden do_logic2(SEXP call, SEXP op, SEXP args, SEXP env)
{
/*  &&	and  ||	 */
    SEXP s1, s2;
    int x1, x2;
    SEXP ans;

    if (length(args) != 2)
	error(_("'%s' operator requires 2 arguments"),
	      PRIMVAL(op) == 1 ? "&&" : "||");

    s1 = CAR(args);
    s2 = CADR(args);
    PROTECT(ans = allocVector(LGLSXP, 1));
    s1 = eval(s1, env);
    if (!isNumber(s1))
	errorcall(call, _("invalid 'x' type in 'x %s y'"),
		  PRIMVAL(op) == 1 ? "&&" : "||");
    x1 = asLogical(s1);

#define get_2nd							\
	s2 = eval(s2, env);					\
	if (!isNumber(s2))					\
	    errorcall(call, _("invalid 'y' type in 'x %s y'"),	\
		      PRIMVAL(op) == 1 ? "&&" : "||");		\
	x2 = asLogical(s2);

    switch (PRIMVAL(op)) {
    case 1: /* && */
	if (x1 == FALSE)
	    LOGICAL(ans)[0] = FALSE;
	else {
	    get_2nd;
	    if (x1 == NA_LOGICAL)
		LOGICAL(ans)[0] = (x2 == NA_LOGICAL || x2) ? NA_LOGICAL : x2;
	    else /* x1 == TRUE */
		LOGICAL(ans)[0] = x2;
	}
	break;
    case 2: /* || */
	if (x1 == TRUE)
	    LOGICAL(ans)[0] = TRUE;
	else {
	    get_2nd;
	    if (x1 == NA_LOGICAL)
		LOGICAL(ans)[0] = (x2 == NA_LOGICAL || !x2) ? NA_LOGICAL : x2;
	    else /* x1 == FALSE */
		LOGICAL(ans)[0] = x2;
	}
    }
    UNPROTECT(1);
    return ans;
}
示例#12
0
文件: llh.c 项目: nickdrozd/lispinc
Obj transformSugarDef(Obj expr) {
    Obj funcArgs = CADR(expr);
    Obj func = CAR(funcArgs);
    Obj args = CDR(funcArgs);
    Obj body = CDDR(expr);

    Obj lambdaExpr = CONS(LAMBDAOBJ, CONS(args, body));

    Obj transformed = CONS(DEFOBJ, CONS(func, CONS(lambdaExpr, NULLOBJ)));

    return transformed;
}
示例#13
0
SEXP attribute_hidden do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP s, x, sa, so, el;
    R_xlen_t i, len;
    int start, stop, k, l;
    size_t slen;
    cetype_t ienc;
    const char *ss;
    char *buf;

    checkArity(op, args);
    x = CAR(args);
    sa = CADR(args);
    so = CADDR(args);
    k = LENGTH(sa);
    l = LENGTH(so);

    if (!isString(x))
	error(_("extracting substrings from a non-character object"));
    len = XLENGTH(x);
    PROTECT(s = allocVector(STRSXP, len));
    if (len > 0) {
	if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
	    error(_("invalid substring arguments"));

	for (i = 0; i < len; i++) {
	    start = INTEGER(sa)[i % k];
	    stop = INTEGER(so)[i % l];
	    el = STRING_ELT(x,i);
	    if (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); /* FIXME -- should handle embedded nuls */
	    buf = R_AllocStringBuffer(slen+1, &cbuff);
	    if (start < 1) start = 1;
	    if (start > stop || start > slen) {
		buf[0] = '\0';
	    } else {
		if (stop > slen) stop = (int) slen;
		substr(buf, ss, ienc, start, stop);
	    }
	    SET_STRING_ELT(s, i, mkCharCE(buf, ienc));
	}
	R_FreeStringBufferL(&cbuff);
    }
    DUPLICATE_ATTRIB(s, x);
    /* This copied the class, if any */
    UNPROTECT(1);
    return s;
}
示例#14
0
文件: fourier.c 项目: SensePlatform/R
SEXP attribute_hidden do_mvfft(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP z, d;
    int i, inv, maxf, maxp, n, p;
    double *work;
    int *iwork;

    checkArity(op, args);

    z = CAR(args);

    d = getAttrib(z, R_DimSymbol);
    if (d == R_NilValue || length(d) > 2)
	error(_("vector-valued (multivariate) series required"));
    n = INTEGER(d)[0];
    p = INTEGER(d)[1];

    switch(TYPEOF(z)) {
    case INTSXP:
    case LGLSXP:
    case REALSXP:
	z = coerceVector(z, CPLXSXP);
	break;
    case CPLXSXP:
	if (NAMED(z)) z = duplicate(z);
	break;
    default:
	error(_("non-numeric argument"));
    }
    PROTECT(z);

    /* -2 for forward  transform, complex values */
    /* +2 for backward transform, complex values */

    inv = asLogical(CADR(args));
    if (inv == NA_INTEGER || inv == 0) inv = -2;
    else inv = 2;

    if (n > 1) {
	fft_factor(n, &maxf, &maxp);
	if (maxf == 0)
	    error(_("fft factorization error"));
	work = (double*)R_alloc(4 * maxf, sizeof(double));
	iwork = (int*)R_alloc(maxp, sizeof(int));
	for (i = 0; i < p; i++) {
	    fft_factor(n, &maxf, &maxp);
	    fft_work(&(COMPLEX(z)[i*n].r), &(COMPLEX(z)[i*n].i),
		     1, n, 1, inv, work, iwork);
	}
    }
    UNPROTECT(1);
    return z;
}
示例#15
0
文件: builtin.c 项目: o-/Rexperiments
SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP x, ans;

    checkArity(op, args);
    check1arg(args, call, "x");

    x = CAR(args);

    if (PRIMVAL(op)) { /* xlength<- */
	if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
					 rho, &ans, 0, 1))
	    return(ans);
	if (!isVector(x) && !isVectorizable(x))
	    error(_("invalid argument"));
	if (length(CADR(args)) != 1)
	    error(_("invalid value"));
	R_xlen_t len = asVecSize(CADR(args));
	return xlengthgets(x, len);
    }
    if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
				     rho, &ans, 0, 1))
	return(ans);
    if (!isVector(x) && !isVectorizable(x))
	error(_("invalid argument"));
    if (length(CADR(args)) != 1)
	error(_("invalid value"));
    R_xlen_t len = asVecSize(CADR(args));
    if (len < 0) error(_("invalid value"));
    if (len > R_LEN_T_MAX) {
#ifdef LONG_VECTOR_SUPPORT
	return xlengthgets(x, len);
#else
        error(_("vector size specified is too large"));
	return x; /* -Wall */
#endif
    }
    return lengthgets(x, (R_len_t) len);
}
示例#16
0
SEXP setWinProgressBar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    args = CDR(args);
    SEXP ptr = CAR(args);
    winprogressbar *pbar;
    double value;

    pbar = R_ExternalPtrAddr(ptr);
    if(!pbar)
	error("invalid progressbar -- has it been closed?");
    value = pbar->val;
    if(!isNull(CADR(args))) {
	int iv;
	double val = asReal(CADR(args));
	SEXP title = CADDR(args), label = CADDDR(args);
	if (R_FINITE(val) && val >= pbar->min && val <= pbar->max) {
	    iv = pbar->width * (val - pbar->min)/(pbar->max - pbar->min);
	    setprogressbar(pbar->pb, iv);
	    pbar->val = val;
	}
	if (!isNull(title)) {
	    SEXP ctxt;
	    if(!isString(title) || length(title) < 1)
		errorcall(call, "invalid '%s' argument", "title");
	    ctxt = STRING_ELT(title, 0);
	    if (ctxt != NA_STRING)
		settext(pbar->wprog, translateChar(ctxt));
	}
	if(pbar->lab && !isNull(label)) {
	    SEXP clab;
	    if(!isString(label) || length(label) < 1)
		errorcall(call, "invalid '%s' argument", "label");
	    clab = STRING_ELT(label, 0);
	    if (clab != NA_STRING)
		settext(pbar->lab, translateChar(clab));
	}
    }
    return ScalarReal(value);
}
示例#17
0
文件: inspect.cpp 项目: csilles/cxxr
/* internal API - takes one mandatory argument (object to inspect) and
   two optional arguments (deep and pvec - see above), positional argument
   matching only */
SEXP attribute_hidden do_inspect(SEXP call, SEXP op, SEXP args, SEXP env) {
    SEXP obj = CAR(args);
    int deep = -1;
    int pvec = 5;
    if (CDR(args) != R_NilValue) {
	deep = asInteger(CADR(args));
	if (CDDR(args) != R_NilValue)
	    pvec = asInteger(CADDR(args));
    }
	
    inspect_tree(0, CAR(args), deep, pvec);
    return obj;
}
示例#18
0
文件: subr.c 项目: grouzen/fflisp
struct lispobj *subr_cons(struct lispobj *args)
{
    if(length(args) != 2)
        return ERROR_ARGS;

    struct lispobj *car, *cdr, *pair;
    car = CAR(args);
    cdr = CADR(args);

    pair = NEW_CONS(car, cdr);

    return pair;
}
示例#19
0
void StrPtrSBreezeProcedureList (FILE * stream, PtrProcedureList procedures, bool onlyPrintLocals, Scope scopes, char *separator, bool longForm)
{
    while (procedures && (!onlyPrintLocals || CAR (procedures)->nature != ContextMarkerProcedure))
    {
        if ((int) CAR (procedures)->scope & (int) scopes)
        {
            StrPtrSBreezeProcedure (stream, CAR (procedures), longForm);
            if (CDR (procedures) && (onlyPrintLocals ? CADR (procedures)->nature != ContextMarkerProcedure : true))
                fprintf (stream, "%s", separator);
        }
        procedures = CDR (procedures);
    }
}
示例#20
0
文件: expand.c 项目: Card1nal/guile
static SCM
expand_if (SCM expr, SCM env SCM_UNUSED)
{
  const SCM cdr_expr = CDR (expr);
  const long length = scm_ilength (cdr_expr);
  ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
  return CONDITIONAL (scm_source_properties (expr),
                      expand (CADR (expr), env),
                      expand (CADDR (expr), env),
                      ((length == 3)
                       ? expand (CADDDR (expr), env)
                       : VOID (SCM_BOOL_F)));
}
示例#21
0
文件: print.c 项目: grouzen/fflisp
void print(struct lispobj *obj)
{
#ifdef __DEBUG_PRINT__
    printf("[");
#endif /* __DEBUG_PRINT__ */
    if(obj == NULL) {
        printf("NIL");
    } else if(OBJ_TYPE(obj) == ERROR) {
        printf("Error: %s", ERROR_VALUE(obj));
    } else if(OBJ_TYPE(obj) == SYMBOL) {
        printf("%s", SYMBOL_VALUE(obj));
    } else if(OBJ_TYPE(obj) == NUMBER) {
        printf("%d", NUMBER_VALUE(obj));
    } else if(OBJ_TYPE(obj) == STRING) {
        printf("\"%s\"", STRING_VALUE(obj));
    } else {
        if(CAR(obj) == NEW_SYMBOL("PROC")) {
            printf("<procedure ");
            if(CADR(obj) != NEW_SYMBOL("NIL")) {
                print_list(CADR(obj));
            } else {
                printf("()");
            }
            printf(" %p>", CADDDR(obj));
        } else if(CAR(obj) == NEW_SYMBOL("SUBR")) {
            printf("<primitive-procedure %p>", CADR(obj));
        } else {
            print_list(obj);
        }
    }
#ifdef __DEBUG_PRINT__
    if(obj != NULL) {
        printf(" => %d]", OBJ_REFS(obj));
    } else {
        printf(" => nil]");
    }
#endif /* __DEBUG_PRINT__ */
    return;
}
示例#22
0
文件: deriv.c 项目: edzer/cxxr
static SEXP AddParens(SEXP expr)
{
    SEXP e;
    if (TYPEOF(expr) == LANGSXP) {
	e = CDR(expr);
	while(e != R_NilValue) {
	    SETCAR(e, AddParens(CAR(e)));
	    e = CDR(e);
	}
    }
    if (isPlusForm(expr)) {
	if (isPlusForm(CADDR(expr))) {
	    SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
	}
    }
    else if (isMinusForm(expr)) {
	if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))) {
	    SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
	}
    }
    else if (isTimesForm(expr)) {
	if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
	    || isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
	    SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
	}
	if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
	    SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
	}
    }
    else if (isDivideForm(expr)) {
	if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
	    || isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
	    SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
	}
	if (isPlusForm(CADR(expr)) || isMinusForm(CADR(expr))) {
	    SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
	}
    }
    else if (isPowerForm(expr)) {
	if (isPowerForm(CADR(expr))) {
	    SETCADR(expr, lang2(ParenSymbol, CADR(expr)));
	}
	if (isPlusForm(CADDR(expr)) || isMinusForm(CADDR(expr))
	    || isTimesForm(CADDR(expr)) || isDivideForm(CADDR(expr))) {
	    SETCADDR(expr, lang2(ParenSymbol, CADDR(expr)));
	}
    }
    return expr;
}
示例#23
0
文件: tcltk.c 项目: kmillar/rho
SEXP RTcl_ObjFromRawVector(SEXP args)
{
    int count;
    Tcl_Obj *tclobj; 
    SEXP val; 

    val = CADR(args);

    count = length(val);
    tclobj = Tcl_NewByteArrayObj(RAW(val), count);

    return makeRTclObject(tclobj);
}
示例#24
0
文件: tcltk.c 项目: kmillar/rho
SEXP RTcl_ObjFromVar(SEXP args)
{
    Tcl_Obj *tclobj;
    const void *vmax = vmaxget();

    tclobj = Tcl_GetVar2Ex(RTcl_interp,
                           translateChar(STRING_ELT(CADR(args), 0)),
                           NULL,
                           0);
    SEXP res = makeRTclObject(tclobj);
    vmaxset(vmax);
    return res;
}
示例#25
0
文件: builtin.c 项目: sdevlin/yoshi
static struct exp *fn_vector_ref(struct exp *args) {
  err_ensure(exp_list_length(args) == 2,
             "vector-ref requires exactly two arguments, got", args);
  struct exp *vector = CAR(args);
  struct exp *k = CADR(args);
  err_ensure(IS(vector, VECTOR),
             "vector-ref requires a vector argument, got", vector);
  err_ensure(IS(k, FIXNUM),
             "vector-ref requires a numeric index, got", k);
  size_t i = k->value.fixnum;
  err_ensure(i >= 0 && i < vector_length(vector->value.vector),
             "vector-ref requires a valid index, got", k);
  return vector_get(vector->value.vector, i);
}
示例#26
0
文件: expand.c 项目: Card1nal/guile
static SCM
expand_with_fluids (SCM expr, SCM env)
{
  SCM binds, fluids, vals;
  ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
  binds = CADR (expr);
  ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
  for (fluids = SCM_EOL, vals = SCM_EOL;
       scm_is_pair (binds);
       binds = CDR (binds))
    {
      SCM binding = CAR (binds);
      ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
                       binding, expr);
      fluids = scm_cons (expand (CAR (binding), env), fluids);
      vals = scm_cons (expand (CADR (binding), env), vals);
    }

  return DYNLET (scm_source_properties (expr),
                 scm_reverse_x (fluids, SCM_UNDEFINED),
                 scm_reverse_x (vals, SCM_UNDEFINED),
                 expand_sequence (CDDR (expr), env));
}
示例#27
0
文件: mrb4R.c 项目: rcqls/mrb4R
SEXP mrb4R_is_Rvector(SEXP args) {
  SEXP obj,ans;
  mrb_value rbobj;
  //int i,n;

  obj=CADR(args);
  PROTECT(ans=allocVector(LGLSXP,1));  
  if (!inherits(obj, "rbObj"))  {
    LOGICAL(ans)[0]=FALSE;
    UNPROTECT(1);
    return ans;
  }
  rbobj=*((mrb_value*) R_ExternalPtrAddr(CADR(obj)));
  
  if(!rbIsRVector(rbobj)) {
    LOGICAL(ans)[0]=FALSE;
    UNPROTECT(1);
    return ans;
  }
  LOGICAL(ans)[0]=TRUE;
  UNPROTECT(1);
  return ans;
}
示例#28
0
文件: builtin.c 项目: sdevlin/yoshi
static struct exp *fn_make_vector(struct exp *args) {
  size_t len = exp_list_length(args);
  err_ensure(len == 1 || len == 2,
             "make-vector requires exactly one or two arguments, got", args);
  struct exp *k = CAR(args);
  err_ensure(k->type == FIXNUM,
             "make-vector requires a numeric argument, got", k);
  struct exp *fill = len == 2 ? CADR(args) : NIL;
  struct exp *v = exp_make_vector(0);
  size_t i;
  for (i = 0; i < k->value.fixnum; i += 1) {
    vector_push(v->value.vector, fill);
  }
  return v;
}
示例#29
0
文件: registry.c 项目: Bgods/r-source
SEXP readRegistry(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans;
    HKEY hive, hkey;
    LONG res;
    const wchar_t *key;
    int maxdepth, view;
    REGSAM acc = KEY_READ;

    args = CDR(args);
    if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
	error(_("invalid '%s' value"),  "key");
    key = filenameToWchar(STRING_ELT(CAR(args), 0), 0);
    if(!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
	error(_("invalid '%s' value"),  "hive");
    maxdepth = asInteger(CADDR(args));
    if(maxdepth == NA_INTEGER || maxdepth < 1)
	error(_("invalid '%s' value"),  "maxdepth");
    hive = find_hive(CHAR(STRING_ELT(CADR(args), 0)));
    view = asInteger(CADDDR(args));
    /* Or KEY_READ with KEY_WOW64_64KEY or KEY_WOW64_32KEY to
       explicitly access the 64- or 32- bit registry view.  See
       http://msdn.microsoft.com/en-us/library/aa384129(VS.85).aspx
    */
    if(view == 2) acc |= KEY_WOW64_32KEY;
    else if(view == 3) acc |= KEY_WOW64_64KEY;

    res = RegOpenKeyExW(hive, key, 0, acc, &hkey);
    if (res == ERROR_FILE_NOT_FOUND)
	error(_("Registry key '%ls' not found"), key);
    if (res != ERROR_SUCCESS)
	error("RegOpenKeyEx error code %d: '%s'", (int) res, formatError(res));
    ans = readRegistryKey(hkey, maxdepth, view);
    RegCloseKey(hkey);
    return ans;
}
示例#30
0
SEXP jr_func(void* p)
{
    ParseStatus status;
    SEXP s, t, ext;
    s = t = PROTECT(R_ParseVector(
        Rf_mkString("function(...) {.External(\".RCall\", NULL, ...)}"),
        -1, &status, R_NilValue));
    ext = PROTECT(R_MakeExternalPtr(p, R_NilValue, R_NilValue));
    SETCADDR(CADR(CADDR(VECTOR_ELT(t ,0))), ext);
    int errorOccurred = 0;
    SEXP ret;
    ret = PROTECT(R_tryEval(VECTOR_ELT(s,0), R_GlobalEnv, &errorOccurred));
    UNPROTECT(3);
    return ret;
}