[net.sources] xlisp part 2 of 4

betz (01/06/83)

::::::::::::::
xlsubr.c
::::::::::::::
/* xlsubr - xlisp builtin functions */

#include "xlisp.h"

/* external variables */
extern int (*xlgetc)();
extern struct node *xlstack;
extern struct node *self;

/* local variables */
static char *sgetptr;

/* xlsubr - define a builtin function */
xlsubr(sname,subr)
  char *sname; int (*subr)();
{
    struct node *sym;

    /* enter the symbol */
    sym = xlenter(sname);

    /* initialize the value */
    sym->n_symvalue = newnode(SUBR);
    sym->n_symvalue->n_subr = subr;
}

/* xlsvar - define a builtin string variable */
xlsvar(sname,str)
  char *sname,*str;
{
    struct node *sym;

    /* enter the symbol */
    sym = xlenter(sname);

    /* initialize the value */
    sym->n_symvalue = newnode(STR);
    sym->n_symvalue->n_str = strsave(str);
}

/* xlarg - get the next argument */
struct node *xlarg(pargs)
  struct node **pargs;
{
    struct node *arg;

    /* make sure the argument exists */
    if (*pargs == NULL)
	xlfail("too few arguments");

    /* get the argument value */
    arg = (*pargs)->n_listvalue;

    /* move the argument pointer ahead */
    *pargs = (*pargs)->n_listnext;

    /* return the argument */
    return (arg);
}

/* xlmatch - get an argument and match its type */
struct node *xlmatch(type,pargs)
  int type; struct node **pargs;
{
    struct node *arg;

    /* get the argument */
    arg = xlarg(pargs);

    /* check its type */
    if (type == LIST) {
	if (arg != NULL && arg->n_type != LIST)
	    xlfail("bad argument type");
    }
    else {
	if (arg == NULL || arg->n_type != type)
	    xlfail("bad argument type");
    }

    /* return the argument */
    return (arg);
}

/* xlevarg - get the next argument and evaluate it */
struct node *xlevarg(pargs)
  struct node **pargs;
{
    struct node *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* get the argument */
    val.n_ptr = xlarg(pargs);

    /* evaluate the argument */
    val.n_ptr = xleval(val.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the argument */
    return (val.n_ptr);
}

/* xlevmatch - get an evaluated argument and match its type */
struct node *xlevmatch(type,pargs)
  int type; struct node **pargs;
{
    struct node *arg;

    /* get the argument */
    arg = xlevarg(pargs);

    /* check its type */
    if (type == LIST) {
	if (arg != NULL && arg->n_type != LIST)
	    xlfail("bad argument type");
    }
    else {
	if (arg == NULL || arg->n_type != type)
	    xlfail("bad argument type");
    }

    /* return the argument */
    return (arg);
}

/* assign - assign a value to a symbol */
static assign(sym,val)
  struct node *sym,*val;
{
    struct node *lptr,*bptr,*optr;

    /* check for a current object */
    if ((optr = self->n_symvalue) != NULL && optr->n_type == OBJ)
	for (lptr = optr->n_obdata; lptr != NULL; lptr = lptr->n_listnext)
	    if ((bptr = lptr->n_listvalue) != NULL && bptr->n_type == BND)
		if (bptr->n_bndsym == sym) {
		    bptr->n_bndvalue = val;
		    return;
		}

    /* not an instance variable of the current object */
    sym->n_symvalue = val;
}

/* eval - evaluate an expression */
static struct node *eval(args)
  struct node *args;
{
    struct node *list;

    /* get the list to evaluate */
    list = xlevmatch(LIST,&args);

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* return it evaluated */
    return (xleval(list));
}

/* set - builtin function set */
static struct node *set(args)
  struct node *args;
{
    struct node *oldstk,arg,sym,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&sym,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the symbol */
    sym.n_ptr = xlevmatch(SYM,&arg.n_ptr);

    /* get the new value */
    val.n_ptr = xlevarg(&arg.n_ptr);

    /* make sure there aren't any more arguments */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

