void Y_arc(int nArgs)
{
Operand op;
int promoteID;
long number, i;
if (nArgs != 1) YError("arc takes exactly one argument");
if (! sp->ops) YError("unexpected keyword");
sp->ops->FormOperand(sp, &op);
promoteID = op.ops->promoteID;
if (promoteID == T_DOUBLE) {
const double rad = TWO_PI;
const double scl = ONE_OVER_TWO_PI;
double *x, *y;
x = op.value;
y = build_result(&op, &doubleStruct);
number = op.type.number;
for (i=0 ; i<number ; ++i) y[i] = x[i] - rad*round(scl*x[i]);
pop_to_d(sp - 2);
} else if (promoteID <= T_FLOAT) {
const float rad = JOIN(TWO_PI,F);
const float scl = JOIN(ONE_OVER_TWO_PI,F);
float *x, *y;
if (promoteID != T_FLOAT) op.ops->ToFloat(&op);
x = op.value;
y = build_result(&op, &floatStruct);
number = op.type.number;
for (i=0 ; i<number ; ++i) y[i] = x[i] - rad*roundf(scl*x[i]);
PopTo(sp - 2);
} else {
YError("expecting non-complex numeric argument");
}
Drop(1);
}
void Y__not_pdb(int nArgs)
{
IOStream *file;
int familyOK, notOK;
if (nArgs!=2) YError("_not_pdb takes exactly two arguments");
file= yarg_file(1);
familyOK= (int)YGetInteger(sp);
if (!pdb_open) pdb_open= Globalize("yPDBopen", 0L);
if (globTab[pdb_open].ops!=&longScalar &&
globTab[pdb_open].ops!=&intScalar)
YError("yPDBopen variable must be an int or long scalar");
yPDBopen= (int)YGetInteger(&globTab[pdb_open]);
notOK= YtestPDB(file, familyOK);
if (notOK>1) {
YWarning("file is open as a PDB file, but partially broken");
notOK= 0;
} else if (notOK==1) {
/* check for a Clog file if it didn't have a PDB header */
notOK= CLopen(file, familyOK);
}
PushIntValue(notOK);
PopTo(sp-3);
Drop(2);
}
/* same as PopToD in ops0.c */
static void pop_to_d(Symbol *s)
{
Array *array = (Array *)sp->value.db;
PopTo(s);
if (s->ops==&dataBlockSym && !array->type.dims) {
s->ops= &doubleScalar;
s->value.d= array->value.d[0];
Unref(array);
}
}
static void unary_worker(int nArgs, looper_t *DLooper, looper_t *ZLooper)
{
Operand op;
int promoteID;
if (nArgs!=1) YError("expecting exactly one argument");
if (!sp->ops) YError("unexpected keyword");
sp->ops->FormOperand(sp, &op);
promoteID = op.ops->promoteID;
if (promoteID <= T_DOUBLE) {
if (promoteID < T_DOUBLE) op.ops->ToDouble(&op);
DLooper(build_result(&op, &doubleStruct), op.value, op.type.number);
pop_to_d(sp - 2);
} else {
if (promoteID>T_COMPLEX) YError("expecting numeric argument");
ZLooper(build_result(&op, &complexStruct), op.value, 2*op.type.number);
PopTo(sp - 2);
}
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);
}
}
}
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);
}
