int numlines(char *name)
// number of lines no comments or blanks
{
FILE *fff ;
char line[MAXSTR] ;
char *spt[MAXSTR] ;
char *sx ;
int nsplit, num=0 ;
num = 0;
if (name == NULL) fatalx("(numlines) no name") ;
openit(name, &fff, "r") ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, MAXFF) ;
if (nsplit==0) continue ;
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
++num ;
freeup(spt, nsplit) ;
}
fclose(fff) ;
return num ;
}
int numcols(char *name)
// number of cols
{
FILE *fff ;
char line[MAXSTR] ;
char *spt[MAXSTR] ;
char *sx ;
int nsplit ;
if (name == NULL) fatalx("(numlines) no name") ;
openit(name, &fff, "r") ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, MAXFF) ;
if (nsplit==0) continue ;
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
freeup(spt, nsplit) ;
fclose(fff) ;
return nsplit ;
}
return 0; // empty file; should this be a fatal error?
}
void flipsnps(char *fsname, SNP **snpm, int numsnps, int phasedmode)
{
FILE *fff ;
char line[MAXSTR] ;
char *spt[MAXFF] ;
char *ss ;
int nsplit, n, k ;
SNP *cupt ;
if (fsname == NULL) return ;
openit (fsname, &fff, "r") ;
freesnpindex() ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, MAXFF) ;
if (nsplit==0) continue ;
if (spt[0][0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
k = snpindex(snpm, numsnps, spt[0]) ;
if (k>=0) {
flip1(snpm[k], phasedmode, flipreference) ;
}
freeup(spt, nsplit) ;
}
fclose (fff) ;
}
void
isetprompt(void)
{
nialptr z;
int t;
z = apop();
if (kind(z) == phrasetype || kind(z) == chartype) {
/* return old prompt */
apush(makephrase(prompt));
/* get new prompt */
if (kind(z) == phrasetype) {
t = tknlength(z);
if (t > MAXPROMPTSIZE)
goto spout;
strcpy(prompt, pfirstchar(z));
}
else if (kind(z) == chartype) {
t = tally(z);
if (t > MAXPROMPTSIZE)
goto spout;
strcpy(prompt, pfirstchar(z));
}
}
else
buildfault("arg to setprompt must be string or phrase");
freeup(z);
return;
spout:
freeup(apop()); /* old prompt already stacked */
buildfault("prompt too long");
}
void flipstrand(char *fsname, SNP **snpm, int numsnps)
// move alleles to opposite strand
{
FILE *fff ;
char line[MAXSTR] ;
char *spt[MAXFF] ;
char *ss ;
int nsplit, n, k ;
SNP *cupt ;
if (fsname == NULL) return ;
openit (fsname, &fff, "r") ;
freesnpindex() ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, MAXFF) ;
if (nsplit==0) continue ;
if (spt[0][0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
k = snpindex(snpm, numsnps, spt[0]) ;
if (k>=0) {
cupt = snpm[k] ;
cupt -> alleles[0] = compbase(cupt -> alleles[0]) ;
cupt -> alleles[1] = compbase(cupt -> alleles[1]) ;
}
freeup(spt, nsplit) ;
}
fclose (fff) ;
}
/* sets various inter globals. The arg may be a phrase or string.
It is mapped to upper case to make the match.
*/
void
iset(void)
{
char *msg;
nialptr name = apop();
if (equalsymbol(name, "SKETCH")) {
msg = (sketch ? "sketch" : "diagram");
sketch = true;
}
else if (equalsymbol(name, "DIAGRAM")) {
msg = (sketch ? "sketch" : "diagram");
sketch = false;
}
else if (equalsymbol(name, "TRACE")) {
msg = (trace ? "trace" : "notrace");
trace = true;
}
else if (equalsymbol(name, "NOTRACE")) {
msg = (trace ? "trace" : "notrace");
trace = false;
}
else if (equalsymbol(name, "DECOR")) {
msg = (decor ? "decor" : "nodecor");
decor = true;
}
else if (equalsymbol(name, "NODECOR")) {
msg = (decor ? "decor" : "nodecor");
decor = false;
}
else if (equalsymbol(name, "LOG")) {
msg = (keeplog ? "log" : "nolog");
if (keeplog == false) {
keeplog = true;
}
}
else if (equalsymbol(name, "NOLOG")) {
msg = (keeplog ? "log" : "nolog");
if (keeplog) {
keeplog = false;
}
}
#ifdef DEBUG
else if (equalsymbol(name, "DEBUG")) {
msg = (debug ? "debug" : "nodebug");
debug = true;
}
else if (equalsymbol(name, "NODEBUG")) {
msg = (debug ? "debug" : "nodebug");
debug = false;
}
#endif
else {
apush(makefault("?unknown set type"));
freeup(name);
return;
}
apush(makephrase(msg));
freeup(name);
}
int readpopx(char *pname, char ***plists, int npops)
// reads lists of npops pops on a line
{
FILE *fff ;
char line[MAXSTR+1], c ;
char *spt[MAXFF], *sx ;
char **pp ;
int nsplit, t, num = 0 ;
openit(pname, &fff, "r") ;
line[MAXSTR] = '\0' ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, MAXFF) ;
if (nsplit == 0) continue ;
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
if (nsplit < npops) fatalx("length mismatch %s\n", line) ;
ZALLOC(plists[num], npops+1, char *) ;
plists[num][npops] == NULL ;
pp = plists[num] ;
for (t=0; t<npops; ++t) {
pp[t] = strdup(spt[t]) ;
}
striptrail(line, '\n') ;
lines[num] = strdup(line) ;
++num ;
freeup(spt, nsplit) ;
}
fclose(fff) ;
return num ;
}
void lapack_zheev(int nn, dcmplx *AA, dreal *ww)
{
int lda, lwork, rsize, info;
char jobz = 'V', uplo = 'U';
dreal *rwork = NULL;
dcmplx *work = NULL;
lda = (1 > nn) ? 1 : nn;
lwork = (1 > 2*nn-1) ? 1 : 2*nn-1;
rsize = (1 > 3*nn-2) ? 1 : 3*nn-2;
work = (dcmplx *) calloc(lwork, sizeof(dcmplx));
check_mem(work, "work");
rwork = (dreal *) calloc(rsize, sizeof(dreal));
check_mem(rwork, "rwork");
zheev_(&jobz, &uplo, &nn, AA, &lda, ww, work, &lwork, rwork, &info);
freeup(rwork);
freeup(work);
return;
error:
if(rwork) freeup(rwork);
if(work) freeup(work);
abort();
}
void
callwtjack(char *iname, char *oname)
{
FILE *ifile, *ofile ;
char line[MAXSTR];
char *sx;
char *spt[MAXFF];
int nsplit, len, i, k;
char c;
openit(iname, &ifile, "r") ;
openit(oname, &ofile, "w") ;
double *jwt, *jmean;
/* output variable */
double est, sig; // NB
est =0; sig=0;
/*input variables */
len = numlines(iname);
ZALLOC(jwt, len, double);
ZALLOC(jmean, len, double);
k = 0;
/* read input file and store data */
while (fgets(line,MAXSTR,ifile) != NULL)
{
nsplit = splitup(line, spt, MAXFF);
sx = spt[0];
c = sx[0];
if (c == '#') {
freeup(spt, nsplit);
continue;
}
jwt[k] = atof(spt[1]);
jmean[k] = atof(spt[2]);
//printf("mean: %9.3f len: %9.3f\n", jmean[k], jwt[k]) ;
k++;
freeup(spt, nsplit);
}
len = k ; // better style who knows how numlines handles commas
fclose(ifile) ;
// printf("mean: %9.3f len: %d\n", mean, len) ;
/*call weightjack */
weightjack(&est, &sig, mean, jmean, jwt, len);
fprintf(ofile,"%9.3f", est); // d format ??
fprintf(ofile,"%9.3f", sig);
fprintf(ofile,"\n");
free(jmean);
free(jwt);
fclose(ofile) ;
}
int
getnamesstripcolon(char ****pnames, int maxrow, int numcol, char *fname, int lo, int hi)
{
// count is base 1
char line[MAXSTR] ;
char *spt[MAXFF] ;
char *sx ;
int nsplit, i, j, num=0, maxff, numcolp, lcount=0 ;
FILE *fff ;
int nbad = 0 ;
char ***names ;
names = *pnames ;
if (fname == NULL) fff = stdin ;
else {
openit(fname, &fff, "r") ;
}
numcolp = numcol + 1 ;
maxff = MAX(MAXFF, numcolp) ;
while (fgets(line, MAXSTR, fff) != NULL) {
subcolon(line) ;
nsplit = splitup(line, spt, maxff) ;
if (nsplit == 0) {
freeup(spt, nsplit) ;
continue ;
}
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
if (nsplit<numcol) {
++nbad ;
if (nbad<10) printf("+++ bad line: nsplit: %d numcol: %d\n%s\n", nsplit, numcol, line) ;
continue ;
}
++lcount ;
if ((lcount<lo) || (lcount>hi)) {
freeup(spt, nsplit) ;
continue ;
}
if (num>=maxrow) fatalx("too much data\n") ;
for (i=0; i<numcol; i++) {
names[i][num] = strdup(spt[i]) ;
}
freeup(spt, nsplit) ;
++num ;
}
if (fname != NULL) fclose(fff) ;
return num ;
}
void
iloaddefs(void)
{
nialptr nm,
x = apop();
int mode;
/* get the file name as a Nial array */
if (atomic(x) || kind(x) == chartype)
nm = x;
else if (kind(x) == atype)
nm = fetch_array(x, 0);
else {
buildfault("invalid file name");
freeup(x);
return;
}
mode = 0; /* default to silent mode */
if (kind(x) == atype && tally(x) == 2) {
/* argument has a mode filed, select it */
nialptr it = fetch_array(x, 1);
if (kind(it) == inttype)
mode = intval(it);
if (kind(it) == booltype)
mode = boolval(it);
}
/* try to put filename into gcharbuf */
if (!ngetname(nm, gcharbuf)) {
buildfault("invalid file name");
freeup(x);
}
else
{ /* check the extension as .ndf */
check_ext(gcharbuf, ".ndf",NOFORCE_EXTENSION);
freeup(x); /* do freeup here so file name doesn't show in iusedspace */
/* load the definition file */
if (loaddefs(true, gcharbuf, mode)) {
apush(Nullexpr);
}
else
buildfault(errmsgptr); /* this is safe since call is from iloaddefs */
}
#ifdef DEBUG
memchk();
#endif
}
void
iload(void)
{
nialptr x = apop();
int n = ngetname(x, gcharbuf);
freeup(x);
if (n == 0)
buildfault("invalid file name");
else {
FILE *f1;
check_ext(gcharbuf, ".nws",FORCE_EXTENSION);
f1 = openfile(gcharbuf, 'r', 'b');
if (f1 == OPENFAILED) {
buildfault("cannot open nws file");
return;
}
wsfileport = f1;
/* jump to do1command */
longjmp(loadsave_env, NC_WS_LOAD);
}
#ifdef DEBUG
if (debug) {
memchk();
nprintf(OF_DEBUG, "after iload memchk\n");
}
#endif
}
static void tddmrg_zWblock_R2L(mat2d_dcmplx *Wvc)
{
int ndim, mdim, idim, idimR;
dreal error;
size_t nlen;
dreal *eig = NULL;
ndim = Wvc->nrow;
mdim = Wvc->ncol;
nlen = ndim*sizeof(dcmplx);
eig = (dreal *) calloc(NdimR, sizeof(dreal));
lapack_zheev(NdimR, Dmat_R2L->addr, eig);
for(idimR = 0, error = 0.0; idimR < NdimR-mdim; ++idimR)
error += eig[idimR];
//if(Rank == Root) {
// printf("%s\n", tddmrglabel);
// printf("%s error = %15.5e\n", tddmrglabel, error);
//}
for(idim = 0; idim < mdim; ++idim) {
idimR = NdimR-idim-1;
memcpy(Wvc->ptr[idim], Dmat_R2L->ptr[idimR], nlen);
}
freeup(eig);
}
int
getxxnamesf(char ***pnames, double **xx, int maxrow, int numcol, FILE *fff)
/**
like getxxnames but file already open
*/
{
#define MAXFF 50
char line[MAXSTR] ;
char *spt[MAXFF] ;
char *sx ;
int nsplit, i, j, num=0, maxff, numcolp ;
int nbad = 0 ;
char **names ;
if (pnames != NULL) names = *pnames ;
numcolp = numcol + 1 ;
maxff = MAX(MAXFF, numcolp) ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, maxff) ;
if (nsplit == 0) {
freeup(spt, nsplit) ;
continue ;
}
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
if (names != NULL) names[num] = strdup(sx) ;
if (nsplit<numcolp) {
++nbad ;
if (nbad<10) printf("+++ bad line: nsplit: %d numcol: %d\n%s\n", nsplit, numcol, line) ;
continue ;
}
if (num>=maxrow) fatalx("too much data\n") ;
for (i=0; i<numcol; i++) {
xx[i][num] = atof(spt[i+1]) ;
}
freeup(spt, nsplit) ;
++num ;
}
return num ;
}
int
getxxnames(char ***pnames, double **xx, int maxrow, int numcol, char *fname)
{
char line[MAXSTR] ;
char *spt[MAXFF] ;
char *sx ;
int nsplit, i, j, num=0, maxff, numcolp ;
FILE *fff ;
int nbad = 0 ;
char **names = NULL ;
if (pnames != NULL) names = *pnames ;
if (fname == NULL) fff = stdin ;
else {
openit(fname, &fff, "r") ;
}
numcolp = numcol + 1 ;
maxff = MAX(MAXFF, numcolp) ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, maxff) ;
if (nsplit == 0) {
freeup(spt, nsplit) ;
continue ;
}
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
if (names != NULL) names[num] = strdup(sx) ;
if (nsplit<numcolp) {
++nbad ;
if (nbad<10) printf("+++ bad line: nsplit: %d numcol: %d\n%s\n", nsplit, numcol, line) ;
continue ;
}
if (num>=maxrow) fatalx("too much data\n") ;
for (i=0; i<numcol; i++) {
xx[i][num] = atof(spt[i+1]) ;
}
freeup(spt, nsplit) ;
++num ;
}
if (fname != NULL) fclose(fff) ;
return num ;
}
nialptr
testbinfaults(nialptr x, nialptr stdfault, int divflag)
{
nialptr x0 = fetch_array(x, 0),
x1 = fetch_array(x, 1);
switch (kind(x0)) {
case booltype:
case inttype:
case realtype:
freeup(stdfault);
return (x1);
case chartype:
case phrasetype: /* fall out to return stdfault */
break;
case faulttype:
switch (kind(x1)) {
case booltype:
if (divflag && boolval(x1) == 0)
break;
freeup(stdfault);
return (x0);
case inttype:
if (divflag && intval(x1) == 0)
break;
freeup(stdfault);
return (x0);
case realtype:
if (divflag && realval(x1) == 0.0)
break;
freeup(stdfault);
return (x0);
case chartype:
case phrasetype:
break;
case faulttype:
if (x0 == x1) {
freeup(stdfault);
return (x0);
}
break;
}
}
return (stdfault);
}
nialptr
arithconvert(nialptr x, int *newk)
{
int k,
ki,
changed;
nialint i,
t = tally(x);
nialptr z,
x0,
xi;
if (t == 0) { /* x is empty */
*newk = kind(x);
return (x);
}
/* set k based on kind of first item */
x0 = fetch_array(x, 0); /* first item */
k = kind(x0);
/* loop to find maximum kind in x */
for (i = 1; i < t; i++) {
xi = fetch_array(x, i);
ki = kind(xi);
if (ki > k)
k = ki;
}
/* convert to highest kind */
changed = true;
if (homotype(k) && k != chartype) {
switch (k) {
case inttype:
z = to_int(x);
break;
case realtype:
z = to_real(x);
break;
default:
z = x;
changed = false;
break;
}
}
else {
z = x;
changed = false;
}
if (changed) /* argument has been converted */
freeup(x);
*newk = k;
return (z);
}
// Inverse of matrix AA
void lapack_dinvs(int nn, dreal *AA)
{
int *ipiv = NULL;
ipiv = (int *) calloc(nn, sizeof(int));
check_mem(ipiv, "ipiv");
lapack_dgetrf(nn, nn, AA, ipiv);
lapack_dgetri(nn, AA, ipiv);
freeup(ipiv);
return;
error:
if(ipiv) freeup(ipiv);
abort();
}
int
getss(char **ss, char *fname)
/**
get list of names
*/
{
char line[MAXSTR] ;
char qqq[MAXSTR] ;
char *spt[MAXFF] ;
char *sx ;
int nsplit, i, j, num=0, maxff ;
FILE *fff ;
if (fname == NULL) fff = stdin ;
else {
openit(fname, &fff, "r") ;
}
maxff = MAXFF ;
while (fgets(line, MAXSTR, fff) != NULL) {
nsplit = splitup(line, spt, maxff) ;
if (nsplit == 0) {
freeup(spt, nsplit) ;
continue ;
}
sx = spt[0] ;
if (sx[0] == '#') {
freeup(spt, nsplit) ;
continue ;
}
if (nsplit<1) {
continue ;
}
ss[num] = strdup(spt[0]) ;
freeup(spt, nsplit) ;
++num ;
}
if (fname != NULL) fclose(fff) ;
return num ;
}
void lapack_dsyev(int nn, dreal *AA, dreal *ww)
{
int lda, lwork, info;
char jobz = 'V', uplo = 'U';
dreal *work = NULL;
lda = (1 > nn) ? 1 : nn;
lwork = (1 > 3*nn-1) ? 1 : 3*nn-1;
work = (dreal *) calloc(lwork, sizeof(dreal));
check_mem(work, "work");
dsyev_(&jobz, &uplo, &nn, AA, &lda, ww, work, &lwork, &info);
freeup(work);
return;
error:
if(work) freeup(work);
abort();
}
void lapack_dsteqr(int nn, int ldz, dreal *alph, dreal *beta, dreal *zz)
{
int nwork, info;
char compz = 'I';
dreal *work = NULL;
nwork = (1 >= 2*nn-2) ? 1 : 2*nn-2;
work = (dreal *) calloc(nwork, sizeof(dreal));
check_mem(work, "work");
dsteqr_(&compz, &nn, alph, beta, zz, &ldz, work, &info);
freeup(work);
return;
error:
if(work) freeup(work);
abort();
}
// Interface to lapack routine dgetri
// nn: nrow and ncol of A
void lapack_dgetri(int nn, dreal *AA, int *ipiv)
{
int lda, lwork, info;
dreal *work = NULL;
lda = (1 > nn) ? 1 : nn;
lwork = lda;
work = (dreal *) calloc(lwork, sizeof(dreal));
check_mem(work, "work");
dgetri_(&nn, AA, &lda, ipiv, work, &lwork, &info);
check(info == 0, "Failed dgetri, info = %d", info);
freeup(work);
return;
error:
if(work) freeup(work);
abort();
}
void
iedit(void)
{
nialptr nm = apop();
if (ngetname(nm, gcharbuf) == 0)
buildfault("invalid_name");
else {
calleditor(gcharbuf);
apush(Nullexpr);
}
freeup(nm);
}
void numeric_kronig(int ngrd, dcmplx *gg, dcmplx *kk)
{
int ig;
dcmplx *fr = NULL, *ff = NULL;
check(ngrd % 2 == 0, "Invalid ngrd");
fr = (dcmplx *) calloc(ngrd, sizeof(dcmplx));
check_mem(fr, "fr");
ff = (dcmplx *) calloc(ngrd, sizeof(dcmplx));
check_mem(ff, "ff");
for(ig = 0; ig < ngrd/2; ++ig) {
fr[ig] = gg[ig+ngrd/2];
fr[ig+ngrd/2] = gg[ig];
}
fourier_dcmplx_1d(ngrd, fr, ff, fourier_forward);
ff[0] *= 0.5; // Removing plateau
for(ig = 0; ig < ngrd / 2; ++ig) {
ff[ig+ngrd/2] = 0.0;
}
fourier_dcmplx_1d(ngrd, ff, fr, fourier_backward);
for(ig = 0; ig < ngrd/2; ++ig) {
kk[ig] = fr[ig+ngrd/2] / ngrd;
kk[ig+ngrd/2] = fr[ig] / ngrd;
}
freeup(ff); freeup(fr);
return;
error:
abort();
}
nialptr
getuppername()
{
nialptr x = apop();
int n = ngetname(x, gcharbuf);
freeup(x);
if (n == 0)
return (grounded);
else {
cnvtup(gcharbuf);
return (makephrase(gcharbuf));
}
}
static void tddmrg_expMat(dreal tau, const mat2d_dreal *Mat, mat2d_dcmplx *expMat)
{
int ndim, idim, jdim;
dreal *mat = NULL, *eig = NULL;
dcmplx *zmat = NULL, *expdiag = NULL, *tmpmat = NULL;
ndim = Mat->nrow;
expMat->Reset(expMat);
mat = (dreal *) calloc(ndim*ndim, sizeof(dreal));
eig = (dreal *) calloc(ndim, sizeof(dreal));
zmat = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
expdiag = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
tmpmat = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
memcpy(mat, Mat->addr, ndim*ndim*sizeof(dreal));
lapack_dsyev(ndim, mat, eig);
for(idim = 0; idim < ndim; ++idim)
for(jdim = 0; jdim < ndim; ++jdim)
zmat[idim*ndim+jdim] = (dcmplx) mat[idim*ndim+jdim];
for(idim = 0; idim < ndim; ++idim)
expdiag[idim*ndim+idim] = cexp(-I * eig[idim] * tau);
lapack_zgemm(ndim, ndim, ndim, 'N', 'C', 1.0, expdiag, zmat, 0.0, tmpmat);
lapack_zgemm(ndim, ndim, ndim, 'N', 'N', 1.0, zmat, tmpmat, 0.0, expMat->addr);
freeup(tmpmat);
freeup(expdiag);
freeup(zmat);
freeup(eig);
freeup(mat);
}
nialptr
testfaults(nialptr x, nialptr stdfault)
{
int found = false;
nialint t = tally(x),
i = 0;
nialptr xi = Null,
z;
/* find first fault */
while (!found && i < t) {
xi = fetch_array(x, i++);
if (kind(xi) == chartype || kind(xi) == phrasetype)
return (stdfault); /* result is stdfault if other literal types occur */
found = kind(xi) == faulttype;
}
if (!found)
return (stdfault); /* used in "and" and "or" in cases like "and o -12" */
z = xi;
#ifdef V4AT
if (stdfault==Logical)
{ /* Logical faults are different in V4 */
i = 0; /* scan all the items */
/* find other faults and compare */
while (i < t) {
xi = fetch_array(x, i++);
if ((kind(xi) == faulttype && z != xi) || kind(xi) != faulttype)
/* result is stdfault if fault value changes or other type */
return (stdfault);
}
}
else
#endif
/* find other faults and compare */
{ while (i < t) {
xi = fetch_array(x, i++);
if ((kind(xi) == faulttype && z != xi) || kind(xi) == chartype ||
kind(xi) == phrasetype) /* result is stdfault if fault value changes
or other literal type */
return (stdfault);
}
}
freeup(stdfault); /* since this is a temporary and not used */
return (z);
}
nialptr
bool_to_real(nialptr x)
{
nialint i,
t = tally(x);
nialptr z;
double *pz;
int v = valence(x);
z = new_create_array(realtype, v, 0, shpptr(x, v));
pz = pfirstreal(z); /* safe */
for (i = 0; i < t; i++)
*pz++ = 1.0 * fetch_bool(x, i);
freeup(x);
return (z);
}
void
ihost()
{
nialptr x = apop();
if (ngetname(x, gcharbuf) == 0)
buildfault("invalid host command");
else {
if (command(gcharbuf) == NORMALRETURN) {
apush(Nullexpr);
}
else
buildfault(errmsgptr);
}
freeup(x);
}
int
convert(nialptr * x, int *kx, int k)
{
if (numeric(k)) {
nialptr z = Null;
int v = valence(*x);
nialint i,
t = tally(*x);
switch (k) {
case inttype: /* must be converting a booltype array */
{
nialint *zptr;
z = new_create_array(inttype, v, 0, shpptr(*x, v));
zptr = pfirstint(z); /* safe */
for (i = 0; i < t; i++)
*zptr++ = fetch_bool(*x, i);
}
break;
case realtype: /* converting a boolean or integer array */
{
double *zptr;
z = new_create_array(realtype, v, 0, shpptr(*x, v));
zptr = pfirstreal(z); /* safe */
if (*kx == booltype) {
for (i = 0; i < t; i++)
*zptr++ = (double) fetch_bool(*x, i);
}
else {
nialint *xptr = pfirstint(*x); /* safe */
for (i = 0; i < t; i++)
*zptr++ = (double) *xptr++;
}
}
break;
}
freeup(*x);
*x = z;
*kx = kind(z);
return true;
}
return false;
}