Exemplo n.º 1
0
Arquivo: mono.c Projeto: kmizumar/Mono
//deep-bindによる。シンボルが見つからなかったら登録。
//見つかったらそこに値をいれておく。
void bindsym(int symaddr, int valaddr){
        int addr,num;
    char *name;
    
    name = symname(symaddr);
    if((addr=findsym(name)) == NIL){
        addr = freshcell();
        SET_NAME(addr,name);
        SET_CDR(addr,E);
        E = addr;
    }
    switch(GET_TAG(valaddr)){
                case NUM: {     SET_TAG(addr,NUM);
                                num = GET_NUMBER(valaddr);
                    SET_NUMBER(addr,num);
                    break; }
        case SYM: {     SET_TAG(addr,SYM);
                                name = GET_NAME(valaddr);
                                SET_NAME(addr,name);
                                break; }
        case LIS: {     SET_TAG(addr,LIS);
                                SET_BIND(addr,valaddr);
                                break; }
    }
}
Exemplo n.º 2
0
/* Autoload default packages and names from autoloads.h
 *
 * This function behaves in almost every way like
 * R's autoload:
 * function (name, package, reset = FALSE, ...)
 * {
 *     if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
 *        stop("an object with that name already exists")
 *     m <- match.call()
 *     m[[1]] <- as.name("list")
 *     newcall <- eval(m, parent.frame())
 *     newcall <- as.call(c(as.name("autoloader"), newcall))
 *     newcall$reset <- NULL
 *     if (is.na(match(package, .Autoloaded)))
 *        assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv)
 *     do.call("delayedAssign", list(name, newcall, .GlobalEnv,
 *                                                         .AutoloadEnv))
 *     invisible()
 * }
 *
 * What's missing is the updating of the string vector .Autoloaded with the list
 * of packages, which by my code analysis is useless and only for informational
 * purposes.
 *
 */
void autoloads(void){
    SEXP da, dacall, al, alcall, AutoloadEnv, name, package;
    int i,j, idx=0, errorOccurred, ptct;
    
    /* delayedAssign call*/
    PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));
    PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));
    if (AutoloadEnv == R_NilValue){
        fprintf(stderr,"%s: Cannot find .AutoloadEnv!\n", programName);
        exit(1);
    }
    PROTECT(dacall = allocVector(LANGSXP,5));
    SETCAR(dacall,da);
    /* SETCAR(CDR(dacall),name); */          /* arg1: assigned in loop */
    /* SETCAR(CDR(CDR(dacall)),alcall); */  /* arg2: assigned in loop */
    SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv); /* arg3 */
    SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv); /* arg3 */


    /* autoloader call */
    PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));
    PROTECT(alcall = allocVector(LANGSXP,3));
    SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
    SETCAR(alcall,al);
    /* SETCAR(CDR(alcall),name); */          /* arg1: assigned in loop */
    /* SETCAR(CDR(CDR(alcall)),package); */  /* arg2: assigned in loop */

    ptct = 5;
    for(i = 0; i < packc; i++){
        idx += (i != 0)? packobjc[i-1] : 0;
        for (j = 0; j < packobjc[i]; j++){
            /*printf("autload(%s,%s)\n",packobj[idx+j],pack[i]);*/
            
            PROTECT(name = NEW_CHARACTER(1));
            PROTECT(package = NEW_CHARACTER(1));
            SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));
            SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));
            
            /* Set up autoloader call */
            PROTECT(alcall = allocVector(LANGSXP,3));
            SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
            SETCAR(alcall,al);
            SETCAR(CDR(alcall),name);
            SETCAR(CDR(CDR(alcall)),package);

            /* Setup delayedAssign call */
            SETCAR(CDR(dacall),name);
            SETCAR(CDR(CDR(dacall)),alcall);
            
            R_tryEval(dacall,R_GlobalEnv,&errorOccurred);
            if (errorOccurred){
                fprintf(stderr,"%s: Error calling delayedAssign!\n", programName);
                exit(1);
            }
            
            ptct += 3;
        }
    }
    UNPROTECT(ptct);
}
Exemplo n.º 3
0
/* Expand dots in args, but do not evaluate */
static SEXP expandDots(SEXP el, SEXP rho)
{
    SEXP ans, tail;

    PROTECT(el); /* in do_switch, this is already protected */
    PROTECT(ans = tail = CONS(R_NilValue, R_NilValue));

    while (el != R_NilValue) {
	if (CAR(el) == R_DotsSymbol) {
	    SEXP h = findVar(CAR(el), rho);
	    if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
		while (h != R_NilValue) {
		    SETCDR(tail, CONS(CAR(h), R_NilValue));
		    tail = CDR(tail);
		    if(TAG(h) != R_NilValue) SET_TAG(tail, TAG(h));
		    h = CDR(h);
		}
	    } else if (h != R_MissingArg)
		error(_("'...' used in an incorrect context"));
	} else {
	    SETCDR(tail, CONS(CAR(el), R_NilValue));
	    tail = CDR(tail);
	    if(TAG(el) != R_NilValue) SET_TAG(tail, TAG(el));
	}
	el = CDR(el);
    }
    UNPROTECT(2);
    return CDR(ans);
}
/*
 * mm_init - Called when a new trace starts.
 */
