static void GetTNworker(int nArgs, int cycs)
{
IOStream *file;
long i, n= 0;
long *ncycs= 0;
double *times= 0;
Array *array;
HistoryInfo *history;
Dimension *dims;
if (nArgs!=1) YError("get_times/get_ncycs takes exactly one argument");
file= yarg_file(0);
history= file->history;
if (history) {
n= history->nRecords;
if (cycs) ncycs= history->ncyc;
else times= history->time;
}
if (n<=0 || (cycs? (!ncycs) : (!times))) {
PushDataBlock(RefNC(&nilDB));
return;
}
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(n, 1L, (Dimension *)0);
array= PushDataBlock(NewArray(cycs? &longStruct : &doubleStruct, tmpDims));
if (cycs)
for (i=0 ; i<n ; i++) array->value.l[i]= ncycs[i];
else
for (i=0 ; i<n ; i++) array->value.d[i]= times[i];
}
void
Y_set_vars(int nArgs)
{
Symbol *stack = sp - nArgs + 1;
IOStream *file, *child;
char **vars, **rvars;
long i, nvars, nrvars;
Dimension *dims;
if (nArgs<2 || nArgs>3 || !stack[0].ops || !stack[1].ops)
YError("set_vars takes exactly two or three arguments");
file = YGetFile(stack++);
child = file->history? file->history->child : 0;
vars = YGet_Q(stack++, 1, &dims);
nvars = (vars&&dims)? (dims->next? -1 : dims->number) : 0;
if (nArgs==3) {
rvars = YGet_Q(stack++, 1, &dims);
nrvars = (vars&&dims)? (dims->next? -1 : dims->number) : 0;
} else {
rvars = 0;
nrvars = 0;
}
if (nvars<0 || nrvars<0) YError("set_vars var lists must be 1D");
if ((nvars && nvars!=file->dataTable.nItems) ||
(nrvars && nrvars!=(child? child->dataTable.nItems : 0)))
YError("set_vars var lists must match number of vars in file");
if (nvars) {
HashTable tmp;
y_hashtmp *h = y_new_tmpobj(sizeof(y_hashtmp), y_zap_hashtmp);
HashInit(&h->table, nvars);
PushDataBlock(h);
for (i=0 ; i<nvars ; i++)
if (HashAdd(&h->table, vars[i], 0)) break;
if (i<nvars) YError("duplicate names in set_vars static var list");
if (p_signalling) p_abort();
tmp = h->table;
h->table = file->dataTable;
file->dataTable = tmp;
Drop(1);
}
if (nrvars) {
HashTable tmp;
y_hashtmp *h = y_new_tmpobj(sizeof(y_hashtmp), y_zap_hashtmp);
HashInit(&h->table, nvars);
PushDataBlock(h);
for (i=0 ; i<nrvars ; i++)
if (HashAdd(&h->table, rvars[i], 0)) break;
if (i<nrvars) YError("duplicate names in set_vars record var list");
if (p_signalling) p_abort();
tmp = h->table;
h->table = child->dataTable;
child->dataTable = tmp;
Drop(1);
}
}
void Y_get_primitives(int nArgs)
{
IOStream *file;
Dimension *dims;
Array *array;
long *p;
FPLayout *fpl;
int i, j;
if (nArgs!=1) YError("get_primitives requires exactly one argument");
file = yarg_file(0);
dims = tmpDims;
tmpDims = 0;
FreeDimension(dims);
tmpDims = NewDimension(32L, 1L, (Dimension *)0);
array = PushDataBlock(NewArray(&longStruct, tmpDims));
p = array->value.l;
for (i=j=0 ; i<6 ; i++) {
p[j++] = file->structList[i]->size;
p[j++] = file->structList[i]->alignment;
p[j++] = file->structList[i]->order;
}
p[1] = file->structAlign;
for (i=4 ; i<6 ; i++) {
fpl = file->structList[i]->fpLayout;
p[j++] = fpl->sgnAddr;
p[j++] = fpl->expAddr;
p[j++] = fpl->expSize;
p[j++] = fpl->manAddr;
p[j++] = fpl->manSize;
p[j++] = fpl->manNorm;
p[j++] = fpl->expBias;
}
}
void Y_digitize(int nArgs)
{
long number, origin, nbins, i, ip;
double *x, *bins;
Dimension *dimsx, *dimsb;
long *ibin;
if (nArgs!=2) YError("digitize takes exactly two arguments");
bins= YGet_D(sp, 0, &dimsb);
x= YGet_D(sp-1, 0, &dimsx);
if (!dimsb || dimsb->number<2 || dimsb->next)
YError("2nd argument to digitize must be 1D with >=2 elements");
nbins= dimsb->number;
origin= dimsb->origin;
number= TotalNumber(dimsx);
if (dimsx) {
Array *array= PushDataBlock(NewArray(&longStruct, dimsx));
ibin= array->value.l;
} else {
PushLongValue(0L);
ibin= &sp->value.l;
}
ip= 0;
for (i=0 ; i<number ; i++)
ibin[i]= ip= origin+hunt(bins, nbins, x[i], ip);
}
void MultiversoSkipGramMixture::TrainNeuralNetwork()
{
std::queue<DataBlock*>datablock_queue;
int data_block_count = 0;
multiverso::Multiverso::BeginTrain();
for (int curr_epoch = 0; curr_epoch < m_option->epoch; ++curr_epoch)
{
m_reader->Open(m_option->train_file);
while (1)
{
++data_block_count;
DataBlock *data_block = new (std::nothrow)DataBlock();
assert(data_block != nullptr);
clock_t start = clock();
LoadData(data_block, m_reader, m_option->data_block_size);
if (data_block->Size() <= 0)
{
delete data_block;
break;
}
multiverso::Log::Info("Rank%d Load%d^thDataBlockTime:%lfs\n", m_process_id, data_block_count,
(clock() - start) / (double)CLOCKS_PER_SEC);
multiverso::Multiverso::BeginClock();
PushDataBlock(datablock_queue, data_block);
multiverso::Multiverso::EndClock();
}
m_reader->Close();
multiverso::Multiverso::BeginClock();
DataBlock *output_data_block = new DataBlock(); //Add a special data_block for dumping model files
output_data_block->AddTable(kInputEmbeddingTableId);
output_data_block->AddTable(kEmbeddingOutputTableId);
output_data_block->AddTable(kWordSensePriorTableId);
output_data_block->SetEpochId(curr_epoch);
++data_block_count;
multiverso::Multiverso::PushDataBlock(output_data_block);
multiverso::Multiverso::EndClock();
}
multiverso::Log::Info("Rank %d pushed %d blocks\n", multiverso::Multiverso::ProcessRank(), data_block_count);
multiverso::Multiverso::EndTrain();
//After EndTrain, all the datablock are done,
//we remove all the datablocks
RemoveDoneDataBlock(datablock_queue);
}
void
Y_mpeg_create(int nArgs)
{
char *filename = (nArgs>=1 && nArgs<=2)? YGetString(sp-nArgs+1) : 0;
long bad_params[4] = { -1, -1, -1, -1 };
long *params = 0;
if (nArgs == 2) {
Dimension *dims = 0;
params = YGet_L(sp-nArgs+2, 1, &dims);
if (!dims || dims->next || dims->number!=4) params = bad_params;
}
PushDataBlock(ympg_create(filename, params));
}
void Y__write(int nArgs)
{
Symbol *keySymbols[1];
Symbol *stack= YGetKeywords(sp-nArgs+1, nArgs, wrtKeys, keySymbols);
IOStream *file= 0;
long address= 0;
int got_address= 0;
Symbol *object= 0;
Operand op;
StructDef *base;
char *type;
while (stack<=sp) {
if (!stack->ops) {
stack+= 2;
continue;
}
if (!file) {
file= YGetFile(stack);
if (file->history) file= file->history->child;
} else if (!got_address) {
got_address= 1;
address= YGetInteger(stack);
} else if (!object) {
object= stack;
} else {
object= 0;
}
stack++;
}
if (!object) YError("_write takes exactly three arguments");
sp->ops->FormOperand(object, &op);
if (!op.ops->isArray)
YError("third argument to _write must be array or scalar data");
if (YNotNil(keySymbols[0])) type= YGetString(keySymbols[0]);
else type= StructName(op.type.base);
if (!HashFind(&file->structTable, type, 0L))
YError("data type of third argument to _write undefined for this file");
base= file->structList[hashIndex];
if (op.type.base==&charStruct) {
/* special case type char, to have a way to do literal writes */
YcWrite(file, op.value, address, op.type.number);
} else {
YWrite(op.value, address, base, op.type.number, (Strider *)0);
}
PushDataBlock(RefNC(&nilDB));
}
/* similar to BuildResultU in ops0.c */
static void *build_result(Operand *op, StructDef *base)
{
if (! op->references && op->type.base == base) {
/* similar to PushCopy in ydata.c */
Symbol *stack = sp + 1;
Symbol *s = op->owner;
int isDB = (s->ops == &dataBlockSym);
stack->ops = s->ops;
if (isDB) stack->value.db = Ref(s->value.db);
else stack->value = s->value;
sp = stack; /* sp updated AFTER new stack element intact */
return (isDB ? op->value : &sp->value);
} else {
return (void *)(((Array *)(PushDataBlock(NewArray(base, op->type.dims))))->value.c);
}
}
void Y_set_tolerances(int nArgs)
{
double *tols, t1, t2, t3;
Dimension *dims;
Array *array;
if (nArgs!=1) YError("set_tolerances takes exactly one argument");
tols= YGet_D(sp, 1, &dims);
if (tols && (!dims || dims->number!=3 || dims->next))
YError("argument to set_tolerances must be nil or array(double,3)");
/* get current tolerances */
if (polishRoot) {
t1= polishTol1;
t2= polishTol2;
} else {
t1= t2= -1.0;
}
t3= findRayTol;
if (tols) {
/* set tolerances to new values */
if (tols[0]>=0.0) {
if (tols[0]>0.0) polishTol1= tols[0];
else polishTol1= 1.0e-3; /* default value as set in track.c */
if (tols[1]>0.0) polishTol2= tols[1];
else polishTol2= 1.0e-6; /* default value as set in track.c */
polishRoot= 1;
} else {
polishRoot= 0;
}
if (tols[2]>0.0) findRayTol= tols[2];
else findRayTol= 0.0; /* default value as set in track.c */
}
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(3L, 1L, (Dimension *)0);
array= (Array *)PushDataBlock(NewArray(&doubleStruct, tmpDims));
tols= array->value.d;
tols[0]= t1;
tols[1]= t2;
tols[2]= t3;
}
void Y_indgen(int nArgs)
{
long number, origin, stride, i;
Array *array;
Dimension *tmp;
Operand op;
if (nArgs != 1) YError("indgen takes exactly one argument");
sp->ops->FormOperand(sp, &op);
if (op.ops==&rangeOps) {
Range *range= op.value;
if (range->rf || range->nilFlags)
YError("range function and/or nil range component in indgen");
origin= range->min;
stride= range->inc;
if (stride>0) number= (range->max-origin)/stride;
else number= (origin-range->max)/(-stride);
number++; /* number of footprints, not number of strides */
} else if (op.ops->promoteID<=T_LONG && !op.type.dims) {
op.ops->ToLong(&op);
number= *(long *)op.value;
origin= 1L;
stride= 1;
} else {
YError("indgen argument must be range or scalar integer");
return;
}
if (number>0) {
tmp= tmpDims;
tmpDims= 0;
FreeDimension(tmp);
tmpDims= NewDimension(number, 1L, (Dimension *)0);
array= PushDataBlock(NewArray(&longStruct, tmpDims));
for (i=0 ; i<number ; i++) {
array->value.l[i]= origin;
origin+= stride;
}
} else {
/* indgen(0) returns default origin */
PushLongValue(1L);
}
}
void Y__jc(int nArgs)
{
IOStream *file;
HistoryInfo *history;
int noRecord;
if (nArgs!=2) YError("jc takes exactly two arguments");
file= yarg_file(1);
history= file->history;
if (!history)
YError("binary file passed to jc has no history records");
noRecord= JumpToCycle(history, YGetInteger(sp));
if (!CalledAsSubroutine()) {
if (noRecord) PushDataBlock(RefNC(&nilDB));
else PushLongValue(history->ncyc[history->recNumber]);
}
}
void Y_random(int nArgs)
{
Symbol *stack= sp-nArgs+1;
double *random;
long n;
if (nArgs==1 && !YNotNil(stack)) {
/* return scalar result */
PushDoubleValue(0.0);
random= &sp->value.d;
n= 1;
} else {
/* return array result */
Array *array;
BuildDimList(stack, nArgs);
array= PushDataBlock(NewArray(&doubleStruct, tmpDims));
random= array->value.d;
n= array->type.number;
}
NextRandom(random, n);
}
void Y_get_vars(int nArgs)
{
IOStream *file, *child;
Array *array;
char **pNames= 0, **cNames= 0;
long i, nParent, nChild;
Dimension *dims;
if (nArgs!=1) YError("get_vars takes exactly one argument");
file= yarg_file(0);
child= file->history? file->history->child : 0;
/* create result array */
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(2L, 1L, (Dimension *)0);
array= PushDataBlock(NewArray(&pointerStruct, tmpDims));
nParent= file->dataTable.nItems;
nChild= child? child->dataTable.nItems : 0;
if (nParent) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nParent, 1L, (Dimension *)0);
array->value.p[0]= pNames= NewArray(&stringStruct, tmpDims)->value.q;
}
if (nChild) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nChild, 1L, (Dimension *)0);
array->value.p[1]= cNames= NewArray(&stringStruct, tmpDims)->value.q;
}
/* and fill it */
for (i=0 ; i<nParent ; i++) pNames[i]= p_strcpy(file->dataTable.names[i]);
for (i=0 ; i<nChild ; i++) cNames[i]= p_strcpy(child->dataTable.names[i]);
}
void Multiverso::BeginClock()
{
static DataBlockBase begin_clock(DataBlockType::BeginClock);
PushDataBlock(&begin_clock);
}
void Multiverso::EndClock()
{
static DataBlockBase end_clock(DataBlockType::EndClock);
PushDataBlock(&end_clock);
}
void Y_ml4read(int nArgs)
{
char *filename="";
char *varname="";
int leave_open = 0;
if (nArgs==2) {
filename=YGetString(sp-nArgs+1);
varname=YGetString(sp-nArgs+2);
leave_open = 0;
} else if (nArgs==3) {
filename=YGetString(sp-nArgs+1);
varname=YGetString(sp-nArgs+2);
leave_open=YGetInteger(sp-nArgs+3);
}
unsigned long bytes_read;
int type,namelen;
unsigned long nElements,nBytesToRead;
int mrows,mcols,imagf;
FILE *fs;
int fileptr;
int endian = 'L';
int size=0,i;
fs = openmat(filename);
if (fs == NULL) YError(p_strncat("Can't open file ",filename,0));
if (!matfind(fs,varname,50000)) YError(p_strncat("No Such variable ",varname,0));
fileptr = ftell(fs);
if (DEBUG) printf("@ position %d\n",fileptr);
bytes_read = fread(&type,sizeof(int),1,fs);
if (bytes_read==0) {
matclose(filename);
YError("Premature end of file");; // end of file
}
fread(&mrows,sizeof(int),1,fs);
fread(&mcols,sizeof(int),1,fs);
fread(&imagf,sizeof(int),1,fs);
fread(&namelen,sizeof(int),1,fs);
if (namelen & 0xffff0000) {
if (DEBUG) printf("Big endian file\n");
endian = 'B';
SWAP_INT(type);
SWAP_INT(mrows);
SWAP_INT(mcols);
SWAP_INT(imagf);
SWAP_INT(namelen);
}
type = type%1000;
if (DEBUG) printf("rows,cols,namelen= %d %d %d\n",mrows,mcols,namelen);
if (namelen>255) {
fseek(fs,fileptr,SEEK_SET); // leave file ptr at begginning of this variable
matclose(filename);
YError("Variable name too long!");
}
fread(tempvarname,(unsigned int)namelen,1,fs);
// if ((*varname!='*') && strcmp(varname,tempvarname)) { // error if not same varname
if (!matchvarname(tempvarname,varname)) { // error if not same varname
fseek(fs,fileptr,SEEK_SET); // leave file ptr at begginning of this variable
matclose(filename);
YError(p_strncat("Can't find variable",varname,0));
}
nElements = (unsigned)mrows*(unsigned)mcols;
Dimension *tmp=tmpDims;
tmpDims=0;
FreeDimension(tmp);
if (mrows<=1) {
tmpDims= NewDimension(mcols, 1L, (Dimension *)0);
} else if (mcols<=1) {
tmpDims= NewDimension(mrows, 1L, (Dimension *)0);
} else {
tmpDims= NewDimension(mrows, 1L, (Dimension *)0);
tmpDims= NewDimension(mcols, 1L, tmpDims);
}
if (type==0) {
// 8-byte doubles
size = 8;
Array *a= PushDataBlock(NewArray(&doubleStruct, tmpDims));
double *data = a->value.d;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_DOUBLE(data[i]); }
} else if (type==10) {
// 4-byte reals
size = 4;
Array *a= PushDataBlock(NewArray(&floatStruct, tmpDims));
float *data = a->value.f;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_FLOAT(data[i]); }
} else if ((type==120) || (type==20)) {
// 4-byte int
size = 4;
Array *a= PushDataBlock(NewArray(&intStruct, tmpDims));
int *data = a->value.l;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_INT(data[i]); }
} else if (type==30) {
// 2-byte signed (30) shorts
size = 2;
Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims));
short *data = a->value.s;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); }
} else if (type==40) {
// 2-byte unsigned (40) shorts
size = 2;
Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims));
short *data = a->value.s;
Array *b= PushDataBlock(NewArray(&longStruct, tmpDims));
long *data2 = b->value.l;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); }
for (i=1;i<=nElements;i++) *(data2++) = (((long)*(data++))|0xFFFF0000)+65535;
} else if (type==50) {
// 1-byte signed or unsigned chars (50)
size = 1;
Array *a= PushDataBlock(NewArray(&charStruct, tmpDims));
char *data = a->value.c;
bytes_read = fread((void *)data,size,nElements,fs);
} else if (type==51) {
// text (51)
size = 1;
Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
char *buf;
a->value.q[0] = buf = p_malloc(nElements+1);
if (DEBUG) printf("strlen: %d\n",(int)strlen((void *)a->value.q[0]));
// bytes_read = fread(a->value.q[0],1,nElements,fs);
bytes_read = fread(buf,1,nElements,fs);
*((char *)buf + nElements) = 0; // append a NULL to text string
} else {
matclose(filename);
sprintf(message,"Unknown type %d",type);
YError(message);
}
if (bytes_read!=nElements) {
fseek(fs,nElements*size,SEEK_CUR);
matclose(filename);
if (DEBUG) printf("read:%ld expected:%ld\n",bytes_read,nBytesToRead);
YError("Premature end of file");
}
if (!leave_open) matclose(filename);
}
void matscan(FILE *fs, int maxVarsToSearch, int returnString)
{
int info[5];
long i;
long fileptr,tfileptr,tfp;
long nbyt=0,nelem,skip;
int type;
int mrows,mcols;
int imagf;
int namelen;
long varNumber = 0;
char varname[80];
char *stype="";
int varnum=0;
Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
long extra=1;
fileptr = ftell(fs);
if (DEBUG) printf("Entering matscan\n");
while (1) {
tfileptr = ftell(fs);
if (DEBUG) printf("at address %ld \n",tfileptr);
if (fread(info,4,5,fs)==5) {
if (info[4] & 0xffff0000) { // convert header from little endian to big indian
// info[0] changed to info[4] 2006/3/15 as double type can be 0, hence
// no way to know big from little endian info[0] for doubles.
if (DEBUG) printf("swapping!\n");
for (i=0;i<5;i++) SWAP_INT(info[i]);
}
info[0] = info[0]%1000;
tfp = ftell(fs);
if (DEBUG) printf("at address %ld \n",tfp);
if (DEBUG) printf("info = %d %d %d %d %d\n",info[0],info[1],info[2],info[3],info[4]);
type = info[0]%1000;
if ((namelen = info[4])<80L) {
if (fread(varname,1,info[4],fs)==(int)info[4]) {
if (type==0) {
// 8-byte doubles
stype=p_strcpy("double*8"); nbyt=8;
} else if (type==10) {
// 4-byte reals
stype=p_strcpy("real*4 "); nbyt=4;
} else if ((type==120) || (type==20)) {
// 4-byte int
stype=p_strcpy("int*4 "); nbyt=4;
} else if (type==30) {
// 2-byte signed (30) shorts
stype=p_strcpy("short*2 "); nbyt=2;
} else if (type==40) {
// 2-byte unsigned (40) shorts
stype=p_strcpy("ushort*2"); nbyt=2;
} else if ((type==50) || (type==51)) {
// 1-byte signed or unsigned chars (50) or text (51)
stype=p_strcpy("char*1 "); nbyt=1;
} else {
sprintf(message,"Unknown data type %d",type);
YError(message);
}
if (returnString) {
if (varnum!=0) a= PushDataBlock((void *)GrowArray(a, extra));
a->value.q[varnum] = p_malloc(81);
sprintf(a->value.q[varnum],"%30s %s array [%d,%d]",varname, \
stype,info[1],info[2]);
varnum++;
} else {
printf("%30s %s array [%d,%d]\n",varname,stype,info[1],info[2]);
}
mrows=info[1];
mcols=info[2];
nelem=mrows*mcols;
imagf=info[3];
if (imagf) nbyt=2*nbyt;
skip = nbyt*nelem;
if (DEBUG) printf("skiping data part: %ld bytes\n",skip);
if (skip) fseek(fs,nbyt*nelem,SEEK_CUR);
}
}
} else {
break;
}
if (maxVarsToSearch) {
if (++varNumber >= maxVarsToSearch) {
break;
}
}
}
}
void Y_integ(int nArgs)
{
long which, nDims, number, nfast;
long i, j, k, l, m, js, ms, ip, ipy;
double *y, *x, *xp, *yi, *psum, c0, c1, dx;
Array *array;
Dimension *tmp;
Operand opy, opx, opxp;
if (nArgs!=3 && nArgs!=4)
YError("integ takes exactly three or four arguments");
if (nArgs==4) {
which= YGetInteger(sp)-1; /* use 0-origin which here */
Drop(1);
} else {
which= 0; /* use 0-origin which here */
ClearTmpArray(); /* need a temporary for this calculation */
}
sp->ops->FormOperand(sp, &opxp);
(sp-1)->ops->FormOperand(sp-1, &opx);
(sp-2)->ops->FormOperand(sp-2, &opy);
opxp.ops->ToDouble(&opxp);
opx.ops->ToDouble(&opx);
opy.ops->ToDouble(&opy);
tmp= tmpDims;
tmpDims= 0;
FreeDimension(tmp);
/* compute dimensions of y array -- nfast-by-number-by-(slow), where
nfast are the first which dimensions of y, number is the length of
the dimension to interpolate on, and (slow) are the rest */
nDims= CountDims(opy.type.dims);
if (which<0) which= nDims+which; /* handle which<0 like array index<0 */
if (which>=nDims || which<0) YError("bad 4th argument to integ");
i= nDims-1-which;
tmp= opy.type.dims;
while (i) { tmp= tmp->next; i--; }
number= tmp? tmp->number : 1;
if (number<2) YError("bad dimension (length 1) in integ");
nfast= TotalNumber(tmp->next);
if (opx.type.number!=number || opx.type.dims->next)
YError("dimension of x does not match target dimension of y in integ");
if (which==nDims-1) {
/* can just tack new element(s) of dimension list onto old */
tmpDims= Ref(opy.type.dims->next);
tmpDims= CopyDims(opxp.type.dims, tmpDims, 1);
} else {
/* make a fresh copy of the index list and find where to insert new */
Dimension *prev, *tmpprev;
i= nDims-which; /* guaranteed >1 AND opy is at least 2D */
tmpDims= prev= CopyDims(opy.type.dims, tmpDims, 1);
tmp= prev->next; i--;
tmp= tmp->next; i--; /* prev is two behind tmp */
while (i) { prev= prev->next; tmp= tmp->next; i--; }
tmpprev= prev->next;
prev->next= 0; /* cut off tail of dimension list */
tmpprev->next= 0; /* this pointed to tmp */
FreeDimension(tmpprev);
prev->next= CopyDims(opxp.type.dims, tmp, 1);
}
/* create partial sum array (integrals up to each xp) */
array= NewTmpArray(&doubleStruct, opy.type.dims);
psum= array->value.d;
/* create result array */
array= PushDataBlock(NewArray(&doubleStruct, tmpDims));
yi= array->value.d;
y= opy.value;
x= opx.value;
xp= opxp.value;
/* The problem is as follows (same as interp):
For each value of the faster indices, and each value of the slower
indices of y, and for each value of xp, find the value of yi
corresponding to xp. Note that for each interpolation, the y
vector has stride nfast, while the x vector always has stride 0.
Note also that ALL of the yi for a given xp should be computed
once xp is found. */
/* first compute partial sums */
js= nfast*number;
for (j=0 ; j<opy.type.number ; j+=js) {
for (k=0 ; k<nfast ; k++) {
psum[k+j]= 0.0;
for (i=1, l=nfast ; i<number ; i++, l+=nfast)
psum[k+l+j]= psum[k+l-nfast+j]+
0.5*(y[k+l-nfast+j]+y[k+l+j])*(x[i]-x[i-1]);
}
}
/* use that to compute interpolated integrals */
ms= nfast*opxp.type.number;
c0= c1= 0.0;
ip= 0; /* hunt takes this as no guess on 1st pass */
for (i=l=0 ; i<opxp.type.number ; i++, l+=nfast) {
ip= hunt(x, number, xp[i], ip);
ipy= ip*nfast;
if (ip>=1 && ip<number) {
dx= xp[i]-x[ip-1];
c1= 0.5*dx*dx/(x[ip]-x[ip-1]);
c0= dx-c1;
}
for (j=m=0 ; j<opy.type.number ; j+=js, m+=ms) {
for (k=0 ; k<nfast ; k++) {
if (ip<1) { /* point below minimum */
yi[k+l+m]= 0.0;
} else if (ip<number) { /* point in range */
yi[k+l+m]= c0*y[k+(ipy-nfast)+j]+c1*y[k+ipy+j]
+psum[k+(ipy-nfast)+j];
} else { /* point above maximum */
yi[k+l+m]= psum[k+(ipy-nfast)+j];
}
}
}
}
ClearTmpArray();
PopToD(sp-4);
Drop(3);
}
static void morph_op(int argc, int mop)
{
char msg[80];
Operand op;
Dimension *dims;
Symbol *s;
Array *ap;
long ndims, width, height, depth, number, *off, *dx, *dy, *dz;
if (argc != 2) {
sprintf(msg, "morph_%s takes exactly 2 arguments",
(mop ? "dilation" : "erosion"));
YError(msg);
}
/* Get input array. */
s = sp - 1;
if (! s->ops) YError("unexpected keyword argument");
dims = s->ops->FormOperand(s, &op)->type.dims;
ndims = 0;
width = height = depth = 0;
while (dims) {
if (++ndims > 3) YError("too many dimensions for input array");
depth = height;
height = width;
width = dims->number;
dims = dims->next;
}
/* Get radius / offset array. */
off = get_offset(sp, &dims);
if (! dims) {
/* Only one extra scalar argument: the structuring element is a
sphere. */
long x, y, z, r, n, lim0, lim1, lim2;
r = off[0];
if (r < 0) {
YError("radius of structuring element must be a positive integer");
}
Drop(1); /* to be able to push temporary workspace */
n = 2*r + 1;
lim0 = r*(r + 1);
number = 0;
if (depth > 1) {
n = n*n*n; /* maximum number of offsets per dimension */
off = yeti_push_workspace(3*sizeof(long)*n);
dx = off;
dy = dx + n;
dz = dy + n;
for (z=-r ; z<=r ; ++z) {
lim1 = lim0 - z*z;
for (y=-r ; y<=r ; ++y) {
lim2 = lim1 - y*y;
for (x=-r ; x<=r ; ++x) {
/* To be inside the structuring element, we must have
* sqrt(x*x + y*y + z*z) < r + 1/2
* which is the same as:
* x*x + y*y + z*z <= r*(r + 1)
* because X, Y, Z and R are integers.
*/
if (x*x <= lim2) {
dx[number] = x;
dy[number] = y;
dz[number] = z;
++number;
}
}
}
}
} else if (height > 1) {
n = n*n; /* maximum number of offsets per dimension */
dx = yeti_push_workspace(2*sizeof(long)*n);
dy = dx + n;
dz = NULL;
for (y=-r ; y<=r ; ++y) {
lim1 = lim0 - y*y;
for (x=-r ; x<=r ; ++x) {
if (x*x <= lim1) {
dx[number] = x;
dy[number] = y;
++number;
}
}
}
} else {
dx = yeti_push_workspace(sizeof(long)*n);
dy = NULL;
dz = NULL;
for (x=-r ; x<=r ; ++x) {
dx[number++] = x;
}
}
} else {
if (ndims > 1) {
if (dims->number != ndims) {
YError("last dimension of OFF not equal to number of dimensions of A");
}
dims = dims->next;
}
number = 1;
while (dims) {
number *= dims->number;
dims = dims->next;
}
dx = off;
dy = (ndims >= 2 ? dx + number : NULL);
dz = (ndims >= 3 ? dy + number : NULL);
}
/* Allocate output array and apply the operation. */
ap = ((Array *)PushDataBlock(NewArray(op.type.base, op.type.dims)));
switch (op.ops->typeID) {
#undef _
#define _(ID) (mop ? dilation_##ID : erosion_##ID)((void *)ap->value.ID, \
op.value, width, height, depth, dx, dy, dz, number); break
case T_CHAR: _(c);
case T_SHORT: _(s);
case T_INT: _(i);
case T_LONG: _(l);
case T_FLOAT: _(f);
case T_DOUBLE: _(d);
#undef _
default:
YError("bad data type");
}
}
void Y__raw_track(int nArgs)
{
long nrays;
Ray *rays;
DratMesh *dm;
double *slimits;
Array *array;
Ray_Path *result;
long ncuts, i;
long *zone, *pt1, *pt2;
double *ds, *f;
EraseRayPath(&path);
if (nArgs!=4) YError("_raw_track takes exactly four arguments");
/* no validity checking -- leave it to interpreted wrapper */
nrays= YGetInteger(sp-3);
rays= (Ray *)YGet_D(sp-2, 0, (Dimension **)0);
dm= YGetDMesh(sp-1, 0);
slimits= YGet_D(sp, 0, (Dimension **)0);
/* push result array onto stack */
array=
(Array *)PushDataBlock(NewArray(sdRay_Path,
NewDimension(nrays, 1L, (Dimension *)0)));
array->type.dims->references--;
result= (Ray_Path *)array->value.c;
while (nrays>0) {
TrackRay(&dm->mesh, rays, slimits, &path);
result->fi= path.fi;
result->ff= path.ff;
ncuts= path.ncuts;
if (ncuts>1) {
Dimension *dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(ncuts, 1L, (Dimension *)0);
result->zone= zone= (NewArray(&longStruct, tmpDims))->value.l;
result->ds= ds= (NewArray(&doubleStruct, tmpDims))->value.d;
result->pt1= pt1= (NewArray(&longStruct, tmpDims))->value.l;
result->pt2= pt2= (NewArray(&longStruct, tmpDims))->value.l;
result->f= f= (NewArray(&doubleStruct, tmpDims))->value.d;
/* convert zone, pt1, and pt2 to 1-origin index lists */
for (i=0 ; i<ncuts ; i++) {
zone[i]= path.zone[i]+1;
ds[i]= path.ds[i];
pt1[i]= path.pt1[i]+1;
pt2[i]= path.pt2[i]+1;
f[i]= path.f[i];
}
}
rays++;
slimits+= 2;
result++;
nrays--;
}
EraseRayPath(&path);
}
void Y_get_addrs(int nArgs)
{
IOStream *file, *child;
Array *array;
long *pAddrs= 0, *cAddrs= 0, *rAddrs= 0;
int *rFiles= 0;
char **rNames= 0;
long i, nParent, nChild, nFamily, nRecords;
HistoryInfo *history;
Dimension *dims;
if (nArgs!=1) YError("get_addrs takes exactly one argument");
file= yarg_file(0);
history= file->history;
child= history? history->child : 0;
/* create result array */
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(5L, 1L, (Dimension *)0);
array= PushDataBlock(NewArray(&pointerStruct, tmpDims));
nParent= file->dataTable.nItems;
nChild= child? child->dataTable.nItems : 0;
nRecords= child? history->nRecords : 0;
nFamily= child? history->nFamily : 0;
if (nParent) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nParent, 1L, (Dimension *)0);
array->value.p[0]= pAddrs= NewArray(&longStruct, tmpDims)->value.l;
}
if (nChild) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nChild, 1L, (Dimension *)0);
array->value.p[1]= cAddrs= NewArray(&longStruct, tmpDims)->value.l;
}
if (nRecords>0) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nRecords, 1L, (Dimension *)0);
array->value.p[2]= rAddrs= NewArray(&longStruct, tmpDims)->value.l;
array->value.p[3]= rFiles= NewArray(&intStruct, tmpDims)->value.i;
}
if (nFamily>0) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nFamily, 1L, (Dimension *)0);
array->value.p[4]= rNames= NewArray(&stringStruct, tmpDims)->value.q;
}
/* and fill it */
for (i=0 ; i<nParent ; i++) pAddrs[i]= file->addresses[i]+file->offset;
for (i=0 ; i<nChild ; i++) cAddrs[i]= child->addresses[i];
for (i=0 ; i<nRecords ; i++) rAddrs[i]= history->offset[i];
for (i=0 ; i<nRecords ; i++) rFiles[i]= history->ifile[i];
for (i=0 ; i<nFamily ; i++) rNames[i]= p_strcpy(history->famNames[i]);
}
void
Y_spawn(int nargs)
{
Dimension *dims = 0;
char **argv = yarg_q(nargs-1, &dims);
long argc = 1;
Operand op;
Operand *pop = yarg_op(nargs-2, &op);
long callout=-1, callerr=-1;
spawn_proc *proc;
if (nargs<2 || nargs>3)
YError("spawn: accepts precisely two or three arguments");
if (dims) {
if (dims->next)
YError("spawn: first argument must be string or 1D array of strings");
argc = dims->number;
}
if (!argv || !argv[0] || !argv[0][0])
YError("spawn: first element of first argument must be process name");
if (!pop || (op.ops!=&functionOps && op.ops!=&builtinOps))
YError("spawn: second argument must be callback function");
if (op.ops==&builtinOps) callout = ((BIFunction *)op.value)->index;
else callout = ((Function *)op.value)->code[0].index;
if (nargs == 3) {
pop = yarg_op(0, &op);
if (!pop || (op.ops!=&functionOps && op.ops!=&builtinOps))
YError("spawn: third argument must be callback function");
if (op.ops==&builtinOps) callerr = ((BIFunction *)op.value)->index;
else callerr = ((Function *)op.value)->code[0].index;
}
if (argv[argc-1]) {
/* must construct a 0-terminated argv list */
typedef struct tmpobj {
int references;
Operations *ops;
void (*zapper)(void *to);
char *argv[1];
} tmpobj;
tmpobj *tmp;
long i;
/* CheckStack(2); fnctn.c guarantees at least 2 free stack slots */
tmp = PushDataBlock(y_new_tmpobj(sizeof(tmpobj)+argc*sizeof(char*),
p_free));
for (i=0 ; i<argc ; i++) tmp->argv[i] = argv[i];
tmp->argv[i] = 0;
argv = tmp->argv;
/* tmp will be cleaned up when stack cleared */
}
/* push result object onto stack */
proc = p_malloc(sizeof(spawn_proc));
proc->references = 0;
proc->ops = &spawn_ops;
proc->proc = p_spawn(argv[0], argv, spawn_callback, proc, callerr>=0);
proc->argv0 = p_strcpy(argv[0]);
proc->callout = callout;
proc->callerr = callerr;
proc->next = spawn_list;
spawn_list = proc;
PushDataBlock(proc);
if (!proc->proc) {
Drop(1);
PushDataBlock(RefNC(&nilDB));
}
if (!spawn_setclean) {
spawn_setclean = 1;
spawn_prevclean = CleanUpForExit;
CleanUpForExit = spawn_cleanup;
}
}
void Y_find_boundary(int nArgs)
{
DratMesh *dm;
int region, sense;
Array *array;
if (liveBoundary) {
liveBoundary= 0;
EraseBoundary(&boundary);
}
if (nArgs<1 || nArgs>3)
YError("update_mesh takes exactly one, two, or three arguments");
dm= YGetDMesh(sp-nArgs+1, 0);
if (nArgs>1) {
if (YNotNil(sp-nArgs+2)) region= (int)YGetInteger(sp-nArgs+2);
else region= 0;
if (nArgs>2 && YNotNil(sp)) sense= (int)YGetInteger(sp);
else sense= 0;
} else {
/* here are the values used in UpdateMesh call to FindBoundaryPoints */
region= 0;
sense= 1;
}
boundary.zsym= dm->mesh.boundary.zsym;
if (region!=0 || sense!=1) {
/* must calculate boundary now */
boundary.nk= boundary.nl= boundary.npoints= 0;
boundary.zone= 0;
boundary.side= 0;
boundary.z= boundary.r= 0;
liveBoundary= 1;
FindBoundaryPoints(&dm->mesh.mesh, region, sense, &boundary,
dm->mesh.work);
} else {
/* boundary already calculated */
boundary.nk= dm->mesh.boundary.nk;
boundary.nl= dm->mesh.boundary.nl;
boundary.npoints= dm->mesh.boundary.npoints;
boundary.zone= dm->mesh.boundary.zone;
boundary.side= dm->mesh.boundary.side;
boundary.z= dm->mesh.boundary.z;
boundary.r= dm->mesh.boundary.r;
}
/* form result -- 1-origin array of 4 pointers */
array=
(Array *)PushDataBlock(NewArray(&pointerStruct,
NewDimension(4L, 1L, (Dimension *)0)));
array->type.dims->references--;
if (boundary.npoints>0) {
long npoints= boundary.npoints;
long i;
void **result= array->value.p;
long *zone;
int *side;
double *z, *r;
Dimension *dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(npoints, 1L, (Dimension *)0);
result[0]= zone= (NewArray(&longStruct, tmpDims))->value.l;
result[1]= side= (NewArray(&intStruct, tmpDims))->value.i;
result[2]= z= (NewArray(&doubleStruct, tmpDims))->value.d;
result[3]= r= (NewArray(&doubleStruct, tmpDims))->value.d;
/* convert zone to 1-origin index list */
for (i=0 ; i<npoints ; i++) {
zone[i]= boundary.zone[i]+1;
side[i]= boundary.side[i];
z[i]= boundary.z[i];
r[i]= boundary.r[i];
}
}
if (liveBoundary) EraseBoundary(&boundary);
}
void Y__jt(int nArgs)
{
Operand op;
IOStream *file;
HistoryInfo *history;
double targetTime= 0.0;
Symbol *stack= sp-nArgs+1;
long recNumber;
int noRecord;
if (nArgs!=1 && nArgs!=2)
YError("jt takes exactly one or two arguments");
stack->ops->FormOperand(stack, &op);
if (op.ops==&streamOps) {
/* first argument is explicit binary file */
file= op.value;
history= file->history;
if (!history)
YError("binary file passed to jt has no history records");
recNumber= history->recNumber;
if (nArgs>1) {
sp->ops->FormOperand(sp, &op);
if (op.ops==&rangeOps) { /* jt, file, - */
/* look for jt, file, - (backup 1 record) */
Range *range= op.value;
if ((range->nilFlags&(~(R_MINNIL|R_MAXNIL|R_PSEUDO))) ||
range->inc!=1)
YError("did you want jt, file, - (jump to previous record)?");
noRecord= recNumber>=0? JumpRecord(history, recNumber-1) :
JumpRecord(history, history->nRecords-1);
} else if (op.ops==&voidOps) { /* jt, file, [] */
noRecord= recNumber>=0? JumpRecord(history, recNumber+1) :
JumpRecord(history, 0);
} else { /* jt, file, time */
targetTime= YGetReal(sp);
noRecord= JumpToTime(history, targetTime);
if (noRecord) {
if (history->time) {
noRecord= 2;
targetTime= history->time[history->recNumber];
} else {
noRecord= 3;
}
}
}
} else { /* jt, file */
noRecord= recNumber>=0? JumpRecord(history, recNumber+1) :
JumpRecord(history, 0);
}
} else { /* jt, time */
IOFileLink *link;
if (nArgs!=1)
YError("did you want jt, file, time (instead of jt, time, file)?");
targetTime= YGetReal(sp);
for (link=yBinaryFiles ; link ; link=link->next) {
file= link->ios;
if (!file) continue;
history= file->history;
if (!history || history->recNumber<0) continue;
JumpToTime(history, targetTime);
}
noRecord= 3;
}
if (!CalledAsSubroutine()) {
if (noRecord>2) PushDataBlock(RefNC(&nilDB));
if (noRecord>1) PushDoubleValue(targetTime);
else if (noRecord) PushIntValue(0);
else PushIntValue(1);
}
}
void Y_sort(int nArgs)
{
Operand op;
Array *result;
long *ilist, i, j, which, nDims, origin;
Dimension *tmp;
void (*ysort)(long *list, long n);
if (nArgs!=1 && nArgs!=2)
YError("sort takes exactly one or two arguments");
if (nArgs==2) { which= YGetInteger(sp)-1; Drop(1); }
else which= 0; /* use 0-origin which here */
/* get array to be sorted */
sp->ops->FormOperand(sp, &op);
if (op.ops->typeID <= T_LONG) {
op.ops->ToLong(&op);
ysort= &ysortL;
longData= op.value;
} else if (op.ops->typeID <= T_DOUBLE) {
op.ops->ToDouble(&op);
ysort= &ysortD;
doubleData= op.value;
} else if (op.ops==&stringOps) {
ysort= &ysortQ;
stringData= op.value;
} else {
YError("sort function requires integer, real, or string operand");
ysort= 0;
}
/* figure out stride for the sort */
nDims= CountDims(op.type.dims);
if (nDims==0) {
PushIntValue(0);
sp->ops= &longScalar;
sp->value.l= 0;
return;
}
if (which<0) which+= nDims;
if (which<0 || which>=nDims)
YError("2nd argument to sort function out of range");
if (nDims<2) {
sortStride= 1;
sortSize= op.type.number;
} else {
which= nDims-1-which;
tmp= op.type.dims;
while (which--) tmp= tmp->next;
sortStride= TotalNumber(tmp->next);
sortSize= sortStride*tmp->number;
}
sortLimit= 7*sortStride; /* use straight insertion for <7 elements */
/* push result Array, then fill it with index to be sorted */
result= PushDataBlock(NewArray(&longStruct, op.type.dims));
ilist= result->value.l;
for (i=0 ; i<op.type.number ; i++) ilist[i]= i;
for (i=0 ; i<sortStride ; i++)
for (j=0 ; j<op.type.number ; j+=sortSize)
ysort(&ilist[i+j], sortSize);
if ((origin= op.type.dims->origin))
for (i=0 ; i<op.type.number ; i++) ilist[i]+= origin;
}
void Y_form_mesh(int nArgs)
{
if (nArgs!=3) YError("form_mesh takes exactly three arguments");
PushDataBlock(NewDratMesh((int)YGetInteger(sp-2),
YGetInteger(sp-1)-1, YGetInteger(sp)-1));
}
void Y_transpose(int nArgs)
{
Symbol *stack= sp-nArgs+1;
Operand op, opp;
int i, nDims, order[10];
long numbers[10], origins[10], strides[10];
long stride, *cycle, index, prev, next, last;
Dimension *dims;
LValue *lvalue;
Strider *strider;
if (nArgs < 1) YError("transpose needs at least argument");
stack->ops->FormOperand(stack, &op);
if (!op.ops->isArray) YError("1st argument to transpose must be array");
nDims= CountDims(op.type.dims);
if (nDims>10) YError("transpose fails for arrays with >10 dimensions");
if (nDims<1) {
if (nArgs>1) Drop(nArgs-1);
return;
}
/* collect dimension lengths and strides into arrays to be permuted */
dims= op.type.dims;
stride= 1;
for (i=0 ; i<nDims ; i++) {
numbers[nDims-1-i]= dims->number;
origins[nDims-1-i]= dims->origin;
dims= dims->next;
}
stride= op.type.base->size;
for (i=0 ; i<nDims ; i++) {
strides[i]= stride;
stride*= numbers[i];
}
/* compute the permutation from the remaining arguments */
for (i=0 ; i<nDims ; i++) order[i]= i;
if (nArgs<2) {
/* default is to swap first and last indices */
if (nDims) {
prev= order[0];
order[0]= order[nDims-1];
order[nDims-1]= prev;
}
} else {
/* read permutation list */
while (stack<sp) {
stack++;
stack->ops->FormOperand(stack, &opp);
if (opp.ops->promoteID>T_LONG ||
(opp.type.dims && opp.type.dims->next))
YError("bad permutation list in transpose");
opp.ops->ToLong(&opp);
cycle= opp.value;
if (opp.type.dims) {
/* this is a cycle list */
last= cycle[0]-1;
if (last<0) last+= nDims;
if (last<0 || last>=nDims)
YError("permutation list references non-existent dimension "
"in transpose");
prev= order[last];
for (i=1 ; i<opp.type.number ; i++) {
index= cycle[i]-1;
if (index<0) index+= nDims;
if (index<0 || index>=nDims)
YError("permutation list references non-existent dimension "
"in transpose");
next= order[index];
order[index]= prev;
prev= next;
}
order[last]= prev;
} else {
/* this is a cyclic permutation of all nDims indices */
long inc= cycle[0]-1; /* index which 0 should go to */
long now;
if (inc<0) inc= nDims - (-inc)%nDims;
if (inc>=nDims) inc%= nDims;
prev= order[0];
now= inc;
last= now;
for (i=0 ; i<nDims ; i++) {
next= order[now];
order[now]= prev;
prev= next;
now+= inc;
if (now>=nDims) now-= nDims;
if (last==now) {
/* handle case of several independent cycles when nDims is
evenly divisible by inc */
prev= order[++now];
now+= inc;
if (now>=nDims) now-= nDims;
last= now;
}
}
}
}
Drop(nArgs-1);
}
/* build re-ordered dimension list */
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
for (i=0 ; i<nDims ; i++)
tmpDims= NewDimension(numbers[order[i]], origins[order[i]], tmpDims);
/* push LValue describing result onto stack */
lvalue= PushDataBlock(NewLValueM((Array *)sp->value.db, op.value,
op.type.base, tmpDims));
/* build strider list describing re-ordering */
for (i=0 ; i<nDims ; i++) {
strider= NewStrider(strides[order[i]], numbers[order[i]]);
strider->next= lvalue->strider;
lvalue->strider= strider;
}
PopTo(sp-2);
Drop(1);
FetchLValue(lvalue, sp);
}
void Y_span(int nArgs)
{
long which, nDims, number, nfast, i, j, k, kx;
double rnumber, dp, *p0, *p1, *p;
Array *array;
Dimension *tmp;
Operand op0, op1;
if (nArgs!=3 && nArgs!=4)
YError("span takes exactly three or four arguments");
if (nArgs==4) { which= YGetInteger(sp)-1; Drop(1); }
else which= 0; /* use 0-origin which here */
number= YGetInteger(sp);
if (number<1) YError("3rd argument to span function must be >0");
Drop(1);
sp->ops->FormOperand(sp, &op1);
(sp-1)->ops->FormOperand(sp-1, &op0);
op1.ops->ToDouble(&op1);
op0.ops->ToDouble(&op0);
if (BinaryConform(&op1, &op0) & 4)
YError("start and stop not conformable in span function");
tmp= tmpDims;
tmpDims= 0;
FreeDimension(tmp);
/* compute dimensions of result -- nfast-by-number-by-(slow),
where nfast are the first which indices of op0 (or op1),
and (slow) are the rest */
nDims= CountDims(op0.type.dims);
if (which<0) which= nDims+1+which; /* handle which<0 like array index<0 */
if (which>8 || nDims-which>8)
YError("the 4th argument to span is unreasonably large");
while (which<0) {
tmpDims= NewDimension(1L, 1L, tmpDims);
which++;
}
if (which>=nDims) {
/* can just tack new element of dimension list onto old */
tmpDims= Ref(op0.type.dims);
while (which>nDims) {
tmpDims= NewDimension(1L, 1L, tmpDims);
which--;
}
tmpDims= NewDimension(number, 1L, tmpDims);
nfast= op0.type.number;
} else {
/* make a fresh copy of the index list, then insert new element */
Dimension *prev;
which= nDims-which; /* guaranteed this is >0 */
tmpDims= tmp= CopyDims(op0.type.dims, tmpDims, 1);
do {
prev= tmp;
tmp= tmp->next;
} while (--which);
prev->next= NewDimension(number, 1L, tmp);
nfast= TotalNumber(tmp);
}
/* create result array and fill it */
array= PushDataBlock(NewArray(&doubleStruct, tmpDims));
p= array->value.d;
p0= op0.value;
p1= op1.value;
rnumber= 1.0/(double)(number-1);
kx= array->type.number - nfast;
for (i=0 ; i<op0.type.number ; i+=nfast) {
for (j=0 ; j<nfast ; j++) {
dp= (p1[i+j]-p0[i+j])*rnumber;
k= j+number*i;
p[k]= p0[i+j];
for (k+=nfast ; k<kx ; k+=nfast) p[k]= p[k-nfast]+dp;
p[k]= p1[i+j]; /* do after loop to assure exact equality */
}
}
}
void
Y_lsdir(int nArgs)
{
Symbol *stack = sp-nArgs+1;
Symbol *glob = 0;
Dimension *dims;
y_dirlist *dlist;
char *name, **list;
long i;
int is_dir = 0;
if (nArgs<1 || nArgs>2) YError("lsdir takes one or two arguments");
if (nArgs==2) {
if (!stack->ops || sp->ops!=&referenceSym)
YError("lsdir second argument not simple variable reference");
glob = &globTab[sp->index];
sp--;
}
dlist = y_new_tmpobj(sizeof(y_dirlist), y_zap_dirlist);
dlist->dir = 0;
dlist->fils = dlist->subs = 0;
dlist->nfils = dlist->nsubs = 0;
PushDataBlock(dlist);
name = YGetString(stack);
if (!name)
YError("first argument to lsdir must be a non-nil scalar string");
dlist->dir = p_dopen(name);
if (!dlist->dir) {
Drop(1);
PushLongValue(0);
return;
}
while ((name = p_dnext(dlist->dir, &is_dir))) {
if (is_dir && nArgs==2)
y_add_item(&dlist->subs, &dlist->nsubs, p_strcpy(name));
else
y_add_item(&dlist->fils, &dlist->nfils, p_strcpy(name));
}
if (stack->ops==&dataBlockSym) {
stack->ops = &intScalar;
Unref(stack->value.db);
}
if (dlist->nfils) {
char *nm;
dims = tmpDims;
tmpDims = 0;
FreeDimension(dims);
tmpDims = NewDimension(dlist->nfils, 1L, (Dimension *)0);
stack->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims);
stack->ops = &dataBlockSym;
list = ((Array *)stack->value.db)->value.q;
for (i=0 ; i<dlist->nfils ; i++) {
nm = dlist->fils[i];
dlist->fils[i] = 0;
list[i] = nm;
}
list = dlist->fils;
dlist->fils = 0;
p_free(list);
} else {
stack->value.db = (DataBlock *)(RefNC(&nilDB));
stack->ops = &dataBlockSym;
}
if (glob) {
if (glob->ops==&dataBlockSym) {
glob->ops = &intScalar;
Unref(glob->value.db);
}
if (dlist->nsubs) {
char *nm;
dims = tmpDims;
tmpDims = 0;
FreeDimension(dims);
tmpDims = NewDimension(dlist->nsubs, 1L, (Dimension *)0);
glob->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims);
glob->ops = &dataBlockSym;
list = ((Array *)glob->value.db)->value.q;
for (i=0 ; i<dlist->nsubs ; i++) {
nm = dlist->subs[i];
dlist->subs[i] = 0;
list[i] = nm;
}
list = dlist->subs;
dlist->subs = 0;
p_free(list);
} else {
glob->value.db = (DataBlock *)(RefNC(&nilDB));
glob->ops = &dataBlockSym;
}
}
Drop(1);
}
void Y_grow(int nArgs)
{
Symbol *s0, *s= sp-nArgs+1;
long index= s->index;
Array *array;
Dimension *dims;
StructDef *base;
Operand op;
long extra, number;
int nDims;
DataBlock *db;
int amSubroutine= CalledAsSubroutine();
if (nArgs < 2) YError("grow function needs at least two arguments");
if (amSubroutine && s->ops!=&referenceSym)
YError("1st argument to grow must be a variable reference");
if (!s->ops) YError("unxepected keyword argument in grow");
dims= growDims;
growDims= 0;
FreeDimension(dims);
/* scan argument list to find first non-nil argument */
base= 0;
s0= 0;
for (;;) {
if (!s0 && amSubroutine) array= (Array *)ForceToDB(&globTab[index]);
else array= (Array *)ForceToDB(s); /* does ReplaceRef if required */
s0= s;
if (array->ops==&lvalueOps) array= FetchLValue(array, s);
if (array->ops->isArray) {
base= array->type.base;
if (array->references) {
/* the grow operation is destructive, must copy 1st arg */
Array *copy= PushDataBlock(NewArray(base, array->type.dims));
base->Copy(base, copy->value.c, array->value.c, array->type.number);
PopTo(s);
array= copy;
}
if (array->type.dims) {
growDims= NewDimension(1L, 1L, Ref(array->type.dims->next));
} else {
growDims= NewDimension(1L, 1L, (Dimension *)0);
array->type.dims= NewDimension(1L, 1L, (Dimension *)0);
}
break;
} else if (array->ops!=&voidOps) {
YError("bad data type in function grow");
}
if (++s > sp) { /* all arguments void, will return nil */
Drop(nArgs-1);
PopTo(sp-1);
return;
}
}
nDims= CountDims(growDims);
/* scan through remaining arguments to force right-conformability with
growDims and count the number of extra dimensions */
extra= 0;
while (s<sp) {
s++;
if (!s->ops) YError("unxepected keyword argument in grow");
s->ops->FormOperand(s, &op);
if (op.ops->isArray) {
if (nDims==CountDims(op.type.dims))
growDims->number= op.type.dims->number;
else
growDims->number= 1;
if (RightConform(growDims, &op))
YError("later arguments not conformable with 1st in grow");
extra+= growDims->number;
} else if (op.ops!=&voidOps) {
YError("illegal data type in function grow");
}
}
if (extra) {
LValue lvalue;
long size;
BinaryOp *Assign= base->dataOps->Assign;
/* phony LValue necessary for Assign virtual function */
lvalue.references= nArgs; /* NEVER want to free this */
lvalue.ops= &lvalueOps;
lvalue.owner= 0; /* not true, but safer */
lvalue.type.base= base; /* NOT Ref(base) -- won't be freed */
lvalue.address.m= 0;
lvalue.strider= 0;
size= base->size;
/* copy 1st non-nil argument */
number= array->type.number;
array= PushDataBlock(GrowArray(array, extra));
lvalue.address.m= array->value.c + size*number;
/* second pass through argument list copies 2nd-Nth arguments
into result array using the Assign virtual function */
s= s0;
while (++s<sp) { /* note that sp is bigger than for previous loop */
s->ops->FormOperand(s, &op);
if (op.ops->isArray) {
lvalue.type.dims= op.type.dims; /* NOT Ref(dims) -- won't be freed */
lvalue.type.number= op.type.number;
/* Assign virtual functions assume their first parameter is an
LValue* rather than an Operation* (like all other BinaryOps). */
(*Assign)((Operand *)&lvalue, &op);
lvalue.address.m+= size*lvalue.type.number;
}
}
}
/* store result back to first reference -- will also be left on stack
by EvalBI */
if (amSubroutine) {
s= &globTab[index]; /* guaranteed this is a dataBlockSym by ForceToDB */
db= s->value.db;
s->value.db= (DataBlock *)Ref(array);
Unref(db);
if (extra) Drop(nArgs);
else Drop(nArgs-1);
ReplaceRef(sp); /* result is 1st argument */
PopTo(sp-1);
} else {
if (extra) { /* result is on top of stack */
PopTo(sp-nArgs-1);
Drop(nArgs);
} else { /* result is unchanged s0 argument */
int nAbove= sp-s0;
Drop(nAbove);
nArgs-= nAbove;
PopTo(sp-nArgs);
Drop(nArgs-1);
}
}
}