/* xnconc - destructively append lists */
LVAL xnconc(void)
{
LVAL next,last=NULL,val;
/* initialize */
val = NIL;
/* concatenate each argument */
if (moreargs()) {
while (xlargc > 1) {
/* ignore everything except lists */
if ((next = nextarg()) && consp(next)) {
/* concatenate this list to the result list */
if (val) rplacd(last,next);
else val = next;
/* find the end of the list */
while (consp(cdr(next)))
next = cdr(next);
last = next;
}
}
/* handle the last argument */
if (val) rplacd(last,nextarg());
else val = nextarg();
}
/* return the 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);
}
/* 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();
}
/* 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);
}
/* xlsetvalue - set the value of a symbol */
void xlsetvalue(LVAL sym, LVAL val)
{
register LVAL fp,ep;
/* look for the symbol in the environment list */
for (fp = xlenv; fp; fp = cdr(fp))
/* check for an instance variable */
if ((ep = car(fp)) && objectp(car(ep))) {
if (xlobsetvalue(ep,sym,val))
return;
}
/* check an environment stack frame */
else {
for (; ep; ep = cdr(ep))
if (sym == car(car(ep))) {
rplacd(car(ep),val);
return;
}
}
/* store the global value */
setvalue(sym,val);
}
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);
}
/* 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);
}
/* 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);
}
/* 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);
}
/* consd - (cons nil x) */
NODE *consd( NODE *x)
{
NODE *val;
val = newnode(LIST);
rplacd(val,x);
return (val);
}
/* 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);
}
}
/* 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
}
}
}
/* gluelists - glue the smaller and larger lists with the pivot */
LOCAL LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger)
{
LVAL last;
/* larger always goes after the pivot */
rplacd(pivot,larger);
/* if the smaller list is empty, we're done */
if (null(smaller)) return (pivot);
/* append the smaller to the front of the resulting list */
for (last = smaller; consp(cdr(last)); last = cdr(last))
;
rplacd(last,pivot);
return (smaller);
}
/* 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);
}
static VOID allocate_internal_points P2C(LVAL, object, int, n)
{
LVAL val;
val = gethistdata(object);
if (adatap(cdr(val)))
reallocaddata(cdr(val), sizeof(struct hist_point), n);
else
rplacd(val, newadata(sizeof(struct hist_point), n, TRUE));
}
// Restore the symbol values to their original value and remove any added
// symbols.
LOCAL void nyx_restore_obarray()
{
LVAL obvec = getvalue(obarray);
int i;
// Scan all obarray vectors
for (i = 0; i < HSIZE; i++) {
LVAL last = NULL;
LVAL dcon;
// Scan all elements
for (dcon = getelement(obvec, i); dcon; dcon = cdr(dcon)) {
LVAL dsym = car(dcon);
char *name = (char *)getstring(getpname(dsym));
LVAL scon;
// Ignore *OBARRAY* since setting it causes the input array to be
// truncated.
if (strcmp(name, "*OBARRAY*") == 0) {
continue;
}
// Ignore *SCRATCH* since it's allowed to be updated
if (strcmp(name, "*SCRATCH*") == 0) {
continue;
}
// Find the symbol in the original obarray.
for (scon = getelement(nyx_obarray, hash(name, HSIZE)); scon; scon = cdr(scon)) {
LVAL ssym = car(scon);
// If found, then set the current symbols value to the original.
if (strcmp(name, (char *)getstring(getpname(ssym))) == 0) {
setvalue(dsym, nyx_dup_value(getvalue(ssym)));
setplist(dsym, nyx_dup_value(getplist(ssym)));
setfunction(dsym, nyx_dup_value(getfunction(ssym)));
break;
}
}
// If we didn't find the symbol in the original obarray, then it must've
// been added and must be removed from the current obarray.
if (scon == NULL) {
if (last) {
rplacd(last, cdr(dcon));
}
else {
setelement(obvec, i, cdr(dcon));
}
}
// Must track the last dcon for symbol removal
last = dcon;
}
}
}
/* 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;
}
}
SExp nreverse(SExp s) {
SExp r = sNIL;
SExp p;
for (p = s; consp(p); ) {
SExp q = CDR(p);
rplacd(p, r);
r = p;
p = q;
}
return r;
}
/* xladdmsg - add a message to a class */
void xladdmsg(LVAL cls, const char *msg, int offset)
{
extern FUNDEF *funtab;
LVAL mptr;
/* enter the message selector */
mptr = entermsg(cls,xlenter(msg));
/* store the method for this message */
rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
}
/* 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 - 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);
}
/* 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 */
}
/* 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);
}
/* xlremprop - remove a property from a property list */
void xlremprop(NODE *sym,NODE *prp)
{
NODE *last,*p;
last = NIL;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
if (car(p) == prp)
if (last)
rplacd(last,cdr(cdr(p)));
else
setplist(sym,cdr(cdr(p)));
last = cdr(p);
}
}
/* Evaluate arguments */
long
eval_args(long func, long arg, long av[2], int n)
{
long x, y;
if ((n != FTYPE_ANY_ARGS) && (n != list_len(arg)))
return err_msg(errmsg_ill_nargs, 1, func);
switch (n){
case 0:
av[0] = TAG_NIL;
break;
case 1:
if ((av[0] = l_eval(l_car(arg))) < 0)
return -1;
break;
case 2:
if ((av[0] = l_eval(l_car(arg))) < 0)
return -1;
if (gc_protect(av[0]) < 0)
return -1;
if ((av[1] = l_eval(l_car(l_cdr(arg)))) < 0)
return -1;
gc_unprotect(av[0]);
break;
case FTYPE_ANY_ARGS: /* return evaluated arguments as a list */
if (D_GET_TAG(arg) != TAG_CONS){
av[0] = TAG_NIL;
} else {
if ((x = l_eval(l_car(arg))) < 0)
return -1;
if ((av[0] = y = l_cons(x, TAG_NIL)) < 0)
return -1;
if (gc_protect(av[0]) < 0)
return -1;
for (arg = l_cdr(arg); D_GET_TAG(arg) == TAG_CONS; arg = l_cdr(arg)){
if ((x = l_eval(l_car(arg))) < 0)
return -1;
rplacd(y, l_cons(x, TAG_NIL));
y = l_cdr(y);
}
gc_unprotect(av[0]);
}
}
return av[0];
}
/* xlremprop - remove a property from a property list */
void xlremprop(LVAL sym, LVAL prp)
{
LVAL last,p;
last = NIL;
for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
if (car(p) == prp) {
if (last)
rplacd(last,cdr(cdr(p)));
else
setplist(sym,cdr(cdr(p)));
}
last = cdr(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);
}
/* xlsetfunction - set the functional value of a symbol */
void xlsetfunction(LVAL sym, LVAL val)
{
register LVAL fp,ep;
/* look for the symbol in the environment list */
for (fp = xlfenv; fp; fp = cdr(fp))
for (ep = car(fp); ep; ep = cdr(ep))
if (sym == car(car(ep))) {
rplacd(car(ep),val);
return;
}
/* store the global value */
setfunction(sym,val);
}
/* xrplcd - replace the cdr of a list node */
LVAL xrplcd(void)
{
LVAL list,newcdr;
/* get the list and the new cdr */
list = xlgacons();
newcdr = xlgetarg();
xllastarg();
/* replace the cdr */
rplacd(list,newcdr);
/* return the list node that was modified */
return (list);
}
/* xdelete - built-in function 'delete' */
LVAL xdelete(void)
{
LVAL x,list,fcn,last,val;
int tresult;
/* protect some pointers */
xlsave1(fcn);
/* get the expression to delete and the list */
x = xlgetarg();
list = xlgalist();
xltest(&fcn,&tresult);
/* delete leading matches */
while (consp(list)) {
if (dotest2(x,car(list),fcn) != tresult)
break;
list = cdr(list);
}
val = last = list;
/* delete embedded matches */
if (consp(list)) {
/* skip the first non-matching element */
list = cdr(list);
/* look for embedded matches */
while (consp(list)) {
/* check to see if this element should be deleted */
if (dotest2(x,car(list),fcn) == tresult)
rplacd(last,cdr(list));
else
last = list;
/* move to the next element */
list = cdr(list);
}
}
/* restore the stack */
xlpop();
/* return the updated list */
return (val);
}