int mm_init(void) {   
    if ((first_block = mem_sbrk(3 * WSIZE + NUMBER_OF_LISTS * DSIZE)) 
        == (void *) -1) 
        return -1;

    int list_offset = 2 * NUMBER_OF_LISTS;
    segregated_list = first_block + WSIZE;    

    memset(segregated_list, 0, NUMBER_OF_LISTS * DSIZE);

    /* Alignment padding */
    PUT(first_block, 0);    
    /* Prologue header */ 
    PUT(first_block + ((list_offset + 1)*WSIZE), PACK(WSIZE, 1));
    /* Epilogue header */
    PUT(first_block + ((list_offset + 2)*WSIZE), PACK(0, 1));     

    SET_TAG(first_block + ((list_offset + 1) * WSIZE));
    SET_TAG(first_block + ((list_offset + 2) * WSIZE));
    
    first_block += ((list_offset + 2) * WSIZE);

    /* Extend the empty heap with a free block of CHUNKSIZE bytes */
    if (extend_heap(CHUNKSIZE/WSIZE) == NULL)
        return -1;

    return 0;
}
Exemplo n.º 5
0
int source(char *file){
    SEXP expr, s, f, p;
    int errorOccurred;

    /* Find source function */
    s = Rf_findFun(Rf_install("source"), R_GlobalEnv);
    PROTECT(s);

    /* Make file argument */
    PROTECT(f = NEW_CHARACTER(1));
    SET_STRING_ELT(f, 0, COPY_TO_USER_STRING(file));

    /* Make print.eval argument */
    PROTECT(p = NEW_LOGICAL(1));
    LOGICAL_DATA(p)[0] = (verbose)? TRUE : FALSE;

    /* expression source(f,print.eval=p) */
    PROTECT(expr = allocVector(LANGSXP,3));
    SETCAR(expr,s); 
    SETCAR(CDR(expr),f);
    SETCAR(CDR(CDR(expr)), p);
    SET_TAG(CDR(CDR(expr)), Rf_install("print.eval"));
    
    errorOccurred=0;
    R_tryEval(expr,NULL,&errorOccurred);
    UNPROTECT(4);

    return errorOccurred;
}
Exemplo n.º 6
0
static
cache_entry
bdd_get_entry(cmu_bdd_manager bddm, int tag, cache_entry *bin)
{
  void (*purge_fn)(cmu_bdd_manager, cache_entry);
  cache_entry p;

  if (bin[0] && bin[1])
    {
      p=bin[1];
      purge_fn=bddm->op_cache.purge_fn[TAG(p)];
      p=CACHE_POINTER(p);
      if (purge_fn)
	(*purge_fn)(bddm, p);
      bddm->op_cache.collisions++;
      if (bddm->op_cache.cache_level == 0)
	bin[1]=bin[0];
      else
	++bin;
    }
  else
    {
      p=(cache_entry)BDD_NEW_REC(bddm, sizeof(struct cache_entry_));
      bddm->op_cache.entries++;
      if (bin[0])
	++bin;
    }
  *bin=(cache_entry)SET_TAG(p, tag);
  return (p);
}
Exemplo n.º 7
0
SEXP _as_dots_literal(SEXP list) {
  assert_type(list, VECSXP);
  int len = LENGTH(list);
  SEXP dotlist;
  
  if (len == 0) {
    dotlist = PROTECT(allocVector(VECSXP, 0));
    setAttrib(dotlist, R_ClassSymbol, ScalarString(mkChar("...")));
    UNPROTECT(1);
    return dotlist;
  } else {
    dotlist = PROTECT(allocate_dots(len));
  }
  SEXP names = getAttrib(list, R_NamesSymbol);
  int i;
  SEXP iter;
  
  for (i = 0, iter = dotlist;
       iter != R_NilValue && i < len;
       i++, iter = CDR(iter)) {
    assert_type(CAR(iter), PROMSXP);
    SET_PRVALUE(CAR(iter), VECTOR_ELT(list, i));
    SET_PRCODE(CAR(iter), VECTOR_ELT(list, i));
    SET_PRENV(CAR(iter), R_NilValue);
    if ((names != R_NilValue) && (STRING_ELT(names, i) != R_BlankString)) {
      SET_TAG(iter, install(CHAR(STRING_ELT(names, i)) ));
    }
  }
  setAttrib(dotlist, R_ClassSymbol, ScalarString(mkChar("...")));
  UNPROTECT(1);
  return dotlist;
}
Exemplo n.º 8
0
SEXP rpy_remove(SEXP symbol, SEXP env, SEXP rho)
{
  SEXP c_R, call_R, res, fun_R;

  PROTECT(fun_R = rpy_findFun(install("rm"), rho));

  if(!isEnvironment(rho)) error("'rho' should be an environment");
  /* incantation to summon R */
  PROTECT(c_R = call_R = allocList(2+1));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the name of the variable to be removed */
  SETCAR(c_R, symbol);
  //SET_TAG(c_R, install("list"));
  c_R = CDR(c_R);

  /* second argument is the environment in which the variable 
     should be removed  */
  SETCAR(c_R, env);
  SET_TAG(c_R, install("envir"));
  c_R = CDR(c_R);

  int error = 0;
  PROTECT(res = R_tryEval(call_R, rho, &error));

  UNPROTECT(3);
  return res;
}
Exemplo n.º 9
0
SEXP librinterface_remove(SEXP symbol, SEXP env, SEXP rho)
{
  SEXP c_R, call_R, res;

  static SEXP fun_R = NULL;
  /* Only fetch rm() the first time */
  if (fun_R == NULL) {
    PROTECT(fun_R = librinterface_FindFun(install("rm"), rho));
    R_PreserveObject(fun_R);
    UNPROTECT(1);
  }
  if(!isEnvironment(rho)) error("'rho' should be an environment");
  /* incantation to summon R */
  PROTECT(c_R = call_R = allocList(2+1));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the name of the variable to be removed */
  SETCAR(c_R, symbol);
  //SET_TAG(c_R, install("list"));
  c_R = CDR(c_R);

  /* second argument is the environment in which the variable 
     should be removed  */
  SETCAR(c_R, env);
  SET_TAG(c_R, install("envir"));
  c_R = CDR(c_R);

  int error = 0;
  PROTECT(res = R_tryEval(call_R, rho, &error));

  UNPROTECT(3);
  return res;
}
Exemplo n.º 10
0
SEXP setOption(SEXP tag, SEXP value)
{
    SEXP opt, old, t;
    t = opt = SYMVALUE(Rf_install(".Options"));
    if (!Rf_isList(opt))
        Rf_error("corrupted options list");
    opt = FindTaggedItem(opt, tag);

    /* The option is being removed. */
    if (value == R_NilValue) {
        for ( ; t != R_NilValue ; t = CDR(t))
            if (TAG(CDR(t)) == tag) {
                old = CAR(t);
                SETCDR(t, CDDR(t));
                return old;
            }
        return R_NilValue;
    }
    /* If the option is new, a new slot */
    /* is added to the end of .Options */
    if (opt == R_NilValue) {
        while (CDR(t) != R_NilValue)
            t = CDR(t);
        PROTECT(value);
        SETCDR(t, Rf_allocList(1));
        UNPROTECT(1);
        opt = CDR(t);
        SET_TAG(opt, tag);
    }
    old = CAR(opt);
    SETCAR(opt, value);
    return old;
}
Exemplo n.º 11
0
Arquivo: mlis.c Projeto: kzfm1024/misc
void clrcell(int addr){
    SET_TAG(addr,EMP);
    free(heap[addr].name);
    heap[addr].name = NULL;
    SET_CAR(addr,0);
    SET_CDR(addr,0);
    SET_BIND(addr,0);
}
Exemplo n.º 12
0
void Stage1_6Layer::showAnother()
{
	UnknownBrick* pUnknownBrck =  UnknownBrick::create();
	pUnknownBrck->setLeftBottomPostion(ccp(TILE_SIZE * 25, TILE_SIZE * 9));
	pUnknownBrck->createBox2dObjectWithPolyShape(m_pWorld);		
	SET_TAG(pUnknownBrck, UNKNOWN_2);
	this->addChild(pUnknownBrck, 10);
}
Exemplo n.º 13
0
Arquivo: mlis.c Projeto: kzfm1024/misc
int makenum(int num){
    int addr;
    
    addr = freshcell();
    SET_TAG(addr,NUM);
    SET_NUMBER(addr,num);
    return(addr);
}
Exemplo n.º 14
0
Arquivo: mlis.c Projeto: kzfm1024/misc
int makesym(char *name){
    int addr;
    
    addr = freshcell();
    SET_TAG(addr,SYM);
    SET_NAME(addr,name);
    return(addr);
}
Exemplo n.º 15
0
Arquivo: mono.c Projeto: kmizumar/Mono
//空リストを作る。シンボルnilを空リストとも解釈している。
int makeempty(void){
        int addr;
    
    addr = freshcell();
    SET_TAG(addr,SYM);
    SET_NAME(addr,"nil");
    return(addr);
}
Exemplo n.º 16
0
//シンボルTを返す。
int makeT(void){
	int addr;
    
    addr = freshcell();
    SET_TAG(addr,SYM);
    SET_NAME(addr,"t");
    return(addr);
}
Exemplo n.º 17
0
void Stage1_6Layer::initUnknownBrick()
{
	UnknownBrick* pUnknownBrck =  UnknownBrick::create();
	pUnknownBrck->setLeftBottomPostion(ccp(TILE_SIZE * 15, TILE_SIZE * 8));
	pUnknownBrck->createBox2dObjectWithPolyShape(m_pWorld);	
	pUnknownBrck->m_nCountRemain = TOTAL_COUNT - 2;
	SET_TAG(pUnknownBrck, UNKNOWN_1);
	this->addChild(pUnknownBrck, 10);

	// 这一块和提示字上的?是对应的
	pUnknownBrck =  UnknownBrick::create();
	pUnknownBrck->setLeftBottomPostion(ccp(325, 317));
	pUnknownBrck->createBox2dObjectWithPolyShape(m_pWorld);		
	pUnknownBrck->setVisible(false);
	SET_TAG(pUnknownBrck, UNKNOWN_3);
	this->addChild(pUnknownBrck, 10);
}
Exemplo n.º 18
0
/*
* mm_realloc - Reallocate a block in place, extending the heap if necessary.
* The new block is padded with a buffer to guarantee that the
* next reallocation can be done without extending the heap,
* assuming that the block is expanded by a constant number of bytes
* per reallocation.
*
* If the buffer is not large enough for the next reallocation,
* mark the next block with the reallocation tag. Free blocks
* marked with this tag cannot be used for allocation or
* coalescing. The tag is cleared when the marked block is
* consumed by reallocation, when the heap is extended, or when
* the reallocated block is freed.
*/
void *mm_realloc(void *ptr, size_t size)
{
void *new_ptr = ptr; /* Pointer to be returned */
size_t new_size = size; /* Size of new block */
int remainder; /* Adequacy of block sizes */
int extendsize; /* Size of heap extension */
int block_buffer; /* Size of block buffer */
/* Filter invalid block size */
if (size == 0)
return NULL;
/* Adjust block size to include boundary tag and alignment requirements */
if (new_size <= DSIZE) {
new_size = 2 * DSIZE;
} else {
new_size = DSIZE * ((new_size + (DSIZE) + (DSIZE - 1)) / DSIZE);
}
/* Add overhead requirements to block size */
new_size += BUFFER;
/* Calculate block buffer */
block_buffer = GET_SIZE(HEAD(ptr)) - new_size;
/* Allocate more space if overhead falls below the minimum */
if (block_buffer < 0) {
/* Check if next block is a free block or the epilogue block */
if (!GET_ALLOC(HEAD(NEXT(ptr))) || !GET_SIZE(HEAD(NEXT(ptr)))) {
remainder = GET_SIZE(HEAD(ptr)) + GET_SIZE(HEAD(NEXT(ptr))) - new_size;
if (remainder < 0) {
extendsize = MAX(-remainder, CHUNKSIZE);
if (extend_heap(extendsize) == NULL)
return NULL;
remainder += extendsize;
}
delete_node(NEXT(ptr));
// Do not split block
PUT_NOTAG(HEAD(ptr), PACK(new_size + remainder, 1)); /* Block header */
PUT_NOTAG(FOOT(ptr), PACK(new_size + remainder, 1)); /* Block footer */
} else {
new_ptr = mm_malloc(new_size - DSIZE);
//line_count--;
memmove(new_ptr, ptr, MIN(size, new_size));
mm_free(ptr);
//line_count--;
}
block_buffer = GET_SIZE(HEAD(new_ptr)) - new_size;
}
/* Tag the next block if block overhead drops below twice the overhead */
if (block_buffer < 2 * BUFFER)
SET_TAG(HEAD(NEXT(new_ptr)));
/*
// Check heap for consistency
line_count++;
if (CHECK && CHECK_REALLOC) {
mm_check('r', ptr, size);
}
*/
/* Return reallocated block */
return new_ptr;
}
Exemplo n.º 19
0
Arquivo: mlis.c Projeto: kzfm1024/misc
int cons(int car, int cdr){
    int addr;
    
    addr = freshcell();
    SET_TAG(addr,LIS);
    SET_CAR(addr,car);
    SET_CDR(addr,cdr);
    return(addr);
}
Exemplo n.º 20
0
SEXP InstanceObjectTable::superClosure() const {
  static SEXP qtbaseNS = R_FindNamespace(mkString("qtbase"));
  static SEXP qinvokeSym = install("qinvokeSuper");
  SEXP f, pf, body;
  PROTECT(f = allocSExp(CLOSXP));
  SET_CLOENV(f, qtbaseNS);
  pf = allocList(2);
  SET_FORMALS(f, pf);
  SET_TAG(pf, R_NameSymbol);
  SETCAR(pf, R_MissingArg);
  pf = CDR(pf);
  SET_TAG(pf, R_DotsSymbol);
  SETCAR(pf, R_MissingArg);
  PROTECT(body =
          lang4(qinvokeSym, _instance->sexp(), R_NameSymbol, R_DotsSymbol));
  SET_BODY(f, body);
  UNPROTECT(2);
  return f;
}
Exemplo n.º 21
0
Arquivo: mlis.c Projeto: kzfm1024/misc
void bindfunc1(char *name, int addr){
    int sym,val;
    
    sym = makesym(name);
    val = freshcell();
    SET_TAG(val,FUNC);
    SET_BIND(val,addr);
    SET_CDR(val,0);
    bindsym(sym,val);
}
Exemplo n.º 22
0
Arquivo: mlis.c Projeto: kzfm1024/misc
void bindfunc(char *name, tag tag, int(*func)(int)){
    int sym,val;
    
    sym = makesym(name);
    val = freshcell();
    SET_TAG(val,tag);
    SET_SUBR(val,func);
    SET_CDR(val,0);
    bindsym(sym,val);
}
Exemplo n.º 23
0
Arquivo: mono.c Projeto: kmizumar/Mono
void initcell(void){
        int addr,addr1;
    
    for(addr=0; addr < HEAPSIZE; addr++){
        heap[addr].tag = EMP;
        heap[addr].cdr = addr+1;
    }
    H = 0;
    
    //0番地はnil、1番地はTとして環境レジスタを設定する。初期環境
    addr = freshcell(); //symbol nil
    SET_TAG(addr,SYM);
    SET_NAME(addr,"nil");
    addr1 = freshcell(); //symbol t
    SET_TAG(addr1,SYM);
    SET_NAME(addr1,"t");
        SET_CDR(addr1,addr);
    E = addr1;
}
Exemplo n.º 24
0
Arquivo: arrr.c Projeto: tony2001/arrr
/* {{{ proto mixed R::parseEval(string code[, mixed &result])
 
 */
