From sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg Tue May 23 15:37:24 EDT 1989 Article: 91 of comp.lang.lisp.x Path: cognos!sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg From: jonnyg@umd5.umd.edu (Jon Greenblatt) Newsgroups: comp.lang.lisp.x Subject: Xlisp2.0 speedups... (Part 1 of 3) Message-ID: <4912@umd5.umd.edu> Date: 18 May 89 16:58:56 GMT Reply-To: jonnyg@umd5.umd.edu (Jon Greenblatt) Organization: University of Maryland, College Park Lines: 910 The following are changes I have made to xlisp 2.0 source. Most of these changes produce considerable speed ups. This distribution is very rough but maybe someone can wade through it and come of with a cleaned up version of the speed ups. Note this is a striaght context diff so more than just the speed ups are included, BEWARE! If you are able to clean up or enhance these speed ups in any way I would apreciate the feedback. JonnyG. diff -c ../xlisp.org/xlbfun.c ../xlisp/xlbfun.c *** ../xlisp.org/xlbfun.c Sun May 7 22:25:38 1989 --- ../xlisp/xlbfun.c Wed Apr 5 16:18:23 1989 *************** *** 558,563 **** --- 558,578 ---- return (val); } + LVAL xcopyarray() + { + LVAL src, dest; + int num; + register int i; + + src = xlgavector(); + dest = xlgavector(); + xllastarg(); + num = (getsize(src) < getsize(dest)) ? getsize(src) : getsize(dest); + for (i = 0; i < num; i++) + setelement(dest,i,getelement(src,i)); + return(dest); + } + /* xerror - special form 'error' */ LVAL xerror() { diff -c ../xlisp.org/xldbug.c ../xlisp/xldbug.c *** ../xlisp.org/xldbug.c Sun May 7 22:25:43 1989 --- ../xlisp/xldbug.c Wed Apr 5 16:18:24 1989 *************** *** 14,20 **** extern char buf[]; /* external routines */ ! extern char *malloc(); /* forward declarations */ FORWARD LVAL stacktop(); --- 14,20 ---- extern char buf[]; /* external routines */ ! extern char *xlmalloc(); /* forward declarations */ FORWARD LVAL stacktop(); diff -c ../xlisp.org/xldmem.c ../xlisp/xldmem.c *** ../xlisp.org/xldmem.c Sun May 7 22:25:46 1989 --- ../xlisp/xldmem.c Wed Apr 5 16:18:25 1989 *************** *** 6,13 **** #include "xlisp.h" /* node flags */ ! #define MARK 1 ! #define LEFT 2 /* macro to compute the size of a segment */ #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node)) --- 6,13 ---- #include "xlisp.h" /* node flags */ ! #define MARK 0x20 ! #define LEFT 0x40 /* macro to compute the size of a segment */ #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node)) *************** *** 21,37 **** SEGMENT *segs,*lastseg,*fixseg,*charseg; int anodes,nsegs,gccalls; long nnodes,nfree,total; ! LVAL fnodes; /* external procedures */ ! extern char *malloc(); ! extern char *calloc(); /* forward declarations */ ! FORWARD LVAL newnode(); FORWARD unsigned char *stralloc(); FORWARD SEGMENT *newsegment(); /* cons - construct a new cons node */ LVAL cons(x,y) LVAL x,y; --- 21,50 ---- SEGMENT *segs,*lastseg,*fixseg,*charseg; int anodes,nsegs,gccalls; long nnodes,nfree,total; ! LVAL fnodes = NIL; /* external procedures */ ! extern char *xlmalloc(); ! extern char *xlcalloc(); /* forward declarations */ ! FORWARD LVAL Newnode(); FORWARD unsigned char *stralloc(); FORWARD SEGMENT *newsegment(); + LVAL _nnode; + FIXTYPE _tfixed; + int _tint; + + #define newnode(type) (((_nnode = fnodes) != NIL) ? \ + ((fnodes = cdr(_nnode)), \ + nfree--, \ + (_nnode->n_type = type), \ + rplacd(_nnode,NIL), \ + _nnode) \ + : (_nnode = Newnode(type))) + + /* cons - construct a new cons node */ LVAL cons(x,y) LVAL x,y; *************** *** 129,140 **** } /* cvfixnum - convert an integer to a fixnum node */ ! LVAL cvfixnum(n) FIXTYPE n; { LVAL val; - if (n >= SFIXMIN && n <= SFIXMAX) - return (&fixseg->sg_nodes[(int)n-SFIXMIN]); val = newnode(FIXNUM); val->n_fixnum = n; return (val); --- 142,151 ---- } /* cvfixnum - convert an integer to a fixnum node */ ! LVAL Cvfixnum(n) FIXTYPE n; { LVAL val; val = newnode(FIXNUM); val->n_fixnum = n; return (val); *************** *** 151,157 **** } /* cvchar - convert an integer to a character node */ ! LVAL cvchar(n) int n; { if (n >= CHARMIN && n <= CHARMAX) --- 162,168 ---- } /* cvchar - convert an integer to a character node */ ! LVAL Cvchar(n) int n; { if (n >= CHARMIN && n <= CHARMAX) *************** *** 180,185 **** --- 191,225 ---- return (val); } + #ifdef WINDOWS + LVAL newwinobj(size) + int size; + { + LVAL val; + val = newnode(WINOBJ); + if (size > 0) { + xlprot1(val); + if ((val->n_winobj = xldcalloc(1,size)) == NULL) { + findmem(); + if ((val->n_winobj = xldcalloc(1,size)) == NULL) + xlfail("insufficient memory"); + } + xlpop(); + } + else val->n_winobj = NULL; + return(val); + } + + LVAL cvwinobj(p) + char *p; + { + LVAL val; + val = newnode(WINOBJ); + val->n_winobj = p; + return(val); + } + #endif + /* newclosure - allocate and initialize a new closure */ LVAL newclosure(name,type,env,fenv) LVAL name,type,env,fenv; *************** *** 204,212 **** vect = newnode(VECTOR); vect->n_vsize = 0; if (bsize = size * sizeof(LVAL)) { ! if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) { findmem(); ! if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) xlfail("insufficient vector space"); } vect->n_vsize = size; --- 244,252 ---- vect = newnode(VECTOR); vect->n_vsize = 0; if (bsize = size * sizeof(LVAL)) { ! if ((vect->n_vdata = (LVAL *)xldcalloc(1,bsize)) == NULL) { findmem(); ! if ((vect->n_vdata = (LVAL *)xldcalloc(1,bsize)) == NULL) xlfail("insufficient vector space"); } vect->n_vsize = size; *************** *** 217,223 **** } /* newnode - allocate a new node */ ! LOCAL LVAL newnode(type) int type; { LVAL nnode; --- 257,263 ---- } /* newnode - allocate a new node */ ! LVAL Newnode(type) int type; { LVAL nnode; *************** *** 248,256 **** unsigned char *sptr; /* allocate memory for the string copy */ ! if ((sptr = (unsigned char *)malloc(size)) == NULL) { gc(); ! if ((sptr = (unsigned char *)malloc(size)) == NULL) xlfail("insufficient string space"); } total += (long)size; --- 288,296 ---- unsigned char *sptr; /* allocate memory for the string copy */ ! if ((sptr = (unsigned char *)xldmalloc(size)) == NULL) { gc(); ! if ((sptr = (unsigned char *)xldmalloc(size)) == NULL) xlfail("insufficient string space"); } total += (long)size; *************** *** 330,336 **** LVAL ptr; { register LVAL this,prev,tmp; ! int type,i,n; /* initialize */ prev = NIL; --- 370,376 ---- LVAL ptr; { register LVAL this,prev,tmp; ! register int i,n; /* initialize */ prev = NIL; *************** *** 340,380 **** for (;;) { /* descend as far as we can */ ! while (!(this->n_flags & MARK)) /* check cons and symbol nodes */ ! if ((type = ntype(this)) == CONS) { ! 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; ! } ! break; ! } /* backup to a point where we can continue descending */ for (;;) --- 380,409 ---- for (;;) { /* descend as far as we can */ ! while (!(this->n_type & MARK)) /* check cons and symbol nodes */ ! if ((i = (this->n_type |= MARK) & TYPEFIELD) == CONS) { ! if (tmp = car(this)) { ! this->n_type |= LEFT; ! rplaca(this,prev);} ! else if (tmp = cdr(this)) rplacd(this,prev); ! else /* both sides nil */ break; ! prev = this; /* step down the branch */ ! this = tmp; ! } else { ! if ((i & ARRAY) != 0) ! for (i = 0, n = getsize(this); i < n;) ! if (tmp = getelement(this,i++)) ! if ((tmp->n_type & (ARRAY|MARK)) == ARRAY || ! tmp->n_type == CONS) ! mark(tmp); ! else tmp->n_type |= MARK; ! break; ! } /* backup to a point where we can continue descending */ for (;;) *************** *** 381,388 **** /* 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)) { --- 410,417 ---- /* make sure there is a previous node */ if (prev) { ! if (prev->n_type & LEFT) { /* came from left side */ ! prev->n_type &= ~LEFT; tmp = car(prev); rplaca(prev,this); if (this = cdr(prev)) { *************** *** 399,406 **** } /* no previous node, must be done */ ! else ! return; } } --- 428,434 ---- } /* no previous node, must be done */ ! else return; } } *************** *** 407,434 **** /* sweep - sweep all unmarked nodes and add them to the free list */ LOCAL sweep() { ! 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) ! if (!(p->n_flags & MARK)) { switch (ntype(p)) { case STRING: if (getstring(p) != NULL) { total -= (long)getslength(p); ! free(getstring(p)); } break; case STREAM: --- 435,463 ---- /* sweep - sweep all unmarked nodes and add them to the free list */ LOCAL sweep() { ! register SEGMENT *seg; ! register LVAL p; ! register int n; fnodes = NIL; ! nfree = 0l; /* add all unmarked nodes */ for (seg = segs; seg; seg = seg->sg_next) { ! if (seg == fixseg || seg == charseg) ! /* don't sweep the fixed segments */ continue; p = &seg->sg_nodes[0]; ! for (n = seg->sg_size; --n >= 0;) ! if (p->n_type & MARK) ! (p++)->n_type &= ~MARK; ! else { switch (ntype(p)) { case STRING: if (getstring(p) != NULL) { total -= (long)getslength(p); ! /* Using getstring here breaks VMEM (JonnyG) */ ! xldfree(p->n_string); } break; case STREAM: *************** *** 435,440 **** --- 464,474 ---- if (getfile(p)) osclose(getfile(p)); break; + #ifdef WINDOWS + case WINOBJ: + free_winobj(p); + break; + #endif case SYMBOL: case OBJECT: case VECTOR: *************** *** 441,447 **** case CLOSURE: if (p->n_vsize) { total -= (long) (p->n_vsize * sizeof(LVAL)); ! free(p->n_vdata); } break; } --- 475,481 ---- case CLOSURE: if (p->n_vsize) { total -= (long) (p->n_vsize * sizeof(LVAL)); ! xldfree(p->n_vdata); } break; } *************** *** 448,458 **** p->n_type = FREE; rplaca(p,NIL); rplacd(p,fnodes); ! fnodes = p; ! nfree += 1L; } - else - p->n_flags &= ~MARK; } } --- 482,490 ---- p->n_type = FREE; rplaca(p,NIL); rplacd(p,fnodes); ! fnodes = p++; ! nfree++; } } } *************** *** 485,491 **** SEGMENT *newseg; /* allocate the new segment */ ! if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL) return (NULL); /* initialize the new segment */ --- 517,524 ---- SEGMENT *newseg; /* allocate the new segment */ ! ! if ((newseg = (SEGMENT *)xlcalloc(1,segsize(n))) == NULL) return (NULL); /* initialize the new segment */ *************** *** 666,677 **** s_gcflag = s_gchook = NIL; /* allocate the evaluation stack */ ! if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL) xlfatal("insufficient memory"); xlstack = xlstktop = xlstkbase + EDEPTH; /* allocate the argument stack */ ! if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL) xlfatal("insufficient memory"); xlargstktop = xlargstkbase + ADEPTH; xlfp = xlsp = xlargstkbase; --- 699,710 ---- s_gcflag = s_gchook = NIL; /* allocate the evaluation stack */ ! if ((xlstkbase = (LVAL **)xlmalloc(EDEPTH * sizeof(LVAL *))) == NULL) xlfatal("insufficient memory"); xlstack = xlstktop = xlstkbase + EDEPTH; /* allocate the argument stack */ ! if ((xlargstkbase = (LVAL *)xlmalloc(ADEPTH * sizeof(LVAL))) == NULL) xlfatal("insufficient memory"); xlargstktop = xlargstkbase + ADEPTH; xlfp = xlsp = xlargstkbase; diff -c ../xlisp.org/xldmem.h ../xlisp/xldmem.h *** ../xlisp.org/xldmem.h Sun May 7 22:25:47 1989 --- ../xlisp/xldmem.h Wed Apr 5 16:45:38 1989 *************** *** 13,21 **** #define CHARMAX 255 #define CHARSIZE 256 - /* new node access macros */ - #define ntype(x) ((x)->n_type) - /* cons access macros */ #define car(x) ((x)->n_car) #define cdr(x) ((x)->n_cdr) --- 13,18 ---- *************** *** 23,72 **** #define rplacd(x,y) ((x)->n_cdr = (y)) /* symbol access macros */ ! #define getvalue(x) ((x)->n_vdata[0]) ! #define setvalue(x,v) ((x)->n_vdata[0] = (v)) ! #define getfunction(x) ((x)->n_vdata[1]) ! #define setfunction(x,v) ((x)->n_vdata[1] = (v)) ! #define getplist(x) ((x)->n_vdata[2]) ! #define setplist(x,v) ((x)->n_vdata[2] = (v)) ! #define getpname(x) ((x)->n_vdata[3]) ! #define setpname(x,v) ((x)->n_vdata[3] = (v)) #define SYMSIZE 4 /* closure access macros */ ! #define getname(x) ((x)->n_vdata[0]) ! #define setname(x,v) ((x)->n_vdata[0] = (v)) ! #define gettype(x) ((x)->n_vdata[1]) ! #define settype(x,v) ((x)->n_vdata[1] = (v)) ! #define getargs(x) ((x)->n_vdata[2]) ! #define setargs(x,v) ((x)->n_vdata[2] = (v)) ! #define getoargs(x) ((x)->n_vdata[3]) ! #define setoargs(x,v) ((x)->n_vdata[3] = (v)) ! #define getrest(x) ((x)->n_vdata[4]) ! #define setrest(x,v) ((x)->n_vdata[4] = (v)) ! #define getkargs(x) ((x)->n_vdata[5]) ! #define setkargs(x,v) ((x)->n_vdata[5] = (v)) ! #define getaargs(x) ((x)->n_vdata[6]) ! #define setaargs(x,v) ((x)->n_vdata[6] = (v)) ! #define getbody(x) ((x)->n_vdata[7]) ! #define setbody(x,v) ((x)->n_vdata[7] = (v)) ! #define getenv(x) ((x)->n_vdata[8]) ! #define setenv(x,v) ((x)->n_vdata[8] = (v)) ! #define getfenv(x) ((x)->n_vdata[9]) ! #define setfenv(x,v) ((x)->n_vdata[9] = (v)) ! #define getlambda(x) ((x)->n_vdata[10]) ! #define setlambda(x,v) ((x)->n_vdata[10] = (v)) #define CLOSIZE 11 /* vector access macros */ #define getsize(x) ((x)->n_vsize) ! #define getelement(x,i) ((x)->n_vdata[i]) ! #define setelement(x,i,v) ((x)->n_vdata[i] = (v)) /* object access macros */ ! #define getclass(x) ((x)->n_vdata[0]) ! #define getivar(x,i) ((x)->n_vdata[i+1]) ! #define setivar(x,i,v) ((x)->n_vdata[i+1] = (v)) /* subr/fsubr access macros */ #define getsubr(x) ((x)->n_subr) --- 20,69 ---- #define rplacd(x,y) ((x)->n_cdr = (y)) /* symbol access macros */ ! #define getvalue(x) (ACESSV(x,0)) ! #define setvalue(x,v) (ACESSV(x,0) = (v)) ! #define getfunction(x) (ACESSV(x,1)) ! #define setfunction(x,v) (ACESSV(x,1) = (v)) ! #define getplist(x) (ACESSV(x,2)) ! #define setplist(x,v) (ACESSV(x,2) = (v)) ! #define getpname(x) (ACESSV(x,3)) ! #define setpname(x,v) (ACESSV(x,3) = (v)) #define SYMSIZE 4 /* closure access macros */ ! #define getname(x) (ACESSV(x,0)) ! #define setname(x,v) (ACESSV(x,0) = (v)) ! #define gettype(x) (ACESSV(x,1)) ! #define settype(x,v) (ACESSV(x,1) = (v)) ! #define getargs(x) (ACESSV(x,2)) ! #define setargs(x,v) (ACESSV(x,2) = (v)) ! #define getoargs(x) (ACESSV(x,3)) ! #define setoargs(x,v) (ACESSV(x,3) = (v)) ! #define getrest(x) (ACESSV(x,4)) ! #define setrest(x,v) (ACESSV(x,4) = (v)) ! #define getkargs(x) (ACESSV(x,5)) ! #define setkargs(x,v) (ACESSV(x,5) = (v)) ! #define getaargs(x) (ACESSV(x,6)) ! #define setaargs(x,v) (ACESSV(x,6) = (v)) ! #define getbody(x) (ACESSV(x,7)) ! #define setbody(x,v) (ACESSV(x,7) = (v)) ! #define getenv(x) (ACESSV(x,8)) ! #define setenv(x,v) (ACESSV(x,8) = (v)) ! #define getfenv(x) (ACESSV(x,9)) ! #define setfenv(x,v) (ACESSV(x,9) = (v)) ! #define getlambda(x) (ACESSV(x,10)) ! #define setlambda(x,v) (ACESSV(x,10) = (v)) #define CLOSIZE 11 /* vector access macros */ #define getsize(x) ((x)->n_vsize) ! #define getelement(x,i) (ACESSV(x,i)) ! #define setelement(x,i,v) (ACESSV(x,i) = (v)) /* object access macros */ ! #define getclass(x) (ACESSV(x,0)) ! #define getivar(x,i) (ACESSV(x,i+1)) ! #define setivar(x,i,v) (ACESSV(x,i+1) = (v)) /* subr/fsubr access macros */ #define getsubr(x) ((x)->n_subr) *************** *** 78,84 **** #define getchcode(x) ((x)->n_chcode) /* string access macros */ ! #define getstring(x) ((x)->n_string) #define getslength(x) ((x)->n_strlen) /* file stream access macros */ --- 75,81 ---- #define getchcode(x) ((x)->n_chcode) /* string access macros */ ! #define getstring(x) (ACESSS((x)->n_string)) #define getslength(x) ((x)->n_strlen) /* file stream access macros */ *************** *** 93,114 **** #define gettail(x) ((x)->n_cdr) #define settail(x,v) ((x)->n_cdr = (v)) /* node types */ #define FREE 0 #define SUBR 1 #define FSUBR 2 #define CONS 3 ! #define SYMBOL 4 ! #define FIXNUM 5 ! #define FLONUM 6 ! #define STRING 7 ! #define OBJECT 8 ! #define STREAM 9 ! #define VECTOR 10 ! #define CLOSURE 11 ! #define CHAR 12 ! #define USTREAM 13 /* subr/fsubr node */ #define n_subr n_info.n_xsubr.xs_subr #define n_offset n_info.n_xsubr.xs_offset --- 90,121 ---- #define gettail(x) ((x)->n_cdr) #define settail(x,v) ((x)->n_cdr = (v)) + #define getwinobj(x) (ACESSS((x)->n_winobj)) + #define setwinobj(x,v) ((x)->n_winobj = (v)) + /* node types */ #define FREE 0 + #define SYMBOL 17 + #define OBJECT 18 + #define VECTOR 19 + #define CLOSURE 20 #define SUBR 1 #define FSUBR 2 #define CONS 3 ! #define FIXNUM 4 ! #define FLONUM 5 ! #define STRING 6 ! #define STREAM 7 ! #define CHAR 8 ! #define USTREAM 9 ! #define WINOBJ 10 + #define ARRAY 16 + #define TYPEFIELD 0x1f + + /* new node access macros */ + #define ntype(x) ((x)->n_type & TYPEFIELD) + /* subr/fsubr node */ #define n_subr n_info.n_xsubr.xs_subr #define n_offset n_info.n_xsubr.xs_offset *************** *** 137,146 **** #define n_vsize n_info.n_xvector.xv_size #define n_vdata n_info.n_xvector.xv_data /* node structure */ typedef struct node { char n_type; /* type of node */ - char n_flags; /* flag bits */ union ninfo { /* value */ struct xsubr { /* subr/fsubr node */ struct node *(*xs_subr)(); /* function pointer */ --- 144,155 ---- #define n_vsize n_info.n_xvector.xv_size #define n_vdata n_info.n_xvector.xv_data + /* window/font node */ + #define n_winobj n_info.n_xwinobj.xw_ptr + /* node structure */ typedef struct node { char n_type; /* type of node */ union ninfo { /* value */ struct xsubr { /* subr/fsubr node */ struct node *(*xs_subr)(); /* function pointer */ *************** *** 171,176 **** --- 180,188 ---- int xv_size; /* vector size */ struct node **xv_data; /* vector data */ } n_xvector; + struct xwinobj { /* window/font object */ + char *xw_ptr; /* Generic structure pointer */ + } n_xwinobj; } n_info; } *LVAL; *************** *** 187,195 **** extern LVAL cvstring(); /* convert a string */ extern LVAL cvfile(); /* convert a FILE * to a file */ extern LVAL cvsubr(); /* convert a function to a subr/fsubr */ ! extern LVAL cvfixnum(); /* convert a fixnum */ extern LVAL cvflonum(); /* convert a flonum */ ! extern LVAL cvchar(); /* convert a character */ extern LVAL newstring(); /* create a new string */ extern LVAL newvector(); /* create a new vector */ --- 199,207 ---- extern LVAL cvstring(); /* convert a string */ extern LVAL cvfile(); /* convert a FILE * to a file */ extern LVAL cvsubr(); /* convert a function to a subr/fsubr */ ! extern LVAL Cvfixnum(); /* convert a fixnum */ extern LVAL cvflonum(); /* convert a flonum */ ! extern LVAL Cvchar(); /* convert a character */ extern LVAL newstring(); /* create a new string */ extern LVAL newvector(); /* create a new vector */ *************** *** 196,198 **** --- 208,249 ---- extern LVAL newobject(); /* create a new object */ extern LVAL newclosure(); /* create a new closure */ extern LVAL newustream(); /* create a new unnamed stream */ + + + /* Speed ups, reduce function calls for fixed characters and numbers */ + /* Speed is exeptionaly noticed on machines with large a instruction cache */ + /* No size effects here (JonnyG) */ + + extern SEGMENT *fixseg,*charseg; + extern FIXTYPE _tfixed; + extern int _tint; + + #define cvfixnum(n) ((_tfixed = n), \ + ((_tfixed > SFIXMIN && _tfixed < SFIXMAX) ? \ + &fixseg->sg_nodes[(int)_tfixed-SFIXMIN] : \ + Cvfixnum(_tfixed))) + + #define cvchar(c) ((_tint = c), \ + ((_tint >= CHARMIN && _tint <= CHARMIN) ? \ + &charseg->sg_nodes[_tint-CHARMIN] : \ + Cvchar(_tint))) + + extern char *xldmalloc(); + extern char *xldcalloc(); + + #ifdef VMEM + + extern char *vload(); + + extern unsigned char *vaccess(); + + #define ACESSV(x,i) (((LVAL *)vaccess((x)->n_vdata))[i]) + #define ACESSS(x) (vaccess(x)) + + #else + + #define xlfcalloc xlcalloc + #define ACESSV(x,i) (x)->n_vdata[i] + #define ACESSS(x) x + + #endif diff -c ../xlisp.org/xlfio.c ../xlisp/xlfio.c *** ../xlisp.org/xlfio.c Sun May 7 22:25:52 1989 --- ../xlisp/xlfio.c Wed Apr 5 16:18:27 1989 *************** *** 349,355 **** /* copy the substring into the stream */ for (i = start; i < end; ++i) ! xlputc(val,str[i]); /* restore the stack */ xlpop(); --- 349,355 ---- /* copy the substring into the stream */ for (i = start; i < end; ++i) ! xlputc(val,getstring(string) + i); /* restore the stack */ xlpop(); *************** *** 450,456 **** LOCAL LVAL getstroutput(stream) LVAL stream; { ! unsigned char *str; LVAL next,val; int len,ch; --- 450,456 ---- LOCAL LVAL getstroutput(stream) LVAL stream; { ! int i; LVAL next,val; int len,ch; *************** *** 462,471 **** val = newstring(len + 1); /* copy the characters into the new string */ ! str = getstring(val); while ((ch = xlgetc(stream)) != EOF) ! *str++ = ch; ! *str = '\0'; /* return the string */ return (val); --- 462,471 ---- val = newstring(len + 1); /* copy the characters into the new string */ ! i = 0; while ((ch = xlgetc(stream)) != EOF) ! getstring(val)[i++] = ch; ! getstring(val)[i] = '\0'; /* return the string */ return (val); From sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg Tue May 23 15:37:32 EDT 1989 Article: 92 of comp.lang.lisp.x Path: cognos!sce!mitel!uunet!lll-winken!ames!haven!umd5!jonnyg From: jonnyg@umd5.umd.edu (Jon Greenblatt) Newsgroups: comp.lang.lisp.x Subject: Xlisp 2.0 speedups (Part 2 of 3) Message-ID: <4913@umd5.umd.edu> Date: 18 May 89 16:59:37 GMT Reply-To: jonnyg@umd5.umd.edu (Jon Greenblatt) Organization: University of Maryland, College Park Lines: 913 diff -c ../xlisp.org/xlftab.c ../xlisp/xlftab.c *** ../xlisp.org/xlftab.c Sun May 7 22:25:54 1989 --- ../xlisp/xlftab.c Wed Apr 5 16:18:28 1989 *************** *** 11,17 **** rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(), clnew(),clisnew(),clanswer(), obisnew(),obclass(),obshow(), ! rmlpar(),rmrpar(),rmsemi(), xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(), xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(), xgensym(),xmakesymbol(),xintern(), --- 11,17 ---- rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(), clnew(),clisnew(),clanswer(), obisnew(),obclass(),obshow(), ! rmlpar(),rmrpar(),rmlbrace(),rmrbrace(),rmsemi(), xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(), xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(), xgensym(),xmakesymbol(),xintern(), *************** *** 70,76 **** xcharp(),xcharint(),xintchar(), xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(), xgetlambda(),xmacroexpand(),x1macroexpand(), ! xtrace(),xuntrace(); /* functions specific to xldmem.c */ LVAL xgc(),xexpand(),xalloc(),xmem(); --- 70,76 ---- xcharp(),xcharint(),xintchar(), xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(), xgetlambda(),xmacroexpand(),x1macroexpand(), ! xtrace(),xuntrace(),xcopyarray(); /* functions specific to xldmem.c */ LVAL xgc(),xexpand(),xalloc(),xmem(); *************** *** 90,96 **** /* the function table */ FUNDEF funtab[] = { - /* read macro functions */ { NULL, S, rmhash }, /* 0 */ { NULL, S, rmquote }, /* 1 */ --- 90,95 ---- *************** *** 100,107 **** { NULL, S, rmlpar }, /* 5 */ { NULL, S, rmrpar }, /* 6 */ { NULL, S, rmsemi }, /* 7 */ ! { NULL, S, xnotimp }, /* 8 */ ! { NULL, S, xnotimp }, /* 9 */ /* methods */ { NULL, S, clnew }, /* 10 */ --- 99,106 ---- { NULL, S, rmlpar }, /* 5 */ { NULL, S, rmrpar }, /* 6 */ { NULL, S, rmsemi }, /* 7 */ ! { NULL, S, rmlbrace }, /* 8 */ ! { NULL, S, rmrbrace }, /* 9 */ /* methods */ { NULL, S, clnew }, /* 10 */ *************** *** 426,432 **** { "SORT", S, xsort }, /* 284 */ /* extra table entries */ ! { NULL, S, xnotimp }, /* 285 */ { NULL, S, xnotimp }, /* 286 */ { NULL, S, xnotimp }, /* 287 */ { NULL, S, xnotimp }, /* 288 */ --- 425,431 ---- { "SORT", S, xsort }, /* 284 */ /* extra table entries */ ! { "COPY-ARRAY", S, xcopyarray }, /* 285 */ { NULL, S, xnotimp }, /* 286 */ { NULL, S, xnotimp }, /* 287 */ { NULL, S, xnotimp }, /* 288 */ *************** *** 447,453 **** {0,0,0} /* end of table marker */ ! }; /* xnotimp - function table entries that are currently not implemented */ LOCAL LVAL xnotimp() --- 446,452 ---- {0,0,0} /* end of table marker */ ! }; /* xnotimp - function table entries that are currently not implemented */ LOCAL LVAL xnotimp() diff -c ../xlisp.org/xlglob.c ../xlisp/xlglob.c *** ../xlisp.org/xlglob.c Sun May 7 22:25:55 1989 --- ../xlisp/xlglob.c Wed Apr 5 16:18:28 1989 *************** *** 22,27 **** --- 22,28 ---- LVAL s_1plus=NIL,s_2plus=NIL,s_3plus=NIL; LVAL s_1star=NIL,s_2star=NIL,s_3star=NIL; LVAL s_minus=NIL,s_printcase=NIL; + LVAL s_send=NIL,s_sendsuper=NIL; /* keywords */ LVAL k_test=NIL,k_tnot=NIL; diff -c ../xlisp.org/xlimage.c ../xlisp/xlimage.c *** ../xlisp.org/xlimage.c Sun May 7 22:25:57 1989 --- ../xlisp/xlimage.c Wed Apr 5 16:18:28 1989 *************** *** 22,28 **** /* external procedures */ extern SEGMENT *newsegment(); extern FILE *osbopen(); ! extern char *malloc(); /* forward declarations */ OFFTYPE readptr(); --- 22,28 ---- /* external procedures */ extern SEGMENT *newsegment(); extern FILE *osbopen(); ! extern char *xlmalloc(); /* forward declarations */ OFFTYPE readptr(); *************** *** 170,176 **** case USTREAM: p = cviptr(off); p->n_type = type; - p->n_flags = 0; rplaca(p,cviptr(readptr())); rplacd(p,cviptr(readptr())); off += 2; --- 170,175 ---- *************** *** 192,198 **** case VECTOR: case CLOSURE: max = getsize(p); ! if ((p->n_vdata = (LVAL *)malloc(max * sizeof(LVAL))) == NULL) xlfatal("insufficient memory - vector"); total += (long)(max * sizeof(LVAL)); for (i = 0; i < max; ++i) --- 191,197 ---- case VECTOR: case CLOSURE: max = getsize(p); ! if ((p->n_vdata = (LVAL *)xlmalloc(max * sizeof(LVAL))) == NULL) xlfatal("insufficient memory - vector"); total += (long)(max * sizeof(LVAL)); for (i = 0; i < max; ++i) *************** *** 200,206 **** break; case STRING: max = getslength(p); ! if ((p->n_string = (unsigned char *)malloc(max)) == NULL) xlfatal("insufficient memory - string"); total += (long)max; for (cp = getstring(p); --max >= 0; ) --- 199,205 ---- break; case STRING: max = getslength(p); ! if ((p->n_string = (unsigned char *)xlmalloc(max)) == NULL) xlfatal("insufficient memory - string"); total += (long)max; for (cp = getstring(p); --max >= 0; ) *************** *** 247,257 **** case VECTOR: case CLOSURE: if (p->n_vsize) ! free(p->n_vdata); break; case STRING: if (getslength(p)) ! free(getstring(p)); break; case STREAM: if ((fp = getfile(p)) && (fp != stdin && fp != stdout)) --- 246,256 ---- case VECTOR: case CLOSURE: if (p->n_vsize) ! xlfree(p->n_vdata); break; case STRING: if (getslength(p)) ! xlfree(getstring(p)); break; case STREAM: if ((fp = getfile(p)) && (fp != stdin && fp != stdout)) *************** *** 259,265 **** break; } next = seg->sg_next; ! free(seg); } } --- 258,264 ---- break; } next = seg->sg_next; ! xlfree(seg); } } *************** *** 302,308 **** char *p = (char *)&node->n_info; int n = sizeof(union ninfo); node->n_type = type; - node->n_flags = 0; while (--n >= 0) *p++ = osbgetc(fp); } --- 301,306 ---- diff -c ../xlisp.org/xlinit.c ../xlisp/xlinit.c *** ../xlisp.org/xlinit.c Sun May 7 22:25:59 1989 --- ../xlisp/xlinit.c Wed Apr 5 16:18:29 1989 *************** *** 27,32 **** --- 27,33 ---- extern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object; extern LVAL a_vector,a_closure,a_char,a_ustream; extern LVAL s_gcflag,s_gchook; + extern LVAL s_send,s_sendsuper; extern FUNDEF funtab[]; /* xlinit - xlisp initialization routine */ *************** *** 106,111 **** --- 107,114 ---- s_eql = xlenter("EQL"); s_ifmt = xlenter("*INTEGER-FORMAT*"); s_ffmt = xlenter("*FLOAT-FORMAT*"); + s_send = xlenter("SEND"); + s_sendsuper = xlenter("SEND-SUPER"); /* symbols set by the read-eval-print loop */ s_1plus = xlenter("+"); diff -c ../xlisp.org/xlisp.c ../xlisp/xlisp.c *** ../xlisp.org/xlisp.c Sun May 7 22:26:02 1989 --- ../xlisp/xlisp.c Thu Apr 6 10:06:46 1989 *************** *** 6,12 **** #include "xlisp.h" /* define the banner line string */ ! #define BANNER "XLISP version 2.0, Copyright (c) 1988, by David Betz" /* global variables */ jmp_buf top_level; --- 6,12 ---- #include "xlisp.h" /* define the banner line string */ ! #define BANNER "XLISP version 2.0w, Copyright (c) 1988, by David Betz" /* global variables */ jmp_buf top_level; *************** *** 52,60 **** } #endif /* initialize and print the banner line */ osinit(BANNER); - /* setup initialization error handler */ xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1); if (setjmp(cntxt.c_jmpbuf)) --- 52,63 ---- } #endif + #ifdef X11 + parse_args(&argc,argv); + #endif + /* initialize and print the banner line */ osinit(BANNER); /* setup initialization error handler */ xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1); if (setjmp(cntxt.c_jmpbuf)) *************** *** 61,67 **** xlfatal("fatal initialization error"); if (setjmp(top_level)) xlfatal("RESTORE not allowed during initialization"); - /* initialize xlisp */ xlinit(); xlend(&cntxt); --- 64,69 ---- diff -c ../xlisp.org/xlisp.h ../xlisp/xlisp.h *** ../xlisp.org/xlisp.h Sun May 7 22:26:12 1989 --- ../xlisp/xlisp.h Wed Apr 5 16:23:51 1989 *************** *** 4,10 **** Permission is granted for unrestricted non-commercial use */ /* system specific definitions */ ! /* #define UNIX */ #include #include --- 4,11 ---- Permission is granted for unrestricted non-commercial use */ /* system specific definitions */ ! #define X11 ! /* #define ADEBUG */ #include #include *************** *** 24,29 **** --- 25,35 ---- /* OFFTYPE number the size of an address (int) */ /* for the BSD 4.3 system. Might work for AT&T garbage */ + #ifdef X11 + #define UNIX + #define WINDOWS + #endif + #ifdef UNIX #define NNODES 2000 #define SAVERESTORE *************** *** 82,87 **** --- 88,105 ---- #define OFFTYPE long #endif + #ifdef MSW + #define NNODES 1000 + #define AFMT "%lx" + #define OFFTYPE long + #define WINDOWS + #define VMEM + #define MSC + #define xlmalloc WMalloc + #define xlcalloc WCalloc + #define xlfree WFree + #endif + /* for the Mark Williams C compiler - Atari ST */ #ifdef MWC #define AFMT "%lx" *************** *** 148,153 **** --- 166,176 ---- #ifndef UCHAR #define UCHAR unsigned char #endif + #ifndef xlmalloc + #define xlmalloc malloc + #define xlcalloc calloc + #define xlfree free + #endif /* useful definitions */ #define TRUE 1 *************** *** 160,166 **** #include "xldmem.h" /* program limits */ ! #define STRMAX 100 /* maximum length of a string constant */ #define HSIZE 199 /* symbol hash table size */ #define SAMPLE 100 /* control character sample rate */ --- 183,189 ---- #include "xldmem.h" /* program limits */ ! #define STRMAX 512 /* maximum length of a string constant */ #define HSIZE 199 /* symbol hash table size */ #define SAMPLE 100 /* control character sample rate */ *************** *** 173,178 **** --- 196,203 ---- #define FT_RMLPAR 5 #define FT_RMRPAR 6 #define FT_RMSEMI 7 + #define FT_RMLBRACE 8 + #define FT_RMRBRACE 9 #define FT_CLNEW 10 #define FT_CLISNEW 11 #define FT_CLANSWER 12 *************** *** 179,191 **** #define FT_OBISNEW 13 #define FT_OBCLASS 14 #define FT_OBSHOW 15 ! /* macro to push a value onto the argument stack */ #define pusharg(x) {if (xlsp >= xlargstktop) xlargstkoverflow();\ ! *xlsp++ = (x);} /* macros to protect pointers */ ! #define xlstkcheck(n) {if (xlstack - (n) < xlstkbase) xlstkoverflow();} #define xlsave(n) {*--xlstack = &n; n = NIL;} #define xlprotect(n) {*--xlstack = &n;} --- 204,216 ---- #define FT_OBISNEW 13 #define FT_OBCLASS 14 #define FT_OBSHOW 15 ! /* macro to push a value onto the argument stack */ #define pusharg(x) {if (xlsp >= xlargstktop) xlargstkoverflow();\ ! *(xlsp++) = (x);} /* macros to protect pointers */ ! #define xlstkcheck(n) {if ((xlstack - (n)) < xlstkbase) xlstkoverflow();} #define xlsave(n) {*--xlstack = &n; n = NIL;} #define xlprotect(n) {*--xlstack = &n;} *************** *** 230,235 **** --- 255,261 ---- #define ustreamp(x) ((x) && ntype(x) == USTREAM) #define boundp(x) (getvalue(x) != s_unbound) #define fboundp(x) (getfunction(x) != s_unbound) + #define winobjp(x) ((x) && ntype(x) == WINOBJ) /* shorthand functions */ #define consa(x) cons(x,NIL) *************** *** 323,326 **** /* error reporting functions (don't *really* return at all) */ extern LVAL xltoofew(); /* report "too few arguments" error */ extern LVAL xlbadtype(); /* report "bad argument type" error */ - --- 349,351 ---- diff -c ../xlisp.org/xlobj.c ../xlisp/xlobj.c *** ../xlisp.org/xlobj.c Sun May 7 22:26:20 1989 --- ../xlisp/xlobj.c Wed Apr 5 16:18:40 1989 *************** *** 41,47 **** /* xsendsuper - send a message to the superclass of an object */ LVAL xsendsuper() { ! LVAL env,p; for (env = xlenv; env; env = cdr(env)) if ((p = car(env)) && objectp(car(p))) return (sendmsg(car(p), --- 41,47 ---- /* xsendsuper - send a message to the superclass of an object */ LVAL xsendsuper() { ! register LVAL env,p; for (env = xlenv; env; env = cdr(env)) if ((p = car(env)) && objectp(car(p))) return (sendmsg(car(p), *************** *** 97,104 **** int xlobgetvalue(pair,sym,pval) LVAL pair,sym,*pval; { ! LVAL cls,names; ! int ivtotal,n; /* find the instance or class variable */ for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) { --- 97,104 ---- int xlobgetvalue(pair,sym,pval) LVAL pair,sym,*pval; { ! register LVAL cls,names; ! register int ivtotal,n; /* find the instance or class variable */ for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) { *************** *** 133,140 **** int xlobsetvalue(pair,sym,val) LVAL pair,sym,val; { ! LVAL cls,names; ! int ivtotal,n; /* find the instance or class variable */ for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) { --- 133,140 ---- int xlobsetvalue(pair,sym,val) LVAL pair,sym,val; { ! register LVAL cls,names; ! register int ivtotal,n; /* find the instance or class variable */ for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) { *************** *** 309,315 **** LOCAL LVAL sendmsg(obj,cls,sym) LVAL obj,cls,sym; { ! LVAL msg,msgcls,method,val,p; /* look for the message in the class or superclasses */ for (msgcls = cls; msgcls; ) { --- 309,316 ---- LOCAL LVAL sendmsg(obj,cls,sym) LVAL obj,cls,sym; { ! LVAL method,val; ! register LVAL msg,msgcls,p; /* look for the message in the class or superclasses */ for (msgcls = cls; msgcls; ) { *************** *** 316,322 **** /* lookup the message in this class */ for (p = getivar(msgcls,MESSAGES); p; p = cdr(p)) ! if ((msg = car(p)) && car(msg) == sym) goto send_message; /* look in class's superclass */ --- 317,323 ---- /* lookup the message in this class */ for (p = getivar(msgcls,MESSAGES); p; p = cdr(p)) ! if ((msg = car(p)) ? car(msg) == sym : 0) goto send_message; /* look in class's superclass */ *************** *** 363,369 **** LOCAL LVAL evmethod(obj,msgcls,method) LVAL obj,msgcls,method; { ! LVAL oldenv,oldfenv,cptr,name,val; CONTEXT cntxt; /* protect some pointers */ --- 364,370 ---- LOCAL LVAL evmethod(obj,msgcls,method) LVAL obj,msgcls,method; { ! LVAL oldenv,oldfenv,name,cptr,val; CONTEXT cntxt; /* protect some pointers */ *************** *** 420,428 **** /* listlength - find the length of a list */ LOCAL int listlength(list) ! LVAL list; { ! int len; for (len = 0; consp(list); len++) list = cdr(list); return (len); --- 421,429 ---- /* listlength - find the length of a list */ LOCAL int listlength(list) ! register LVAL list; { ! register int len; for (len = 0; consp(list); len++) list = cdr(list); return (len); *************** *** 470,473 **** xladdmsg(object,":CLASS",FT_OBCLASS); xladdmsg(object,":SHOW",FT_OBSHOW); } - --- 471,473 ---- diff -c ../xlisp.org/xlprin.c ../xlisp/xlprin.c *** ../xlisp.org/xlprin.c Sun May 7 22:26:23 1989 --- ../xlisp/xlprin.c Fri May 5 13:35:51 1989 *************** *** 33,38 **** --- 33,41 ---- case FSUBR: putsubr(fptr,"FSubr",vptr); break; + case WINOBJ: + putsymbol(fptr,"",flag); + break; case CONS: xlputc(fptr,'('); for (nptr = vptr; nptr != NIL; nptr = next) { diff -c ../xlisp.org/xlread.c ../xlisp/xlread.c *** ../xlisp.org/xlread.c Sun May 7 22:26:26 1989 --- ../xlisp/xlread.c Wed Apr 5 16:18:41 1989 *************** *** 15,20 **** --- 15,21 ---- extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat; extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro; extern LVAL k_sescape,k_mescape; + extern LVAL s_send, s_sendsuper; extern char buf[]; /* external routines */ *************** *** 29,35 **** /* forward declarations */ FORWARD LVAL callmacro(); FORWARD LVAL psymbol(),punintern(); ! FORWARD LVAL pnumber(),pquote(),plist(),pvector(); FORWARD LVAL tentry(); /* xlload - load a file of xlisp expressions */ --- 30,36 ---- /* forward declarations */ FORWARD LVAL callmacro(); FORWARD LVAL psymbol(),punintern(); ! FORWARD LVAL pnumber(),pquote(),plist(),pmessage(),pvector(); FORWARD LVAL tentry(); /* xlload - load a file of xlisp expressions */ *************** *** 366,371 **** --- 367,386 ---- return (consa(plist(fptr))); } + /* rmlbrace - read macro for '{' */ + LVAL rmlbrace() + { + LVAL fptr,mch; + + /* get the file and macro character */ + fptr = xlgetfile(); + mch = xlgachar(); + xllastarg(); + + /* make the return value */ + return (consa(pmessage(fptr))); + } + /* rmrpar - read macro for ')' */ LVAL rmrpar() { *************** *** 372,377 **** --- 387,398 ---- xlfail("misplaced right paren"); } + /* rmbrace - read macro for '}' */ + LVAL rmrbrace() + { + xlfail("misplaced right brace"); + } + /* rmsemi - read macro for ';' */ LVAL rmsemi() { *************** *** 485,490 **** --- 506,555 ---- return (val); } + /* plist - parse a message */ + LOCAL LVAL pmessage(fptr) + LVAL fptr; + { + LVAL val,expr,lastnptr,nptr; + LVAL mess = s_send; + + /* protect some pointers */ + xlstkcheck(2); + xlsave(val); + xlsave(expr); + + if (nextch(fptr) == '+') { /* Look for super class message */ + mess = s_sendsuper; + xlgetc(fptr); + } + + /* keep appending nodes until a closing paren is found */ + for (lastnptr = NIL; nextch(fptr) != '}'; ) + + /* get the next expression */ + if (readone(fptr,&expr) == EOF) + badeof(fptr); + else { + nptr = consa(expr); + if (lastnptr == NIL) + val = nptr; + else + rplacd(lastnptr,nptr); + lastnptr = nptr; + } + + /* skip the closing bracket */ + xlgetc(fptr); + + val = cons(mess,val); + + /* restore the stack */ + xlpopn(2); + + /* return successfully */ + return (val); + } + /* pvector - parse a vector */ LOCAL LVAL pvector(fptr) LVAL fptr; *************** *** 807,811 **** --- 872,878 ---- defmacro('(', k_tmacro,FT_RMLPAR); defmacro(')', k_tmacro,FT_RMRPAR); defmacro(';', k_tmacro,FT_RMSEMI); + defmacro('{', k_tmacro,FT_RMLBRACE); + defmacro('}', k_tmacro,FT_RMRBRACE); } diff -c ../xlisp.org/xlsym.c ../xlisp/xlsym.c *** ../xlisp.org/xlsym.c Sun May 7 22:26:32 1989 --- ../xlisp/xlsym.c Wed Apr 5 16:18:43 1989 *************** *** 4,10 **** Permission is granted for unrestricted non-commercial use */ #include "xlisp.h" ! /* external variables */ extern LVAL obarray,s_unbound; extern LVAL xlenv,xlfenv,xldenv; --- 4,11 ---- Permission is granted for unrestricted non-commercial use */ #include "xlisp.h" ! #undef HSIZE ! #define HSIZE 399 /* external variables */ extern LVAL obarray,s_unbound; extern LVAL xlenv,xlfenv,xldenv; *************** *** 16,22 **** LVAL xlenter(name) char *name; { ! LVAL sym,array; int i; /* check for nil */ --- 17,24 ---- LVAL xlenter(name) char *name; { ! register LVAL sym,array; ! LVAL sym2; int i; /* check for nil */ *************** *** 31,44 **** 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)); } /* xlmakesym - make a new symbol node */ --- 33,45 ---- return (car(sym)); /* make a new symbol node and link it into the list */ ! xlsave1(sym2); ! sym2 = consd(getelement(array,i)); ! rplaca(sym2,xlmakesym(name)); ! setelement(array,i,sym2); xlpop(); /* return the new symbol */ ! return (car(sym2)); } /* xlmakesym - make a new symbol node */ *************** *** 68,74 **** /* xlxgetvalue - get the value of a symbol */ LVAL xlxgetvalue(sym) ! LVAL sym; { register LVAL fp,ep; LVAL val; --- 69,75 ---- /* xlxgetvalue - get the value of a symbol */ LVAL xlxgetvalue(sym) ! register LVAL sym; { register LVAL fp,ep; LVAL val; *************** *** 95,101 **** /* xlsetvalue - set the value of a symbol */ xlsetvalue(sym,val) ! LVAL sym,val; { register LVAL fp,ep; --- 96,103 ---- /* xlsetvalue - set the value of a symbol */ xlsetvalue(sym,val) ! register LVAL sym; ! LVAL val; { register LVAL fp,ep; *************** *** 137,143 **** /* xlxgetfunction - get the functional value of a symbol */ LVAL xlxgetfunction(sym) ! LVAL sym; { register LVAL fp,ep; --- 139,145 ---- /* xlxgetfunction - get the functional value of a symbol */ LVAL xlxgetfunction(sym) ! register LVAL sym; { register LVAL fp,ep; *************** *** 192,198 **** xlremprop(sym,prp) LVAL sym,prp; { ! LVAL last,p; last = NIL; for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) { if (car(p) == prp) --- 194,200 ---- xlremprop(sym,prp) LVAL sym,prp; { ! register LVAL last,p; last = NIL; for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) { if (car(p) == prp) *************** *** 208,214 **** LOCAL LVAL findprop(sym,prp) LVAL sym,prp; { ! LVAL p; for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p))) if (car(p) == prp) return (cdr(p)); --- 210,216 ---- LOCAL LVAL findprop(sym,prp) LVAL sym,prp; { ! register LVAL p; for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p))) if (car(p) == prp) return (cdr(p)); *************** *** 217,226 **** /* hash - hash a symbol name string */ int hash(str,len) ! char *str; { ! int i; ! for (i = 0; *str; ) i = (i << 2) ^ *str++; i %= len; return (i < 0 ? -i : i); --- 219,228 ---- /* hash - hash a symbol name string */ int hash(str,len) ! register char *str; { ! register int i = 0; ! while (*str) i = (i << 2) ^ *str++; i %= len; return (i < 0 ? -i : i);