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);
}