v10i090: XLisP 2.1 Sources 1c (3/3) / 5
Gary Murphy
garym at cognos.UUCP
Tue Feb 27 14:11:10 AEST 1990
Posting-number: Volume 10, Issue 90
Submitted-by: garym at 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 at umd5.umd.edu (Jon Greenblatt)
XNewsgroups: comp.lang.lisp.x
XSubject: Xlisp2.0 speedups... (Part 1 of 3)
XMessage-ID: <4912 at umd5.umd.edu>
XDate: 18 May 89 16:58:56 GMT
XReply-To: jonnyg at 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 at umd5.umd.edu (Jon Greenblatt)
XNewsgroups: comp.lang.lisp.x
XSubject: Xlisp 2.0 speedups (Part 2 of 3)
XMessage-ID: <4913 at umd5.umd.edu>
XDate: 18 May 89 16:59:37 GMT
XReply-To: jonnyg at 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 <stdio.h>
X #include <ctype.h>
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 <stdio.h>
X #include <ctype.h>
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,"<Windows object>",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 at 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
More information about the Comp.sources.misc
mailing list