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