    /* assign the symbol the value of argument 2 and the return value */
    assign(sym.n_ptr,val.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val.n_ptr);
}

/* setq - builtin function setq */
static struct node *setq(args)
  struct node *args;
{
    struct node *oldstk,arg,sym,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&sym,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the symbol */
    sym.n_ptr = xlmatch(SYM,&arg.n_ptr);

    /* get the new value */
    val.n_ptr = xlevarg(&arg.n_ptr);

    /* make sure there aren't any more arguments */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

    /* assign the symbol the value of argument 2 and the return value */
    assign(sym.n_ptr,val.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val.n_ptr);
}

/* load - direct input from a file */
static struct node *load(args)
  struct node *args;
{
    struct node *fname;

    /* get the file name */
    fname = xlevmatch(STR,&args);

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* direct input from the file */
    xlfin(fname->n_str);

    /* return the filename */
    return (fname);
}

/* defun - builtin function defun */
static struct node *defun(args)
  struct node *args;
{
    struct node *oldstk,arg,sym,fargs,*fun;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&sym,&fargs,&fun,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the function symbol */
    sym.n_ptr = xlmatch(SYM,&arg.n_ptr);

    /* get the formal argument list */
    fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);

    /* create a new function definition */
    fun = newnode(FUN);
    fun->n_funargs = fargs.n_ptr;
    fun->n_funcode = arg.n_ptr;

    /* make the symbol point to a new function definition */
    assign(sym.n_ptr,fun);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the function symbol */
    return (sym.n_ptr);
}

/* sgetc - get a character from a string */
static int sgetc()
{
    if (*sgetptr == 0)
	return (-1);
    else
	return (*sgetptr++);
}

/* read - read an expression */
static struct node *read(args)
  struct node *args;
{
    struct node *val;
    int (*oldgetc)();

    /* save the old input stream */
    oldgetc = xlgetc;

    /* get the string or file pointer */
    if (args != NULL) {
	sgetptr = xlevmatch(STR,&args)->n_str;
	xlgetc = sgetc;
    }

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* read an expression */
    val = xlread();

    /* restore the old input stream */
    xlgetc = oldgetc;

    /* return the expression read */
    return (val);
}

/* print - builtin function print */
static struct node *print(args)
  struct node *args;
{
    struct node *oldstk,arg,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and print each argument */
    while (arg.n_ptr != NULL)
	xlprint(xlevarg(&arg.n_ptr));

    /* restore previous stack frame */
    xlstack = oldstk;

    /* return null */
    return (NULL);
}

/* fwhile - builtin function while */
static struct node *fwhile(args)
  struct node *args;
{
    struct node *oldstk,farg,arg,*val;
    int done;

    /* create a new stack frame */
    oldstk = xlsave(&farg,&arg,NULL);

    /* initialize */
    farg.n_ptr = arg.n_ptr = args;

    /* loop until test fails */
    for (done = FALSE; TRUE; arg.n_ptr = farg.n_ptr) {

	/* evaluate the test expression */
	if ((val = xlevarg(&arg.n_ptr)) == NULL)
	    break;

	/* check the value type */
	switch (val->n_type) {
	case INT:
		if (val->n_int == 0)
		    done = TRUE;
		break;
	case STR:
		if (strlen(val->n_str) == 0)
		    done = TRUE;
		break;
	}

	/* check for loop done */
	if (done)
	    break;

	/* evaluate each remaining argument */
	while (arg.n_ptr != NULL)
	    xlevarg(&arg.n_ptr);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the last test expression value */
    return (val);
}

/* fif - builtin function if */
static struct node *fif(args)
  struct node *args;
{
    struct node *oldstk,arg,testexpr,thenexpr,elseexpr,*val;
    int dothen;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&testexpr,&thenexpr,&elseexpr,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate the test expression */
    testexpr.n_ptr = xlevarg(&arg.n_ptr);

    /* get the then clause */
    thenexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);

    /* get the else clause */
    if (arg.n_ptr != NULL)
	elseexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
    else
	elseexpr.n_ptr = NULL;

