/* 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);
}
/* newvector - allocate and initialize a new vector node */
NODE *newvector(int size)
{
NODE ***oldstk,*vect __HEAPIFY;
int bsize;
/* establish a new stack frame */
oldstk = xlsave1(&vect);
/* allocate a vector node and set the size to zero (in case of gc) */
vect = newnode(VECT);
vect->n_vsize = 0;
/* allocate memory for the vector */
bsize = size * sizeof(NODE *);
vect->n_vsize = size;
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
findmem();
if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
xlfail("insufficient vector space");
}
total += (long) bsize;
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new vector */
return (vect);
}
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);
}
/* xlenter - enter a symbol into the obarray */
NODE *xlenter(char *name,int type)
{
NODE ***oldstk,*sym __HEAPIFY,*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,getstring(getpname(car(sym)))) == 0)
return (car(sym));
/* make a new symbol node and link it into the list */
oldstk = xlsave1(&sym);
sym = consd(getelement(array,i));
rplaca(sym,xlmakesym(name,type));
setelement(array,i,sym);
xlstack = oldstk;
/* return the new symbol */
return (car(sym));
}
/* 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 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);
}
/* 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);
}
/* 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();
}
/* cvcsymbol - convert a constant string to a symbol */
NODE *cvcsymbol( char *pname)
{
NODE ***oldstk,*val __HEAPIFY;
oldstk = xlsave1(&val);
val = newnode(SYM);
val->n_symplist = newnode(LIST);
rplaca(val->n_symplist,cvcstring(pname));
xlstack = oldstk;
return (val);
}
/* cvstring - convert a string to a string node */
NODE *cvstring( char *str)
{
NODE ***oldstk,*val __HEAPIFY;
oldstk = xlsave1(&val);
val = newnode(STR);
val->n_str = strsave(str);
val->n_strtype = DYNAMIC;
xlstack = oldstk;
return (val);
}
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 */
/* :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);
}
/* 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);
}
/* 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);
}
/* newstring - allocate and initialize a new string */
NODE *newstring(int size)
{
NODE ***oldstk,*val __HEAPIFY;
oldstk = xlsave1(&val);
val = newnode(STR);
val->n_str = stralloc(size);
*getstring(val) = 0;
val->n_strtype = DYNAMIC;
xlstack = oldstk;
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 */
/* 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);
}
/* 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);
}
/* xlputprop - put a property value onto the property list */
void xlputprop(NODE *sym,NODE *val,NODE *prp)
{
NODE ***oldstk,*p __HEAPIFY,*pair;
if ((pair = findprop(sym,prp)) == NIL) {
oldstk = xlsave1(&p);
p = consa(prp);
rplacd(p,pair = cons(val,getplist(sym)));
setplist(sym,p);
xlstack = oldstk;
}
rplaca(pair,val);
}
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;
}
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;
}
/* 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);
}
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;
}
/* xmkstrinput - make a string input stream */
LVAL xmkstrinput(void)
{
int start,end,len,i;
unsigned char *str;
LVAL string,val;
/* protect the return value */
xlsave1(val);
/* get the string and length */
string = xlgastring();
str = getstring(string);
len = getslength(string) - 1;
/* get the starting offset */
if (moreargs()) {
val = xlgafixnum();
start = (int)getfixnum(val);
}
else start = 0;
/* get the ending offset */
if (moreargs()) {
val = xlgafixnum();
end = (int)getfixnum(val);
}
else end = len;
xllastarg();
/* check the bounds */
if (start < 0 || start > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
if (end < 0 || end > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
/* make the stream */
val = newustream();
/* copy the substring into the stream */
for (i = start; i < end; ++i)
xlputc(val,str[i]);
/* restore the stack */
xlpop();
/* return the new stream */
return (val);
}
/* sublis - substitute using an association list */
LOCAL LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult)
{
LVAL carval,cdrval,pair;
if ((pair = assoc(expr,alist,fcn,tresult)))
return (cdr(pair));
else if (consp(expr)) {
xlsave1(carval);
carval = sublis(alist,car(expr),fcn,tresult);
cdrval = sublis(alist,cdr(expr),fcn,tresult);
xlpop();
return (cons(carval,cdrval));
}
else
return (expr);
}
/* subst - substitute one expression for another */
LOCAL LVAL subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult)
{
LVAL carval,cdrval;
if (dotest2(expr,from,fcn) == tresult)
return (to);
else if (consp(expr)) {
xlsave1(carval);
carval = subst(to,from,car(expr),fcn,tresult);
cdrval = subst(to,from,cdr(expr),fcn,tresult);
xlpop();
return (cons(carval,cdrval));
}
else
return (expr);
}