static PHP_METHOD(R, parseEval)
{ 
	char *code;
	int code_len, error_occured = 0;
	SEXP e1, e2, tmp, val_parse, val, next;
	zval *result = NULL;

	if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "s|z/", &code, &code_len, &result) == FAILURE) {
		return;
	}

	if (result) {
		zval_dtor(result);
		ZVAL_NULL(result);
	}

	PROTECT(e1 = allocVector(LANGSXP, 2));
	SETCAR(e1, Rf_install("parse"));
	SETCAR(CDR(e1), tmp = NEW_CHARACTER(1));
	SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(code));

	next = CDR(e1);
	SET_TAG(next, Rf_install("text"));

	val_parse = R_tryEval(e1, R_GlobalEnv, &error_occured);
	if (error_occured) {
		UNPROTECT(1);
		RETURN_FALSE;
	}

	/* okay, the call succeeded */
	PROTECT(val_parse);

	PROTECT(e2 = allocVector(LANGSXP, 2));
	SETCAR(e2, Rf_install("eval"));
	SETCAR(CDR(e2), val_parse);

	UNPROTECT(1);

	val = R_tryEval(e2, R_GlobalEnv, &error_occured);
	if (error_occured) {
		UNPROTECT(2);
		RETURN_FALSE;
	}

	if (result) {
		php_r_to_zval(val, result);
		UNPROTECT(2);
		RETURN_TRUE;
	} else {
		php_r_to_zval(val, return_value);
		UNPROTECT(2);
	}
}
Exemplo n.º 25
0
SEXP exprToFunction(int nVariables, const char **vaList, SEXP rExpr)  {
  PROTECT(rExpr);
  SEXP charList, rChar, pl;
  SEXP rFunc;
  PROTECT(rFunc= allocSExp(CLOSXP));
  SET_CLOENV(rFunc, R_GlobalEnv);
  int i = 0, warn= 0, n= 0;
  if(nVariables > 0) {
  PROTECT(charList = allocVector(STRSXP, nVariables));
  
  for(int i=0; i < nVariables; i++){ //TODO STRSXP fill
    PROTECT(rChar= mkChar(vaList[i]));
    SET_STRING_ELT(charList, i, rChar);
    UNPROTECT(1);
  }
  PROTECT(charList= VectorToPairList(charList));
  n= length(charList);
  if(n > 0) { 
    PROTECT(pl = allocList(n));
    if(n == 1) {
      SET_TAG(pl, CreateTag(CAR(charList)));
      SETCAR(pl, R_MissingArg);
               }
     else
     { SET_TAG(pl, CreateTag(CAR(charList)));
       SETCAR(pl, R_MissingArg);
       SEXP nextpl= CDR(pl);
       SEXP nextChar= CDR(charList);
       for (i= 1; i < n; i++, nextpl = CDR(nextpl), nextChar = CDR(nextChar)) {
        SET_TAG(nextpl, CreateTag(CAR(nextChar)));
	SETCAR(nextpl, R_MissingArg);
        }
     }  
   } }
  SET_FORMALS(rFunc, pl); 
  SET_BODY(rFunc, rExpr);
  //setAttrib(rFunc, R_SourceSymbol, eval(lang2(install("deparse"), rFunc), R_BaseEnv)); // TODO: Deparse not necessary
  if(n > 0) {UNPROTECT(1);}
  UNPROTECT(4); 
  return rFunc;
}
/* place - 
 * Places the requested block at the beginning of the freeblock, and splitting * only if the size of the remainder block would equal or exceed the minimum  * block size */
