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); }