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); }