/* cons - construct a new cons node */
LVAL cons(LVAL x, LVAL y)
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
xlstkcheck(2);
xlprotect(x);
xlprotect(y);
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
xlpop();
xlpop();
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
--nfree;
/* initialize the new node */
nnode->n_type = CONS;
rplaca(nnode,x);
rplacd(nnode,y);
/* return the new node */
return (nnode);
}
/* xreadline - read a line from a file */
LVAL xreadline(void)
{
unsigned char buf[STRMAX+1],*p,*sptr;
LVAL fptr,str,newstr;
int len,blen,ch;
/* protect some pointers */
xlsave1(str);
/* get file pointer */
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
xllastarg();
/* get character and check for eof */
len = blen = 0; p = buf;
while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
/* check for buffer overflow */
if (blen >= STRMAX) {
newstr = new_string(len + STRMAX + 1);
sptr = getstring(newstr); *sptr = '\0';
if (str) strcat((char *) sptr, (char *) getstring(str));
*p = '\0'; strcat((char *) sptr, (char *) buf);
p = buf; blen = 0;
len += STRMAX;
str = newstr;
}
/* store the character */
*p++ = ch; ++blen;
}
/* check for end of file */
if (len == 0 && p == buf && ch == EOF) {
xlpop();
return (NIL);
}
/* append the last substring */
if (str == NIL || blen) {
newstr = new_string(len + blen + 1);
sptr = getstring(newstr); *sptr = '\0';
if (str) strcat((char *) sptr, (char *) getstring(str));
*p = '\0'; strcat((char *) sptr, (char *) buf);
str = newstr;
}
/* restore the stack */
xlpop();
/* return the string */
return (str);
}
/* xmember - built-in function 'member' */
LVAL xmember(void)
{
LVAL x,list,fcn,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(list); list = cdr(list))
if (dotest2(x,car(list),fcn) == tresult) {
val = list;
break;
}
/* restore the stack */
xlpop();
/* return the result */
return (val);
}
LOCAL LVAL datareduce1 P4C(subrfun, f, subrfun, bf, LVAL, nullval, int, count)
{
LVAL fcn, x, result;
switch (xlargc) {
case 0: result = nullval; break;
case 1:
if (compoundp(peekarg(0))) {
xlstkcheck(2);
xlsave(x);
xlsave(fcn);
fcn = cvsubr(bf, SUBR, 0);
x = subr_map_elements(f);
x = compounddataseq(x);
result = reduce(fcn, x, FALSE, NIL);
xlpopn(2);
}
else result = (count) ? cvfixnum((FIXTYPE) 1) : xlgetarg();
break;
default:
xlsave1(x);
x = makearglist(xlargc, xlargv);
result = xlcallsubr1(f, x);
xlpop();
}
return(result);
}
/* xlenter - enter a symbol into the obarray */
LVAL xlenter(char *name)
{
LVAL sym,array;
int i;
/* check for nil */
if (strcmp(name,"NIL") == 0)
return (NIL);
/* check for symbol already in table */
array = getvalue(obarray);
i = hash(name,HSIZE);
for (sym = getelement(array,i); sym; sym = cdr(sym))
if (strcmp(name,(char *) getstring(getpname(car(sym)))) == 0)
return (car(sym));
/* make a new symbol node and link it into the list */
xlsave1(sym);
sym = consd(getelement(array,i));
rplaca(sym,xlmakesym(name));
setelement(array,i,sym);
xlpop();
/* return the new symbol */
return (car(sym));
}
LVAL iview_hist_add_points(V)
{
IVIEW_WINDOW w;
int old_n, n;
LVAL object, data, hdata;
gethistargs(&w, &object, &hdata);
if (IVIEW_WINDOW_NULL(w)) return(NIL);
old_n = IViewNumPoints(w);
xlsave1(data);
data = xlgetarg();
data = (fixp(data) || (consp(data) && seqp(car(data))))
? data : consa(data);
internal_iview_add_points(w, object, data);
xlpop();
n = IViewNumPoints(w);
allocate_internal_points(object, n);
initialize_points(w, hdata, old_n, n);
check_add_to_screen(object, 'P', old_n, n, TRUE);
return(NIL);
}
/* evpushargs - evaluate and push a list of arguments */
LOCAL int evpushargs(LVAL fun, LVAL args)
{
LVAL *newfp;
int argc;
/* protect the argument list */
xlprot1(args);
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL); /* will be argc */
/* evaluate and push each argument */
for (argc = 0; consp(args); args = cdr(args), ++argc)
pusharg(xleval(car(args)));
/* establish the new stack frame */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
/* restore the stack */
xlpop();
/* return the number of arguments */
return (argc);
}
/* xassoc - built-in function 'assoc' */
LVAL xassoc(void)
{
LVAL x,alist,fcn,pair,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to look for and the association list */
x = xlgetarg();
alist = xlgalist();
xltest(&fcn,&tresult);
/* look for the expression */
for (val = NIL; consp(alist); alist = cdr(alist))
if ((pair = car(alist)) && consp(pair))
if (dotest2(x,car(pair),fcn) == tresult) {
val = pair;
break;
}
/* restore the stack */
xlpop();
/* return result */
return (val);
}
/* xappend - built-in function append */
LVAL xappend(void)
{
LVAL list,last=NULL,next,val;
/* protect some pointers */
xlsave1(val);
/* initialize */
val = NIL;
/* append each argument */
if (moreargs()) {
while (xlargc > 1) {
/* append each element of this list to the result list */
for (list = nextarg(); consp(list); list = cdr(list)) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
LVAL xsaxpy(V)
{
LVAL result, next, tx, a, x, y;
int i, j, m, n, start, end, lower;
double val;
a = getdarraydata(xlgamatrix());
x = xlgaseq();
y = xlgaseq();
lower = (moreargs() && xlgetarg() != NIL) ? TRUE : FALSE;
n = seqlen(x);
m = seqlen(y);
if (lower && m != n)
xlfail("dimensions do not match");
xlsave1(result);
result = mklist(m, NIL);
for (i = 0, start = 0, next = result;
i < m;
i++, start += n, next = cdr(next)) {
val = makefloat(getnextelement(&y, i));
end = (lower) ? i +1 : n;
for (j = 0, tx = x; j < end; j++) {
val += makefloat(getnextelement(&tx, j))
* makefloat(gettvecelement(a, start + j));
}
rplaca(next, cvflonum((FLOTYPE) val));
}
xlpop();
return(result);
}
static LVAL add_contour_point P10C(int, m,
int, i,
int, j,
int, k,
int, l,
double *, x,
double *, y,
double *, z,
double, v,
LVAL, result)
{
LVAL pt;
double p, q;
double zij = z[i * m + j];
double zkl = z[k * m + l];
if ((zij <= v && v < zkl) || (zkl <= v && v < zij)) {
xlsave(pt);
pt = mklist(2, NIL);
p = (v - zij) / (zkl - zij);
q = 1.0 - p;
rplaca(pt, cvflonum((FLOTYPE) (q * x[i] + p * x[k])));
rplaca(cdr(pt), cvflonum((FLOTYPE) (q * y[j] + p * y[l])));
result = cons(pt, result);
xlpop();
}
return(result);
}
/* splitlist - split the list around the pivot */
LOCAL void splitlist(LVAL pivot, LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn)
{
LVAL next;
xlprot1(list); // protect list from gc
// the rplacd disconnects list, and next is the only
// reference to it, but next is immediately assigned to list
// before dotest2 which is where gc might run.
/* initialize the result lists */
*psmaller = *plarger = NIL;
/* split the list */
for (; consp(list); list = next) {
next = cdr(list);
if (dotest2(car(list),car(pivot),fcn)) {
rplacd(list,*psmaller);
*psmaller = list;
}
else {
rplacd(list,*plarger);
*plarger = list;
}
}
xlpop();
}
/* xformat - formatted output function */
LVAL xformat(void)
{
unsigned char *fmt;
LVAL stream,val;
int ch;
/* protect stream in case it is a new ustream */
xlsave1(stream);
/* get the stream and format string */
stream = xlgetarg();
if (stream == NIL)
val = stream = newustream();
else {
if (stream == s_true)
stream = getvalue(s_stdout);
else if (!streamp(stream) && !ustreamp(stream))
xlbadtype(stream);
val = NIL;
}
fmt = getstring(xlgastring());
/* process the format string */
while ((ch = *fmt++))
if (ch == '~') {
switch (*fmt++) {
case '\0':
xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
case 'a': case 'A':
xlprint(stream,xlgetarg(),FALSE);
break;
case 's': case 'S':
xlprint(stream,xlgetarg(),TRUE);
break;
case '%':
xlterpri(stream);
break;
case '~':
xlputc(stream,'~');
break;
case '\n':
case '\r':
/* mac may read \r -- this should be ignored */
if (*fmt == '\r') fmt++;
while (*fmt && *fmt != '\n' && isspace(*fmt))
++fmt;
break;
default:
xlerror("unknown format directive",cvstring((char *) (fmt-1)));
}
}
else
xlputc(stream,ch);
/* return the value */
if (val) val = getstroutput(val);
xlpop();
return val;
}
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */
LVAL xshlibinit()
{
LVAL subr, val, sym;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
struct version_info defversion;
defversion.current = moreargs()?getfixnum(xlgafixnum()):-1;
defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
if (defversion.current >= 0 &&
! check_version(&defversion, &(info->modversion)))
xlfail("module not compatible with requested version");
xlsave1(val);
val = NIL;
if (p != NULL)
for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) {
subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0);
setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE);
val = cons(subr, val);
if (p->fd_name != NULL) {
sym = xlenter(p->fd_name);
setfunction(sym, subr);
}
}
if (pfix != NULL)
for (; pfix->name != NULL; pfix++) {
sym = xlenter(pfix->name);
defconstant(sym, cvfixnum(pfix->val));
}
if (pflo != NULL)
for (; pflo->name != NULL; pflo++) {
sym = xlenter(pflo->name);
defconstant(sym, cvflonum(pflo->val));
}
if (pstr != NULL)
for (; pstr->name != NULL; pstr++) {
sym = xlenter(pstr->name);
defconstant(sym, cvstring(pstr->val));
}
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
if (pulong != NULL)
for (; pulong->name != NULL; pulong++) {
sym = xlenter(pulong->name);
defconstant(sym, ulong2lisp(pulong->val));
}
}
xlpop();
return xlnreverse(val);
}
VOID newhistinternals P1C(LVAL, object)
{
LVAL val;
xlsave1(val);
val = newadata(sizeof(struct hist), 1, FALSE);
val = consa(val);
set_slot_value(object, s_histogram_internals, val);
xlpop();
}
LVAL Native_Put()
{
TVeosErr iErr;
TTimeStamp tNow;
#ifndef OPTIMAL
if (!KERNEL_INIT)
Native_TrapErr(NATIVE_NOKERNEL, nil);
#endif
/** get mandatory data argument **/
native_putPB.pXReplaceElt = xlgetarg();
/** get pattern from xlisp args **/
iErr = Native_GetPatternArg(&native_putPB.pPatGr, NANCY_ReplaceMatch);
if (iErr != VEOS_SUCCESS)
Native_TrapErr(iErr, nil);
/** get optional frequency argument **/
NATIVE_FREQ_ARG(native_putPB.iFreqFlag);
/** set the data time-stamp **/
GET_TIME(tNow);
native_putPB.pStampTime = &tNow;
/** dispatch the matcher **/
xlsave1(native_putPB.pXResult);
Native_XMandR(&native_putPB);
xlpop();
/** clean up **/
Nancy_DisposeGrouple(native_putPB.pPatGr);
return (native_putPB.pXResult);
} /* Native_Put */
/* cvstring - convert a string to a string node */
LVAL cvstring(char *str)
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = strlen(str) + 1;
val->n_string = stralloc(getslength(val));
strcpy((char *) getstring(val),str);
xlpop();
return (val);
}
/* :APPEND-ITEMS Method */
LVAL xsappend_items(V)
{
LVAL menu, new_items;
xlsave1(new_items);
menu = xlgaobject();
new_items = makearglist(xlargc, xlargv);
append_items(menu, new_items);
xlpop();
return(NIL);
}
/* new_string - allocate and initialize a new string */
LVAL new_string(int size)
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = size;
val->n_string = stralloc(getslength(val));
strcpy((char *) getstring(val),"");
xlpop();
return (val);
}
LVAL Native_Init()
{
LVAL pXReturn;
int iPort;
TVeosErr iErr;
xlsave1(pXReturn);
if (!moreargs())
iPort = TALK_BOGUS_FD;
else
iPort = getfixnum(xlgafixnum());
xllastarg();
/** invoke veos kernel inialization **/
iErr = Kernel_Init(iPort, Native_MessageToLSpace);
if (iErr == VEOS_SUCCESS) {
/** create a lisp based inspace for messages **/
s_InSpace = xlenter("VEOS_INSPACE");
setvalue(s_InSpace, NIL);
NATIVE_INSPACE = &getvalue(s_InSpace);
/** create keyword symbols for nancy prims **/
k_TestTime = xlenter(":TEST-TIME"); /* use with copy only */
k_Freq = xlenter(":FREQ"); /* use with copy, put or get */
/** setup invariant matcher settings in global param blocks **/
Native_InitMatcherPBs();
/** make a uid return value to signify success **/
Uid2XVect(&IDENT_ADDR, &pXReturn);
}
xlpop();
return(pXReturn);
} /* Native_Init */
void nyx_cleanup()
{
if (nyx_output_string) {
free(nyx_output_string);
nyx_output_string = NULL;
nyx_output_pos = 0;
nyx_output_len = 0;
}
xlpop(); /* garbage-collect nyx_result */
gc(); /* run the garbage-collector now */
}
LVAL snd_make_yin(sound_type s, double low_step, double high_step, long stepsize)
{
LVAL result;
int j;
register yin_susp_type susp;
rate_type sr = s->sr;
time_type t0 = s->t0;
falloc_generic(susp, yin_susp_node, "snd_make_yin");
susp->susp.fetch = yin_fetch;
susp->terminate_cnt = UNKNOWN;
/* initialize susp state */
susp->susp.free = yin_free;
susp->susp.sr = sr / stepsize;
susp->susp.t0 = t0;
susp->susp.mark = yin_mark;
susp->susp.print_tree = yin_print_tree;
susp->susp.name = "yin";
susp->logically_stopped = false;
susp->susp.log_stop_cnt = logical_stop_cnt_cvt(s);
susp->susp.current = 0;
susp->s = s;
susp->s_cnt = 0;
susp->m = (long) (sr / step_to_hz(high_step));
if (susp->m < 2) susp->m = 2;
/* add 1 to make sure we round up */
susp->middle = (long) (sr / step_to_hz(low_step)) + 1;
susp->blocksize = susp->middle * 2;
susp->stepsize = stepsize;
/* blocksize must be at least step size to implement stepping */
if (susp->stepsize > susp->blocksize) susp->blocksize = susp->stepsize;
susp->block = (sample_type *) malloc(susp->blocksize * sizeof(sample_type));
susp->temp = (float *) malloc((susp->middle - susp->m + 1) * sizeof(float));
susp->fillptr = susp->block;
susp->endptr = susp->block + susp->blocksize;
xlsave1(result);
result = newvector(2); /* create array for F0 and harmonicity */
/* create sounds to return */
for (j = 0; j < 2; j++) {
sound_type snd = sound_create((snd_susp_type)susp,
susp->susp.t0, susp->susp.sr, 1.0);
LVAL snd_lval = cvsound(snd);
/* nyquist_printf("yin_create: sound %d is %x, LVAL %x\n", j, snd, snd_lval); */
setelement(result, j, snd_lval);
susp->chan[j] = snd->list;
/* DEBUG: ysnd[j] = snd; */
}
xlpop();
return result;
}
/* cvsymbol - convert a string to a symbol */
LVAL cvsymbol(char *pname)
{
LVAL val;
xlsave1(val);
val = newvector(SYMSIZE);
val->n_type = SYMBOL;
setvalue(val,s_unbound);
setfunction(val,s_unbound);
setpname(val,cvstring(pname));
xlpop();
return (val);
}
void nyx_set_input_audio(nyx_audio_callback callback,
void *userdata,
int num_channels,
long len, double rate)
{
LVAL val;
int ch;
nyx_set_audio_params(rate, len);
if (num_channels > 1) {
val = newvector(num_channels);
}
xlprot1(val);
for (ch = 0; ch < num_channels; ch++) {
nyx_susp_type susp;
sound_type snd;
falloc_generic(susp, nyx_susp_node, "nyx_set_input_audio");
susp->callback = callback;
susp->userdata = userdata;
susp->len = len;
susp->channel = ch;
susp->susp.fetch = nyx_susp_fetch;
susp->susp.keep_fetch = NULL;
susp->susp.free = nyx_susp_free;
susp->susp.mark = NULL;
susp->susp.print_tree = nyx_susp_print_tree;
susp->susp.name = "nyx";
susp->susp.toss_cnt = 0;
susp->susp.current = 0;
susp->susp.sr = rate;
susp->susp.t0 = 0.0;
susp->susp.log_stop_cnt = 0;
snd = sound_create((snd_susp_type) susp, 0.0, rate, 1.0);
if (num_channels > 1) {
setelement(val, ch, cvsound(snd));
}
else {
val = cvsound(snd);
}
}
setvalue(xlenter("S"), val);
xlpop();
}
LOCAL LVAL linalg2genvec P2C(LVAL, x, int, n)
{
LVAL y;
if (! tvecp(x)) xlbadtype(x);
if (n <= 0 || gettvecsize(x) < n) xlfail("bad dimensions");
xlsave1(y);
y = newvector(n);
xlreplace(y, x, 0, n, 0, n);
xlpop();
return y;
}
LOCAL LVAL newmatrix P2C(int, m, int, n)
{
LVAL dim, result;
xlsave1(dim);
checknonneg(m);
checknonneg(n);
dim = integer_list_2(m, n);
result = mkarray(dim, NIL, NIL, s_true);
xlpop();
return result;
}
/* makearglist - make a list of the remaining arguments */
LVAL makearglist(int argc, LVAL *argv)
{
LVAL list,this,last;
xlsave1(list);
for (last = NIL; --argc >= 0; last = this) {
this = cons(*argv++,NIL);
if (last) rplacd(last,this);
else list = this;
last = this;
}
xlpop();
return (list);
}
table_type get_window_samples(LVAL window, sample_type **samples, long *len)
{
table_type result = NULL;
if (soundp(window)) {
sound_type window_sound = getsound(window);
xlprot1(window); /* maybe not necessary */
result = sound_to_table(window_sound);
xlpop();
*samples = result->samples;
*len = (long) (result->length + 0.5);
}
return result;
}
double sound_max(LVAL snd_expr, long n)
{
LVAL s_as_lval;
sound_type s = NULL;
long blocklen;
sample_block_values_type sbufp;
register double maximum = 0;
s_as_lval = xleval(snd_expr);
/* BE CAREFUL - DO NOT ALLOW GC TO RUN WHILE LVAL IS UNPROTECTED */
if (exttypep(s_as_lval, a_sound)) {
/* if snd_expr was simply a symbol, then s now points to
a shared sound_node. If we read samples from it, then
the sound bound to the symbol will be destroyed, so
copy it first. If snd_expr was a real expression that
computed a new value, then the next garbage collection
will reclaim the sound_node. We need to make the new
sound reachable by the garbage collector to that any
lisp data reachable from the sound do not get collected.
To make the sound reachable, we need to allocate a node,
and the GC might run, so we need to protect the OLD s
but then make it unreachable.
We will let the GC collect the sound in the end.
*/
xlprot1(s_as_lval);
s = sound_copy(getsound(s_as_lval));
s_as_lval = cvsound(s); /* destroys only ref. to original */
/* printf("sound_max: copy is %x, lval %x\n", s, s_as_lval); */
while (n > 0) {
long togo, j;
sample_block_type sampblock =
sound_get_next(s, &blocklen);
if (sampblock == zero_block || blocklen == 0) {
break;
}
togo = MIN(blocklen, n);
sbufp = sampblock->samples;
for (j = 0; j < togo; j++) {
register double samp = *sbufp++;
if (samp > maximum) maximum = samp;
else if (-samp > maximum) maximum = -samp;
}
n -= togo;
}
xlpop();
} else {
xlerror("sound_max: expression did not return a sound",
s_as_lval);
}
return maximum * s->scale;
}
/* xsendmsg - send a message to an object */
LOCAL LVAL xsendmsg(LVAL obj, LVAL cls, LVAL sym)
{
LVAL msg=NULL,msgcls,method,val,p;
/* look for the message in the class or superclasses */
for (msgcls = cls; msgcls; ) {
/* lookup the message in this class */
for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
if ((msg = car(p)) && car(msg) == sym)
goto send_message;
/* look in class's superclass */
msgcls = getivar(msgcls,SUPERCLASS);
}
/* message not found */
xlerror("no method for this message",sym);
send_message:
/* insert the value for 'self' (overwrites message selector) */
*--xlargv = obj;
++xlargc;
/* invoke the method */
if ((method = cdr(msg)) == NULL)
xlerror("bad method",method);
switch (ntype(method)) {
case SUBR:
val = (*getsubr(method))();
break;
case CLOSURE:
if (gettype(method) != s_lambda)
xlerror("bad method",method);
val = evmethod(obj,msgcls,method);
break;
default:
xlerror("bad method",method);
}
/* after creating an object, send it the ":isnew" message */
if (car(msg) == k_new && val) {
xlprot1(val);
xsendmsg(val,getclass(val),k_isnew);
xlpop();
}
/* return the result value */
return (val);
}
