void *kalloc(unsigned int len){
Bucket *bdesc;
struct _bucket_dir *bdir;
void *retval = NULL;
for(bdir = bucket_dir;bdir->size;bdir++)
if(bdir->size > len)
break;
if(!bdir->size) panic("Don't alloc the memory!\n");
lock();
for(bdesc = bdir->bucket;bdesc;bdesc = bdesc->next)
if(bdesc->freeptr)
break;
if(isnull(bdesc)){
char *cp = NULL;
if(isnull(free_bucket)) bucket_init();
bdesc = free_bucket;
free_bucket = free_bucket->next;
bdesc->refcnt = 0;
bdesc->bucket_size = bdir->size;
bdesc->page = bdesc->freeptr = cp = (void *)(get_kfree_page());
if(isnull(cp)) panic("Out of memory in kernel malloc()\n");
for(int i = PAGE_SIZE / bdir->size;i > 1;i--){
*((char **)cp) = cp + bdir->size;
cp += bdir->size;
}
*((char **)cp) = NULL;
bdesc->next = bdir->bucket;
bdir->bucket = bdesc;
}
retval = bdesc->freeptr;
bdesc->freeptr = *((void **) retval);
bdesc->refcnt++;
unlock();
return retval;
}
/* Return the division of the expressions */
static exp_t *
prim_div(exp_t *args)
{
if (isnull(args))
everr("/: need at least one argument -- given", null);
else if(isnull(cdr(args)))
return divs(nfixnum(1), car(args));
return foldl(divs, car(args), cdr(args));
}
/* Return the cumulated substraction of the arguments */
static exp_t *
prim_sub(exp_t *args)
{
if (isnull(args))
everr("- : need at least one argument, given", null);
else if (isnull(cdr(args)))
return sub(nfixnum(0), car(args));
return foldl(sub, car(args), cdr(args));
}
static char *next_att(const char *buf)
{
while (!isspace(*buf) && !isnull(*buf))
buf++;
if (isnull(*buf) || isnull(*(buf + 1)))
return NULL;
else
while (isspace(*(buf + 1)) && !isnull(*(buf + 1)))
buf++;
buf++;
return (char *)buf;
}
/* Check if the primitive has the right number of arguments */
static inline void
chkargs(char *name, exp_t *args, int num)
{
exp_t *ep;
int n;
for (ep = args, n = num; n-- && !isnull(ep); ep = cdr(ep))
;
if (n != -1 || !isnull(ep))
RAISE1(eval_error, "%s: expects %d arguments, given %s",
name, num, tostr(args));
}
void CVarianceDecomposition::aestimateHeritability(VectorXd* out, const MatrixXd& Y, const MatrixXd& fixed, const MatrixXd& K)
{
/*
* estimates the genetic and the noise variance and creates a matrirx object to return them
*/
MatrixXd covs;
if(isnull(fixed))
covs = MatrixXd::Ones(Y.rows(),1);
else
covs = fixed;
//use mixed model code to estimate heritabiltiy
CLMM lmm;
lmm.setK(K);
lmm.setSNPs(MatrixXd::Zero(K.rows(),1));
lmm.setPheno(Y);
lmm.setCovs(covs);
lmm.setVarcompApprox0(-20, 20, 1000);
lmm.process();
mfloat_t delta0 = exp(lmm.getLdelta0()(0,0));
mfloat_t Vtotal = exp(lmm.getLSigma()(0,0));
VectorXd rv = VectorXd(2);
rv(0) = Vtotal;
rv(1) = Vtotal*delta0;
(*out) =rv;
}
object_t primitive_isnull(object_t argl) {
if(isnull(car(argl))) {
return obj_new_symbol("#t");
} else {
return obj_new_symbol("#f");
}
}
void printdata(struct BSTnode * pt)
{
if( isnull(pt) )//it will not print the data when the pt is NULL;
return ;
printf("[addr:%p \tdata : %d]\n",pt,pt->data);
return ;
}
void onSet_SW_F(SEXP SW_F_construct) {
int i, j;
SEXP ProjDir;
SEXP FilesIn;
SEXP Rweather_prefix;
SEXP Routput_prefix;
PROTECT(ProjDir = GET_SLOT(SW_F_construct, install("ProjDir")));
//_ProjDir = R_alloc(strlen(CHAR(STRING_ELT(ProjDir,0))));
strcpy(_ProjDir, CHAR(STRING_ELT(ProjDir,0)));
PROTECT(FilesIn = GET_SLOT(SW_F_construct, install("InFiles")));
j = LENGTH(FilesIn);
for(i=0;i<SW_NFILES;i++)
if (!isnull(InFiles[i])) {
Mem_Free(InFiles[i]);
}
for (i = 0; i < j; i++) {
InFiles[i] = Str_Dup(CHAR(STRING_ELT(FilesIn,i)));
}
PROTECT(Rweather_prefix = GET_SLOT(SW_F_construct, install("WeatherPrefix")));
//weather_prefix = R_alloc(strlen(CHAR(STRING_ELT(Rweather_prefix,0))));
strcpy(weather_prefix, CHAR(STRING_ELT(Rweather_prefix,0)));
PROTECT(Routput_prefix = GET_SLOT(SW_F_construct, install("OutputPrefix")));
//output_prefix = R_alloc(strlen(CHAR(STRING_ELT(Routput_prefix,0))));
strcpy(output_prefix, CHAR(STRING_ELT(Routput_prefix,0)));
UNPROTECT(4);
}
int delnode(struct BSTnode *pt)
{
if( isnull(pt)){
return -1;
}
}
muint_t ACovarianceFunction::Kdim() const
{
if(isnull(X))
throw CLimixException("ACovarianceFunction: cannot query covariance dimension without X!");
//standard: use X to determine dimension:
return X.rows();
}
void CLinearMean::aEvaluate(MatrixXd* outY)
{
checkDimensions(weights,fixedEffects,Y, true, true, true);
*outY = this->Y;
if (!isnull(this->weights))
*outY -= (this->fixedEffects * this->weights);
}
int BSTsearch(const struct BSTnode * pt,const DataType key)// recurency implementation
{
static int recdeep = 0;// count the recerency deepth
recdeep ++;
if( isnull(pt) ){
if(1 == recdeep){
recdeep = 0;
return -1;// the intput (pt) is null;
}
else{
recdeep = 0;
return 0;// the pt doesn't contain the key;
}
}
const struct BSTnode * pbst = pt;
if( key == pbst->data){
printf("[deepth: %d]\t",recdeep);
BSTsearch(pbst->rnode,key);//keep searching
recdeep = 0;
return 1;//the pt does constain the key;
}else if(key < pbst-> data){
//printf("%d\t",pbst->data);
return BSTsearch(pbst->lnode,key);
}else{
//printf("%d\t",pbst->data);
return BSTsearch(pbst->rnode,key);
}
}
const char *check_pars(parameters *p, char *buff,int *bufflen) {
// a static message - just holds the last one
static char c[1023];
*bufflen+=sprintf(buff,"Checking parameters read from infile file\n",buff);
if (p->g.sizemodel>0&&(!p->usetheta)&&isnullpriorval(&p->g.alpha))
return "parameters incorrect - exponential growth with N and mu but with no prior for alpha\n";
if (p->g.sizemodel>0&&p->usetheta&&isnullpriorval(&p->g.omega))
return "parameters incorrect - exponential growth using theta with no prior"
" for omega\n";
if (fopen(p->datafilename,"r")==0) {
sprintf(c,"Data file %s does not exist - please try again\n",p->datafilename);
return c;
}
if ( (!isnullpriorval(&p->g.N))&&(isnull(&p->muprior[1])))
return "parameters incorrect, have defined Nprior but not muprior";
if (p->usetheta&&!isnullpriorval(&p->g.N))
return "parameters incorrect, have defined Nprior but using thetaprior";
if (p->migmodel) {
if (fopen(p->locationfilename,"r")==0) {
sprintf(c,"Location file %s does not exist and you selected a splitting model\n "
"Either select a non-splitting model or a new location file",p->locationfilename);
return c;
}
if (p->splitprior.prtype==NULLPRIOR)
return "you selected a splitting model, but split prior is not defined";
if (p->propprior.prtype!=DIRICHLET) {
// printprior(stdout,p->propprior,"\n");
return "you selected a splitting model, but proportion prior is not defined";
}
if (p->propprior.par[1]<=0.)
return "parameter of exchangeable Dirichlet prior must be greater than 0";
}
if (p->g.sizemodel==2) {
if (!isnullpriorval(&p->g.beta)) {
if (!isnullpriorval(&p->g.kappa))
return "parameters incorrect - exponential growth from base \n"
"with priors for both beta and kappa"
"we require a prior for one of these";
} else {
if (isnullpriorval(&p->g.kappa))
return "parameters incorrect - exponential growth from base \n"
"with no priors for beta or kappa";
}
}
/*
if (p->seed<1)
return "random number seed should be greater than zero";
*/
return NULL;
}
void represent(const list p)
{
if (isnull(p))
puts("[]");
putchar('[');
for (node *q = p->body; q!= NULL; q = q->next)
printf("%d%s", q->val, (q->next != NULL) ? ", " : "]\n");
}
FILE * OpenFile(const char *name, const char *mode) {
FILE *fp;
fp = fopen(name, mode);
if (isnull(fp))
LogError(stdout, LOGERROR | LOGEXIT, "Cannot open file %s: %s", name, strerror(errno));
return (fp);
}
void SW_VES_deconstruct(void)
{
OutPeriod pd;
IntU i;
// De-allocate parameters
if (SW_VegEstab.count > 0)
{
for (i = 0; i < SW_VegEstab.count; i++)
{
Mem_Free(SW_VegEstab.parms[i]);
SW_VegEstab.parms[i] = NULL;
}
Mem_Free(SW_VegEstab.parms);
SW_VegEstab.parms = NULL;
}
ForEachOutPeriod(pd)
{
// De-allocate days and parameters
if (SW_VegEstab.count > 0)
{
if (!isnull(SW_VegEstab.p_oagg[pd]->days)) {
Mem_Free(SW_VegEstab.p_oagg[eSW_Year]->days);
}
if (!isnull(SW_VegEstab.p_accu[pd]->days)) {
Mem_Free(SW_VegEstab.p_accu[eSW_Year]->days);
}
}
// De-allocate output structures
if (pd > eSW_Day && !isnull(SW_VegEstab.p_oagg[pd])) {
Mem_Free(SW_VegEstab.p_oagg[pd]);
SW_VegEstab.p_oagg[pd] = NULL;
}
if (!isnull(SW_VegEstab.p_accu[pd])) {
Mem_Free(SW_VegEstab.p_accu[pd]);
SW_VegEstab.p_accu[pd] = NULL;
}
}
}
int g1 (/*@null@*/ int *y)
{
if (isnull (y))
{
return 0;
}
return *y;
}
void ACovarianceFunction::agetParamBounds(CovarParams* lower,
CovarParams* upper) const {
//query intrinsic bound
agetParamBounds0(lower,upper);
//override if needed
if(!isnull(bound_upper))
{
for (muint_t i=0; i<this->numberParams; i++)
if ((this->bound_lower)(i)>(*lower)(i)) (*lower)(i)=(this->bound_lower)(i);
}
if(!isnull(bound_lower))
{
for (muint_t i=0; i<this->numberParams; i++)
if ((this->bound_upper)(i)<(*upper)(i)) (*upper)(i)=(this->bound_upper)(i);
}
}
void list_extend(list *pp1, const list *pp2)
{
if (isnull(*pp1))
*pp1 = *pp2;
node *q = *pp1;
while (q->next != NULL)
q = q->next;
q->next = *pp2;
}
void print_table(str s, const Dtable& T, bool latex, Slist labels) {
int SIZE = 7;
int MAXSIZE = 10;
int MAXLINE = 50;
int STANDARDSIZE = 1;
bool square(true);
int l = T.size();
if (MAXLINE<l) printf("Cautious, table is of size %d, only %d will be displayed \n",l,MAXLINE);
int cc = T[0].size();
for (int i=0; i<l; i++) if (T[i].size()!=cc) square = false;
int max = max_row(T);
List maxRow = initList(max);
if (square) {
Table sizestr = initTable(l,max);
for (int i=0; i<l; i++) {
for (int j=0; j<max; j++) {
int sz = f(T[i][j]).size()+1;
sizestr[i][j] = sz<MAXSIZE ? sz : MAXSIZE;
}
}
maxRow = max_on_row(sizestr);
}
else maxRow = initList(max,STANDARDSIZE);
str et = latex ? " &" : "|";
str slash = latex ? " \\\\ \n" : "\n";
str rrr(T[0].size(),'r');
printf("%s", s.c_str());
printf("\n");
bool labelsB = isnull(labels);
str space(6,' ');
printf("%s", space.c_str());
//rnc 10/25/15
printf("Obs. made ");
for (int j=0; j<6;j++){
//for (int j=0; j<max; j++) {
str s = (j==max-1) ? slash : et;
printf("%s%s",format(maxRow[j],f(j)).c_str(),s.c_str());
}
printf("initial& fibers&obs'rvd&percent& wght'd\\\\ \n");
for (int i=0; i<l && i<MAXLINE; i++) {
str pre = labelsB ? f(i) : format(11,labels[i]);
printf("%3s %s",pre.c_str(),et.c_str());
int c = T[i].size();
if (c==0) printf("\n");
for (int j=0; j<c; j++) {
str s = (j==c-1) ? slash : et;
str num = T[i][j]==-1 ? "" : f(T[i][j]).c_str();
printf("%s%s",format(maxRow[j],num).c_str(),s.c_str());
}
}
printf("\n");
}
List list_extend(List ls1, List ls2)
{
if (isnull(ls1))
return ls2;
node *q = ls1;
while (q->next != NULL)
q = q->next;
q->next = ls2;
return ls1;
}
/* Return the accumulation of the expression combined with the
procedure f */
static exp_t *
foldl(exp_t *(*f)(), exp_t *init, exp_t *lst)
{
exp_t *acc;
for (acc = init; !isnull(lst); lst = cdr(lst))
if ((acc = f(acc, car(lst))) == NULL)
return NULL;
return acc;
}
Bool GetALine(FILE *f, char buf[]) {
/* Read a line of possibly commented input from the file *f.
* Skip blank lines and comment lines. Comments within the
* line are removed and trailing whitespace is removed.
*/
char *p;
Bool not_eof = FALSE;
while (!isnull( fgets(buf, 1024, f) )) {
if (!isnull( p=strchr(buf, (int) '\n')))
*p = '\0';
UnComment(buf);
if (*buf != '\0') {
not_eof = TRUE;
break;
}
}
return (not_eof);
}
static void init_media_clock_server(chanend media_clock_ctl)
{
media_clock_svr = media_clock_ctl;
if (!isnull(media_clock_ctl)) {
for (int i=0;i<AVB_NUM_MEDIA_OUTPUTS;i++) {
xc_abi_outuint(media_clock_svr, outputs[i].fifo);
}
}
}
object_t primitive_print(object_t argl) {
while(!isnull(argl)) {
if(!isstring(car(argl)))
print_object(car(argl));
else
printf("%s", obj_get_string(car(argl)));
argl = cdr(argl);
}
return NULL;
}
Bool MkDir(const char *dname) {
/* make a path with 'mkdir -p' -like behavior. provides an
* interface for portability problems.
* RELATIVE PATH ONLY solves problems like "C:\etc" and null
* first element in absolute path.
* if you need to make an absolute path, use ChDir() first.
* if you care about mode of new dir, use mkdir(), not MkDir()
* if MkDir returns FALSE, check errno.
*
* Notes:
* - portability issues seem to be quite problematic, at least
* between platforms and GCC and Borland. The only common
* error code is EACCES, so if something else happens (and it
* well might in unix), more tests have to be included, perhaps
* with macros that test the compiler/platform.
* - we're borrowing errstr to build the path to facilitate the
* -p behavior.
*/
int r, i, n;
Bool result = TRUE;
char *a[256] = { 0 }, /* points to each path element for mkdir -p behavior */
*delim = "\\/", /* path separators */
*c; /* duplicate of dname so we don't change it */
if (isnull(dname))
return FALSE;
if (NULL == (c = strdup(dname))) {
fprintf(stderr, "Out of memory making string in MkDir()");
exit(-1);
}
n = 0;
a[n++] = strtok(c, delim);
while (NULL != (a[n++] = strtok(NULL, delim)))
; /* parse path */
n--;
errstr[0] = '\0';
for (i = 0; i < n; i++) {
strcat(errstr, a[i]);
if (!DirExists(errstr)) {
if (0 != (r = mkdir(errstr, 0777))) {
if (errno == EACCES) {
result = FALSE;
break;
}
}
}
strcat(errstr, "/");
}
return result;
}
int reduce(int (*pf)(int, int), const list p)
{
if (isnull(p)) {
fprintf(stderr, "reduce() of empty list.\n");
exit(EXIT_WRONG_ARG);
}
int result = p->val;
for (node *q = p->next; q != NULL; q = q->next)
result = (*pf)(result, q->val);
return result;
}
//check whether a *char is a number
int isdigit_all(char *str)
{
if (isnull(str))
return 0;
while (*str != '\0')
{
if (!isdigit(*str++))
return 0;
}
return 1;
}
/* Fold (left) across an argument list, applying one of the num wrappers above */
object_t num_primitive(object_t argl, int (*f) (int, int)) {
int result = obj_get_number(car(argl));
argl = cdr(argl);
int arg;
while(!isnull(argl)) {
arg = obj_get_number(car(argl));
result = f(result, arg);
argl = cdr(argl);
}
object_t ret = obj_new_number(result);
return ret;
}
