jcw@cvl.UUCP (07/20/84)
This portion contains the first third of the C source for David
Betz' XLISP interpreter.
Tear at the dotted line, run sh(1) over it.
Jay Weber
---------------------------------------------------------------
: Run this shell script with "sh" not "csh"
PATH=:/bin:/usr/bin:/usr/ucb
export PATH
/bin/echo 'Extracting xlbind.c'
sed 's/^X//' <<'//go.sysin dd *' >xlbind.c
X /* xlbind - xlisp symbol binding routines */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X /* global variables */
X
Xstruct node *xlenv;
X
X
X /********************************************************
X * xlunbind - unbind symbols bound in this environment *
X ********************************************************/
X
Xxlunbind(env)
X struct node *env;
X{
X struct node *bnd;
X
X for (; xlenv != env; xlenv = xlenv->n_listnext)
X {
X bnd = xlenv->n_listvalue;
X bnd->n_bndsym->n_symvalue = bnd->n_bndvalue;
X }
X}
X
X
X /**************************************
X * xlbind - bind a symbol to a value *
X **************************************/
X
Xxlbind(sym,val)
X struct node *sym,*val;
X{
X struct node *lptr,*bptr;
X
X lptr = newnode(LIST); /* Create new environment list entry */
X lptr->n_listnext = xlenv;
X xlenv = lptr;
X
X lptr->n_listvalue = bptr = newnode(LIST); /* New variable binding */
X bptr->n_bndsym = sym;
X bptr->n_bndvalue = val;
X}
X
X
X /*******************************************************
X * xlfixbindings - make a new set of bindings visible *
X *******************************************************/
X
Xxlfixbindings(env)
X struct node *env;
X{
X struct node *eptr,*bnd,*sym,*oldvalue;
X
X for (eptr = xlenv; eptr != env; eptr = eptr->n_listnext) {
X bnd = eptr->n_listvalue;
X sym = bnd->n_bndsym;
X oldvalue = sym->n_symvalue;
X sym->n_symvalue = bnd->n_bndvalue;
X bnd->n_bndvalue = oldvalue;
X }
X}
//go.sysin dd *
/bin/chmod 664 xlbind.c
/bin/echo -n ' '; /bin/ls -ld xlbind.c
/bin/echo 'Extracting xldebug.c'
sed 's/^X//' <<'//go.sysin dd *' >xldebug.c
X /* xldebug - some debug routines */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X
Xint debug_level = 0;
XFILE *debug_fp = NULL;
X
X
X
X /***************************************************
X * xldbgmsg : Display a message in the debug file *
X ***************************************************/
X
Xxldbgmsg(s)
X char *s;
X{
X if (debug_fp)
X fprintf(debug_fp, "\n%s", s);
X}
X
X
X /*******************************************
X * xldump : dump a node to the debug file *
X *******************************************/
X
Xxldump(nptr)
X struct node *nptr;
X{
X
X if (debug_fp == NULL) /* Debug file open ? */
X return;
X
X fprintf(debug_fp, "\n@%4x : %2x ", nptr, nptr->n_flags);
X
X switch(nptr->n_type)
X {
X case FREE:
X fprintf(debug_fp, "FREE node");
X return;
X
X case SYM:
X fprintf(debug_fp, "SYM %s = @%4x", nptr->n_symname, nptr->n_symvalue);
X return;
X
X case LIST:
X fprintf(debug_fp, "LIST @%4x , @%4x", nptr->n_listvalue,
X nptr->n_listnext);
X return;
X
X case SUBR:
X fprintf(debug_fp, "SUBR %4x", nptr->n_subr);
X return;
X
X case INT:
X fprintf(debug_fp, "INT = %d", nptr->n_int);
X return;
X
X case STR:
X fprintf(debug_fp, "STRING = %s", nptr->n_str);
X return;
X
X case OBJ:
X fprintf(debug_fp, "OBJ @%4x , @%4x", nptr->n_obclass,
X nptr->n_obdata);
X return;
X
X case FPTR:
X fprintf(debug_fp, "FILE %4x", nptr->n_fp);
X return;
X
X case KMAP:
X fprintf(debug_fp, "KMAP");
X return;
X
X#ifdef REALS
X case REAL:
X fprintf(debug_fp, "REAL = %g", nptr->n_real);
X return;
X#endif
X
X default:
X fprintf(debug_fp, "Type %d ?????????", nptr->n_type);
X return;
X }
X}
X
X
X /************************************************
X * debug : xlisp function to set debug options *
X ************************************************/
X
Xstatic struct node *debug(args)
X struct node *args;
X{
X debug_level = xlevmatch(INT, &args)->n_int;
X
X if (args != NULL)
X {
X if (debug_fp)
X fclose(debug_fp);
X if ((debug_fp = fopen(xlevmatch(STR, &args)->n_str, "w")) == NULL)
X xlfail("Cannot open debug file");
X xllastarg(args);
X }
X
X return (NULL);
X}
X
X
X /*******************************************
X * xldebuginit : initialize debug package *
X *******************************************/
X
Xxldebuginit()
X{
X debug_level = 0;
X debug_fp = NULL;
X
X xlsubr("debug", debug);
X}
//go.sysin dd *
/bin/chmod 664 xldebug.c
/bin/echo -n ' '; /bin/ls -ld xldebug.c
/bin/echo 'Extracting xldmem.c'
sed 's/^X//' <<'//go.sysin dd *' >xldmem.c
X /* xldmem - xlisp dynamic memory management routines */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X
X /* useful definitions */
X
X#define ALLOCSIZE (sizeof(struct segment) + anodes * sizeof(struct node))
X
X
X /* memory segment structure definition */
X
Xstruct segment {
X int sg_size;
X struct segment *sg_next;
X struct node sg_nodes[];
X};
X
X /* external variables */
X
Xextern struct node *oblist;
Xextern struct node *xlstack;
Xextern struct node *xlenv;
X
X
X /* external procedures */
X
Xextern char *malloc();
Xextern char *calloc();
X
X
X /* local variables */
X
Xint anodes,nnodes,nsegs,nfree,gccalls;
Xstatic struct segment *segs;
Xstatic struct node *fnodes;
X
X
X /**********************************
X * newnode - allocate a new node *
X **********************************/
X
Xstruct node *newnode(type)
X int type;
X{
X struct node *nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NULL) {
X gc();
X if ((nnode = fnodes) == NULL)
X xlfail("insufficient node space");
X }
X
X /* unlink the node from the free list */
X fnodes = nnode->n_right;
X nfree -= 1;
X
X /* initialize the new node */
X nnode->n_type = type;
X nnode->n_left = NULL;
X nnode->n_right = NULL;
X
X /* return the new node */
X return (nnode);
X}
X
X
X /*****************************************************************************
X * stralloc - allocate memory for a string adding a byte for the terminator *
X *****************************************************************************/
X
Xchar *stralloc(size)
X int size;
X{
X char *sptr;
X
X /* allocate memory for the string copy */
X if ((sptr = malloc(size+1)) == NULL) {
X gc();
X if ((sptr = malloc(size+1)) == NULL)
X xlfail("insufficient string space");
X }
X
X /* return the new string memory */
X return (sptr);
X}
X
X
X /**************************************************
X * strsave - generate a dynamic copy of a string *
X **************************************************/
X
Xchar *strsave(str)
X char *str;
X{
X char *sptr;
X
X /* */
X sptr = stralloc(strlen(str));
X strcpy(sptr,str);
X
X /* return the new string */
X return (sptr);
X}
X
X
X /*********************************
X * strfree - free string memory *
X *********************************/
X
Xstrfree(str)
X char *str;
X{
X free(str);
X}
X
X
X /*************************
X * gc - garbage collect *
X *************************/
X
Xstatic gc()
X{
X unmark(); /* Unmark all nodes */
X
X#ifdef DEBUG
X xldbgmsg("\n\tOBLIST mark");
X mark(oblist);
X xldbgmsg("\n\tSTACK mark");
X mark(xlstack);
X xldbgmsg("\n\tENVIRONMENT");
X mark(xlenv);
X#else
X mark(oblist); /* Mark all accessible nodes */
X mark(xlstack);
X mark(xlenv);
X#endif
X
X sweep(); /* Sweep up the grabage */
X
X if (fnodes == NULL) /* Allocate more if necessary */
X addseg();
X
X gccalls += 1;
X}
X
X
X /******************************
X * unmark - unmark each node *
X ******************************/
X
Xstatic unmark()
X{
X struct node *n = xlstack;
X
X while (n != NULL) /* Unmark the stack */
X {
X n->n_flags &= ~(MARK | LEFT);
X n = n->n_listnext;
X }
X}
X
X /*************************************
X * mark - mark all accessible nodes *
X *************************************/
X
Xstatic mark(ptr)
X struct node *ptr;
X{
X struct node *this,*prev,*tmp;
X
X if (ptr == NULL) /* Return on null */
X return;
X
X prev = NULL; /* Initialize */
X this = ptr;
X
X while (TRUE) /* Mark this list */
X {
X while (TRUE) /* Descend as far as we can */
X {
X if (this->n_flags & MARK) /* Node already marked ? */
X break;
X else /* NO : mark it and its descendents */
X {
X
X#ifdef DEBUG
X xldump(this);
X#endif
X this->n_flags |= MARK; /* This node ...*/
X
X if (left(this)) /* .. the left sublist */
X {
X this->n_flags |= LEFT;
X tmp = prev;
X prev = this;
X this = prev->n_left;
X prev->n_left = tmp;
X }
X else
X if (right(this)) /* .. the right sublist */
X {
X this->n_flags &= ~LEFT;
X tmp = prev;
X prev = this;
X this = prev->n_right;
X prev->n_right = tmp;
X }
X else
X break;
X }
X }
X
X while (TRUE) /* Backup to last restart point */
X {
X if (prev == NULL) /* Finished yet ? */
X return;
X
X if (prev->n_flags & LEFT) /* Coming from left side ? */
X {
X if (right(prev))
X {
X prev->n_flags &= ~LEFT;
X tmp = prev->n_left;
X prev->n_left = this;
X this = prev->n_right;
X prev->n_right = tmp;
X break;
X }
X else
X {
X tmp = prev;
X prev = tmp->n_left;
X tmp->n_left = this;
X this = tmp;
X }
X }
X else /* came from the right side */
X {
X tmp = prev;
X prev = tmp->n_right;
X tmp->n_right = this;
X this = tmp;
X }
X }
X }
X}
X
X
X /*******************************************************************
X * sweep - sweep all unmarked nodes and add them to the free list *
X *******************************************************************/
X
Xstatic sweep()
X{
X struct segment *seg;
X struct node *n;
X int i;
X
X fnodes = NULL; /* Empty the free list */
X nfree = 0;
X
X /* add all unmarked nodes */
X for (seg = segs; seg != NULL; seg = seg->sg_next)
X for (i = 0; i < seg->sg_size; i++)
X if (!((n = &seg->sg_nodes[i])->n_flags & MARK))
X {
X switch (n->n_type)
X {
X case STR:
X if (n->n_strtype == DYNAMIC && n->n_str != NULL)
X strfree(n->n_str);
X break;
X
X case SYM:
X if (n->n_symname != NULL)
X strfree(n->n_symname);
X break;
X
X#ifdef KEYMAPCLASS
X case KMAP:
X xlkmfree(n);
X break;
X#endif
X }
X
X n->n_type = FREE;
X n->n_left = NULL;
X n->n_right = fnodes;
X fnodes = n;
X nfree += 1;
X }
X else
X n->n_flags &= ~MARK;
X}
X
X
X /***************************************************
X * addseg - add a segment to the available memory *
X ***************************************************/
X
Xstatic int addseg()
X{
X struct segment *newseg;
X int i;
X
X /* allocate a new segment */
X if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL)
X {
X newseg->sg_size = anodes; /* Initialize the new segment */
X newseg->sg_next = segs;
X segs = newseg;
X /* add each new node to the free list */
X for (i = 0; i < newseg->sg_size; i++)
X {
X newseg->sg_nodes[i].n_right = fnodes;
X fnodes = &newseg->sg_nodes[i];
X }
X
X nnodes += anodes; /* Update the statistics */
X nfree += anodes;
X nsegs += 1;
X
X return (TRUE); /* return success */
X }
X else
X return (FALSE);
X}
X
X
X /************************************
X * left - check for a left sublist *
X ************************************/
X
Xstatic int left(n)
X struct node *n;
X{
X switch (n->n_type)
X {
X case SYM:
X case SUBR:
X case INT:
X case STR:
X case FPTR:
X case REAL:
X return (FALSE);
X
X#ifdef KEYMAPCLASS
X case KMAP:
X xlkmmark(n);
X return (FALSE);
X#endif
X
X case LIST:
X case OBJ:
X return (n->n_left != NULL);
X
X default:
X printf("bad node type (%d) found during left scan\n",n->n_type);
X exit();
X }
X}
X
X
X /**************************************
X * right - check for a right sublist *
X **************************************/
X
Xstatic int right(n)
X struct node *n;
X{
X switch (n->n_type)
X {
X case SUBR:
X case INT:
X case REAL:
X case STR:
X case FPTR:
X case KMAP:
X return (FALSE);
X
X case SYM:
X case LIST:
X case OBJ:
X return (n->n_right != NULL);
X
X default:
X printf("bad node type (%d) found during right scan\n",n->n_type);
X exit();
X }
X}
X
X
X /************************************
X * stats - print memory statistics *
X ************************************/
X
Xstatic stats()
X{
X printf("\nNodes: %d\n",nnodes);
X printf("Free nodes: %d\n",nfree);
X printf("Segments: %d\n",nsegs);
X printf("Allocate: %d\n",anodes);
X printf("Collections: %d\n\n",gccalls);
X}
X
X
X /*****************************************************
X * fgc - xlisp function to force garbage collection *
X *****************************************************/
X
Xstatic struct node *fgc(args)
X struct node *args;
X{
X xllastarg(args); /* No arguments */
X gc(); /* Collect that garbage */
X return (NULL);
X}
X
X
X /*******************************************************
X * fexpand - xlisp function to force memory expansion *
X *******************************************************/
X
Xstatic struct node *fexpand(args)
X struct node *args;
X{
X struct node *val;
X int n,i;
X
X /* get new number to allocate */
X n = (args == NULL) ? 1 : xlevmatch(INT, &args)->n_int;
X xllastarg(args); /* No more arguments */
X
X for (i = 0; i < n; i++) /* Allocate more segments */
X if (!addseg())
X break;
X
X val = newnode(INT); /* Return number of segments added */
X val->n_int = i;
X return (val);
X}
X
X /*******************************************************************
X * falloc - xlisp function to set the number of nodes to allocate *
X *******************************************************************/
X
Xstatic struct node *falloc(args)
X struct node *args;
X{
X struct node *val;
X int n,oldn;
X
X n = xlevmatch(INT,&args)->n_int; /* new number to allocate */
X xllastarg(args); /* No more arguments */
X
X oldn = anodes; /* Set new number */
X anodes = n;
X
X val = newnode(INT); /* Return old value */
X val->n_int = oldn;
X return (val);
X}
X
X
X /*****************************************************
X * fmem - xlisp function to print memory statistics *
X *****************************************************/
X
Xstatic struct node *fmem(args)
X struct node *args;
X{
X xllastarg(args); /* No arguments */
X stats(); /* Print statistics */
X return (NULL);
X}
X
X
X /******************************************************
X * xldmeminit - initialize the dynamic memory module *
X ******************************************************/
X
Xxldmeminit()
X{
X anodes = NNODES; /* Default number of nodes */
X nnodes = nsegs = nfree = gccalls = 0;
X
X xlsubr("gc",fgc); /* Define some xlisp functions */
X xlsubr("expand",fexpand);
X xlsubr("alloc",falloc);
X xlsubr("mem",fmem);
X}
//go.sysin dd *
/bin/chmod 664 xldmem.c
/bin/echo -n ' '; /bin/ls -ld xldmem.c
/bin/echo 'Extracting xleval.c'
sed 's/^X//' <<'//go.sysin dd *' >xleval.c
X /* XLISP evaluation module */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "a:setjmp.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <setjmp.h>
X#include <xlisp.h>
X#endif
X
X
X /* global variables */
X struct node *xlstack;
X
X /* trace stack */
X static struct node *trace_stack[TDEPTH];
X static int trace_pointer;
X
X /* external variables */
X extern struct node *xlenv;
X
X /* local variables */
X static struct node *slash;
X
X /* forward declarations (the extern hack is for decusc) */
X extern struct node *evlist();
X extern struct node *evsym();
X extern struct node *evfun();
X
X
X /***************************************
X * eval - the builtin function 'eval' *
X ***************************************/
X
Xstatic struct node *eval(args)
X struct node *args;
X{
X struct node *oldstk,expr,*val;
X
X oldstk = xlsave(&expr,NULL); /* Create new stack frame */
X
X expr.n_ptr = xlevarg(&args); /* Expression to evaluate */
X xllastarg(args); /* No more args ! */
X
X val = xleval(expr.n_ptr); /* Do evaluation */
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val);
X}
X
X /******************************************
X * xleval - evaluate an xlisp expression *
X ******************************************/
X
X
Xstruct node *xleval(expr)
X struct node *expr;
X{
X if (expr == NULL) /* Null evaluates to null */
X return (NULL);
X
X switch (expr->n_type) /* Value type */
X {
X case LIST:
X return (evlist(expr));
X
X case SYM:
X return (evsym(expr));
X
X case INT:
X case STR:
X case SUBR:
X case REAL:
X return (expr);
X
X default:
X xlfail("can't evaluate expression");
X }
X}
X
X
X
X /*************************************
X * xlsave - save nodes on the stack *
X *************************************/
X
Xstruct node *xlsave(n)
X struct node *n;
X{
X struct node **nptr,*oldstk;
X
X oldstk = xlstack; /* Save old stack pointer */
X
X for (nptr = &n; *nptr != NULL; nptr++) /* Save for each node */
X {
X (*nptr)->n_type = LIST;
X (*nptr)->n_listvalue = NULL;
X (*nptr)->n_listnext = xlstack;
X xlstack = *nptr;
X }
X
X return (oldstk); /* Return old stack pointer */
X}
X
X
X
X /*****************************
X * evlist - evaluate a list *
X *****************************/
X
Xstatic struct node *evlist(nptr)
X struct node *nptr;
X{
X struct node *oldstk,fun,args,*val;
X
X oldstk = xlsave(&fun,&args,NULL); /* Creat a stack frame */
X
X fun.n_ptr = nptr->n_listvalue; /* Get function and arg list */
X args.n_ptr = nptr->n_listnext;
X
X tpush(nptr); /* Add trace entry */
X
X if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL) /* Evaluate first expression */
X xlfail("null function");
X
X switch (fun.n_ptr->n_type) /* Evaluate function */
X {
X case SUBR:
X val = (*fun.n_ptr->n_subr)(args.n_ptr);
X break;
X
X case LIST:
X val = evfun(fun.n_ptr,args.n_ptr);
X break;
X
X case OBJ:
X val = xlsend(fun.n_ptr,args.n_ptr);
X break;
X
X default:
X xlfail("bad function");
X }
X
X xlstack = oldstk; /* Restore old stack frame */
X tpop(); /* Remove trace entry */
X return (val); /* and return result value */
X}
X
X
X
X /******************************
X * evsym - evaluate a symbol *
X ******************************/
X
Xstatic struct node *evsym(sym)
X struct node *sym;
X{
X struct node *lptr;
X
X if ((lptr = xlobsym(sym)) != NULL) /* Check for current object */
X return (lptr->n_listvalue);
X else
X return (sym->n_symvalue);
X}
X
X
X /********************************
X * evfun - evaluate a function *
X ********************************/
X
Xstatic struct node *evfun(fun,args)
X struct node *fun,*args;
X{
X struct node *oldenv,*oldstk,cptr,*fargs,*val;
X
X oldstk = xlsave(&cptr,NULL); /* Creat a new stack frame */
X
X /* get the formal argument list */
X if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST)
X xlfail("bad formal argument list");
X
X oldenv = xlenv; /* Bind the formal parameters*/
X xlabind(fargs,args);
X xlfixbindings(oldenv);
X
X for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; ) /* execute */
X val = xlevarg(&cptr.n_ptr);
X
X xlunbind(oldenv); /* Restore environment */
X xlstack = oldstk; /* ..then the stack frame */
X return (val); /* ...and return result */
X}
X
X
X
X /************************************************
X * xlabind - bind the arguments for a function *
X ************************************************/
X
Xxlabind(fargs,aargs)
X struct node *fargs,*aargs;
X{
X struct node *oldstk,farg,aarg,val;
X
X oldstk = xlsave(&farg,&aarg,&val,NULL); /* Create a stack frame */
X
X farg.n_ptr = fargs; /* Initialze the pointers */
X aarg.n_ptr = aargs;
X
X while (farg.n_ptr != NULL && aarg.n_ptr != NULL) /* evaluate and bind */
X {
X if (farg.n_ptr->n_listvalue == slash) /* Check for local separator*/
X break;
X
X val.n_ptr = xlevarg(&aarg.n_ptr); /* Evaluate the arg */
X xlbind(farg.n_ptr->n_listvalue,val.n_ptr); /* ..and bind to formal */
X
X farg.n_ptr = farg.n_ptr->n_listnext; /* Move pointer ahead */
X }
X
X /* check for local variables */
X if (farg.n_ptr != NULL && farg.n_ptr->n_listvalue == slash)
X while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
X xlbind(farg.n_ptr->n_listvalue,NULL);
X
X xlstack = oldstk; /* Restore old stack frame */
X
X if (farg.n_ptr != aarg.n_ptr) /* Check for correct # */
X xlfail("incorrect number of arguments to a function");
X}
X
X
X
X /************************************
X * xlfail - error handling routine *
X ************************************/
X
Xxlfail(err)
X char *err;
X{
X printf("error: %s\n",err); /* Print the error message */
X xlunbind(NULL); /* Unbind any bound symbols */
X xltin(TRUE); /* Restore input to terminal */
X trace(); /* Do the back trace */
X trace_pointer = -1;
X xlabort(); /* Restart */
X}
X
X
X /********************************************
X * tpush - add an entry to the trace stack *
X ********************************************/
X
Xstatic tpush(nptr)
X struct node *nptr;
X{
X if (++trace_pointer < TDEPTH)
X trace_stack[trace_pointer] = nptr;
X}
X
X
X
X /*********************************************
X * tpop - pop an entry from the trace stack *
X *********************************************/
X
Xstatic tpop()
X{
X trace_pointer--;
X}
X
X
X
X /****************************
X * trace - do a back trace *
X ****************************/
X
Xstatic trace()
X{
X for (; trace_pointer >= 0; trace_pointer--)
X if (trace_pointer < TDEPTH)
X {
X xlprint(trace_stack[trace_pointer],TRUE);
X putchar('\n');
X }
X}
X
X
X
X /***************************************
X * xleinit - initialize the evaluator *
X ***************************************/
X
Xxleinit()
X{
X slash = xlenter("/"); /* the local variable separator */
X
X trace_pointer = -1; /* Initialize debugging */
X
X xlsubr("eval",eval); /* Built in functions from this module */
X}
//go.sysin dd *
/bin/chmod 664 xleval.c
/bin/echo -n ' '; /bin/ls -ld xleval.c
/bin/echo 'Extracting xlfio.c'
sed 's/^X//' <<'//go.sysin dd *' >xlfio.c
X /* xlfio - xlisp file i/o */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X /* external variables */
X
Xextern struct node *xlstack;
X
X
X /* local variables */
X
Xstatic char buf[STRMAX+1];
X
X
X /**************************
X * xlfopen - open a file *
X **************************/
X
Xstatic struct node *xlfopen(args)
X struct node *args;
X{
X struct node *oldstk,arg,fname,mode,*val;
X FILE *fp;
X
X oldstk = xlsave(&arg,&fname,&mode,NULL);
X arg.n_ptr = args;
X
X fname.n_ptr = xlevmatch(STR,&arg.n_ptr);
X mode.n_ptr = xlevmatch(STR,&arg.n_ptr);
X
X xllastarg(arg.n_ptr);
X
X if ((fp = fopen(fname.n_ptr->n_str,
X mode.n_ptr->n_str)) != NULL)
X {
X val = newnode(FPTR);
X val->n_fp = fp;
X }
X else
X val = NULL;
X
X xlstack = oldstk;
X return (val);
X}
X
X
X /****************************
X * xlfclose - close a file *
X ****************************/
X
Xstatic struct node *xlfclose(args)
X struct node *args;
X{
X struct node *fptr;
X
X fptr = xlevmatch(FPTR,&args);
X
X xllastarg(args);
X
X if (fptr->n_fp == NULL)
X xlfail("file not open");
X
X fclose(fptr->n_fp);
X fptr->n_fp = NULL;
X
X return (NULL);
X}
X
X
X /*****************************************
X * xlgetc - get a character from a file *
X *****************************************/
X
Xstatic struct node *xlgetc(args)
X struct node *args;
X{
X struct node *val;
X FILE *fp;
X int ch;
X
X if (args != NULL)
X fp = xlevmatch(FPTR,&args)->n_fp;
X else
X fp = stdin;
X
X xllastarg(args);
X
X if (fp == NULL)
X xlfail("file not open");
X
X if ((ch = getc(fp)) != EOF)
X {
X val = newnode(INT);
X val->n_int = ch;
X }
X else
X val = NULL;
X
X return (val);
X}
X
X
X /***************************************
X * xlputc - put a character to a file *
X ***************************************/
X
Xstatic struct node *xlputc(args)
X struct node *args;
X{
X struct node *oldstk,arg,chr;
X FILE *fp;
X
X oldstk = xlsave(&arg,&chr,NULL);
X arg.n_ptr = args;
X
X chr.n_ptr = xlevmatch(INT,&arg.n_ptr);
X
X if (arg.n_ptr != NULL)
X fp = xlevmatch(FPTR,&arg.n_ptr)->n_fp;
X else
X fp = stdout;
X
X xllastarg(arg.n_ptr);
X
X if (fp == NULL)
X xlfail("file not open");
X
X putc(chr.n_ptr->n_int,fp);
X
X xlstack = oldstk;
X return (chr.n_ptr);
X}
X
X
X /***************************************
X * xlfgets - get a string from a file *
X ***************************************/
X
Xstatic struct node *xlfgets(args)
X struct node *args;
X{
X struct node *str;
X char *sptr;
X FILE *fp;
X
X if (args != NULL)
X fp = xlevmatch(FPTR,&args)->n_fp;
X else
X fp = stdin;
X
X xllastarg(args);
X
X if (fp == NULL)
X xlfail("file not open");
X
X if (fgets(buf,STRMAX,fp) != NULL)
X {
X str = newnode(STR);
X str->n_str = strsave(buf);
X
X while (buf[strlen(buf)-1] != '\n')
X {
X if (fgets(buf,STRMAX,fp) == NULL)
X break;
X sptr = str->n_str;
X str->n_str = stralloc(strlen(sptr) + strlen(buf));
X strcpy(str->n_str,sptr);
X strcat(buf);
X strfree(sptr);
X }
X }
X else
X str = NULL;
X
X return (str);
X}
X
X
X /*************************************
X * xlfputs - put a string to a file *
X *************************************/
X
Xstatic struct node *xlfputs(args)
X struct node *args;
X{
X struct node *oldstk,arg,str;
X FILE *fp;
X
X oldstk = xlsave(&arg,&str,NULL);
X arg.n_ptr = args;
X
X str.n_ptr = xlevmatch(STR,&arg.n_ptr);
X
X if (arg.n_ptr != NULL)
X fp = xlevmatch(FPTR,&arg.n_ptr)->n_fp;
X else
X fp = stdout;
X
X xllastarg(arg.n_ptr);
X
X if (fp == NULL)
X xlfail("file not open");
X
X fputs(str.n_ptr->n_str,fp);
X
X xlstack = oldstk;
X return (str.n_ptr);
X}
X
X
X /************************************
X * xlfinit - initialize file stuff *
X ************************************/
X
Xxlfinit()
X{
X xlsubr("fopen",xlfopen);
X xlsubr("fclose",xlfclose);
X xlsubr("getc",xlgetc);
X xlsubr("putc",xlputc);
X xlsubr("fgets",xlfgets);
X xlsubr("fputs",xlfputs);
X}
//go.sysin dd *
/bin/chmod 664 xlfio.c
/bin/echo -n ' '; /bin/ls -ld xlfio.c
/bin/echo 'Extracting xlsubr.c'
sed 's/^X//' <<'//go.sysin dd *' >xlsubr.c
X /* xlsubr - xlisp builtin functions */
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include <xlisp.h>
X#endif
X
X
X /* external variables */
X
Xextern int (*xlgetc)();
Xextern struct node *xlstack;
X
X
X /* local variables */
X
Xstatic char *sgetptr;
X
X
X /***************************************
X * xlsubr - define a builtin function *
X ***************************************/
X
Xxlsubr(sname,subr)
X char *sname; struct node *(*subr)();
X{
X struct node *sym;
X
X sym = xlenter(sname); /* Enter the symbol */
X
X sym->n_symvalue = newnode(SUBR); /* Initialize the value */
X sym->n_symvalue->n_subr = subr;
X}
X
X
X /**********************************************
X * xlsvar - define a builtin string variable *
X **********************************************/
X
Xxlsvar(sname,str)
X char *sname,*str;
X{
X struct node *sym;
X
X sym = xlenter(sname); /* Enter the symbol */
X
X sym->n_symvalue = newnode(STR); /* Initialize the value */
X sym->n_symvalue->n_str = strsave(str);
X}
X
X
X /**********************************
X * xlarg - get the next argument *
X **********************************/
X
Xstruct node *xlarg(pargs)
X struct node **pargs;
X{
X struct node *arg;
X
X if (*pargs == NULL) /* Does argument exist ? */
X xlfail("too few arguments");
X
X arg = (*pargs)->n_listvalue; /* If so get its value */
X *pargs = (*pargs)->n_listnext; /* and mov arg pointer ahead */
X
X return (arg);
X}
X
X
X /*************************************************
X * xlmatch - get an argument and match its type *
X *************************************************/
X
Xstruct node *xlmatch(type,pargs)
X int type; struct node **pargs;
X{
X struct node *arg;
X
X arg = xlarg(pargs); /* Get the argument */
X if (type == LIST) /* Check its type */
X {
X if (arg != NULL && arg->n_type != LIST)
X xlfail("bad argument type");
X }
X else
X {
X if (arg == NULL || arg->n_type != type)
X xlfail("bad argument type");
X }
X
X return (arg);
X}
X
X
X /****************************************************
X * xlevarg - get the next argument and evaluate it *
X ****************************************************/
X
Xstruct node *xlevarg(pargs)
X struct node **pargs;
X{
X struct node *oldstk,val;
X
X oldstk = xlsave(&val,NULL); /* Creat new stack frame */
X
X val.n_ptr = xlarg(pargs); /* Get and evaluate the argument */
X val.n_ptr = xleval(val.n_ptr);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /*************************************************************
X * xlevmatch - get an evaluated argument and match its type *
X *************************************************************/
X
Xstruct node *xlevmatch(type,pargs)
X int type; struct node **pargs;
X{
X struct node *arg;
X
X arg = xlevarg(pargs); /* Get argument and check type */
X if (type == LIST)
X {
X if (arg != NULL && arg->n_type != LIST)
X xlfail("bad argument type");
X }
X else
X {
X if (arg == NULL || arg->n_type != type)
X xlfail("bad argument type");
X }
X
X return (arg);
X}
X
X
X /**********************************************************************
X * xllastarg - make sure the remainder of the argument list is empty *
X **********************************************************************/
X
Xxllastarg(args)
X struct node *args;
X{
X if (args != NULL)
X xlfail("too many arguments");
X}
X
X
X /****************************************
X * assign - assign a value to a symbol *
X ****************************************/
X
Xstatic assign(sym,val)
X struct node *sym,*val;
X{
X struct node *lptr;
X
X if ((lptr = xlobsym(sym)) != NULL) /* Check for a current object */
X lptr->n_listvalue = val;
X else
X sym->n_symvalue = val;
X}
X
X
X /*******************************
X * set - builtin function set *
X *******************************/
X
Xstatic struct node *set(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,val;
X
X oldstk = xlsave(&arg,&sym,&val,NULL); /* Create new stack frame */
X arg.n_ptr = args;
X
X sym.n_ptr = xlevmatch(SYM,&arg.n_ptr); /* Get symbol */
X val.n_ptr = xlevarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X assign(sym.n_ptr,val.n_ptr);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /*********************************
X * setq - builtin function setq *
X *********************************/
X
Xstatic struct node *setq(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,val;
X
X oldstk = xlsave(&arg,&sym,&val,NULL); /* Create new stack frame */
X arg.n_ptr = args;
X
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr); /* get symbol */
X val.n_ptr = xlevarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X assign(sym.n_ptr,val.n_ptr);
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /************************************
X * load - direct input from a file *
X ************************************/
X
Xstatic struct node *load(args)
X struct node *args;
X{
X struct node *fname;
X
X fname = xlevmatch(STR,&args); /* Get file name */
X xllastarg(args);
X
X xlfin(fname->n_str);
X
X return (fname);
X}
X
X
X /***********************************
X * defun - builtin function defun *
X ***********************************/
X
Xstatic struct node *defun(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,fargs,fun;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&sym,&fargs,&fun,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the function symbol */
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X
X /* get the formal argument list */
X fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* create a new function definition */
X fun.n_ptr = newnode(LIST);
X fun.n_ptr->n_listvalue = fargs.n_ptr;
X fun.n_ptr->n_listnext = arg.n_ptr;
X
X /* make the symbol point to a new function definition */
X assign(sym.n_ptr,fun.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the function symbol */
X return (sym.n_ptr);
X}
X
X
X /******************************************
X * sgetc - get a character from a string *
X ******************************************/
X
Xstatic int sgetc()
X{
X if (*sgetptr == 0)
X return (-1);
X else
X return (*sgetptr++);
X}
X
X
X /******************************
X * read - read an expression *
X ******************************/
X
Xstatic struct node *read(args)
X struct node *args;
X{
X struct node *val;
X int (*oldgetc)();
X
X /* save the old input stream */
X oldgetc = xlgetc;
X
X /* get the string or file pointer */
X if (args != NULL) {
X sgetptr = xlevmatch(STR,&args)->n_str;
X xlgetc = sgetc;
X }
X
X /* make sure there aren't any more arguments */
X xllastarg(args);
X
X val = xlread();
X xlgetc = oldgetc;
X
X return (val);
X}
X
X
X /************************************
X * fwhile - builtin function while *
X ************************************/
X
Xstatic struct node *fwhile(args)
X struct node *args;
X{
X struct node *oldstk,farg,arg,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&farg,&arg,NULL);
X
X /* initialize */
X farg.n_ptr = arg.n_ptr = args;
X
X /* loop until test fails */
X val = NULL;
X for (; TRUE; arg.n_ptr = farg.n_ptr) {
X
X /* evaluate the test expression */
X if (!testvalue(xlevarg(&arg.n_ptr)))
X break;
X
X /* evaluate each remaining argument */
X while (arg.n_ptr != NULL)
X val = xlevarg(&arg.n_ptr);
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val);
X}
X
X
X /**************************************
X **************************************/
X
Xstatic struct node *frepeat(args)
X struct node *args;
X{
X struct node *oldstk,farg,arg,*val;
X int cnt;
X
X /* create a new stack frame */
X oldstk = xlsave(&farg,&arg,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X cnt = xlevmatch(INT,&arg.n_ptr)->n_int;
X
X /* save the first expression to repeat */
X farg.n_ptr = arg.n_ptr;
X
X /* loop until test fails */
X val = NULL;
X for (; cnt > 0; cnt--) {
X
X /* evaluate each remaining argument */
X while (arg.n_ptr != NULL)
X val = xlevarg(&arg.n_ptr);
X
X /* restore pointer to first expression */
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last test expression value */
X return (val);
X}
X
X
X /***************************************
X * foreach - builtin function foreach *
X ***************************************/
X
Xstatic struct node *foreach(args)
X struct node *args;
X{
X struct node *oldstk,arg,sym,list,code,oldbnd,*val;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&sym,&list,&code,&oldbnd,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* get the symbol to bind to each list element */
X sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
X /* save the old binding of the symbol */
X oldbnd.n_ptr = sym.n_ptr->n_symvalue;
X
X /* get the list to iterate over */
X list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
X
X /* save the pointer to the code */
X code.n_ptr = arg.n_ptr;
X
X /* loop until test fails */
X val = NULL;
X while (list.n_ptr != NULL) {
X
X /* check the node type */
X if (list.n_ptr->n_type != LIST)
X xlfail("bad node type in list");
X
X /* bind the symbol to the list element */
X sym.n_ptr->n_symvalue = list.n_ptr->n_listvalue;
X
X /* evaluate each remaining argument */
X while (arg.n_ptr != NULL)
X val = xlevarg(&arg.n_ptr);
X
X /* point to the next list element */
X list.n_ptr = list.n_ptr->n_listnext;
X
X /* restore the pointer to the code */
X arg.n_ptr = code.n_ptr;
X }
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* restore the old binding of the symbol */
X sym.n_ptr->n_symvalue = oldbnd.n_ptr;
X
X /* return the last test expression value */
X return (val);
X}
X
X
X /******************************
X * fif - builtin function if *
X ******************************/
X
Xstatic struct node *fif(args)
X struct node *args;
X{
X struct node *oldstk,arg,testexpr,thenexpr,elseexpr,*val;
X int dothen;
X
X /* create a new stack frame */
X oldstk = xlsave(&arg,&testexpr,&thenexpr,&elseexpr,NULL);
X
X /* initialize */
X arg.n_ptr = args;
X
X /* evaluate the test expression */
X testexpr.n_ptr = xlevarg(&arg.n_ptr);
X
X /* get the then clause */
X thenexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
X
X /* get the else clause */
X if (arg.n_ptr != NULL)
X elseexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
X else
X elseexpr.n_ptr = NULL;
X
X /* make sure there aren't any more arguments */
X xllastarg(arg.n_ptr);
X
X /* figure out which expression to evaluate */
X dothen = testvalue(testexpr.n_ptr);
X
X /* default the result value to the value of the test expression */
X val = testexpr.n_ptr;
X
X /* evaluate the appropriate clause */
X if (dothen)
X while (thenexpr.n_ptr != NULL)
X val = xlevarg(&thenexpr.n_ptr);
X else
X while (elseexpr.n_ptr != NULL)
X val = xlevarg(&elseexpr.n_ptr);
X
X /* restore the previous stack frame */
X xlstack = oldstk;
X
X /* return the last value */
X return (val);
X}
X
X
X /****************************************************
X * quote - builtin function to quote an expression *
X ****************************************************/
X
Xstatic struct node *quote(args)
X struct node *args;
X{
X /* make sure there is exactly one argument */
X if (args == NULL || args->n_listnext != NULL)
X xlfail("incorrect number of arguments");
X
X /* return the quoted expression */
X return (args->n_listvalue);
X}
X
X
X /*****************************
X * fexit - get out of xlisp *
X *****************************/
X
Xfexit()
X{
X exit();
X}
X
X
X /***********************************************
X * testvalue - test a value for true or false *
X ***********************************************/
X
Xstatic int testvalue(val)
X struct node *val;
X{
X /* check for a nil value */
X if (val == NULL)
X return (FALSE);
X
X /* check the value type */
X switch (val->n_type) {
X case INT:
X return (val->n_int != 0);
X
X case STR:
X return (strlen(val->n_str) != 0);
X
X default:
X return (TRUE);
X }
X}
X
X
X /******************************************
X * xlinit - xlisp initialization routine *
X ******************************************/
X
Xxlinit()
X{
X /* enter a copyright notice into the oblist */
X xlenter("Copyright-1983-by-David-Betz");
X
X /* enter the builtin functions */
X xlsubr("set",set);
X xlsubr("setq",setq);
X xlsubr("load",load);
X xlsubr("read",read);
X xlsubr("quote",quote);
X xlsubr("while",fwhile);
X xlsubr("repeat",frepeat);
X xlsubr("foreach",foreach);
X xlsubr("defun",defun);
X xlsubr("if",fif);
X xlsubr("exit",fexit);
X}
//go.sysin dd *
/bin/chmod 664 xlsubr.c
/bin/echo -n ' '; /bin/ls -ld xlsubr.c