    /* make sure there aren't any more arguments */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

    /* do else if value is null */
    if (testexpr.n_ptr == NULL)
	dothen = FALSE;

    /* check the value */
    else {

	/* check the value type */
	switch (testexpr.n_ptr->n_type) {
	case INT:
		dothen = (testexpr.n_ptr->n_int != 0);
		break;
	case STR:
		dothen = (strlen(testexpr.n_ptr->n_str) != 0);
		break;
	default:
		dothen = TRUE;
		break;
	}
    }

    /* default the result value to the value of the test expression */
    val = testexpr.n_ptr;

    /* evaluate the appropriate clause */
    if (dothen)
	while (thenexpr.n_ptr != NULL)
	    val = xlevarg(&thenexpr.n_ptr);
    else
	while (elseexpr.n_ptr != NULL)
	    val = xlevarg(&elseexpr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the last value */
    return (val);
}

/* quote - builtin function to quote an expression */
static struct node *quote(args)
  struct node *args;
{
    /* make sure there is exactly one argument */
    if (args == NULL || args->n_listnext != NULL)
	xlfail("incorrect number of arguments");

    /* return the quoted expression */
    return (args->n_listvalue);
}

/* fexit - get out of xlisp */
fexit()
{
    exit();
}

/* xlinit - xlisp initialization routine */
xlinit()
{
    xlsubr("set",set);
    xlsubr("setq",setq);
    xlsubr("load",load);
    xlsubr("read",read);
    xlsubr("print",print);
    xlsubr("quote",quote);
    xlsubr("while",fwhile);
    xlsubr("defun",defun);
    xlsubr("if",fif);
    xlsubr("eval",eval);
    xlsubr("exit",fexit);

    xlsvar("newline","\n");
    xlsvar("tab","\t");
    xlsvar("bell","\007");
}


::::::::::::::
xllist.c
::::::::::::::
/* xllist - xlisp list builtin functions */

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;

/* external procedures */
extern struct node *xlarg();
extern struct node *xlevarg();
extern struct node *xlmatch();
extern struct node *xlevmatch();

/* xlist - builtin function list */
static struct node *xlist(args)
  struct node *args;
{
    struct node *oldstk,arg,list,val,*last,*lptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and append each argument */
    for (last = NULL; arg.n_ptr != NULL; last = lptr) {

	/* evaluate the next argument */
	val.n_ptr = xlevarg(&arg.n_ptr);

	/* append this argument to the end of the list */
	lptr = newnode(LIST);
	if (last == NULL)
	    list.n_ptr = lptr;
	else
	    last->n_listnext = lptr;
	lptr->n_listvalue = val.n_ptr;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* head - return the head of a list */
static struct node *head(args)
  struct node *args;
{
    struct node *list;

    /* get the list */
    if ((list = xlevmatch(LIST,&args)) == NULL)
	xlfail("null list");

    /* make sure this is the only argument */
    if (args != NULL)
	xlfail("too many arguments");

    /* return the head of the list */
    return (list->n_listvalue);
}

/* tail - return the tail of a list */
static struct node *tail(args)
  struct node *args;
{
    struct node *list;

    /* get the list */
    if ((list = xlevmatch(LIST,&args)) == NULL)
	xlfail("null list");

    /* make sure this is the only argument */
    if (args != NULL)
	xlfail("too many arguments");

    /* return the tail of the list */
    return (list->n_listnext);
}

/* nth - return the nth element of a list */
static struct node *nth(args)
  struct node *args;
{
    struct node *oldstk,arg,list;
    int n;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get n */
    n = xlevmatch(INT,&arg.n_ptr)->n_int;

    /* get the list */
    list.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* make sure this is the only argument */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

    /* find the nth element */
    for (; n-- > 0 && list.n_ptr != NULL; list.n_ptr = list.n_ptr->n_listnext)
	;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* make sure we got something */
    if (list.n_ptr == NULL)
	return (NULL);
    else
	return (list.n_ptr->n_listvalue);
}

/* append - builtin function append */
static struct node *append(args)
  struct node *args;
{
    struct node *oldstk,arg,list,last,val,*lptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,&last,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the list to append to */
    list.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* find the last node in the list */
    last.n_ptr = list.n_ptr;
    while (last.n_ptr != NULL && last.n_ptr->n_listnext != NULL)
	last.n_ptr = last.n_ptr->n_listnext;

    /* evaluate and append each argument */
    while (arg.n_ptr != NULL) {

	/* evaluate the next argument */
	val.n_ptr = xlevarg(&arg.n_ptr);

	/* append this argument to the end of the list */
	lptr = newnode(LIST);
	if (last.n_ptr == NULL)
	    list.n_ptr = lptr;
	else
	    last.n_ptr->n_listnext = lptr;
	lptr->n_listvalue = val.n_ptr;

	/* save the new last element */
	last.n_ptr = lptr;
    }

    /* restore previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* prepend - builtin function prepend */
static struct node *prepend(args)
  struct node *args;
{
    struct node *oldstk,arg,list,val,*lptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&list,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the list to prepend to */
    list.n_ptr = xlevmatch(LIST,&arg.n_ptr);

    /* evaluate and prepend each argument */
    while (arg.n_ptr != NULL) {

	/* evaluate the next argument */
	val.n_ptr = xlevarg(&arg.n_ptr);

	/* prepend this argument to the end of the list */
	lptr = newnode(LIST);
	lptr->n_listnext = list.n_ptr;
	list.n_ptr = lptr;
	lptr->n_listvalue = val.n_ptr;
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the list */
    return (list.n_ptr);
}

/* xllinit - xlisp list initialization routine */
xllinit()
{
    xlsubr("list",xlist);
    xlsubr("head",head); xlsubr("CAR",head);
    xlsubr("tail",tail); xlsubr("CDR",tail);
    xlsubr("nth",nth);
    xlsubr("append",append);
    xlsubr("prepend",prepend);
}


::::::::::::::
xlmath.c
::::::::::::::
/* xlmath - xlisp builtin arithmetic functions */

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;

/* external procedures */
extern struct node *xlarg();
extern struct node *xlevarg();
extern struct node *xlmatch();
extern struct node *xlevmatch();

/* local variables */
static struct node *true;

/* forward declarations (the extern hack is for decusc) */
extern struct node *arith();
extern struct node *compare();

/* add - builtin function for addition */
static struct node *xadd(val,arg)
  int val,arg;
{
    return (val + arg);
}
static struct node *add(args)
  struct node *args;
{
    return (arith(args,xadd));
}

/* sub - builtin function for subtraction */
static struct node *xsub(val,arg)
  int val,arg;
{
    return (val - arg);
}
static struct node *sub(args)
  struct node *args;
{
    return (arith(args,xsub));
}

/* mul - builtin function for multiplication */
static struct node *xmul(val,arg)
  int val,arg;
{
    return (val * arg);
}
static struct node *mul(args)
  struct node *args;
{
    return (arith(args,xmul));
}

/* div - builtin function for division */
static struct node *xdiv(val,arg)
  int val,arg;
{
    return (val / arg);
}
static struct node *div(args)
  struct node *args;
{
    return (arith(args,xdiv));
}

/* mod - builtin function for modulus */
static struct node *xmod(val,arg)
  int val,arg;
{
    return (val % arg);
}
static struct node *mod(args)
  struct node *args;
{
    return (arith(args,xmod));
}

/* and - builtin function for modulus */
static struct node *xand(val,arg)
  int val,arg;
{
    return (val & arg);
}
static struct node *and(args)
  struct node *args;
{
    return (arith(args,xand));
}

/* or - builtin function for modulus */
static struct node *xor(val,arg)
  int val,arg;
{
    return (val | arg);
}
static struct node *or(args)
  struct node *args;
{
    return (arith(args,xor));
}

/* not - bitwise not */
static struct node *not(args)
  struct node *args;
{
    struct node *oldstk,val,*rval;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* evaluate the argument */
    val.n_ptr = xlevarg(&args);

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* convert and check the value  */
    rval = newnode(INT);
    rval->n_int = ~cnvnum(val.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (rval);
}

/* min - builtin function for minimum */
static struct node *xmin(val,arg)
  int val,arg;
{
    return (val < arg ? val : arg);
}
static struct node *min(args)
  struct node *args;
{
    return (arith(args,xmin));
}

/* max - builtin function for maximum */
static struct node *xmax(val,arg)
  int val,arg;
{
    return (val > arg ? val : arg);
}
static struct node *max(args)
  struct node *args;
{
    return (arith(args,xmax));
}

/* arith - common arithmetic function */
static struct node *arith(args,funct)
  struct node *args; int (*funct)();
{
    struct node *oldstk,arg,*val;
    int first,ival,iarg;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;
    first = TRUE;
    ival = 0;

    /* evaluate and sum each argument */
    while (arg.n_ptr != NULL) {

	/* get the next argument */
	iarg = cnvnum(xlevarg(&arg.n_ptr));

	/* accumulate the result value */
	if (first) {
	    ival = iarg;
	    first = FALSE;
	}
	else
	    ival = (*funct)(ival,iarg);
    }

    /* initialize value */
    val = newnode(INT);
    val->n_int = ival;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* land - logical and */
static struct node *land(args)
  struct node *args;
{
    struct node *oldstk,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;
    val = true;

    /* evaluate each argument */
    while (arg.n_ptr != NULL)

	/* get the next argument */
	if (cnvnum(xlevarg(&arg.n_ptr)) == 0) {
	    val = NULL;
	    break;
	}

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* lor - logical or */
static struct node *lor(args)
  struct node *args;
{
    struct node *oldstk,arg,*val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;
    val = NULL;

    /* evaluate each argument */
    while (arg.n_ptr != NULL)
	if (cnvnum(xlevarg(&arg.n_ptr)) != 0) {
	    val = true;
	    break;
	}

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}

/* lnot - logical not */
static struct node *lnot(args)
  struct node *args;
{
    struct node *val;

    /* evaluate the argument */
    val = xlevarg(&args);

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* convert and check the value  */
    if (cnvnum(val) != 0)
	return (NULL);
    else
	return (true);
}

/* lss - builtin function for < */
static struct node *xlss(cmp)
  int cmp;
{
    return (cmp < 0);
}
static struct node *lss(args)
  struct node *args;
{
    return (compare(args,xlss));
}

/* leq - builtin function for <= */
static struct node *xleq(cmp)
  int cmp;
{
    return (cmp <= 0);
}
static struct node *leq(args)
  struct node *args;
{
    return (compare(args,xleq));
}

/* eql - builtin function for == */
static struct node *xeql(cmp)
  int cmp;
{
    return (cmp == 0);
}
static struct node *eql(args)
  struct node *args;
{
    return (compare(args,xeql));
}

/* neq - builtin function for != */
static struct node *xneq(cmp)
  int cmp;
{
    return (cmp != 0);
}
static struct node *neq(args)
  struct node *args;
{
    return (compare(args,xneq));
}

/* geq - builtin function for >= */
static struct node *xgeq(cmp)
  int cmp;
{
    return (cmp >= 0);
}
static struct node *geq(args)
  struct node *args;
{
    return (compare(args,xgeq));
}

/* gtr - builtin function for > */
static struct node *xgtr(cmp)
  int cmp;
{
    return (cmp > 0);
}
static struct node *gtr(args)
  struct node *args;
{
    return (compare(args,xgtr));
}

/* compare - common compare function */
static struct node *compare(args,funct)
  struct node *args; int (*funct)();
{
    struct node *oldstk,arg,arg1,arg2;
    int type1,type2,cmp;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&arg1,&arg2,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get argument 1 */
    arg1.n_ptr = xlevarg(&arg.n_ptr);
    type1 = gettype(arg1.n_ptr);

    /* get argument 2 */
    arg2.n_ptr = xlevarg(&arg.n_ptr);
    type2 = gettype(arg2.n_ptr);

    /* make sure there aren't any more arguments */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

    /* do the compare */
    if (type1 == STR && type2 == STR)
	cmp = strcmp(arg1.n_ptr->n_str,arg2.n_ptr->n_str);
    else if (type1 == INT || type2 == INT)
	cmp = cnvnum(arg1.n_ptr) - cnvnum(arg2.n_ptr);
    else
	cmp = arg1.n_ptr - arg2.n_ptr;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return result of the compare */
    if ((*funct)(cmp))
	return (true);
    else
	return (NULL);
}

/* gettype - return the type of an argument */
static int gettype(arg)
  struct node *arg;
{
    if (arg == NULL)
	return (LIST);
    else
	return (arg->n_type);
}

/* cnvnum - convert a numeric value */
static int cnvnum(arg)
  struct node *arg;
{
    int ival;

    /* return false if node is null */
    if (arg == NULL)
	return (FALSE);

    /* convert the value if necessary */
    switch (arg->n_type) {
    case INT:
	    ival = arg->n_int;
	    break;
    case STR:
	    if (sscanf(arg->n_str,"%d",&ival) != 1)
		ival = 0;
	    break;
    default:
	    ival = TRUE;
	    break;
    }

    /* return the integer value */
    return (ival);
}

/* xlminit - xlisp math initialization routine */
xlminit()
{
    xlsubr("+",add);
    xlsubr("-",sub);
    xlsubr("*",mul);
    xlsubr("/",div);
    xlsubr("%",mod);
    xlsubr("&",and);
    xlsubr("|",or);
    xlsubr("~",not);
    xlsubr("<",lss);
    xlsubr("<=",leq);
    xlsubr("==",eql);
    xlsubr("!=",neq);
    xlsubr(">=",geq);
    xlsubr(">",gtr);
    xlsubr("&&",land);
    xlsubr("||",lor);
    xlsubr("!",lnot);
    xlsubr("min",min);
    xlsubr("max",max);
    true = xlenter("t");
    true->n_symvalue = true;
}


::::::::::::::
xlstr.c
::::::::::::::
/* xlstr - xlisp string builtin functions */

#include <stdio.h>
#include <ctype.h>
#include "xlisp.h"

/* external variables */
extern struct node *xlstack;

/* len - length of a string */
static struct node *len(args)
  struct node *args;
{
    struct node *oldstk,arg,*val;
    int total;

    /* create a new stack frame */
    oldstk = xlsave(&arg,NULL);

    /* initialize */
    arg.n_ptr = args;
    total = 0;

    /* loop over args and total */
    while (arg.n_ptr != NULL)
	total += strlen(xlevmatch(STR,&arg.n_ptr)->n_str);

    /* create return node */
    val = newnode(INT);
    val->n_int = total;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the total */
    return (val);
}

/* concat - concatenate a bunch of strings */
/*		this routine does it the dumb way -- one at a time */
static struct node *concat(args)
  struct node *args;
{
    struct node *oldstk,arg,val,rval;
    int newlen;
    char *result,*argstr,*newstr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&val,&rval,NULL);

    /* initialize */
    arg.n_ptr = args;
    rval.n_ptr = newnode(STR);
    rval.n_ptr->n_str = result = stralloc(0);
    *result = 0;

    /* loop over args */
    while (arg.n_ptr != NULL) {

	/* get next argument */
	val.n_ptr = xlevmatch(STR,&arg.n_ptr);
	argstr = val.n_ptr->n_str;

	/* compute length of result */
	newlen = strlen(result) + strlen(argstr);

	/* allocate string and copy */
	newstr = stralloc(newlen);
	strcpy(newstr,result);
	strfree(result);
	rval.n_ptr->n_str = result = strcat(newstr,argstr);
    }

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (rval.n_ptr);
}

/* substr - return a substring */
static struct node *substr(args)
  struct node *args;
{
    struct node *oldstk,arg,src,val;
    int start,forlen,srclen;
    char *srcptr,*dstptr;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&src,&val,NULL);

    /* initialize */
    arg.n_ptr = args;
    
    /* get string and its length */
    src.n_ptr = xlevmatch(STR,&arg.n_ptr);
    srcptr = src.n_ptr->n_str;
    srclen = strlen(srcptr);

    /* get starting pos -- must be present */
    start = xlevmatch(INT,&arg.n_ptr)->n_int;

    /* get length -- if not present use remainder of string */
    if (arg.n_ptr != NULL)
	forlen = xlevmatch(INT,&arg.n_ptr)->n_int;
    else
	forlen = srclen;		/* use len and fix below */

    /* make sure there aren't any more arguments */
    if (arg.n_ptr != NULL)
	xlfail("too many arguments");

    /* don't take more than exists */
    if (start + forlen > srclen)
	forlen = srclen - start + 1;

    /* if start beyond string -- return null string */
    if (start > srclen) {
	start = 1;
	forlen = 0; }
	
    /* create return node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = dstptr = stralloc(forlen);

    /* move string */
    for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
	;
    *dstptr = 0;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the substring */
    return (val.n_ptr);
}

/* makstr - make a string of chars of specified length */
static struct node *makestr(args)
  struct node *args;
{
    struct node *oldstk,val,arg;
    char *sptr,*fptr;
    int len;

    /* create a new stack frame */
    oldstk = xlsave(&val,&arg,NULL);

    /* get the length */
    len = xlevmatch(INT,&args)->n_int;

    /* get the character */
    fptr = xlevmatch(STR,&args)->n_str;
    
    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* build return node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = sptr = stralloc(len);

    /* fill with desired char */
    while (len--) *sptr++ = *fptr;
    *sptr = 0;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* ascii - return ascii value */
static struct node *ascii(args)
  struct node *args;
{
    struct node *oldstk,val;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* build return node */
    val.n_ptr = newnode(INT);
    val.n_ptr->n_int = *(xlevmatch(STR,&args)->n_str);

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the character */
    return (val.n_ptr);
}

/* chr - convert an INT into a one character ascii string */
static struct node *chr(args)
  struct node *args;
{
    struct node *oldstk,val;
    char *sptr;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* build return node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = sptr = stralloc(1);
    *sptr++ = xlevmatch(INT,&args)->n_int;
    *sptr = 0;

    /* make sure there aren't any more arguments */
    if (args != NULL)
	xlfail("too many arguments");

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* readchr - read a character from terminal */
static struct node *readchr()
{
    struct node *oldstk,val;
    char *cptr;

    /* create a new stack frame */
    oldstk = xlsave(&val,NULL);

    /* clear any output */
    fflush(stdout);

    /* build return node */
    val.n_ptr = newnode(STR);
    val.n_ptr->n_str = cptr = stralloc(1);
    *cptr++ = kbin();
    *cptr = 0;    

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new string */
    return (val.n_ptr);
}

/* getnum - parse a number */
static struct node *getnum()
{
    struct node *val;
    int ch,ival,sign;

    /* initialize the node */
    val = newnode(INT);
    val->n_int = 0;

    /* first might be sign */
    ival = 0;
    switch (ch = kbin()) {
	case '+' : sign =  1; break;
	case '-' : sign = -1; break;
	default:   if (!isdigit(ch))
			return(val);		/* no value */
		    else { sign =  1; ival = ch - '0'; }
    }
	

    /* loop looking for digits */
    for (;
	 (ch = kbin()) > 0 && isdigit(ch);
	 ival = ival * 10 + ch - '0')
	;

    val->n_int = ival * sign;

    /* return the new number */
    return (val);
}

/* xlsinit - xlisp string initialization routine */
xlsinit()
{
    xlsubr("len",len);
    xlsubr("concat",concat);
    xlsubr("substr",substr);
    xlsubr("makestr", makestr);
    xlsubr("ascii",ascii);
    xlsubr("chr", chr);
    xlsubr("readchr", readchr);
    xlsubr("getnum", getnum);
}