/* eql - internal eql function */
int eql P2C(LVAL, arg1, LVAL, arg2)
{
/* compare the arguments */
if (arg1 == arg2)
return (TRUE);
else if (arg1 != NIL) {
switch (ntype(arg1)) {
case FIXNUM:
return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
#ifdef BIGNUMS
case RATIO:
return (ratiop(arg2) ? compareratio(arg1, arg2) : FALSE);
case BIGNUM:
return (bignump(arg2) ? comparebignum(arg1, arg2) == 0 : FALSE);
#endif
case FLONUM:
return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
case COMPLEX:
return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
default:
return (FALSE);
}
}
else
return (FALSE);
}
void nyx_get_label(unsigned int index,
double *start_time,
double *end_time,
const char **label)
{
LVAL s = nyx_result;
LVAL label_expr;
LVAL t0_expr;
LVAL t1_expr;
LVAL str_expr;
if (nyx_get_type(nyx_result) != nyx_labels) {
return;
}
while (index) {
index--;
s = cdr(s);
if (s == NULL) {
// index was larger than number of labels
return;
}
}
/* We either have (t0 "label") or (t0 t1 "label") */
label_expr = car(s);
t0_expr = car(label_expr);
t1_expr = car(cdr(label_expr));
if (stringp(t1_expr)) {
str_expr = t1_expr;
t1_expr = t0_expr;
}
else {
str_expr = car(cdr(cdr(label_expr)));
}
if (floatp(t0_expr)) {
*start_time = getflonum(t0_expr);
}
else if (fixp(t0_expr)) {
*start_time = (double)getfixnum(t0_expr);
}
if (floatp(t1_expr)) {
*end_time = getflonum(t1_expr);
}
else if (fixp(t1_expr)) {
*end_time = (double)getfixnum(t1_expr);
}
*label = (const char *)getstring(str_expr);
}
/* xwrfloat - write a float to a file */
LVAL xwrfloat(void)
{
LVAL val, fptr;
union {
char b[8];
float f;
double d;
} v;
int n = 4;
int i;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
/* get the float and file pointer and optional byte count */
val = xlgaflonum();
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n != 4 && n != 8) {
xlerror("must be 4 or 8 bytes", count);
}
}
xllastarg();
#ifdef XL_BIG_ENDIAN
/* flip the bytes */
index = n - 1 - index;
incr = -incr;
#endif
/* build output v.b */
if (n == 4) v.f = (float) getflonum(val);
else v.d = getflonum(val);
/* put bytes to the file */
for (i = 0; i < n; i++) {
xlputc(fptr, v.b[index]);
index += incr;
}
/* return the flonum */
return val;
}
double nyx_get_double()
{
if (nyx_get_type(nyx_result) != nyx_double)
return -1.0;
return getflonum(nyx_result);
}
LOCAL double spin_angle P1C(LVAL, object)
{
LVAL value = slot_value(object, s_rotation_angle);
if (floatp(value)) return(getflonum(value));
else return(0.0);
}
/*
* returns true if it is time to terminate
*
* Note: compute_lvl gets called in the outer loop to skip over
* a breakpoint pair before starting the compute_incr loop, which
* searches for a breakpoint that is some number of samples in the
* future. This code is not embedded in compute_incr because it is
* NOT called from the initialization, where it would be wrong to
* skip over the first breakpoint.
*/
boolean compute_lvl(pwl_susp_type susp)
{
if (!cdr(susp->bpt_ptr)) return true;
susp->lvl = getflonum(car(cdr(susp->bpt_ptr)));
susp->bpt_ptr = cdr(cdr(susp->bpt_ptr));
return !susp->bpt_ptr;
}
void nyx_get_label(int index,
double *time,
const char **label)
{
LVAL s = nyx_result;
LVAL t_expr;
if (nyx_get_type(nyx_result) != nyx_labels)
return;
if (index < 0 || index >= nyx_get_num_labels())
return;
while(index) {
index--;
s = cdr(s);
}
t_expr = car(car(s));
if (floatp(t_expr))
*time = getflonum(t_expr);
else if (fixp(t_expr))
*time = (double)getfixnum(t_expr);
*label = (const char *)getstring(car(cdr(car(s))));
}
void nyx_get_label(int index,
double *start_time,
double *end_time,
const char **label)
{
LVAL s = nyx_result;
LVAL label_expr;
LVAL t0_expr;
LVAL t1_expr;
LVAL str_expr;
if (nyx_get_type(nyx_result) != nyx_labels)
return;
if (index < 0 || index >= nyx_get_num_labels())
return;
while(index) {
index--;
s = cdr(s);
}
/* We either have (t0 "label") or (t0 t1 "label") */
label_expr = car(s);
t0_expr = car(label_expr);
t1_expr = car(cdr(label_expr));
if (stringp(t1_expr)) {
str_expr = t1_expr;
t1_expr = t0_expr;
}
else
str_expr = car(cdr(cdr(label_expr)));
if (floatp(t0_expr))
*start_time = getflonum(t0_expr);
else if (fixp(t0_expr))
*start_time = (double)getfixnum(t0_expr);
if (floatp(t1_expr))
*end_time = getflonum(t1_expr);
else if (fixp(t1_expr))
*end_time = (double)getfixnum(t1_expr);
*label = (const char *)getstring(str_expr);
}
/* equal - internal equal function */
int equal P2C(LVAL, arg1, LVAL, arg2)
{
FIXTYPE n=0; /* for circularity check -- 6/93 */
/* compare the arguments */
isItEqual: /* turn tail recursion into iteration */
if (arg1 == arg2)
return (TRUE);
else if (arg1 != NIL) {
switch (ntype(arg1)) {
case FIXNUM:
return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
#ifdef BIGNUMS
case RATIO:
return (ratiop(arg2) ? compareratio(arg1, arg2) : FALSE);
case BIGNUM:
return (bignump(arg2) ? comparebignum(arg1, arg2) == 0 : FALSE);
#endif
case FLONUM:
return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
case COMPLEX:
return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
case STRING: /* TAA MOD */
return (stringp(arg2) ? stringcmp(arg1,arg2) : FALSE);
case CONS: /* TAA MOD turns tail recursion into iteration */
/* Not only is this faster, but greatly reduces chance */
/* of stack overflow */
#ifdef STSZ
if (consp(arg2) && (stchck(), equal(car(arg1),car(arg2))))
#else
if (consp(arg2) && equal(car(arg1),car(arg2)))
#endif
{
arg1 = cdr(arg1);
arg2 = cdr(arg2);
if (++n > nnodes) xlfail("circular list");
goto isItEqual;
}
return FALSE;
default:
return (FALSE);
}
}
else
return (FALSE);
}
LVAL xlc_snd_set_latency(void)
{
double arg1 = getflonum(xlgaflonum());
double result;
xllastarg();
result = snd_set_latency(arg1);
return cvflonum(result);
}
LVAL xlc_log(void)
{
double arg1 = getflonum(xlgaflonum());
double result;
xllastarg();
result = xlog(arg1);
return cvflonum(result);
}
void fromobject__fetch(register fromobject_susp_type susp, snd_list_type snd_list)
{
int cnt = 0; /* how many samples computed */
int togo;
int n;
sample_block_type out;
register sample_block_values_type out_ptr;
register sample_block_values_type out_ptr_reg;
register boolean done_reg;
register LVAL src_reg;
falloc_sample_block(out, "fromobject__fetch");
out_ptr = out->samples;
snd_list->block = out;
while (cnt < max_sample_block_len) { /* outer loop */
/* first compute how many samples to generate in inner loop: */
/* don't overflow the output sample block: */
togo = max_sample_block_len - cnt;
if (susp->done) {
togo = 0; /* indicate termination */
break; /* we're done */
}
n = togo;
done_reg = susp->done;
src_reg = susp->src;
out_ptr_reg = out_ptr;
if (n) do { /* the inner sample computation loop */
LVAL rslt = xleval(cons(s_send, cons(src_reg,
consa(s_next))));
if (floatp(rslt)) {
*out_ptr_reg++ = (sample_type) getflonum(rslt);
} else {
done_reg = true;
/* adjust togo to what it should have been */
break;
};
} while (--n); /* inner loop */
togo -= n;
susp->done = done_reg;
out_ptr += togo;
cnt += togo;
} /* outer loop */
/* test for termination */
if (togo == 0 && cnt == 0) {
snd_list_terminate(snd_list);
} else {
snd_list->block_len = cnt;
susp->susp.current += cnt;
}
} /* fromobject__fetch */
/* return value of a number coerced to a FLOTYPE */
FLOTYPE makefloat P1C(LVAL, x)
{
switch (ntype(x)) {
case FIXNUM: return ((FLOTYPE) getfixnum(x));
case FLONUM: return getflonum(x);
#ifdef BIGNUMS
case BIGNUM: return cvtbigflonum(x);
case RATIO: return cvtratioflonum(x);
#endif
}
xlerror("not a real number", x);
return 0.0; /* never reached */
}
/*
* returns true if it is time to terminate
*/
boolean compute_incr(pwl_susp_type susp, long *n, long cur)
{
double target;
while (*n == 0) {
*n = getfixnum(car(susp->bpt_ptr)) - cur;
/* if there is a 2nd element of the pair, get the target */
if (cdr(susp->bpt_ptr))
target = getflonum(car(cdr(susp->bpt_ptr)));
else target = 0.0;
if (*n > 0) susp->incr = (target - susp->lvl) / *n;
else if (compute_lvl(susp)) return true;
}
return false;
}
// Copy a node (recursively if appropriate)
LOCAL LVAL nyx_dup_value(LVAL val)
{
LVAL nval = val;
// Protect old and new values
xlprot1(val);
xlprot1(nval);
// Copy the node
if (val != NIL) {
switch (ntype(val))
{
case FIXNUM:
nval = cvfixnum(getfixnum(val));
break;
case FLONUM:
nval = cvflonum(getflonum(val));
break;
case CHAR:
nval = cvchar(getchcode(val));
break;
case STRING:
nval = cvstring((char *) getstring(val));
break;
case VECTOR:
{
int len = getsize(val);
int i;
nval = newvector(len);
nval->n_type = ntype(val);
for (i = 0; i < len; i++) {
if (getelement(val, i) == val) {
setelement(nval, i, val);
}
else {
setelement(nval, i, nyx_dup_value(getelement(val, i)));
}
}
}
break;
case CONS:
nval = nyx_dup_value(cdr(val));
nval = cons(nyx_dup_value(car(val)), nval);
break;
case SUBR:
case FSUBR:
nval = cvsubr(getsubr(val), ntype(val), getoffset(val));
break;
// Symbols should never be copied since their addresses are cached
// all over the place.
case SYMBOL:
nval = val;
break;
// Streams are not copied (although USTREAM could be) and reference
// the original value.
case USTREAM:
case STREAM:
nval = val;
break;
// Externals aren't copied because I'm not entirely certain they can be.
case EXTERN:
nval = val;
break;
// For all other types, just allow them to reference the original
// value. Probably not the right thing to do, but easier.
case OBJECT:
case CLOSURE:
default:
nval = val;
break;
}
}
xlpop();
xlpop();
return nval;
}
void ifft__fetch(register ifft_susp_type susp, snd_list_type snd_list)
{
int cnt = 0; /* how many samples computed */
int togo;
int n;
sample_block_type out;
register sample_block_values_type out_ptr;
register sample_block_values_type out_ptr_reg;
register long index_reg;
register sample_type * outbuf_reg;
falloc_sample_block(out, "ifft__fetch");
out_ptr = out->samples;
snd_list->block = out;
while (cnt < max_sample_block_len) { /* outer loop */
/* first compute how many samples to generate in inner loop: */
/* don't overflow the output sample block: */
togo = max_sample_block_len - cnt;
if (susp->src == NULL) {
out: togo = 0; /* indicate termination */
break; /* we're done */
}
if (susp->index >= susp->stepsize) {
long i;
long m, n;
LVAL elem;
susp->index = 0;
susp->array =
xleval(cons(s_send, cons(susp->src, consa(s_next))));
if (susp->array == NULL) {
susp->src = NULL;
goto out;
} else if (!vectorp(susp->array)) {
xlerror("array expected", susp->array);
} else if (susp->samples == NULL) {
/* assume arrays are all the same size as first one;
now that we know the size, we just have to do this
first allocation.
*/
susp->length = getsize(susp->array);
if (susp->length < 1)
xlerror("array has no elements", susp->array);
if (susp->window && (susp->window_len != susp->length))
xlerror("window size and spectrum size differ",
susp->array);
/* tricky non-power of 2 detector: only if this is a
* power of 2 will the highest 1 bit be cleared when
* we subtract 1 ...
*/
if (susp->length & (susp->length - 1))
xlfail("spectrum size must be a power of 2");
susp->samples = (sample_type *) calloc(susp->length,
sizeof(sample_type));
susp->outbuf = (sample_type *) calloc(susp->length,
sizeof(sample_type));
} else if (getsize(susp->array) != susp->length) {
xlerror("arrays must all be the same length", susp->array);
}
/* at this point, we have a new array to put samples */
/* the incoming array format is [DC, R1, I1, R2, I2, ... RN]
* where RN is the real coef at the Nyquist frequency
* but susp->samples should be organized as [DC, RN, R1, I1, ...]
*/
n = susp->length;
/* get the DC (real) coef */
elem = getelement(susp->array, 0);
MUST_BE_FLONUM(elem)
susp->samples[0] = (sample_type) getflonum(elem);
/* get the Nyquist (real) coef */
elem = getelement(susp->array, n - 1);
MUST_BE_FLONUM(elem);
susp->samples[1] = (sample_type) getflonum(elem);
/* get the remaining coef */
for (i = 1; i < n - 1; i++) {
elem = getelement(susp->array, i);
MUST_BE_FLONUM(elem)
susp->samples[i + 1] = (sample_type) getflonum(elem);
}
susp->array = NULL; /* free the array */
/* here is where the IFFT and windowing should take place */
//fftnf(1, &n, susp->samples, susp->samples + n, -1, 1.0);
m = round(log(n) / M_LN2);
if (!fftInit(m)) riffts(susp->samples, m, 1);
else xlfail("FFT initialization error");
if (susp->window) {
n = susp->length;
for (i = 0; i < n; i++) {
susp->samples[i] *= susp->window[i];
}
}
/* shift the outbuf */
n = susp->length - susp->stepsize;
for (i = 0; i < n; i++) {
susp->outbuf[i] = susp->outbuf[i + susp->stepsize];
}
/* clear end of outbuf */
for (i = n; i < susp->length; i++) {
susp->outbuf[i] = 0;
}
/* add in the ifft result */
n = susp->length;
for (i = 0; i < n; i++) {
susp->outbuf[i] += susp->samples[i];
}
}
togo = min(togo, susp->stepsize - susp->index);
n = togo;
index_reg = susp->index;
outbuf_reg = susp->outbuf;
out_ptr_reg = out_ptr;
if (n) do { /* the inner sample computation loop */
*out_ptr_reg++ = outbuf_reg[index_reg++];;
} while (--n); /* inner loop */
susp->index = index_reg;
susp->outbuf = outbuf_reg;
out_ptr += togo;
cnt += togo;
} /* outer loop */
/* test for termination */
if (togo == 0 && cnt == 0) {
snd_list_terminate(snd_list);
} else {
snd_list->block_len = cnt;
susp->susp.current += cnt;
}
} /* ifft__fetch */
/* xlprint - print an xlisp value */
void xlprint(LVAL fptr, LVAL vptr, int flag)
{
LVAL nptr,next;
int n,i;
/* print nil */
if (vptr == NIL) {
putsymbol(fptr,"NIL",flag);
return;
}
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putsubr(fptr,"Subr",vptr);
break;
case FSUBR:
putsubr(fptr,"FSubr",vptr);
break;
case CONS:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NIL; nptr = next) {
xlprint(fptr,car(nptr),flag);
if (next = cdr(nptr))
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYMBOL:
putsymbol(fptr,(char *) getstring(getpname(vptr)),flag);
break;
case FIXNUM:
putfixnum(fptr,getfixnum(vptr));
break;
case FLONUM:
putflonum(fptr,getflonum(vptr));
break;
case CHAR:
putchcode(fptr,getchcode(vptr),flag);
break;
case STRING:
if (flag)
putqstring(fptr,vptr);
else
putstring(fptr,vptr);
break;
case STREAM:
putatm(fptr,"File-Stream",vptr);
break;
case USTREAM:
putatm(fptr,"Unnamed-Stream",vptr);
break;
case OBJECT:
putatm(fptr,"Object",vptr);
break;
case VECTOR:
xlputc(fptr,'#');
xlputc(fptr,'(');
for (i = 0, n = getsize(vptr); n-- > 0; ) {
xlprint(fptr,getelement(vptr,i++),flag);
if (n) xlputc(fptr,' ');
}
xlputc(fptr,')');
break;
case CLOSURE:
putclosure(fptr,vptr);
break;
case EXTERN:
if (getdesc(vptr)) {
(*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
}
break;
case FREE_NODE:
putatm(fptr,"Free",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}