static void place(void *bp, size_t asize) {
    size_t csize = GET_SIZE(HDRP(bp));   
    size_t remainder = csize - asize;

    if (remainder >= (MINSIZE * WSIZE)) {          
        remove_from_list(find_list(GET_SIZE(HDRP(bp))), bp);
        SET_SIZE(HDRP(bp), asize);
        SET_ALLOC(HDRP(bp));
        bp = NEXT_BLKP(bp);
        SET_SIZE(HDRP(bp), remainder);
        SET_SIZE(FTRP(bp), remainder);
        UNSET_ALLOC(HDRP(bp));
        UNSET_ALLOC(FTRP(bp));        
        SET_TAG(HDRP(bp));
        SET_TAG(FTRP(bp));        
        add_to_list(find_list(GET_SIZE(HDRP(bp))), bp);
    }else { 
        remove_from_list(find_list(GET_SIZE(HDRP(bp))), bp);
        SET_ALLOC(HDRP(bp));
        SET_TAG(HDRP(NEXT_BLKP(bp)));
    }
}
Exemplo n.º 27
0
Error RFunction::call(SEXP evalNS, SEXP* pResultSEXP, sexp::Protect* pProtect)
{
   // verify the function
   if (functionSEXP_ == R_UnboundValue)
   {
      Error error(errc::SymbolNotFoundError, ERROR_LOCATION);
      if (!functionName_.empty())
         error.addProperty("symbol", functionName_);
      return error;
   }
   
   // create the call object (LANGSXP) with the correct number of elements
   SEXP callSEXP ;
   pProtect->add(callSEXP = Rf_allocVector(LANGSXP, 1 + params_.size()));
   SET_TAG(callSEXP, R_NilValue); // just like do_ascall() does 
   
   // assign the function to the first element of the call
   SETCAR(callSEXP, functionSEXP_);
   
   // assign parameters to the subseqent elements of the call
   SEXP nextSlotSEXP = CDR(callSEXP);
   for (std::vector<Param>::const_iterator 
            it = params_.begin(); it != params_.end(); ++it)
   {
      SETCAR(nextSlotSEXP, it->valueSEXP);
      // parameters can optionally be named
      if (!(it->name.empty()))
         SET_TAG(nextSlotSEXP, Rf_install(it->name.c_str()));
      nextSlotSEXP = CDR(nextSlotSEXP);
   }
   
   // call the function
   Error error = evaluateExpressions(callSEXP, evalNS, pResultSEXP, pProtect);  
   if (error)
      return error;
   
   // return success
   return Success();
}
/*
 * coalesce - Implements boundary-tag coalescing to merge the input block 
 * with any adjacent free blocks in constant time.
 */
