void marker_loglik(int n_ind, int n_gen, int *geno,
double error_prob, double initf(int, int *),
double emitf(int, int, double, int *),
double *loglik)
{
int i, v;
double temp;
int cross_scheme[2];
/* cross scheme hidden in loglik argument; used by hmm_bcsft */
cross_scheme[0] = (int) ftrunc(*loglik / 1000.0);
cross_scheme[1] = ((int) *loglik) - 1000 * cross_scheme[0];
*loglik = 0.0;
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
temp = initf(1, cross_scheme) + emitf(geno[i], 1, error_prob, cross_scheme);
for(v=1; v<n_gen; v++)
temp = addlog(temp, initf(v+1, cross_scheme) + emitf(geno[i], v+1, error_prob, cross_scheme));
(*loglik) += temp;
}
}
int scot(FILE *inf, FILE *outf, char *fil)
{
char s[128];
Inst *insttop, *ip;
initf(inf, outf, fil);
if (findword(s) || strcmp(s, "orchestra"))
scotferror(Str("Score must start with orchestra section"));
readorch(&insttop);
for (;;) {
if (findword(s))
break;
if (!strcmp(s, "functions"))
readfunctions();
else if (!strcmp(s, "score"))
readscore(insttop);
else
scotferror(Str("Expected score or functions section"));
}
fputs("e\n", outfile);
while (insttop) {
ip = insttop;
insttop = insttop->next;
free(ip->name);
free((char *) ip);
}
if (errcount)
reporterrcount();
return errcount;
}
void marker_loglik(int n_ind, int n_gen, int *geno,
double error_prob, double initf(int),
double emitf(int, int, double),
double *loglik)
{
int i, v;
double temp;
*loglik = 0.0;
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
temp = initf(1) + emitf(geno[i], 1, error_prob);
for(v=1; v<n_gen; v++)
temp = addlog(temp, initf(v+1) + emitf(geno[i], v+1, error_prob));
(*loglik) += temp;
}
}
int main (){
float tab[N];
float tab2[N];
initf(tab, N);
// read(tab, N);
copyf(tab, tab2, N);
priintf(tab2, N);
npermutf(tab2, N, 2);
priintf(tab2, N);
char tab3[N];
char tab4[N];
char tab5[N];
initc(tab3, N);
initc(tab4, N);
initc(tab5, N);
npermutc(tab4, N, 1);
minToMaj(tab5, N);
printc(tab3, N);
printc(tab4, N);
printc(tab5, N);
mirror(tab4, N);
printc(tab3, N);
printc(tab4, N);
printc(tab5, N);
printf("%d\n", searchs(tab3, tab4, N, N));
printf("%d\n", searchs(tab3, tab5, N, N));
frac ax = {30, 50};
frac bx = {30, 50};
printf("frac %d %d\n", ax.nume, ax.deno);
simplify(&ax);
printf("simply frac %d %d\n", ax.nume, ax.deno);
return 0;
}
static void comsubst(void)
{
/* command substn */
FILEBLK cb;
register char d;
register STKPTR savptr = fixstak();
usestak();
while ((d = readc()) != SQUOTE && d)
pushstak(d);
{
register char *argc;
trim(argc = fixstak());
push(&cb);
estabf(argc);
}
{
register TREPTR t =
makefork(FPOU, cmd(EOFSYM, MTFLG | NLFLG));
int pv[2];
/* this is done like this so that the pipe
* is open only when needed
*/
chkpipe(pv);
initf(pv[INPIPE]);
execute(t, 0, 0, pv);
close(pv[OTPIPE]);
}
tdystak(savptr);
staktop = movstr(savptr, stakbot);
while (d = readc())
pushstak(d | quote);
await(0);
while (stakbot != staktop) {
if ((*--staktop & STRIP) != NL) {
++staktop;
break;
}
}
pop();
}
void *
radiusd_load_ext(const char *name, const char *ident, void **symbol)
{
lt_dlhandle handle;
GRAD_DEBUG2(1,"Loading module '%s', symbol '%s'", name, ident);
if (lt_dlinit()) {
GRAD_DEBUG(1,"lt_ldinit failed");
return NULL;
}
handle = lt_dlopenext(name);
if (handle) {
*symbol = lt_dlsym(handle, ident);
if (*symbol) {
grad_dl_init_t initf =
(grad_dl_init_t) lt_dlsym(handle, "init");
if (initf) {
if (initf()) {
grad_log(GRAD_LOG_ERR,
_("Cannot load module %s: init function failed"),
name);
lt_dlclose(handle);
handle = NULL;
}
}
} else {
grad_log(GRAD_LOG_ERR,
_("Cannot load module %s: symbol %s not found"),
name, ident);
lt_dlclose(handle);
handle = NULL;
}
} else
grad_log(GRAD_LOG_NOTICE, _("Cannot load module %s: %s"),
name, lt_dlerror());
GRAD_DEBUG1(1,"Handle %p", handle);
if (!handle)
lt_dlexit();
else
store_handle(handle);
return handle;
}
void subst(int in, int ot)
{
register char c;
FILEBLK fb;
register int count = CPYSIZ;
push(&fb);
initf(in);
/* DQUOTE used to stop it from quoting */
while (c = (getch(DQUOTE) & STRIP)) {
pushstak(c);
if (--count == 0) {
flush(ot);
count = CPYSIZ;
}
}
flush(ot);
pop();
}
void *
psc_memnode_getobj(int pos, void *(*initf)(void *), void *arg)
{
struct psc_memnode *pmn;
void *p;
pmn = psc_memnode_get();
p = psc_memnode_getkey(pmn, pos);
if (p)
return (p);
spinlock(&pmn->pmn_lock);
p = psc_memnode_getkey(pmn, pos);
if (p) {
freelock(&pmn->pmn_lock);
return (p);
}
p = initf(arg);
psc_memnode_setkey(pmn, pos, p);
freelock(&pmn->pmn_lock);
return (p);
}
void forward_prob(int i, int n_mar, int n_gen, int curpos, int *cross_scheme, double error_prob,
int **Geno, double **probmat, double **alpha,
double initf(int, int *),
double emitf(int, int, double, int *))
{
/* forward equations */
/* Note: true genotypes coded as 1, 2, ...
but in the alpha's and beta's, we use 0, 1, ... */
int j,v,v2;
double errortol,salpha;
/* initialize alpha */
/* curpos = -1: use error_prob always */
/* curpos >= 0: use TOL except when j == curpos, then use error_prob */
errortol = error_prob;
if(curpos > 0) errortol = TOL;
for(v=0; v<n_gen; v++)
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, errortol, cross_scheme);
if(curpos == 0) errortol = TOL;
for(j=1; j<n_mar; j++) {
if(curpos == j) errortol = error_prob;
for(v=0; v<n_gen; v++) {
salpha = alpha[0][j-1] + stepfc(1, v+1, j-1, probmat);
for(v2=1; v2<n_gen; v2++)
salpha = addlog(salpha, alpha[v2][j-1] + stepfc(v2+1, v+1, j-1, probmat));
alpha[v][j] = salpha + emitf(Geno[j][i], v+1, errortol, cross_scheme);
}
if(curpos == j) errortol = TOL;
}
}
void est_map(int n_ind, int n_mar, int n_gen, int *geno, double *rf,
double *rf2, double error_prob, double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *),
double nrecf1(int, int, double, int*), double nrecf2(int, int, double, int*),
double *loglik, int maxit, double tol, int sexsp,
int verbose)
{
int i, j, j2, v, v2, it, flag=0, **Geno, ndigits;
double s, **alpha, **beta, **gamma, *cur_rf, *cur_rf2;
double curloglik, maxdif, temp;
char pattern[100], text[200];
int cross_scheme[2];
/* cross scheme hidden in loglik argument; used by hmm_bcsft */
cross_scheme[0] = (int) ftrunc(*loglik / 1000.0);
cross_scheme[1] = ((int) *loglik) - 1000 * cross_scheme[0];
*loglik = 0.0;
/* allocate space for beta and reorganize geno */
reorg_geno(n_ind, n_mar, geno, &Geno);
allocate_alpha(n_mar, n_gen, &alpha);
allocate_alpha(n_mar, n_gen, &beta);
allocate_dmatrix(n_gen, n_gen, &gamma);
allocate_double(n_mar-1, &cur_rf);
allocate_double(n_mar-1, &cur_rf2);
/* digits in verbose output */
if(verbose) {
ndigits = (int)ceil(-log10(tol));
if(ndigits > 16) ndigits=16;
sprintf(pattern, "%s%d.%df", "%", ndigits+3, ndigits+1);
}
/* begin EM algorithm */
for(it=0; it<maxit; it++) {
for(j=0; j<n_mar-1; j++) {
cur_rf[j] = cur_rf2[j] = rf[j];
rf[j] = 0.0;
if(sexsp) {
cur_rf2[j] = rf2[j];
rf2[j] = 0.0;
}
}
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* initialize alpha and beta */
for(v=0; v<n_gen; v++) {
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
beta[v][n_mar-1] = 0.0;
}
/* forward-backward equations */
for(j=1,j2=n_mar-2; j<n_mar; j++, j2--) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, cur_rf[j-1], cur_rf2[j-1], cross_scheme);
beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,cur_rf[j2], cur_rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],1,error_prob, cross_scheme);
for(v2=1; v2<n_gen; v2++) {
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,cur_rf[j-1],cur_rf2[j-1], cross_scheme));
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
stepf(v+1,v2+1,cur_rf[j2],cur_rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme));
}
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme);
}
}
for(j=0; j<n_mar-1; j++) {
/* calculate gamma = log Pr(v1, v2, O) */
for(v=0, s=0.0; v<n_gen; v++) {
for(v2=0; v2<n_gen; v2++) {
gamma[v][v2] = alpha[v][j] + beta[v2][j+1] +
emitf(Geno[j+1][i], v2+1, error_prob, cross_scheme) +
stepf(v+1, v2+1, cur_rf[j], cur_rf2[j], cross_scheme);
if(v==0 && v2==0) s = gamma[v][v2];
else s = addlog(s, gamma[v][v2]);
}
}
for(v=0; v<n_gen; v++) {
for(v2=0; v2<n_gen; v2++) {
rf[j] += nrecf1(v+1,v2+1, cur_rf[j], cross_scheme) * exp(gamma[v][v2] - s);
if(sexsp) rf2[j] += nrecf2(v+1,v2+1, cur_rf[j], cross_scheme) * exp(gamma[v][v2] - s);
}
}
}
} /* loop over individuals */
/* rescale */
for(j=0; j<n_mar-1; j++) {
rf[j] /= (double)n_ind;
if(rf[j] < tol/1000.0) rf[j] = tol/1000.0;
else if(rf[j] > 0.5-tol/1000.0) rf[j] = 0.5-tol/1000.0;
if(sexsp) {
rf2[j] /= (double)n_ind;
if(rf2[j] < tol/1000.0) rf2[j] = tol/1000.0;
else if(rf2[j] > 0.5-tol/1000.0) rf2[j] = 0.5-tol/1000.0;
}
else rf2[j] = rf[j];
}
if(verbose>1) {
/* print estimates as we go along*/
Rprintf(" %4d ", it+1);
maxdif=0.0;
for(j=0; j<n_mar-1; j++) {
temp = fabs(rf[j] - cur_rf[j])/(cur_rf[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
if(sexsp) {
temp = fabs(rf2[j] - cur_rf2[j])/(cur_rf2[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
}
/* bsy add */
if(verbose > 2)
Rprintf("%d %f %f\n", j+1, cur_rf[j], rf[j]);
/* bsy add */
}
sprintf(text, "%s%s\n", " max rel've change = ", pattern);
Rprintf(text, maxdif);
}
/* check convergence */
for(j=0, flag=0; j<n_mar-1; j++) {
if(fabs(rf[j] - cur_rf[j]) > tol*(cur_rf[j]+tol*100.0) ||
(sexsp && fabs(rf2[j] - cur_rf2[j]) > tol*(cur_rf2[j]+tol*100.0))) {
flag = 1;
break;
}
}
if(!flag) break;
} /* end EM algorithm */
if(flag) warning("Didn't converge!\n");
/* calculate log likelihood */
*loglik = 0.0;
for(i=0; i<n_ind; i++) { /* i = individual */
/* initialize alpha */
for(v=0; v<n_gen; v++) {
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
}
/* forward equations */
for(j=1; j<n_mar; j++) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] +
stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme);
for(v2=1; v2<n_gen; v2++)
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme));
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme);
}
}
curloglik = alpha[0][n_mar-1];
for(v=1; v<n_gen; v++)
curloglik = addlog(curloglik, alpha[v][n_mar-1]);
*loglik += curloglik;
}
if(verbose) {
if(verbose < 2) {
/* print final estimates */
Rprintf(" no. iterations = %d\n", it+1);
maxdif=0.0;
for(j=0; j<n_mar-1; j++) {
temp = fabs(rf[j] - cur_rf[j])/(cur_rf[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
if(sexsp) {
temp = fabs(rf2[j] - cur_rf2[j])/(cur_rf2[j]+tol*100.0);
if(maxdif < temp) maxdif = temp;
}
}
sprintf(text, "%s%s\n", " max rel've change at last step = ", pattern);
Rprintf(text, maxdif);
}
Rprintf(" loglik: %10.4lf\n\n", *loglik);
}
}
int test_moves() {
Board b;
Move *moves;
int status, num_moves, expected;
status = WIN;
/* on startup, there shouldn't be any king moves */
setup(&b);
moves = gen_moves(&b, &num_moves);
expected = 20;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* try this config (black moves) */
initf(&b, "rnbqkbnr/pp1ppppp/8/2p5/4P3/5N2/PPPP1PPP/RNBQKB1R b KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 22;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* try this config (white moves) */
initf(&b, "rnbqkbnr/pp1ppppp/8/2p5/4P3/5N2/PPPP1PPP/RNBQKB1R b KQkq - 1 2");
set_play(&b, WHITE);
moves = gen_moves(&b, &num_moves);
expected = 13 + 7 + 1 + 1 + 5; /* pawns, knights, king, queen, bishop */
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* here is one with only rook moves */
initf(&b, "8/8/8/2r5/8/5R2/8/8 b KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 14;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* here is one with only rook moves */
initf(&b, "8/2p5/8/2r5/8/5R2/8/8 b KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 13;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* here is another one with only rook moves */
initf(&b, "8/2p5/8/2rp4/8/5R2/8/8 b KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 9;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* here is one last one with only rook moves */
initf(&b, "8/2p5/8/2rp4/8/2p2R2/8/8 b KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 7;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* and again for white... */
initf(&b, "8/2p5/8/2rp4/8/2p2R2/8/8 w KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 12;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
/* try to figure out bishop issue */
initf(&b, "8/3/8/2B5/8/8/8/8 w KQkq - 1 2");
moves = gen_moves(&b, &num_moves);
expected = 11;
if(num_moves != expected) {
if(!QUIET) {
if(to_play(&b) == WHITE)
printf("\t>> WHITE to play, ");
else
printf("\t>> BLACK to play, ");
printf("expected %d moves, but saw %d\n", expected, num_moves);
printb(&b);
}
status = FAIL;
}
free(moves);
return status;
}
/* mexFunction is the gateway routine for the MEX-file. */
void
mexFunction( int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[] )
{
int i, r, c, Xrows, Xcols, Lrows, Lcols;
float **mfv, **X, **L, *inData, *inLib, *outData, *outMd;
(void) nlhs; /* unused parameters */
(void) plhs;
const mwSize *dims;
mwSize number_of_dimensions;
mxClassID category;
/* Check to see if we are on a platform that does not support the compatibility layer. */
#if defined(_LP64) || defined (_WIN64)
#ifdef MX_COMPAT_32
for (i=0; i<nrhs; i++) {
if (mxIsSparse(prhs[i])) {
mexErrMsgIdAndTxt("MATLAB:explore:NoSparseCompat",
"MEX-files compiled on a 64-bit platform that use sparse array functions need to be compiled using -largeArrayDims.");
}
}
#endif
#endif
/* check inputs */
if (nrhs != 2)
{
fprintf(stderr,"I need 2 inputs\n");
return;
}
if (mxGetNumberOfDimensions(prhs[0]) != 2)
{
mexPrintf("usage: mf(X,L), where each row of X is a spectrum\n");
return;
}
if (mxGetNumberOfDimensions(prhs[1]) != 2)
{
mexPrintf("usage: mf(X,L), where each row of L is a spectrum\n");
return;
}
category = mxGetClassID(prhs[0]);
if (category != mxSINGLE_CLASS)
{
mexPrintf("The data matrix must have type 'single'\n");
return;
}
category = mxGetClassID(prhs[1]);
if (category != mxSINGLE_CLASS)
{
mexPrintf("The library matrix must have type 'single'\n");
return;
}
/* Get input dimensions */
dims = mxGetDimensions(prhs[0]);
Xrows = dims[0];
Xcols = dims[1];
dims = mxGetDimensions(prhs[1]);
Lrows = dims[0];
Lcols = dims[1];
if (Lcols != Xcols)
{
mexPrintf("Dimension mismatch between library and data\n");
return;
}
inData = (float *) mxGetData(prhs[0]);
inLib = (float *) mxGetData(prhs[1]);
/* build data arrays. do MF detection, clean up */
newf(&X, Xrows, Xcols);
newf(&L, Lrows, Lcols);
initf(&mfv, Xrows, Lrows, 0);
/* Copy matlab input arrays into X and L */
for (r=0; r<Xrows; r++)
{
for (c=0; c<Xcols; c++)
{
X[r][c] = inData[c*Xrows+r];
}
}
for (r=0; r<Lrows; r++)
{
for (c=0; c<Lcols; c++)
{
L[r][c] = inLib[c*Lrows+r];
}
}
/* create space for output */
outData = (float *) mxCalloc(Xrows*Lrows, sizeof(float));
outMd = (float *) mxCalloc(Xrows, sizeof(float));
/* call the library function for matched filter detection */
mf(X, Xrows, Xcols, L, Lrows, NEVALS, DIAG, mfv, outMd);
/* copy into the output array */
for (r=0; r<Xrows; r++)
{
for (c=0; c<Lrows; c++)
{
outData[c*Xrows+r] = mfv[r][c];
}
}
/* clean up */
clearf(X, Xrows, Xcols);
clearf(L, Lrows, Lcols);
clearf(mfv, Xrows, Lrows);
/* create output structure */
plhs[0] = mxCreateNumericMatrix(0, 0, mxSINGLE_CLASS, mxREAL);
mxSetData(plhs[0], outData);
mxSetM(plhs[0], Xrows);
mxSetN(plhs[0], Lrows);
if (nlhs > 1)
{
plhs[1] = mxCreateNumericMatrix(0, 0, mxSINGLE_CLASS, mxREAL);
mxSetData(plhs[1], outMd);
mxSetM(plhs[1], Xrows);
mxSetN(plhs[1], 1);
}
else
{
mxFree(outMd);
}
}
void calc_genoprob_special(int n_ind, int n_pos, int n_gen, int *geno,
double *rf, double *rf2,
double error_prob, double *genoprob,
double initf(int),
double emitf(int, int, double),
double stepf(int, int, double, double))
{
int i, j, j2, v, v2, curpos;
double s, **alpha, **beta;
int **Geno;
double ***Genoprob;
/* allocate space for alpha and beta and
reorganize geno and genoprob */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_genoprob(n_ind, n_pos, n_gen, genoprob, &Genoprob);
allocate_alpha(n_pos, n_gen, &alpha);
allocate_alpha(n_pos, n_gen, &beta);
for(i=0; i<n_ind; i++) { /* i = individual */
for(curpos=0; curpos < n_pos; curpos++) {
if(!Geno[curpos][i]) continue;
R_CheckUserInterrupt(); /* check for ^C */
/* initialize alpha and beta */
for(v=0; v<n_gen; v++) {
if(curpos==0)
alpha[v][0] = initf(v+1) + emitf(Geno[0][i], v+1, error_prob);
else
alpha[v][0] = initf(v+1) + emitf(Geno[0][i], v+1, TOL);
beta[v][n_pos-1] = 0.0;
}
/* forward-backward equations */
for(j=1,j2=n_pos-2; j<n_pos; j++, j2--) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1]);
if(curpos==j2+1)
beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2]) +
emitf(Geno[j2+1][i],1,error_prob);
else
beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2]) +
emitf(Geno[j2+1][i],1,TOL);
for(v2=1; v2<n_gen; v2++) {
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,rf[j-1],rf2[j-1]));
if(curpos==j2+1)
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
stepf(v+1,v2+1,rf[j2],rf2[j2]) +
emitf(Geno[j2+1][i],v2+1,error_prob));
else
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
stepf(v+1,v2+1,rf[j2],rf2[j2]) +
emitf(Geno[j2+1][i],v2+1,TOL));
}
if(curpos==j)
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob);
else
alpha[v][j] += emitf(Geno[j][i],v+1,TOL);
}
}
/* calculate genotype probabilities */
s = Genoprob[0][curpos][i] = alpha[0][curpos] + beta[0][curpos];
for(v=1; v<n_gen; v++) {
Genoprob[v][curpos][i] = alpha[v][curpos] + beta[v][curpos];
s = addlog(s, Genoprob[v][curpos][i]);
}
for(v=0; v<n_gen; v++)
Genoprob[v][curpos][i] = exp(Genoprob[v][curpos][i] - s);
} /* end loop over current position */
} /* loop over individuals */
}
static void
exfile(int prof)
{
time_t mailtime = 0; /* Must not be a register variable */
time_t curtime = 0;
/*
* move input
*/
if (input > 0) {
Ldup(input, INIO);
input = INIO;
}
setmode(prof);
if (setjmp(errshell) && prof) {
close(input);
(void) endjobs(0);
return;
}
/*
* error return here
*/
loopcnt = peekc = peekn = 0;
fndef = 0;
nohash = 0;
iopend = 0;
if (input >= 0)
initf(input);
/*
* command loop
*/
for (;;) {
tdystak(0);
stakchk(); /* may reduce sbrk */
exitset();
if ((flags & prompt) && standin->fstak == 0 && !eof) {
if (mailp) {
time(&curtime);
if ((curtime - mailtime) >= mailchk) {
chkmail();
mailtime = curtime;
}
}
/* necessary to print jobs in a timely manner */
if (trapnote & TRAPSET)
chktrap();
prs(ps1nod.namval);
#ifdef TIME_OUT
alarm(TIMEOUT);
#endif
}
trapnote = 0;
peekc = readwc();
if (eof) {
if (endjobs(JOB_STOPPED))
return;
eof = 0;
}
#ifdef TIME_OUT
alarm(0);
#endif
{
struct trenod *t;
t = cmd(NL, MTFLG);
if (t == NULL && flags & ttyflg)
freejobs();
else
execute(t, 0, eflag);
}
eof |= (flags & oneflg);
}
}
void calc_genoprob(int n_ind, int n_pos, int n_gen, int *geno,
double *rf, double *rf2,
double error_prob, double *genoprob,
double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *))
{
int i, j, j2, v, v2;
double s, **alpha, **beta;
int **Geno;
double ***Genoprob;
int cross_scheme[2];
/* cross scheme hidden in genoprob argument; used by hmm_bcsft */
cross_scheme[0] = genoprob[0];
cross_scheme[1] = genoprob[1];
genoprob[0] = 0.0;
genoprob[1] = 0.0;
/* allocate space for alpha and beta and
reorganize geno and genoprob */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_genoprob(n_ind, n_pos, n_gen, genoprob, &Genoprob);
allocate_alpha(n_pos, n_gen, &alpha);
allocate_alpha(n_pos, n_gen, &beta);
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* initialize alpha and beta */
for(v=0; v<n_gen; v++) {
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
beta[v][n_pos-1] = 0.0;
}
/* forward-backward equations */
for(j=1,j2=n_pos-2; j<n_pos; j++, j2--) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme);
beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],1,error_prob, cross_scheme);
for(v2=1; v2<n_gen; v2++) {
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme));
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
stepf(v+1,v2+1,rf[j2],rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme));
}
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme);
}
}
/* calculate genotype probabilities */
for(j=0; j<n_pos; j++) {
s = Genoprob[0][j][i] = alpha[0][j] + beta[0][j];
for(v=1; v<n_gen; v++) {
Genoprob[v][j][i] = alpha[v][j] + beta[v][j];
s = addlog(s, Genoprob[v][j][i]);
}
for(v=0; v<n_gen; v++)
Genoprob[v][j][i] = exp(Genoprob[v][j][i] - s);
}
/* the following is the old version */
/* for(j=0; j<n_pos; j++) {
s = 0.0;
for(v=0; v<n_gen; v++)
s += (Genoprob[v][j][i] = exp(alpha[v][j] + beta[v][j]));
for(v=0; v<n_gen; v++)
Genoprob[v][j][i] /= s;
} */
} /* loop over individuals */
}
void calc_pairprob(int n_ind, int n_pos, int n_gen, int *geno,
double *rf, double *rf2,
double error_prob, double *genoprob,
double *pairprob,
double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *))
{
int i, j, j2, v, v2, v3;
double s=0.0, **alpha, **beta;
int **Geno;
double ***Genoprob, *****Pairprob;
int cross_scheme[2];
/* cross scheme hidden in genoprob argument; used by hmm_bcsft */
cross_scheme[0] = genoprob[0];
cross_scheme[1] = genoprob[1];
genoprob[0] = 0.0;
genoprob[1] = 0.0;
/* n_pos must be at least 2, or there are no pairs! */
if(n_pos < 2) error("n_pos must be > 1 in calc_pairprob");
/* allocate space for alpha and beta and
reorganize geno, genoprob, and pairprob */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_genoprob(n_ind, n_pos, n_gen, genoprob, &Genoprob);
reorg_pairprob(n_ind, n_pos, n_gen, pairprob, &Pairprob);
allocate_alpha(n_pos, n_gen, &alpha);
allocate_alpha(n_pos, n_gen, &beta);
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* initialize alpha and beta */
for(v=0; v<n_gen; v++) {
alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
beta[v][n_pos-1] = 0.0;
}
/* forward-backward equations */
for(j=1,j2=n_pos-2; j<n_pos; j++, j2--) {
for(v=0; v<n_gen; v++) {
alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme);
beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],1,error_prob, cross_scheme);
for(v2=1; v2<n_gen; v2++) {
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme));
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
stepf(v+1,v2+1,rf[j2],rf2[j2], cross_scheme) +
emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme));
}
alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme);
}
}
/* calculate genotype probabilities */
for(j=0; j<n_pos; j++) {
s = Genoprob[0][j][i] = alpha[0][j] + beta[0][j];
for(v=1; v<n_gen; v++) {
Genoprob[v][j][i] = alpha[v][j] + beta[v][j];
s = addlog(s, Genoprob[v][j][i]);
}
for(v=0; v<n_gen; v++)
Genoprob[v][j][i] = exp(Genoprob[v][j][i] - s);
}
/* calculate Pr(G[j], G[j+1] | marker data) for i = 1...n_pos-1 */
for(j=0; j<n_pos-1; j++) {
for(v=0; v<n_gen; v++) {
for(v2=0; v2<n_gen; v2++) {
Pairprob[v][v2][j][j+1][i] = alpha[v][j] + beta[v2][j+1] +
stepf(v+1,v2+1,rf[j],rf2[j], cross_scheme) +
emitf(Geno[j+1][i],v2+1,error_prob, cross_scheme);
if(v==0 && v2==0) s=Pairprob[v][v2][j][j+1][i];
else s = addlog(s,Pairprob[v][v2][j][j+1][i]);
}
}
/* scale to sum to 1 */
for(v=0; v<n_gen; v++)
for(v2=0; v2<n_gen; v2++)
Pairprob[v][v2][j][j+1][i] =
exp(Pairprob[v][v2][j][j+1][i] - s);
}
/* now calculate Pr(G[i], G[j] | marker data) for j > i+1 */
for(j=0; j<n_pos-2; j++) {
for(j2=j+2; j2<n_pos; j2++) {
for(v=0; v<n_gen; v++) { /* genotype at pos'n j */
for(v2=0; v2<n_gen; v2++) { /* genotype at pos'n j2 */
Pairprob[v][v2][j][j2][i] = 0.0;
for(v3=0; v3<n_gen; v3++) { /* genotype at pos'n j2-1 */
s = Genoprob[v3][j2-1][i];
if(fabs(s) > TOL) /* avoid 0/0 */
Pairprob[v][v2][j][j2][i] += Pairprob[v][v3][j][j2-1][i]*
Pairprob[v3][v2][j2-1][j2][i]/s;
}
}
} /* end loops over genotypes */
}
} /* end loops over pairs of positions */
} /* end loop over individuals */
}
void argmax_geno(int n_ind, int n_pos, int n_gen, int *geno,
double *rf, double *rf2,
double error_prob, int *argmax,
double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *))
{
int i, j, v, v2;
double s, t, *gamma, *tempgamma, *tempgamma2;
int **Geno, **Argmax, **traceback;
int cross_scheme[2];
/* cross scheme hidden in argmax argument; used by hmm_bcsft */
cross_scheme[0] = argmax[0];
cross_scheme[1] = argmax[1];
argmax[0] = geno[0];
argmax[1] = geno[1];
/* Read R's random seed */
/* in the case of multiple "most likely" genotype sequences,
we pick from them at random */
GetRNGstate();
/* allocate space and
reorganize geno and argmax */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_geno(n_ind, n_pos, argmax, &Argmax);
allocate_imatrix(n_pos, n_gen, &traceback);
allocate_double(n_gen, &gamma);
allocate_double(n_gen, &tempgamma);
allocate_double(n_gen, &tempgamma2);
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* begin viterbi algorithm */
if(n_pos > 1) { /* multiple markers */
for(v=0; v<n_gen; v++)
gamma[v] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
for(j=0; j<n_pos-1; j++) {
for(v=0; v<n_gen; v++) {
tempgamma[v] = s = gamma[0] + stepf(1, v+1, rf[j], rf2[j], cross_scheme);
traceback[j][v] = 0;
for(v2=1; v2<n_gen; v2++) {
t = gamma[v2] + stepf(v2+1, v+1, rf[j], rf2[j], cross_scheme);
if(t > s || (fabs(t-s) < TOL && unif_rand() < 0.5)) {
tempgamma[v] = s = t;
traceback[j][v] = v2;
}
}
tempgamma2[v] = tempgamma[v] + emitf(Geno[j+1][i], v+1, error_prob, cross_scheme);
}
for(v=0; v<n_gen; v++) gamma[v] = tempgamma2[v];
}
/* finish off viterbi and then traceback to get most
likely sequence of genotypes */
Argmax[n_pos-1][i] = 0;
s = gamma[0];
for(v=1; v<n_gen; v++) {
if(gamma[v] > s || (fabs(gamma[v]-s) < TOL &&
unif_rand() < 0.5)) {
s = gamma[v];
Argmax[n_pos-1][i] = v;
}
}
for(j=n_pos-2; j >= 0; j--)
Argmax[j][i] = traceback[j][Argmax[j+1][i]];
}
else { /* for exactly one marker */
s = initf(1, cross_scheme) + emitf(Geno[0][i], 1, error_prob, cross_scheme);
Argmax[0][i] = 0;
for(v=1; v<n_gen; v++) {
t = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme);
if(t > s || (fabs(t-s) < TOL && unif_rand() < 0.5)) {
s = t;
Argmax[0][i] = v;
}
}
}
/* code genotypes as 1, 2, ... */
for(j=0; j<n_pos; j++) Argmax[j][i]++;
} /* loop over individuals */
/* write R's random seed */
PutRNGstate();
}
static void exfile(BOOL prof)
{
register L_INT mailtime = 0;
register int userid;
struct stat statb;
/* move input */
if (input > 0) {
Ldup(input, INIO);
input = INIO;
}
/* move output to safe place */
if (output == 2) {
Ldup(dup(2), OTIO);
output = OTIO;
}
userid = getuid();
/* decide whether interactive */
if ((flags & intflg)
|| ((flags & oneflg) == 0 && isatty(output) && isatty(input))) {
dfault(&ps1nod, (userid ? stdprompt : supprompt));
dfault(&ps2nod, readmsg);
flags |= ttyflg | prompt;
ignsig(KILL);
} else {
flags |= prof;
flags &= ~prompt;
}
if (setjmp(errshell) && prof) {
close(input);
return;
}
/* error return here */
loopcnt = breakcnt = peekc = 0;
iopend = 0;
if (input >= 0)
initf(input);
/* command loop */
for (;;) {
tdystak(0);
stakchk(); /* may reduce sbrk */
exitset();
if ((flags & prompt) && standin->fstak == 0 && !eof) {
if (mailnod.namval
&& stat(mailnod.namval, &statb) >= 0
&& statb.st_size
&& (statb.st_mtime != mailtime)
&& mailtime) {
prs(mailmsg);
}
mailtime = statb.st_mtime;
prs(ps1nod.namval);
alarm(TIMEOUT);
flags |= waiting;
}
trapnote = 0;
peekc = readc();
if (eof)
return;
alarm(0);
flags &= ~waiting;
execute(cmd(NL, MTFLG), 0, NULL, NULL);
eof |= (flags & oneflg);
}
}
void sim_geno(int n_ind, int n_pos, int n_gen, int n_draws,
int *geno, double *rf, double *rf2,
double error_prob, int *draws,
double initf(int, int *),
double emitf(int, int, double, int *),
double stepf(int, int, double, double, int *))
{
int i, k, j, v, v2;
double s, **beta, *probs;
int **Geno, ***Draws, curstate;
int cross_scheme[2];
/* cross scheme hidden in draws argument; used by hmm_bcsft */
cross_scheme[0] = draws[0];
cross_scheme[1] = draws[1];
draws[0] = 0;
draws[1] = 0;
/* allocate space for beta and
reorganize geno and draws */
/* Geno indexed as Geno[pos][ind] */
/* Draws indexed as Draws[rep][pos][ind] */
reorg_geno(n_ind, n_pos, geno, &Geno);
reorg_draws(n_ind, n_pos, n_draws, draws, &Draws);
allocate_alpha(n_pos, n_gen, &beta);
allocate_double(n_gen, &probs);
/* Read R's random seed */
GetRNGstate();
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* do backward equations */
/* initialize beta */
for(v=0; v<n_gen; v++) beta[v][n_pos-1] = 0.0;
/* backward equations */
for(j=n_pos-2; j>=0; j--) {
for(v=0; v<n_gen; v++) {
beta[v][j] = beta[0][j+1] + stepf(v+1,1,rf[j], rf2[j], cross_scheme) +
emitf(Geno[j+1][i],1,error_prob, cross_scheme);
for(v2=1; v2<n_gen; v2++)
beta[v][j] = addlog(beta[v][j], beta[v2][j+1] +
stepf(v+1,v2+1,rf[j],rf2[j], cross_scheme) +
emitf(Geno[j+1][i],v2+1,error_prob, cross_scheme));
}
}
for(k=0; k<n_draws; k++) { /* k = simulation replicate */
/* first draw */
/* calculate probs */
s = (probs[0] = initf(1, cross_scheme)+emitf(Geno[0][i],1,error_prob, cross_scheme)+beta[0][0]);
for(v=1; v<n_gen; v++) {
probs[v] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme) +
beta[v][0];
s = addlog(s, probs[v]);
}
for(v=0; v<n_gen; v++) probs[v] = exp(probs[v] - s);
/* make draw: returns a value from {1, 2, ..., n_gen} */
curstate = Draws[k][0][i] = sample_int(n_gen, probs);
/* move along chromosome */
for(j=1; j<n_pos; j++) {
/* calculate probs */
for(v=0; v<n_gen; v++)
probs[v] = exp(stepf(curstate,v+1,rf[j-1],rf2[j-1], cross_scheme) +
emitf(Geno[j][i],v+1,error_prob, cross_scheme) +
beta[v][j] - beta[curstate-1][j-1]);
/* make draw */
curstate = Draws[k][j][i] = sample_int(n_gen, probs);
}
} /* loop over replicates */
} /* loop over individuals */
/* write R's random seed */
PutRNGstate();
}
int udl_load( const char *pname )
{
FILE *fp;
char *pdata;
int id;
u32 temp;
char ctemp[ UDL_MAX_LTR_SYMNAME + 1 ];
udl_module_data *m;
udl_module_data tmpm;
udl_debug( "Loading module %s\n", pname );
if( ( fp = fopen( pname, "rb" ) ) == NULL )
{
udl_debug( "Cannot read module from file %s\n", pname );
return UDL_INVALID_MODULE;
}
// Read hash
fread( &tmpm.hash, 1, 4, fp );
// Read signature
fread( &temp, 1, 4, fp );
if( temp != UDL_MOD_SIGN )
{
udl_debug( "Invalid module signature\n" );
fclose( fp );
return UDL_INVALID_MODULE;
}
// Read module data
fread( &tmpm.total, 1, 4, fp );
fread( &tmpm.offset, 1, 4, fp );
udl_debug( "module size: %u offset: %08X\n", ( unsigned )tmpm.total, ( unsigned )tmpm.offset );
// Read module name (fixed size always)
fread( ctemp, 1, UDL_MAX_MOD_NAME, fp );
udl_debug( "module name: %s\n", ctemp );
// Now it's a good time to check if the module is already loaded
if( ( id = udlh_slot_from_name( ctemp ) ) != -1 )
{
udl_debug( "Module %s already loaded.\n", ctemp );
if( udl_modules[ id ].hash == tmpm.hash )
{
udl_debug( "Modules are identical, incrementing reference count.\n" );
udl_modules[ id ].refcount ++;
}
else
{
udl_debug( "Another version of '%s' is already loaded, unable to load the new module.\n", ctemp );
id = UDL_VERSION_ERROR;
}
fclose( fp );
return id;
}
else
{
if( ( id = udlh_find_slot() ) == -1 )
{
udl_debug( "No slots available\n" );
fclose( fp );
return UDL_NO_SLOTS;
}
}
m = udl_modules + id;
*m = tmpm;
m->refcount = 1;
udl_debug( "Will load module at slot %d\n", id );
// Read all data now
if( ( pdata = ( char* )malloc( m->total + UDL_MAX_MOD_NAME ) ) == NULL )
{
udl_debug( "Not enough memory\n" );
fclose( fp );
return UDL_OUT_OF_MEMORY;
}
m->data = pdata;
memcpy( pdata, ctemp, UDL_MAX_MOD_NAME );
pdata += UDL_MAX_MOD_NAME;
if( fread( pdata, 1, m->total, fp ) != m->total )
{
udl_debug( "Unable to read %u bytes from file\n", ( unsigned )m->total );
fclose( fp );
udlh_free_slot( id );
return UDL_INVALID_MODULE;
}
fclose( fp );
// Is this a LTR-compatible Lua module?
// It needs two symbols for this: luaopen_<modname> and <modname>_map
strcpy( ctemp, "luaopen_" );
strncat( ctemp, ( const char* )m->data, UDL_MAX_LTR_SYMNAME );
udl_rotables[ id ] = 0;
if( udl_find_symbol( id, ctemp ) )
{
strncpy( ctemp, ( const char* )m->data, UDL_MAX_LTR_SYMNAME );
strncat( ctemp, "_map", UDL_MAX_LTR_SYMNAME );
if( ( temp = udl_find_symbol( id, ctemp ) ) != 0 )
{
udl_debug( "This is a LTR module\n" );
// Save the adress of module's rotable in udl_rotables
udl_rotables[ id ] = temp;
udl_debug( "ROMTABLE at %X\n", ( unsigned )udl_rotables[ id ] );
}
}
#if 0 && defined( UDL_DEBUG )
// Dump symbol table
printf( "Symbol table: \n" );
pdata = m->data + UDL_MAX_MOD_NAME;
while( 1 )
{
if( *pdata == '\0' )
{
pdata ++;
break;
}
printf( " name: %s\t\t ", pdata );
pdata += strlen( pdata ) + 1;
pdata = ( char* )( ( ( u32 )pdata + 3 ) & ~3 );
printf( "offset: %08X\n", ( unsigned )*( u32* )pdata );
pdata += 4;
}
pdata = ( char* )( ( ( u32 )pdata + 3 ) & ~3 );
#endif
// If the module has an init function, call it now
if( ( temp = udl_find_symbol( id, UDL_MOD_INIT_FNAME ) ) != 0 )
{
p_udl_init_func initf = ( p_udl_init_func )temp;
if( initf( id ) == 0 )
{
udl_debug( "The module init function returned 0, unloading module.\n" );
udlh_free_slot( id );
return UDL_INIT_ERROR;
}
}
else
udl_debug( "the module doesn't have an init function.\n" );
// Return module slot
return id;
}
int
readvar(unsigned char **names)
{
struct fileblk fb;
register struct fileblk *f = &fb;
unsigned char c[MULTI_BYTE_MAX+1];
register int rc = 0;
struct namnod *n;
unsigned char *rel;
unsigned char *oldstak;
register unsigned char *pc, *rest;
int d;
unsigned int (*newwc)(void);
extern const char badargs[];
if (eq(*names, "-r")) {
if (*++names == NULL)
error(badargs);
newwc = readwc;
} else
newwc = nextwc;
n = lookup(*names++); /* done now to avoid storage mess */
rel = (unsigned char *)relstak();
push(f);
initf(dup(0));
/*
* If stdin is a pipe then this lseek(2) will fail with ESPIPE, so
* the read buffer size is set to 1 because we will not be able
* lseek(2) back towards the beginning of the file, so we have
* to read a byte at a time instead
*
*/
if (lseek(0, (off_t)0, SEEK_CUR) == -1)
f->fsiz = 1;
#ifdef __sun
/*
* If stdin is a socket then this isastream(3C) will return 1, so
* the read buffer size is set to 1 because we will not be able
* lseek(2) back towards the beginning of the file, so we have
* to read a byte at a time instead
*
*/
if (isastream(0) == 1)
f->fsiz = 1;
#endif
/*
* strip leading IFS characters
*/
for (;;)
{
d = newwc();
if(eolchar(d))
break;
rest = readw(d);
pc = c;
while(*pc++ = *rest++);
if(!anys(c, ifsnod.namval))
break;
}
oldstak = curstak();
for (;;)
{
if ((*names && anys(c, ifsnod.namval)) || eolchar(d))
{
if (staktop >= brkend)
growstak(staktop);
zerostak();
assign(n, absstak(rel));
setstak(rel);
if (*names)
n = lookup(*names++);
else
n = 0;
if (eolchar(d))
{
break;
}
else /* strip imbedded IFS characters */
while(1) {
d = newwc();
if(eolchar(d))
break;
rest = readw(d);
pc = c;
while(*pc++ = *rest++);
if(!anys(c, ifsnod.namval))
break;
}
}
else
{
if(d == '\\' && newwc == nextwc) {
d = newwc();
rest = readw(d);
while(d = *rest++) {
if (staktop >= brkend)
growstak(staktop);
pushstak(d);
}
oldstak = staktop;
}
else
{
pc = c;
while(d = *pc++) {
if (staktop >= brkend)
growstak(staktop);
pushstak(d);
}
if(!anys(c, ifsnod.namval))
oldstak = staktop;
}
d = newwc();
if (eolchar(d))
staktop = oldstak;
else
{
rest = readw(d);
pc = c;
while(*pc++ = *rest++);
}
}
}
while (n)
{
assign(n, nullstr);
if (*names)
n = lookup(*names++);
else
n = 0;
}
if (eof)
rc = 1;
#ifdef __sun
if (isastream(0) != 1)
#endif
/*
* If we are reading on a stream do not attempt to
* lseek(2) back towards the start because this is
* logically meaningless, but there is nothing in
* the standards to pervent the stream implementation
* from attempting it and breaking our code here
*
*/
lseek(0, (off_t)(f->nxtoff - f->endoff), SEEK_CUR);
pop();
return(rc);
}
