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);
}
/* xlbind - bind a value to a symbol */
void xlbind(NODE *sym,NODE *val,NODE *env)
{
NODE *ptr;
/* create a new environment list entry */
ptr = consd(car(env));
rplaca(env,ptr);
/* create a new variable binding */
rplaca(ptr,cons(sym,val));
}
/* 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)));
}
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);
}
/* 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);
}
LOCAL VOID pushnextargs P4C(LVAL, fcn, int, n, LVAL, args, int, i)
{
LVAL *newfp, next, value = NULL;
/* build a new argument stack frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fcn);
pusharg(cvfixnum((FIXTYPE)n));
/* push the arguments and shift the list pointers */
for (next = args; consp(next); next = cdr(next)) {
switch (ntype(car(next))) {
case VECTOR:
value = getelement(car(next), i);
break;
case TVEC:
value = gettvecelement(car(next), i);
break;
case CONS:
value = car(car(next));
rplaca(next, cdr(car(next)));
break;
}
pusharg(value);
}
/* establish the new stack frame */
xlfp = newfp;
}
/* 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));
}
/* consa - (cons x nil) */
NODE *consa( NODE *x)
{
NODE *val;
val = newnode(LIST);
rplaca(val,x);
return (val);
}
/* 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));
}
/* cons - construct a new cons node */
NODE *cons( NODE *x,NODE *y)
{
NODE *val;
val = newnode(LIST);
rplaca(val,x);
rplacd(val,y);
return (val);
}
/* xlputprop - put a property value onto the property list */
void xlputprop(LVAL sym, LVAL val, LVAL prp)
{
LVAL pair;
if ((pair = findprop(sym,prp)))
rplaca(pair,val);
else
setplist(sym,cons(prp,cons(val,getplist(sym))));
}
/* 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);
}
/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL void sweep(void)
{
struct segment *seg;
//NODE *p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0;
/* add all unmarked nodes */
for (seg = segs; seg != NULL; seg = seg->sg_next) {
//p = &seg->sg_nodes[0];
NODE *SNT end = 0;
NODE * BND(__this, end) p = 0;
end = &seg->sg_nodes[0] + seg->sg_size;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; n--; p++) {
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STR:
if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
total -= (long) (strlen(p->n_str)+1);
free(p->n_str);
}
break;
case FPTR:
if (p->n_fp)
fclose(p->n_fp);
break;
case VECT:
if (p->n_vsize) {
//sm: total -= (long) (p->n_vsize * sizeof(NODE **));
total -= (long) (p->n_vsize * sizeof(*(p->n_vdata))); // see xlisp.h defn of NODE
free(p->n_vdata);
}
break;
}
#ifdef DEPUTY
memset(&p->n_info, 0, sizeof(p->n_info)); //matth
#else
rplaca(p,NIL);
#endif
p->n_type = FREE;
p->n_flags = 0;
rplacd(p,fnodes);
fnodes = p;
nfree++;
}
else
p->n_flags &= ~(MARK | LEFT);
}
p = 0;
}
}
/* 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);
}
/* xrplca - replace the car of a list node */
LVAL xrplca(void)
{
LVAL list,newcar;
/* get the list and the new car */
list = xlgacons();
newcar = xlgetarg();
xllastarg();
/* replace the car */
rplaca(list,newcar);
/* return the list node that was modified */
return (list);
}
LVAL iview_hist_bin_counts(V)
{
LVAL object, hdata, result, next;
IVIEW_WINDOW w;
int i, bins;
IViewHist h;
gethistargs(&w, &object, &hdata);
xllastarg();
if (hdata == NULL || (h = getinternals(hdata)) == NULL) result = NIL;
else {
bins = h->num_bins;
xlsave1(result);
result = mklist(bins, NIL);
for (i = 0, next = result; i < bins; i++, next = cdr(next))
rplaca(next, cvfixnum((FIXTYPE) h->bins[i].count));
xlpop();
}
return(result);
}
/* 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);
}
LVAL xlistdir(void)
{
const char *path;
LVAL result = NULL;
LVAL *tail;
/* get the path, converting unsigned char * to char * */
path = (char *)getstring(xlgetfname());
/* try to start listing */
if (osdir_list_start(path)) {
const char *filename;
xlsave1(result);
tail = &result;
while ((filename = osdir_list_next())) {
*tail = cons(NIL, NIL);
rplaca(*tail, cvstring(filename));
tail = &cdr(*tail);
}
osdir_list_finish();
xlpop();
}
return result;
}
/* SHLIB-INFO funtab */
LVAL xshlibinfo()
{
LVAL val;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
xlsave1(val);
val = cons(cvfixnum((FIXTYPE) info->modversion.current), NIL);
val = cons(cvfixnum((FIXTYPE) info->modversion.oldest), val);
val = cons(NIL, val);
if (p != NULL) {
for (; (p->fd_subr) != (LVAL(*)(void)) NULL; p++)
rplaca(val, cons(cvstring(p->fd_name), car(val)));
rplaca(val, xlnreverse(car(val)));
}
val = cons(NIL, val);
if (pfix != NULL)
for (; pfix->name != NULL; pfix++)
rplaca(val, cons(cvstring(pfix->name), car(val)));
if (pflo != NULL)
for (; pflo->name != NULL; pflo++)
rplaca(val, cons(cvstring(pflo->name), car(val)));
if (pstr != NULL)
for (; pstr->name != NULL; pstr++)
rplaca(val, cons(cvstring(pstr->name), car(val)));
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
for (; pulong->name != NULL; pulong++)
rplaca(val, cons(cvstring(pulong->name), car(val)));
}
rplaca(val, xlnreverse(car(val)));
xlpop();
return xlnreverse(val);
}
static LVAL elementlist P1C(LVAL, x)
{
LVAL next, last, result;
if (!compoundp(x)) result = consa(x);
else {
xlprot1(x);
x = compounddataseq(x);
x = (listp(x)) ? copylist(x) : coerce_to_list(x);
if (all_simple(x)) result = x;
else {
for (next = x; consp(next); next = cdr(next))
rplaca(next, elementlist(car(next)));
result = car(x);
last = lastcdr(car(x));
for (next = cdr(x); consp(next); next = cdr(next)) {
rplacd(last, car(next));
last = lastcdr(car(next));
}
}
xlpop();
}
return(result);
}
/* mark - mark all accessible nodes */
void mark(LVAL ptr)
{
register LVAL this,prev,tmp;
int type,i,n;
/*
if (ptr == test_mark) {
printf("\n\nFound test_mark\n\n");
}
*/
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
for (;;) {
/* descend as far as we can */
while (!(this->n_flags & MARK))
/* check cons and symbol nodes */
if ((type = ntype(this)) == CONS || type == USTREAM) {
if (tmp = car(this)) {
this->n_flags |= MARK|LEFT;
rplaca(this,prev);
}
else if (tmp = cdr(this)) {
this->n_flags |= MARK;
rplacd(this,prev);
}
else { /* both sides nil */
this->n_flags |= MARK;
break;
}
prev = this; /* step down the branch */
this = tmp;
}
/* mark other node types */
else {
this->n_flags |= MARK;
switch (type) {
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
for (i = 0, n = getsize(this); --n >= 0; ++i)
if (tmp = getelement(this,i))
mark(tmp);
break;
case EXTERN:
if (getdesc(this)->mark_meth) { (*(getdesc(this)->mark_meth))(getinst(this));
}
}
break;
}
/* backup to a point where we can continue descending */
for (;;)
/* make sure there is a previous node */
if (prev) {
if (prev->n_flags & LEFT) { /* came from left side */
prev->n_flags &= ~LEFT;
tmp = car(prev);
rplaca(prev,this);
if (this = cdr(prev)) {
rplacd(prev,tmp);
break;
}
}
else { /* came from right side */
tmp = cdr(prev);
rplacd(prev,this);
}
this = prev; /* step back up the branch */
prev = tmp;
}
/* no previous node, must be done */
else
return;
}
}
//
// Free empty segments
//
LOCAL void freesegs()
{
SEGMENT *seg;
SEGMENT *next;
// Free up as many nodes as possible
gc();
// Reset free node tracking
fnodes = NIL;
nfree = 0L;
// Reset the last segment pointer
lastseg = NULL;
// Scan all segments
for (seg = segs; seg != NULL; seg = next) {
int n = seg->sg_size;
int empty = TRUE;
int i;
LVAL p;
// Check this segment for in-use nodes
p = &seg->sg_nodes[0];
for (i = n; --i >= 0; ++p) {
if (ntype(p) != FREE_NODE) {
empty = FALSE;
break;
}
}
// Retain pointer to next segment
next = seg->sg_next;
// Was the current segment empty?
if (empty) {
// Free the segment;
free((void *) seg);
// Unlink it from the list. No need to worry about a NULL lastseg
// pointer here since the fixnum and char segments will always exist
// at the head of the list and they will always have nodes. So, lastseg
// will have been set before we find any empty nodes.
lastseg->sg_next = next;
// Reduce the stats
total -= (long) segsize(n);
nsegs--;
nnodes -= n;
}
else {
// Not empty, so remember this node as the last segment
lastseg = seg;
// Add all of the free nodes in this segment to the free list
p = &seg->sg_nodes[0];
for (i = n; --i >= 0; ++p) {
if (ntype(p) == FREE_NODE) {
rplaca(p, NIL);
rplacd(p, fnodes);
fnodes = p;
nfree++;
}
}
}
}
}
/* map - internal mapping function */
LOCAL LVAL map(int carflag, int valflag)
{
LVAL *newfp,fun,lists,val,last,p,x,y;
int argc;
/* protect some pointers */
xlstkcheck(3);
xlsave(fun);
xlsave(lists);
xlsave(val);
/* get the function to apply and the first list */
fun = xlgetarg();
lists = xlgalist();
/* initialize the result list */
val = (valflag ? NIL : lists);
/* build a list of argument lists */
for (lists = last = consa(lists); moreargs(); last = cdr(last))
rplacd(last,cons(xlgalist(),NIL));
/* loop through each of the argument lists */
for (;;) {
/* build an argument list from the sublists */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(NIL);
argc = 0;
for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
pusharg(carflag ? car(y) : y);
rplaca(x,cdr(y));
++argc;
}
/* quit if any of the lists were empty */
if (x) {
xlsp = newfp;
break;
}
/* apply the function to the arguments */
newfp[2] = cvfixnum((FIXTYPE)argc);
xlfp = newfp;
if (valflag) {
p = consa(xlapply(argc));
if (val) rplacd(last,p);
else val = p;
last = p;
}
else
xlapply(argc);
}
/* restore the stack */
xlpopn(3);
/* return the last test expression value */
return (val);
}
/* dmazzoni: was LOCAL void sweep(void) */
void sweep(void)
{
SEGMENT *seg;
LVAL p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0L;
/* add all unmarked nodes */
for (seg = segs; seg; seg = seg->sg_next) {
if (seg == fixseg) /* don't sweep the fixnum segment */
continue;
else if (seg == charseg) /* don't sweep the character segment */
continue;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; --n >= 0; ++p) {
#ifdef DEBUG_MEM
if (xldmem_trace &&
ntype(p) == EXTERN &&
xldmem_trace == getinst(p)) {
printf("sweep: EXTERN node %lx is %smarked, points to %lx\n",
p, (p->n_flags & MARK ? "" : "un"), getinst(p));
}
#endif
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STRING:
if (getstring(p) != NULL) {
total -= (long)getslength(p);
free(getstring(p));
}
break;
case STREAM:
if (getfile(p))
osclose(getfile(p));
break;
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
if (p->n_vsize) {
total -= (long) (p->n_vsize * sizeof(LVAL));
free((void *) p->n_vdata);
}
break;
case EXTERN:
/* printf("GC about to free %x\n", p);
* fflush(stdout);
*/
if (getdesc(p)) { (*(getdesc(p)->free_meth))(getinst(p));
}
break;
}
p->n_type = FREE_NODE;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree += 1L;
}
else
p->n_flags &= ~MARK;
}
}
}
/* mark - mark all accessible nodes */
void mark(NODE *ptr)
{
NODE *this,*prev,*tmp;
/* just return on nil */
if (ptr == NIL)
return;
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
while (TRUE) {
/* descend as far as we can */
while (TRUE) {
/* check for this node being marked */
if (this->n_flags & MARK)
break;
/* mark it and its descendants */
else {
/* mark the node */
this->n_flags |= MARK;
/* follow the left sublist if there is one */
if (livecar(this)) {
this->n_flags |= LEFT;
tmp = prev;
prev = this;
this = car(prev);
rplaca(prev,tmp);
}
/* otherwise, follow the right sublist if there is one */
else if (livecdr(this)) {
this->n_flags &= ~LEFT;
tmp = prev;
prev = this;
this = cdr(prev);
rplacd(prev,tmp);
}
else
break;
}
}
/* backup to a point where we can continue descending */
while (TRUE) {
/* check for termination condition */
if (prev == NIL)
return;
/* check for coming from the left side */
if (prev->n_flags & LEFT)
if (livecdr(prev)) {
prev->n_flags &= ~LEFT;
tmp = car(prev);
rplaca(prev,this);
this = cdr(prev);
rplacd(prev,tmp);
break;
}
else {
tmp = prev;
prev = car(tmp);
rplaca(tmp,this);
this = tmp;
}
/* otherwise, came from the right side */
else {
tmp = prev;
prev = cdr(tmp);
rplacd(tmp,this);
this = tmp;
}
}
}
}
node *cons (node *head, node *tail) {
node *ptr = newnode(LIST);
rplaca(ptr, head);
rplacd(ptr, tail);
return ptr;
}
/* rmhash - read macro for '#' */
LVAL rmhash(void)
{
LVAL fptr,mch,val;
int escflag,ch;
/* protect some pointers */
xlsave1(val);
/* get the file and macro character */
fptr = xlgetfile();
mch = xlgachar();
xllastarg();
/* make the return value */
val = consa(NIL);
/* check the next character */
switch (ch = xlgetc(fptr)) {
case '\'':
rplaca(val,pquote(fptr,s_function));
break;
case '(':
rplaca(val,pvector(fptr));
break;
case 'b':
case 'B':
rplaca(val,pnumber(fptr,2));
break;
case 'o':
case 'O':
rplaca(val,pnumber(fptr,8));
break;
case 'x':
case 'X':
rplaca(val,pnumber(fptr,16));
break;
case '\\':
xlungetc(fptr,ch);
pname(fptr,&escflag);
ch = buf[0];
if (strlen(buf) > 1) {
upcase((char *) buf);
if (strcmp(buf,"NEWLINE") == 0)
ch = '\n';
else if (strcmp(buf,"SPACE") == 0)
ch = ' ';
else if (strcmp(buf,"TAB") == 0)
ch = '\t';
else
xlerror("unknown character name",cvstring(buf));
}
rplaca(val,cvchar(ch));
break;
case ':':
rplaca(val,punintern(fptr));
break;
case '|':
pcomment(fptr);
val = NIL;
break;
default:
xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
}
/* restore the stack */
xlpop();
/* return the value */
return (val);
}