static void *coalesce(void *bp) {
    size_t prev_alloc = GET_PREV_ALLOC(HDRP(bp));
    size_t next_alloc = GET_ALLOC(HDRP(NEXT_BLKP(bp)));
    size_t size = GET_SIZE(HDRP(bp));

    if (prev_alloc && next_alloc) {            /* Case 1 */
        UNSET_TAG(HDRP(NEXT_BLKP(bp)));    
        add_to_list(find_list(GET_SIZE(HDRP(bp))), bp);
        return bp;
    }
    else if (prev_alloc && !next_alloc) {      /* Case 2 */
        remove_from_list(find_list(GET_SIZE(HDRP(NEXT_BLKP(bp)))), NEXT_BLKP(bp));
        size += GET_SIZE(HDRP(NEXT_BLKP(bp)));
        PUT(HDRP(bp), PACK(size, 0));
        PUT(FTRP(bp), PACK(size,0));
        SET_TAG(HDRP(bp));
        SET_TAG(FTRP(bp));
    }
    else if (!prev_alloc && next_alloc) {      /* Case 3 */
        remove_from_list(find_list(GET_SIZE(HDRP(PREV_BLKP(bp)))), PREV_BLKP(bp));
        size += GET_SIZE(HDRP(PREV_BLKP(bp)));
        SET_SIZE(FTRP(bp), size);
        SET_SIZE(HDRP(PREV_BLKP(bp)), size);
        bp = PREV_BLKP(bp);
    }
    else {                                     /* Case 4 */
        remove_from_list(find_list(GET_SIZE(HDRP(PREV_BLKP(bp)))), PREV_BLKP(bp));
        remove_from_list(find_list(GET_SIZE(HDRP(NEXT_BLKP(bp)))), NEXT_BLKP(bp));
        size += GET_SIZE(HDRP(PREV_BLKP(bp))) +  GET_SIZE(FTRP(NEXT_BLKP(bp)));
        SET_SIZE(HDRP(PREV_BLKP(bp)), size);
        SET_SIZE(FTRP(NEXT_BLKP(bp)), size);
        bp = PREV_BLKP(bp);
    }
    
    UNSET_TAG(HDRP(NEXT_BLKP(bp)));    
    add_to_list(find_list(GET_SIZE(HDRP(bp))), bp);

    return bp;
}
Exemplo n.º 29
0
Arquivo: swap.c Projeto: xcw0579/mudOS
/*
 * Reload line number information from swap.
 */
