[net.sources] XLISP, part 3 of 4

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