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