void load_line_numbers(program_t *  prog)
{
    int size;

    if (prog->line_info)
	return;

    debug(d_flag, ("Unswap line numbers for /%s\n", prog->name));

    size = swap_in((char **) &prog->file_info, prog->line_swap_index);
    SET_TAG(prog->file_info, TAG_LINENUMBERS);
    prog->line_info = (unsigned char *)&prog->file_info[prog->file_info[1]];
    line_num_bytes_swapped -= size;
}
Exemplo n.º 30
0
SEXP rpy_devoff(SEXP devnum, SEXP rho)
{
  SEXP c_R, call_R, res, fun_R;

#ifdef RPY_DEBUG_GRDEV
    printf("rpy_devoff(): checking 'rho'.\n");
#endif
  if(!isEnvironment(rho)) {
#ifdef RPY_DEBUG_GRDEV
    printf("rpy_devoff(): invalid 'rho'.\n");
#endif
    error("'rho' should be an environment\n");
  }

#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): Looking for dev.off()...\n");
#endif
  PROTECT(fun_R = rpy2_findfun(install("dev.off"), rho));
  if (fun_R == R_UnboundValue)
    printf("dev.off() could not be found.\n");
#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): found.\n");
#endif


  /* incantation to summon R */
  PROTECT(c_R = call_R = allocList(2));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the device number to be closed */
  SETCAR(c_R, devnum);
  SET_TAG(c_R, install("which"));
  c_R = CDR(c_R);
  int error = 0;

#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): R_tryEval()\n");
#endif

  PROTECT(res = R_tryEval(call_R, rho, &error));

#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): unprotecting.\n");
#endif

  UNPROTECT(3);
  return res;
}