XLISP, part 3 of 4
jcw at cvl.UUCP
jcw at cvl.UUCP
Sat Jul 21 01:14:40 AEST 1984
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
More information about the Comp.sources.unix
mailing list