/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(NODE *expr)
{
NODE ***oldstk,*ehook __HEAPIFY,*ahook __HEAPIFY,*args __HEAPIFY,*val;
/* create a new stack frame */
oldstk = xlsave3(&ehook,&ahook,&args);
/* make an argument list */
args = consa(expr);
rplacd(args,consa(xlenv));
/* rebind the hook functions to nil */
ehook = getvalue(s_evalhook);
setvalue(s_evalhook,NIL);
ahook = getvalue(s_applyhook);
setvalue(s_applyhook,NIL);
/* call the hook function */
val = xlapply(ehook,args);
/* unbind the symbols */
setvalue(s_evalhook,ehook);
setvalue(s_applyhook,ahook);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* xcomplement - create a complementary function */
LVAL xcomplement(V)
{
LVAL val;
LVAL args, body;
LVAL newxlenv;
/* protect some pointers */
xlstkcheck(3);
xlsave(newxlenv);
xlsave(args);
xlsave(body);
/* get the argument */
val = xlgetarg();
xllastarg();
/* build the argument list (&rest x) */
args = cons(lk_rest, consa(s_x));
/* build body (not (apply s x)) */
body = consa(cons(s_not, consa(cons(s_apply, cons(s_s, consa(s_x))))));
/* create a closure for lambda expressions */
newxlenv = xlframe(newxlenv);
xlpbind(s_s, val, newxlenv);
val = xlclose(NIL,s_lambda,args,body,newxlenv,NIL);
/* unprotect pointers */
xlpopn(3);
/* return the function */
return (val);
}
mword *new_dstack_entry(mword *operand, mword alloc_type){ // new_dstack_entry#
return
consa( operand,
consa( _newva( alloc_type), nil )); //FIXME DEPRECATED _newva
}
LOCAL VOID set_hardware_address P3C(CPTR, ptr, LVAL, object, int *, type)
{
LVAL t, p, last, result, oblistsym, newoblist;
if (! objectp(object)) xlerror("not an object", object);
oblistsym = s_hardware_objects;
if (! consp(getvalue(oblistsym))) setvalue(oblistsym, NIL);
xlstkcheck(4);
xlsave(t);
xlsave(p);
xlsave(result);
xlsave(newoblist);
t = cvfixnum((FIXTYPE) time_stamp);
p = cvfixnum((FIXTYPE) ptr);
result = last = consa(object);
result = cons(p, result);
result = cons(t, result);
newoblist = cons(result, getvalue(oblistsym));
setvalue(oblistsym, newoblist);
set_slot_value(object, s_hardware_address, result);
for (;*type != NONE; type++, last = cdr(last)) {
t = cvfixnum((FIXTYPE) *type);
t = consa(t);
rplacd(last, t);
}
xlpopn(4);
}
mword *new_rstack_entry(mword *operand, mword *eval_type){ // new_rstack_entry#
return
consa( operand,
consa( eval_type, nil ));
}
/* if list is NIL. */
LOCAL LVAL rplac_end P2C(LVAL, list, LVAL, item)
{
LVAL next;
if (list == NIL) return(consa(item));
else if (listp(list)) {
for (next = list; consp(cdr(next)); next = cdr(next))
;
rplacd(next, consa(item));
return(list);
}
else xlerror("not a list", list);
return NIL; /* not reached */
}
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);
}
/* xlputc - put a character to a file or stream */
void xlputc(LVAL fptr, int ch)
{
LVAL lptr;
FILE *fp;
/* count the character */
++xlfsize;
/* check for output to nil */
if (fptr == NIL)
;
/* otherwise, check for output to an unnamed stream */
else if (ustreamp(fptr)) {
lptr = consa(cvchar(ch));
if (gettail(fptr))
rplacd(gettail(fptr),lptr);
else
sethead(fptr,lptr);
settail(fptr,lptr);
}
/* otherwise, check for terminal output or file output */
else {
fp = getfile(fptr);
if (!fp)
xlfail("file not open");
else if (fp == stdout || fp == STDERR)
ostputc(ch);
else
osaputc(ch,fp);
}
}
LVAL xschol_decomp(V)
{
LVAL a, da, val;
int n;
double maxoffl, maxadd;
a = xlgadarray();
maxoffl = moreargs() ? makefloat(xlgetarg()) : 0.0;
xllastarg();
checksquarematrix(a);
n = numrows(a);
xlstkcheck(2);
xlsave(da);
xlsave(val);
da = gen2linalg(a, n, n, s_c_double, FALSE);
choldecomp(REDAT(da), n, maxoffl, &maxadd);
val = consa(cvflonum((FLOTYPE) maxadd));
val = cons(linalg2genmat(da, n, n, FALSE), val);
xlpopn(2);
return val;
}
/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
LVAL list,fcn,val,last=NULL,next;
/* protect some pointers */
xlstkcheck(2);
xlsave(fcn);
xlsave(val);
/* get the expression to remove and the list */
fcn = xlgetarg();
list = xlgalist();
xllastarg();
/* remove matches */
for (; consp(list); list = cdr(list))
/* check to see if this element should be deleted */
if (dotest1(car(list),fcn) != tresult) {
next = consa(car(list));
if (val) rplacd(last,next);
else val = next;
last = next;
}
/* restore the stack */
xlpopn(2);
/* return the updated list */
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);
}
VOID initialize_graph_window P1C(LVAL, object)
{
LVAL internals, value;
int v, width, height, size;
StGWWinInfo *gwinfo;
ColorCode bc,dc; /* added JKL */
internals = newadata(StGWWinInfoSize(), 1, FALSE);
set_slot_value(object, s_internals, consa(internals));
StGWInitWinInfo(object);
gwinfo = StGWObWinInfo(object);
if (gwinfo == NULL) return;
StGWSetObject(gwinfo, object);
if (slot_value(object, s_black_on_white) == NIL) {
bc = StGWBackColor(gwinfo); /* this seems better for color */
dc = StGWDrawColor(gwinfo); /* machines - 0 and 1 are not */
StGWSetDrawColor(gwinfo, bc); /* the default draw and back */
StGWSetBackColor(gwinfo, dc); /* colors on the Amiga JKL */
}
StGetScreenSize(&width, &height);
size = (width > height) ? width : height;
if ((value = slot_value(object, s_has_h_scroll)) != NIL) {
v = (fixp(value)) ? getfixnum(value) : size;
StGWSetHasHscroll(gwinfo, TRUE, v);
}
if ((value = slot_value(object, s_has_v_scroll)) != NIL) {
v = (fixp(value)) ? getfixnum(value) : size;
StGWSetHasVscroll(gwinfo, TRUE, v);
}
}
/* xlputc - put a character to a file or stream */
VOID xlputc P2C(LVAL, fptr, int, ch)
{
LVAL lptr;
FILEP fp;
/* TAA MOD -- delete output to NIL and character counting 1/97 */
/* check for output to an unnamed stream */
if (ntype(fptr) == USTREAM) { /* TAA MOD, was ustreamp() */
lptr = consa(cvchar((unsigned char)ch));
if (gettail(fptr)!=NIL)
rplacd(gettail(fptr),lptr);
else
sethead(fptr,lptr);
settail(fptr,lptr);
}
/* otherwise, check for terminal output or file output */
else {
fp = getfile(fptr);
if (fp == CLOSED) /* TAA MOD -- give error */
xlfail("can't write closed stream");
if (fp == CONSOLE) /* TAA MOD -- for redirecting */
ostputc(ch);
else {
if ((fptr->n_sflags & S_FORWRITING) == 0)
xlerror("can't write read-only file stream", fptr);
if ((fptr->n_sflags & S_WRITING) == 0) {
/* possible direction change*/
if (fptr->n_sflags & S_READING) {
OSSEEKCUR(fp,
(getsavech(fptr)?(setsavech(fptr,'\0'),-1L):0L));
}
fptr->n_sflags |= S_WRITING;
fptr->n_sflags &= ~S_READING;
#ifdef BIGNUMS
if ((fptr->n_sflags & S_BINARY) == 0)
#endif
fptr->n_cpos = 0; /* best guess */
}
#ifdef BIGNUMS
if ((fptr->n_sflags & S_BINARY) == 0) {
#endif
if (ch == '\n') fptr->n_cpos = 0;
else fptr->n_cpos++;
#ifdef BIGNUMS
}
#endif
#ifdef OSAGETC
if (((fptr->n_sflags & S_BINARY) ?
OSPUTC(ch,fp) : OSAPUTC(ch,fp)) == EOF)
/* TAA MOD to check for write to RO file */
xlerror("write failed", fptr);
#else
if (OSPUTC(ch,fp)==EOF) /* TAA MOD to check for write to RO file*/
xlerror("write failed", fptr);
#endif
}
}
}
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 */
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();
}
/* plist - parse a list */
LOCAL LVAL plist(LVAL fptr)
{
LVAL val,expr,lastnptr,nptr;
/* protect some pointers */
xlstkcheck(2);
xlsave(val);
xlsave(expr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL; nextch(fptr) != ')'; )
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
/* check for a dotted tail */
if (expr == s_dot) {
/* make sure there's a node */
if (lastnptr == NIL)
xlfail("invalid dotted pair");
/* parse the expression after the dot */
if (!xlread(fptr,&expr,TRUE))
badeof(fptr);
rplacd(lastnptr,expr);
/* make sure its followed by a close paren */
if (nextch(fptr) != ')')
xlfail("invalid dotted pair");
}
/* otherwise, handle a normal list element */
else {
nptr = consa(expr);
if (lastnptr == NIL)
val = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
}
break;
}
/* skip the closing paren */
xlgetc(fptr);
/* restore the stack */
xlpopn(2);
/* return successfully */
return (val);
}
xlsinit(void)
{
NODE *array,*p;
obarray = xlmakesym("*OBARRAY*",1);
array = newvector(199);
((obarray)->n_info.n_xsym.xsy_value = (array));
p = consa(obarray);
((array)->n_info.n_xvect.xv_data[hash("*OBARRAY*",199)] = (p));
s_unbound = xlsenter("*UNBOUND*");
((s_unbound)->n_info.n_xsym.xsy_value = (s_unbound));
}
/* rmlpar - read macro for '(' */
LVAL rmlpar(void)
{
LVAL fptr,mch;
/* get the file and macro character */
fptr = xlgetfile();
mch = xlgachar();
xllastarg();
/* make the return value */
return (consa(plist(fptr)));
}
/* rmbquote - read macro for '`' */
LVAL rmbquote(void)
{
LVAL fptr,mch;
/* get the file and macro character */
fptr = xlgetfile();
mch = xlgachar();
xllastarg();
/* parse the quoted expression */
return (consa(pquote(fptr,s_bquote)));
}
/* arguments by circular lists of one element. */
LOCAL VOID fixuparglist P1C(LVAL, list)
{
LVAL next;
for (next = list; consp(next); next = cdr(next))
if (! compoundp(car(next))) {
/* make circular list */
rplaca(next, consa(car(next)));
rplacd(car(next), car(next));
}
else
rplaca(next, compounddataseq(car(next)));
}
xlputprop(NODE *sym, NODE *val, NODE *prp)
{
NODE ***oldstk,*p,*pair;
if ((pair = findprop(sym,prp)) == (NODE *)0) {
oldstk = xlsave(&p,(NODE **)0);
p = consa(prp);
((p)->n_info.n_xlist.xl_cdr = (pair = cons(val,((sym)->n_info.n_xsym.xsy_plist->n_info.n_xlist.xl_cdr))));
((sym)->n_info.n_xsym.xsy_plist->n_info.n_xlist.xl_cdr = (p));
xlstack = oldstk;
}
((pair)->n_info.n_xlist.xl_car = (val));
}
/* 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);
}
/* pquote - parse a quoted expression */
LOCAL LVAL pquote(LVAL fptr, LVAL sym)
{
LVAL val,p;
/* protect some pointers */
xlsave1(val);
/* allocate two nodes */
val = consa(sym);
rplacd(val,consa(NIL));
/* initialize the second to point to the quoted expression */
if (!xlread(fptr,&p,TRUE))
badeof(fptr);
rplaca(cdr(val),p);
/* restore the stack */
xlpop();
/* return the quoted expression */
return (val);
}
/* xlsinit - symbol initialization routine */
void xlsinit(void)
{
LVAL array,p;
/* initialize the obarray */
obarray = xlmakesym("*OBARRAY*");
array = newvector(HSIZE);
setvalue(obarray,array);
/* add the symbol *OBARRAY* to the obarray */
p = consa(obarray);
setelement(array,hash("*OBARRAY*",HSIZE),p);
}
/* pvector - parse a vector */
LOCAL LVAL pvector(LVAL fptr)
{
LVAL list,expr,val,lastnptr,nptr;
int len,ch,i;
/* protect some pointers */
xlstkcheck(2);
xlsave(list);
xlsave(expr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {
/* check for end of file */
if (ch == EOF)
badeof(fptr);
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
nptr = consa(expr);
if (lastnptr == NIL)
list = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
len++;
break;
}
}
/* skip the closing paren */
xlgetc(fptr);
/* make a vector of the appropriate length */
val = newvector(len);
/* copy the list into the vector */
for (i = 0; i < len; ++i, list = cdr(list))
setelement(val,i,car(list));
/* restore the stack */
xlpopn(2);
/* return successfully */
return (val);
}
/* xlsinit - symbol initialization routine */
void xlsinit(void)
{
NODE *array,*p;
/* initialize the obarray */
obarray = xlmakesym("*OBARRAY*",STATIC);
array = newvector(HSIZE);
setvalue(obarray,array);
/* add the symbol *OBARRAY* to the obarray */
p = consa(obarray);
setelement(array,hash("*OBARRAY*",HSIZE),p);
/* enter the unbound symbol indicator */
s_unbound = xlsenter("*UNBOUND*");
setvalue(s_unbound,s_unbound);
}
/* entermsg - add a message to a class */
LOCAL LVAL entermsg(LVAL cls, LVAL msg)
{
LVAL lptr,mptr;
/* lookup the message */
for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
if (car(mptr = car(lptr)) == msg)
return (mptr);
/* allocate a new message entry if one wasn't found */
xlsave1(mptr);
mptr = consa(msg);
setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
xlpop();
/* return the symbol node */
return (mptr);
}
/* rmcomma - read macro for ',' */
LVAL rmcomma(void)
{
LVAL fptr,mch,sym;
int ch;
/* get the file and macro character */
fptr = xlgetfile();
mch = xlgachar();
xllastarg();
/* check the next character */
if ((ch = xlgetc(fptr)) == '@')
sym = s_comat;
else {
xlungetc(fptr,ch);
sym = s_comma;
}
/* make the return value */
return (consa(pquote(fptr,sym)));
}
LVAL iview_get_nice_range(V)
{
double low, high;
int ticks;
LVAL temp, result;
low = makefloat(xlgetarg());
high = makefloat(xlgetarg());
ticks = getfixnum(xlgafixnum());
xllastarg();
GetNiceRange(&low, &high, &ticks);
xlstkcheck(2);
xlsave(result);
xlsave(temp);
temp = cvfixnum((FIXTYPE) ticks); result = consa(temp);
temp = cvflonum((FLOTYPE) high); result = cons(temp, result);
temp = cvflonum((FLOTYPE) low); result = cons(temp, result);
xlpopn(2);
return(result);
}
/* xlist - built a list of the arguments */
LVAL xlist(void)
{
LVAL last=NULL,next,val;
/* protect some pointers */
xlsave1(val);
/* add each argument to the list */
for (val = NIL; moreargs(); ) {
/* append this argument to the end of the list */
next = consa(nextarg());
if (val) rplacd(last,next);
else val = next;
last = next;
}
/* restore the stack */
xlpop();
/* return the list */
return (val);
}
