jcw@cvl.UUCP (07/20/84)
This portion contains the second 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 xlfmath.c' sed 's/^X//' <<'//go.sysin dd *' >xlfmath.c X X /* xlmath - xlisp builtin arithmetic functions */ 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 struct node *true; X X X /* forward declarations (the extern hack is for decusc) */ X Xextern struct node *iarith(); Xextern struct node *compare(); X X X /* Comparison operator defines */ X X#define lss_op 1 X#define leq_op 2 X#define eql_op 3 X#define neq_op 4 X#define geq_op 5 X#define gtr_op 6 X X#define sign(n) (((n)<0) ? -1 : (((n)>0) ? 1 : 0)) X X X /**************************************** X * add - builtin function for addition * X ****************************************/ X Xstatic struct node *add(args) X struct node *args; X{ X return iarith(args,'+'); X} X X X /******************************************* X * sub - builtin function for subtraction * X *******************************************/ X Xstatic struct node *sub(args) X struct node *args; X{ X return iarith(args,'-'); X} X X X /********************************************** X * mul - builtin function for multiplication * X **********************************************/ X Xstatic struct node *mul(args) X struct node *args; X{ X return iarith(args,'*'); X} X X X /**************************************** X * div - builtin function for division * X ****************************************/ X Xstatic struct node *div(args) X struct node *args; X{ X return iarith(args,'/'); X} X X X /*************************************** X * mod - builtin function for modulus * X ***************************************/ X Xstatic struct node *mod(args) X struct node *args; X{ X return iarith(args,'%'); X} X X X /*************************************** X * min - builtin function for minimum * X ***************************************/ X Xstatic struct node *min(args) X struct node *args; X{ X return iarith(args,'m'); X} X X X /*************************************** X * max - builtin function for maximum * X ***************************************/ X Xstatic struct node *max(args) X struct node *args; X{ X return iarith(args,'M'); X} X X X /*************************************** X * and - builtin function for modulus * X ***************************************/ X Xstatic struct node *and(args) X struct node *args; X{ X return iarith(args,'&'); X} X X X /************************************** X * or - builtin function for modulus * X **************************************/ X Xstatic struct node *or(args) X struct node *args; X{ X return iarith(args,'|'); X} X X X /********************** X * not - bitwise not * X **********************/ X Xstatic struct node *not(args) X struct node *args; X{ X struct node *rval; X int val; X X val = xlevmatch(INT,&args)->n_int; /* Evaluate the argument */ X xllastarg(args); X X rval = newnode(INT); X rval->n_int = ~val; X return (rval); X} X X X /************************* X * abs - absolute value * X *************************/ X Xstatic struct node *abs(args) X struct node *args; X{ X struct node *rval, *argp; X X switch (gettype(argp = xlevarg(&args))) X { X case INT: X xllastarg(args); X rval = newnode(INT); X if ((rval->n_int = argp->n_int) < 0) X rval->n_int *= -1; X break; X X#ifdef REALS X case REAL: X xllastarg(args); X rval = newnode(REAL); X if ((rval->n_real = argp->n_real) < 0) X rval->n_real *= -1; X break; X#endif X X default: X xlfail("bad argument type"); X } X X return (rval); X} X X X#ifdef REALS X X /**************************** X * fix - integer from real * X ****************************/ X Xstatic struct node *fix(args) X struct node *args; X{ X struct node *rval, *argp; X X switch (gettype(argp = xlevarg(&args))) X { X case INT: X xllastarg(args); X rval = newnode(INT); X rval->n_int = argp->n_int; X break; X X case REAL: X xllastarg(args); X rval = newnode(INT); X rval->n_int = (int) argp->n_real; X break; X X default: X xlfail("bad argument type"); X } X X return (rval); X} X X X /****************************** X * float - real from integer * X ******************************/ X Xstatic struct node *lfloat(args) X struct node *args; X{ X struct node *rval, *argp; X X switch (gettype(argp = xlevarg(&args))) X { X case INT: X xllastarg(args); X rval = newnode(REAL); X rval->n_real = argp->n_int; X break; X X case REAL: X xllastarg(args); X rval = newnode(REAL); X rval->n_real = argp->n_real; X break; X X default: X xlfail("bad argument type"); X } X X return (rval); X} X X X /************************************************* X * farith - common floating arithmetic function * X *************************************************/ X Xstatic struct node *farith(ival, oldstk, arg, val, ifunct, funct) X struct node *oldstk, *arg, *val; X int ival; X char ifunct, funct; X{ X struct node *rval; X long float rslt = (long float) ival, arg_val; X int arg_typ = REAL; X X while(1) X { X if (arg_typ == INT) X arg_val = (long float) (val->n_ptr)->n_int; X else X if (arg_typ == REAL) X arg_val = (val->n_ptr)->n_real; X else X xlfail("bad argument type"); X X switch (ifunct) X { X case '+': X rslt += arg_val; X break; X X case '-': X rslt -= arg_val; X break; X X case '*': X rslt *= arg_val; X break; X X case '/': X rslt /= arg_val; X break; X X case '%': X case '&': X case '|': X xlfail("bad argument type"); X X case 'm': X if (rslt > arg_val) X rslt = arg_val; X break; X X case 'M': X if (rslt < arg_val) X rslt = arg_val; X break; X } X X ifunct = funct; X X if (arg->n_ptr == NULL) X break; X X arg_typ = gettype((val->n_ptr = xlevarg(&(arg->n_ptr)))); X } X X rval = newnode(REAL); X rval->n_real = rslt; X X xlstack = oldstk; X return (rval); X} X#endif X X X /*************************************** X * arith - common arithmetic function * X ***************************************/ X Xstatic struct node *iarith(args,funct) X struct node *args; X char funct; X{ X struct node *oldstk,arg,val,*rval; X int rslt, arg_val; X X oldstk = xlsave(&arg,&val,NULL); /* Create a new stack frame */ X X arg.n_ptr = args; /* Get first parameter */ X X arg_val = gettype((val.n_ptr = xlevarg(&arg.n_ptr))); X X#ifdef REALS X if (arg_val == REAL) X return farith(0, oldstk, &arg, &val, '+', funct); X#endif X X if (arg_val != INT) X xlfail("bad argument type"); X X rslt = val.n_ptr->n_int; X X while (arg.n_ptr != NULL) X { X arg_val = gettype((val.n_ptr = xlevarg(&arg.n_ptr))); X X#ifdef REALS X if (arg_val == REAL) X return farith(rslt, oldstk, &arg, &val, funct, funct); X#endif X X if (arg_val != INT) X xlfail("bad argument type"); X X arg_val = val.n_ptr->n_int; X X switch (funct) X { X case '+': X rslt += arg_val; X break; X X case '-': X rslt -= arg_val; X break; X X case '*': X rslt *= arg_val; X break; X X case '/': X rslt /= arg_val; X break; X X case '%': X rslt %= arg_val; X break; X X case '&': X rslt &= arg_val; X break; X X case '|': X rslt |= arg_val; X break; X X case 'm': X if (rslt > arg_val) X rslt = arg_val; X break; X X case 'M': X if (rslt < arg_val) X rslt = arg_val; X break; X } X } X X rval = newnode(INT); X rval->n_int = rslt; X X xlstack = oldstk; X return (rval); X} X X X /*********************** X * land - logical and * X ***********************/ X Xstatic struct node *land(args) X struct node *args; X{ X struct node *oldstk,arg,*val; X X oldstk = xlsave(&arg,NULL); X arg.n_ptr = args; X val = true; X X while (arg.n_ptr != NULL) X if (xlevarg(&arg.n_ptr) == NULL) X { X val = NULL; X break; X } X X xlstack = oldstk; X return (val); X} X X X /********************* X * lor - logical or * X *********************/ X Xstatic struct node *lor(args) X struct node *args; X{ X struct node *oldstk,arg,*val; X X oldstk = xlsave(&arg,NULL); X arg.n_ptr = args; X val = NULL; X X while (arg.n_ptr != NULL) X if (xlevarg(&arg.n_ptr) != NULL) X { X val = true; X break; X } X X xlstack = oldstk; X return (val); X} X X X /*********************** X * lnot - logical not * X ***********************/ X Xstatic struct node *lnot(args) X struct node *args; X{ X struct node *val; X X val = xlevarg(&args); X xllastarg(args); X X if (val == NULL) X return (true); X else X return (NULL); X} X X X /********************************* X * lss - builtin function for < * X *********************************/ X Xstatic struct node *lss(args) X struct node *args; X{ X return (compare(args,lss_op)); X} X X X /********************************** X * leq - builtin function for <= * X **********************************/ X Xstatic struct node *leq(args) X struct node *args; X{ X return (compare(args,leq_op)); X} X X X /********************************** X * eql - builtin function for == * X **********************************/ X Xstatic struct node *eql(args) X struct node *args; X{ X return (compare(args,eql_op)); X} X X X /********************************** X * neq - builtin function for != * X **********************************/ X Xstatic struct node *neq(args) X struct node *args; X{ X return (compare(args,neq_op)); X} X X X /********************************** X * geq - builtin function for >= * X **********************************/ X Xstatic struct node *geq(args) X struct node *args; X{ X return (compare(args,geq_op)); X} X X X /********************************* X * gtr - builtin function for > * X *********************************/ X Xstatic struct node *gtr(args) X struct node *args; X{ X return (compare(args,gtr_op)); X} X X X /************************************** X * compare - common compare function * X **************************************/ X Xstatic struct node *compare(args,funct) X struct node *args; X int funct; X{ X struct node *oldstk,arg,arg1,arg2; X int type1,type2,cmp; X X oldstk = xlsave(&arg,&arg1,&arg2,NULL); X arg.n_ptr = args; X X type1 = gettype(arg1.n_ptr = xlevarg(&arg.n_ptr)); X type2 = gettype(arg2.n_ptr = xlevarg(&arg.n_ptr)); X xllastarg(arg.n_ptr); X X if ((type1 == STR) && (type2 == STR)) X cmp = strcmp(arg1.n_ptr->n_str,arg2.n_ptr->n_str); X else X X#ifdef REALS X if (type1 == INT) X { X if (type2 == INT) X cmp = sign(arg1.n_ptr->n_int - arg2.n_ptr->n_int); X else X X if (type2 == REAL) X cmp = sign(arg1.n_ptr->n_int - arg2.n_ptr->n_real); X else X cmp = arg1.n_ptr - arg2.n_ptr; X } X else X X if (type1 == REAL) X { X if (type2 == INT) X cmp = sign(arg1.n_ptr->n_real - arg2.n_ptr->n_int); X else X X if (type2 == REAL) X cmp = sign(arg1.n_ptr->n_real - arg2.n_ptr->n_real); X else X cmp = arg1.n_ptr - arg2.n_ptr; X } X#else X X if ((type1 == INT) && (type2 == INT)) X cmp = sign(arg1.n_ptr->n_int - arg2.n_ptr->n_int); X#endif X X else X cmp = arg1.n_ptr - arg2.n_ptr; X X xlstack = oldstk; X X switch (funct) X { X case lss_op: X return (cmp < 0) ? true : NULL; X X case leq_op: X return (cmp <= 0) ? true : NULL; X X case eql_op: X return (cmp == 0) ? true : NULL; X X case neq_op: X return (cmp != 0) ? true : NULL; X X case geq_op: X return (cmp >= 0) ? true : NULL; X X case gtr_op: X return (cmp > 0) ? true : NULL; X X } X xlfail("bad compare operator"); X} X X X /********************************************* X * gettype - return the type of an argument * X *********************************************/ X Xstatic int gettype(arg) X struct node *arg; X{ X if (arg == NULL) X return (LIST); X else X return (arg->n_type); X} X X X /************************************************ X * xlminit - xlisp math initialization routine * X ************************************************/ X Xxlminit() X{ X xlsubr("+",add); X xlsubr("-",sub); X xlsubr("*",mul); X xlsubr("/",div); X xlsubr("%",mod); X xlsubr("&",and); X xlsubr("|",or); X xlsubr("~",not); X xlsubr("<",lss); X xlsubr("<=",leq); X xlsubr("==",eql); X xlsubr("!=",neq); X xlsubr(">=",geq); X xlsubr(">",gtr); X xlsubr("&&",land); X xlsubr("||",lor); X xlsubr("!",lnot); X xlsubr("min",min); X xlsubr("max",max); X xlsubr("abs",abs); X X#ifdef REALS X xlsubr("fix",fix); X xlsubr("float",lfloat); X#endif X X true = xlenter("t"); X true->n_symvalue = true; X} //go.sysin dd * /bin/chmod 664 xlfmath.c /bin/echo -n ' '; /bin/ls -ld xlfmath.c /bin/echo 'Extracting xlio.c' sed 's/^X//' <<'//go.sysin dd *' >xlio.c X /* xlio - xlisp i/o routines */ X 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 Xint (*xlgetc)(); Xint xlpvals; Xint xlplevel; X X X /* local variables */ X Xstatic int prompt; Xstatic FILE *ifp; X X X /********************************************** X * tgetc - get a character from the terminal * X **********************************************/ X Xstatic int tgetc() X{ X int ch; X X if (prompt) /* Prompt if required */ X { X if (xlplevel > 0) X printf("%d> ", xlplevel); X else X printf("> "); X prompt = FALSE; X } X X if ((ch = getc(stdin)) == '\n') X prompt = TRUE; X X return (ch); X} X X X /********************************* X * xltin - setup terminal input * X *********************************/ X Xint xltin(flag) X int flag; X{ X if (flag & !prompt) /* Flush line if flag set */ X while (tgetc() != '\n') X ; X X prompt = TRUE; X xlplevel = 0; X xlgetc = tgetc; X xlpvals = TRUE; X} X X X /***************************************** X * fgetcx - get a character from a file * X *****************************************/ X Xstatic int fgetcx() X{ X int ch; X X if ((ch = getc(ifp)) <= 0) { X xlgetc = tgetc; X xlpvals = TRUE; X return (tgetc()); X } X X return (ch); X} X X X /***************************** X * xlfin - setup file input * X *****************************/ X Xxlfin(str) X char *str; X{ X X#ifdef DEFEXT X char fname[100]; X X strcpy(fname, str); X#else X#define fname str X#endif X X if ((ifp = fopen(fname, "r")) != NULL) X { X xlgetc = fgetcx; X xlpvals = FALSE; X return; X } X X#ifdef DEFEXT X if (strchr(fname, '.') == 0) X strcat(fname, ".lsp"); X X if ((ifp = fopen(fname, "r")) != NULL) X { X xlgetc = fgetcx; X xlpvals = FALSE; X return; X } X#endif X X printf("Can't open \"%s\" for input\n", fname); X} //go.sysin dd * /bin/chmod 664 xlio.c /bin/echo -n ' '; /bin/ls -ld xlio.c /bin/echo 'Extracting xlisp.c' sed 's/^X//' <<'//go.sysin dd *' >xlisp.c X X /* xlisp - a small subset of lisp */ 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 "a:setjmp.h" X#include "xlisp.h" X#endif X X#ifdef DECUS X#include <stdio.h> X#include <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 /* External variables */ X Xextern struct node *xlenv; Xextern struct node *xlstack; Xextern int xlpvals; X X /* Local variables */ X Xstatic char ljmp[6]; X X /************************** X * main - the main routine * X **************************/ X Xmain(argc,argv) X int argc; char *argv[]; X{ X struct node expr; X X xldmeminit(); /* initialize the dynamic memory module */ X /* (must be first initilization call */ X#ifdef DEBUG X xldebuginit(); X#endif X /* initialize each lisp module */ X xlinit(); X xleinit(); X xllinit(); X xlminit(); X xloinit(); X xlsinit(); X xlfinit(); X xlpinit(); X X#ifdef KEYMAPCLASS X xlkinit(); X#endif X X xltin(FALSE); X X if (argc > 1) /* read the input file if specified */ X xlfin(argv[1]); X else X printf("XLISP version 1.2\n"); X X setjmp(ljmp); /* Set up the error return */ X while (TRUE) /* Main command processing loop */ X { X xlstack = xlenv = NULL; /* Free any previous expression and */ X /* left over context */ X X xlsave(&expr,NULL); /* create a new stack frame */ X X expr.n_ptr = xlread(); /* Read and evaluate an expression */ X expr.n_ptr = xleval(expr.n_ptr); X X if (xlpvals) /* print it if necessary */ X { X xlprint(expr.n_ptr, TRUE); X putchar('\n'); X } X } X} X X Xxlabort() X{ X /* Procedure to localize machine dependent abort jump */ X X longjmp(ljmp); X} //go.sysin dd * /bin/chmod 664 xlisp.c /bin/echo -n ' '; /bin/ls -ld xlisp.c /bin/echo 'Extracting xlkmap.c' sed 's/^X//' <<'//go.sysin dd *' >xlkmap.c X /* xlkmap - xlisp key map functions */ 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; Xextern struct node *xlenv; Xextern struct node *self; X X X /* local definitions */ X X#define KMSIZE 256 /* number of characters in a keymap */ X#define KMAX 20 /* maximum number of characters in a key sequence */ X#define KEYMAP 0 /* instance variable number for 'keymap' */ X X X /* local variables */ X Xstatic struct node *currentenv; X X X /* forward declarations (the extern hack is because of decusc) */ X Xextern struct node *sendmsg(); X X X /************************************ X * isnew - initialize a new keymap * X ************************************/ X Xstatic struct node *isnew(args) X struct node *args; X{ X xllastarg(args); /* No arguments ! */ X X /* Create a keymap node */ X xlivar(self->n_symvalue,KEYMAP)->n_listvalue = newnode(KMAP); X X return (self->n_symvalue); /* and return it */ X} X X X /******************************************************* X * newkmap - allocate memory for a new key map vector * X *******************************************************/ X Xstatic struct node *(*newkmap())[] X{ X struct node *(*map)[]; X X /* allocate the vector */ X if ((map = (struct node *(*)[]) calloc(1,sizeof(struct node *) * KMSIZE)) X == NULL) X { X printf("insufficient memory"); X exit(); X } X X return (map); /* And return it */ X} X X X /*********************** X * key - define a key * X ***********************/ X Xstatic struct node *key(args) X struct node *args; X{ X struct node *oldstk,arg,kstr,ksym,*kmap,*kmptr; X struct node *(*map)[]; X char *sptr; X int ch; X X oldstk = xlsave(&arg,&kstr,&ksym,NULL); /* Create new stack frame */ X arg.n_ptr = args; /* initialize */ X X kmap = xlivar(self->n_symvalue,KEYMAP)->n_listvalue; /* get keymap */ X if (kmap == NULL && kmap->n_type != KMAP) X xlfail("bad keymap object"); X X kstr.n_ptr = xlevmatch(STR,&arg.n_ptr); /* Find key string */ X ksym.n_ptr = xlevmatch(SYM,&arg.n_ptr); /* the the key symbol */ X xllastarg(arg.n_ptr); /* and make sure thats all */ X X for (kmptr = kmap, sptr = kstr.n_ptr->n_str; /* process each char */ X *sptr != 0; X kmptr = (*map)[ch]) X { X ch = *sptr++; /* Get the character */ X if ((map = kmptr->n_kmap) == NULL) /* Allocate key map if reqd */ X map = kmptr->n_kmap = newkmap(); X X if (*sptr == 0) /* End of string ? */ X (*map)[ch] = ksym.n_ptr; X else X if ((*map)[ch] == NULL || (*map)[ch]->n_type != KMAP) X { X (*map)[ch] = newnode(KMAP); X (*map)[ch]->n_kmap = newkmap(); X } X } X X xlstack = oldstk; /* Restore old stack frame */ X return (self->n_symvalue); /* and return keymap */ X} X X X /******************************************************* X * process - process input characters using a key map * X *******************************************************/ X Xstatic struct node *process(args) X struct node *args; X{ X struct node *oldstk,arg,env,margs,*kmap,*kmptr,*nptr,*oldenv; X struct node *(*map)[]; X char keys[KMAX+1]; X int ch,kndx; X X oldstk = xlsave(&arg,&env,&margs,NULL); /* create new stack frame */ X arg.n_ptr = args; /* Initialize */ X X kmap = xlivar(self->n_symvalue,KEYMAP)->n_listvalue; /* Get keymap */ X if (kmap == NULL && kmap->n_type != KMAP) X xlfail("bad keymap object"); X X env.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* Get the environment */ X xllastarg(arg.n_ptr); /* Ensure thats all */ X X oldenv = xlenv; /* Bind the environment variable */ X xlbind(currentenv,env.n_ptr); X xlfixbindings(oldenv); X X if (kmap->n_kmap == NULL) /* Ensure key map is defined */ X xlfail("empty keymap"); X X margs.n_ptr = newnode(LIST); /* Create argument list */ X margs.n_ptr->n_listvalue = newnode(STR); X margs.n_ptr->n_listvalue->n_str = keys; X margs.n_ptr->n_listvalue->n_strtype = STATIC; X X for (kmptr = kmap, kndx = 0; TRUE; ) /* Character processing loop */ X { X fflush(stdout); /* Flush pending output */ X X if ((ch = kbin()) < 0) /* Get a character */ X break; X X if (kndx < KMAX) /* Put it is the key sequence */ X keys[kndx++] = ch; X else X xlfail("key sequence too long"); X X if ((map = kmptr->n_kmap) == NULL) /* dispatch on character code */ X xlfail("bad keymap"); X else X if ((nptr = (*map)[ch]) == NULL) X { X kmptr = kmap; X kndx = 0; X } X else X if (nptr->n_type == KMAP) X kmptr = (*map)[ch]; X else X if (nptr->n_type == SYM) X { X keys[kndx] = 0; X if (sendmsg(nptr,currentenv->n_symvalue,margs.n_ptr) == NULL) X break; X kmptr = kmap; X kndx = 0; X } X else X xlfail("bad keymap"); X } X X xlunbind(oldenv); /* unbind */ X xlstack = oldstk; /* Restore old stack frame */ X return (self->n_symvalue); /* and return keymap object */ X} X X X /******************************************************* X * sendmsg - send a message given an environment list * X *******************************************************/ X Xstatic struct node *sendmsg(msym,env,args) X struct node *msym,*env,*args; X{ X struct node *eptr,*obj,*msg; X X /* look for an object that answers the message */ X for (eptr = env; eptr != NULL; eptr = eptr->n_listnext) X if ((obj = eptr->n_listvalue) != NULL && obj->n_type == OBJ) X if ((msg = xlmfind(obj,msym)) != NULL) X return (xlxsend(obj,msg,args)); X X /* return the message if no object answered it */ X return (msym); X} X X X /***************************** X * xlkmmark - mark a keymap * X *****************************/ X Xxlkmmark(km) X struct node *km; X{ X struct node *(*map)[]; X int i; X X km->n_flags |= MARK; /* Mark the keymap node */ X X if ((map = km->n_kmap) == NULL) /* Check for null keymap */ X return; X X for (i = 0; i < KMSIZE; i++) /* Loop through each entry */ X if (((*map)[i] != NULL) && (*map)[i]->n_type == KMAP) X xlkmmark((*map)[i]); X} X X X /***************************** X * xlkmfree - free a keymap * X *****************************/ X Xxlkmfree(km) X struct node *km; X{ X struct node *(*map)[]; X int i; X X if ((map = km->n_kmap) == NULL) /* Check for null keymap */ X return; X X for (i = 0; i < KMSIZE; i++) /* loop through each entry */ X if (((*map)[i] != NULL) && (*map)[i]->n_type == KMAP) X xlkmfree((*map)[i]); X X free(km->n_kmap); /* and free this one */ X} X X X /****************************************************** X * xlkinit - key map function initialization routine * X ******************************************************/ X Xxlkinit() X{ X struct node *keymap; X X currentenv = xlenter("currentenv"); /* Define xlisp variables */ X X keymap = xlclass("Keymap",1); /* Define keymap class */ X xladdivar(keymap,"keymap"); X xladdmsg(keymap,"isnew",isnew); X xladdmsg(keymap,"key",key); X xladdmsg(keymap,"process",process); X} X X X /****************************** X * kbin : fetch a key stroke * X ******************************/ X Xstatic kbin() X{ X#ifdef AZTEC X return (CPM(6, 0xFF)); X#endif X X#ifdef CI_86 X if (bdos(0x0b, 0) & 0xFF == 0xFF) X return (bdos(0x08, 0)); X return -1; X#endif X} //go.sysin dd * /bin/chmod 664 xlkmap.c /bin/echo -n ' '; /bin/ls -ld xlkmap.c /bin/echo 'Extracting xllist.c' sed 's/^X//' <<'//go.sysin dd *' >xllist.c X /* xllist - xlisp list builtin functions */ 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 struct node *t; Xstatic struct node *a_subr; Xstatic struct node *a_list; Xstatic struct node *a_sym; Xstatic struct node *a_int; Xstatic struct node *a_str; Xstatic struct node *a_obj; Xstatic struct node *a_fptr; Xstatic struct node *a_kmap; X X X /********************************** X * xlist - builtin function list * X **********************************/ X Xstatic struct node *xlist(args) X struct node *args; X{ X struct node *oldstk,arg,list,val,*last,*lptr; X X oldstk = xlsave(&arg,&list,&val,NULL); X arg.n_ptr = args; X X for (last = NULL; arg.n_ptr != NULL; last = lptr) X { X val.n_ptr = xlevarg(&arg.n_ptr); X lptr = newnode(LIST); X if (last == NULL) X list.n_ptr = lptr; X else X last->n_listnext = lptr; X lptr->n_listvalue = val.n_ptr; X } X X xlstack = oldstk; X return (list.n_ptr); X} X X X /********************************* X * cond - builtin function cond * X *********************************/ X Xstatic struct node *cond(args) X struct node *args; X{ X struct node *oldstk,arg,list,*val; X X oldstk = xlsave(&arg,&list,NULL); X arg.n_ptr = args; X X val = NULL; X while (arg.n_ptr != NULL) X { X list.n_ptr = xlmatch(LIST,&arg.n_ptr); X if (xlevarg(&list.n_ptr) != NULL) X { X while (list.n_ptr != NULL) X val = xlevarg(&list.n_ptr); X break; X } X } X X xlstack = oldstk; X return (val); X} X X X /**************************** X * atom - is this an atom? * X ****************************/ X Xstatic struct node *atom(args) X struct node *args; X{ X struct node *arg; X X if ((arg = xlevarg(&args)) == NULL || arg->n_type != LIST) X return (t); X else X return (NULL); X} X X X /************************* X * null - is this null? * X *************************/ X Xstatic struct node *null(args) X struct node *args; X{ X if (xlevarg(&args) == NULL) X return (t); X else X return (NULL); X} X X X /********************************** X * type - return type of a thing * X **********************************/ X Xstatic struct node *type(args) X struct node *args; X{ X struct node *arg; X X if (!(arg = xlevarg(&args))) X return (NULL); X X switch (arg->n_type) X { X case SUBR: return (a_subr); X X case LIST: return (a_list); X X case SYM: return (a_sym); X X case INT: return (a_int); X X case STR: return (a_str); X X case OBJ: return (a_obj); X X case FPTR: return (a_fptr); X X case KMAP: return (a_kmap); X X default: xlfail("Bad node."); X X } X} X X X /**************************** X * listp - is this a list? * X ****************************/ X Xstatic struct node *listp(args) X struct node *args; X{ X if (xlistp(xlevarg(&args))) X return (t); X else X return (NULL); X} X X X /************************************* X * xlistp - internal listp function * X *************************************/ X Xstatic int xlistp(arg) X struct node *arg; X{ X return (arg == NULL || arg->n_type == LIST); X} X X X /************************** X * eq - are these equal? * X **************************/ X Xstatic struct node *eq(args) X struct node *args; X{ X struct node *oldstk,arg,arg1,arg2,*val; X X oldstk = xlsave(&arg,&arg1,&arg2,NULL); X arg.n_ptr = args; X X arg1.n_ptr = xlevarg(&arg.n_ptr); X arg2.n_ptr = xlevarg(&arg.n_ptr); X xllastarg(arg.n_ptr); X X if (xeq(arg1.n_ptr,arg2.n_ptr)) X val = t; X else X val = NULL; X X xlstack = oldstk; X return (val); X} X X X /******************************* X * xeq - internal eq function * X *******************************/ X Xstatic int xeq(arg1,arg2) X struct node *arg1,*arg2; X{ X if (arg1 != NULL && arg1->n_type == INT && X arg2 != NULL && arg2->n_type == INT) X return (arg1->n_int == arg2->n_int); X else X return (arg1 == arg2); X} X X X /***************************** X * equal - are these equal? * X *****************************/ X Xstatic struct node *equal(args) X struct node *args; X{ X struct node *oldstk,arg,arg1,arg2,*val; X X oldstk = xlsave(&arg,&arg1,&arg2,NULL); X arg.n_ptr = args; X X arg1.n_ptr = xlevarg(&arg.n_ptr); X arg2.n_ptr = xlevarg(&arg.n_ptr); X xllastarg(arg.n_ptr); X X if (xequal(arg1.n_ptr,arg2.n_ptr)) X val = t; X else X val = NULL; X X xlstack = oldstk; X return (val); X} X X X /************************************* X * xequal - internal equal function * X *************************************/ X Xstatic int xequal(arg1,arg2) X struct node *arg1,*arg2; X{ X if (xeq(arg1,arg2)) X return (TRUE); X else X if (xlistp(arg1) && xlistp(arg2)) X return (xequal(arg1->n_listvalue,arg2->n_listvalue) && X xequal(arg1->n_listnext, arg2->n_listnext)); X else X return (FALSE); X} X X X /************************************* X * head - return the head of a list * X *************************************/ X Xstatic struct node *head(args) X struct node *args; X{ X struct node *list; X X if ((list = xlevmatch(LIST,&args)) == NULL) X xlfail("null list"); X X xllastarg(args); X X return (list->n_listvalue); X} X X X /************************************* X * tail - 4i+rn the tail of a list * X *************************************/ X Xstatic struct node *tail(args) X struct node *args; X{ X struct node *list; X X if ((list = xlevmatch(LIST,&args)) == NULL) X xlfail("null list"); X X xllastarg(args); X X return (list->n_listnext); X} X X X /******************************************* X * nth - return the nth element of a list * X *******************************************/ X Xstatic struct node *nth(args) X struct node *args; X{ X struct node *oldstk,arg,list; X int n; X X oldstk = xlsave(&arg,&list,NULL); X arg.n_ptr = args; X X if ((n = xlevmatch(INT,&arg.n_ptr)->n_int) < 1) X xlfail("invalid argument"); X X if ((list.n_ptr = xlevmatch(LIST,&arg.n_ptr)) == NULL) X xlfail("invalid argument"); X X xllastarg(arg.n_ptr); X X for (; n > 1; n--) X { X list.n_ptr = list.n_ptr->n_listnext; X if (list.n_ptr == NULL || list.n_ptr->n_type != LIST) X xlfail("invalid argument"); X } X X xlstack = oldstk; X return (list.n_ptr->n_listvalue); X} X X X /***************************************** X * length - return the length of a list * X *****************************************/ X Xstatic struct node *length(args) X struct node *args; X{ X struct node *oldstk,list,*val; X int n; X X oldstk = xlsave(&list,NULL); X X list.n_ptr = xlevmatch(LIST,&args); X xllastarg(args); X X for (n = 0; list.n_ptr != NULL; n++) X list.n_ptr = list.n_ptr->n_listnext; X X xlstack = oldstk; X X val = newnode(INT); X val->n_int = n; X return (val); X} X X X /************************************* X * append - builtin function append * X *************************************/ X Xstatic struct node *append(args) X struct node *args; X{ X struct node *oldstk,arg,list,last,val,*lptr; X X oldstk = xlsave(&arg,&list,&last,&val,NULL); X arg.n_ptr = args; X X while (arg.n_ptr != NULL) X { X list.n_ptr = xlevmatch(LIST,&arg.n_ptr); X while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) X { X lptr = newnode(LIST); X if (last.n_ptr == NULL) X val.n_ptr = lptr; X else X last.n_ptr->n_listnext = lptr; X lptr->n_listvalue = list.n_ptr->n_listvalue; X last.n_ptr = lptr; X list.n_ptr = list.n_ptr->n_listnext; X } X X if (list.n_ptr != NULL) X xlfail("bad list"); X } X X xlstack = oldstk; X return (val.n_ptr); X} X X X /*************************************** X * reverse - builtin function reverse * X ***************************************/ X Xstatic struct node *reverse(args) X struct node *args; X{ X struct node *oldstk,list,val,*lptr; X X oldstk = xlsave(&list,&val,NULL); X X list.n_ptr = xlevmatch(LIST,&args); X xllastarg(args); X X while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) X { X lptr = newnode(LIST); X lptr->n_listvalue = list.n_ptr->n_listvalue; X lptr->n_listnext = val.n_ptr; X val.n_ptr = lptr; X X list.n_ptr = list.n_ptr->n_listnext; X } X X if (list.n_ptr != NULL) X xlfail("bad list"); X X xlstack = oldstk; X return (val.n_ptr); X} X X X /************************************* X * cons - construct a new list cell * X *************************************/ X Xstatic struct node *cons(args) X struct node *args; X{ X struct node *oldstk,arg,arg1,arg2,*lptr; X X oldstk = xlsave(&arg,&arg1,&arg2,NULL); X arg.n_ptr = args; X X arg1.n_ptr = xlevarg(&arg.n_ptr); X arg2.n_ptr = xlevarg(&arg.n_ptr); X xllastarg(arg.n_ptr); X X lptr = newnode(LIST); X lptr->n_listvalue = arg1.n_ptr; X lptr->n_listnext = arg2.n_ptr; X X xlstack = oldstk; X return (lptr); X} X X X /************************************************ X * xllinit - xlisp list initialization routine * X ************************************************/ X Xxllinit() X{ X /* define some symbols */ X t = xlenter("t"); X a_subr = xlenter("SUBR"); X a_list = xlenter("LIST"); X a_sym = xlenter("SYM"); X a_int = xlenter("INT"); X a_str = xlenter("STR"); X a_obj = xlenter("OBJ"); X a_fptr = xlenter("FPTR"); X a_kmap = xlenter("KMAP"); X X /* functions with reasonable names */ X xlsubr("head",head); X xlsubr("tail",tail); X xlsubr("nth",nth); X X /* real lisp functions */ X xlsubr("atom",atom); X xlsubr("eq",eq); X xlsubr("equal",equal); X xlsubr("null",null); X xlsubr("type",type); X xlsubr("listp",listp); X xlsubr("cond",cond); X xlsubr("list",xlist); X xlsubr("cons",cons); X xlsubr("car",head); X xlsubr("cdr",tail); X xlsubr("append",append); X xlsubr("reverse",reverse); X xlsubr("length",length); X} //go.sysin dd * /bin/chmod 664 xllist.c /bin/echo -n ' '; /bin/ls -ld xllist.c