betz (04/11/83)
This file is xlisp4.txt
<<<<<<<<<< xlstr.c >>>>>>>>>>
/* xlstr - xlisp string builtin functions */
#include <stdio.h>
#include "xlisp.h"
/* external variables */
extern struct node *xlstack;
/* external procedures */
extern char *strcat();
/* xstrlen - length of a string */
static struct node *xstrlen(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);
/* restore the previous stack frame */
xlstack = oldstk;
/* create the value node */
val = newnode(INT);
val->n_int = total;
/* return the total */
return (val);
}
/* xstrcat - concatenate a bunch of strings */
/* this routine does it the dumb way -- one at a time */
static struct node *xstrcat(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 */
xllastarg(arg.n_ptr);
/* 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);
}
/* 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 */
xllastarg(args);
/* 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 */
xllastarg(args);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val.n_ptr);
}
/* xatoi - convert an ascii string to an integer */
static struct node *xatoi(args)
struct node *args;
{
struct node *val;
int n;
/* get the string and convert it */
n = atoi(xlevmatch(STR,&args)->n_str);
/* make sure there aren't any more arguments */
xllastarg(args);
/* create the value node */
val = newnode(INT);
val->n_int = n;
/* return the number */
return (val);
}
/* xitoa - convert an integer to an ascii string */
static struct node *xitoa(args)
struct node *args;
{
struct node *val;
char buf[20];
/* get the integer and convert it */
sprintf(buf,"%d",xlevmatch(INT,&args)->n_int);
/* make sure there aren't any more arguments */
xllastarg(args);
/* create the value node */
val = newnode(STR);
val->n_str = strsave(buf);
/* return the string */
return (val);
}
/* xlsinit - xlisp string initialization routine */
xlsinit()
{
xlsubr("strlen",xstrlen);
xlsubr("strcat",xstrcat);
xlsubr("substr",substr);
xlsubr("ascii",ascii);
xlsubr("chr", chr);
xlsubr("atoi",xatoi);
xlsubr("itoa",xitoa);
}
<<<<<<<<<< xlsubr.c >>>>>>>>>>
/* xlsubr - xlisp builtin functions */
#include <stdio.h>
#include "xlisp.h"
/* external variables */
extern int (*xlgetc)();
extern struct node *xlstack;
/* local variables */
static char *sgetptr;
/* xlsubr - define a builtin function */
xlsubr(sname,subr)
char *sname; struct node *(*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);
}
/* xllastarg - make sure the remainder of the argument list is empty */
xllastarg(args)
struct node *args;
{
if (args != NULL)
xlfail("too many arguments");
}
/* assign - assign a value to a symbol */
static assign(sym,val)
struct node *sym,*val;
{
struct node *lptr;
/* check for a current object */
if ((lptr = xlobsym(sym)) != NULL)
lptr->n_listvalue = val;
else
sym->n_symvalue = val;
}
/* 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 */
xllastarg(arg.n_ptr);
/* 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 */
xllastarg(arg.n_ptr);
/* 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 */
xllastarg(args);
/* 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(LIST);
fun->n_listvalue = fargs.n_ptr;
fun->n_listnext = 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 */
xllastarg(args);
/* read an expression */
val = xlread();
/* restore the old input stream */
xlgetc = oldgetc;
/* return the expression read */
return (val);
}
/* fwhile - builtin function while */
static struct node *fwhile(args)
struct node *args;
{
struct node *oldstk,farg,arg,*val;
/* create a new stack frame */
oldstk = xlsave(&farg,&arg,NULL);
/* initialize */
farg.n_ptr = arg.n_ptr = args;
/* loop until test fails */
for (; TRUE; arg.n_ptr = farg.n_ptr) {
/* evaluate the test expression */
if (!testvalue(val = xlevarg(&arg.n_ptr)))
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);
}
/* foreach - builtin function foreach */
static struct node *foreach(args)
struct node *args;
{
struct node *oldstk,arg,sym,list,code,oldbnd,*val;
/* create a new stack frame */
oldstk = xlsave(&arg,&sym,&list,&code,&oldbnd,NULL);
/* initialize */
arg.n_ptr = args;
/* get the symbol to bind to each list element */
sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
/* save the old binding of the symbol */
oldbnd.n_ptr = sym.n_ptr->n_symvalue;
/* get the list to iterate over */
list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
/* save the pointer to the code */
code.n_ptr = arg.n_ptr;
/* loop until test fails */
val = NULL;
while (list.n_ptr != NULL) {
/* check the node type */
if (list.n_ptr->n_type != LIST)
xlfail("bad node type in list");
/* bind the symbol to the list element */
sym.n_ptr->n_symvalue = list.n_ptr->n_listvalue;
/* evaluate each remaining argument */
while (arg.n_ptr != NULL)
val = xlevarg(&arg.n_ptr);
/* point to the next list element */
list.n_ptr = list.n_ptr->n_listnext;
/* restore the pointer to the code */
arg.n_ptr = code.n_ptr;
}
/* restore the previous stack frame */
xlstack = oldstk;
/* restore the old binding of the symbol */
sym.n_ptr->n_symvalue = oldbnd.n_ptr;
/* 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 */
xllastarg(arg.n_ptr);
/* figure out which expression to evaluate */
dothen = testvalue(testexpr.n_ptr);
/* 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();
}
/* testvalue - test a value for true or false */
static int testvalue(val)
struct node *val;
{
/* check for a nil value */
if (val == NULL)
return (FALSE);
/* check the value type */
switch (val->n_type) {
case INT:
return (val->n_int != 0);
case STR:
return (strlen(val->n_str) != 0);
default:
return (TRUE);
}
}
/* xlinit - xlisp initialization routine */
xlinit()
{
xlsubr("set",set);
xlsubr("setq",setq);
xlsubr("load",load);
xlsubr("read",read);
xlsubr("quote",quote);
xlsubr("while",fwhile);
xlsubr("foreach",foreach);
xlsubr("defun",defun);
xlsubr("if",fif);
xlsubr("exit",fexit);
}
<<<<<<<<<< xlisp.h >>>>>>>>>>
/* xlisp - a small subset of lisp */
/* system specific definitions */
/* DEFEXT define to enable default extension of '.lsp' on 'load' */
/* FGETNAME define if system supports 'fgetname' */
/* CNTRLGBREAK define if control-g is a break character */
/* for the VAX-11 C compiler */
#ifdef vms
#define DEFEXT
#define FGETNAME
#define CNTRLGBREAK
#endif
/* for the DECUS C compiler */
#ifdef decusc
#define DEFEXT /* enable extension defaulting on 'load' */
#define CNTRLGBREAK /* control-g is a break character */
#endif
/* for unix compilers */
#ifdef unix
#endif
/* for the AZTEC C compiler */
#ifdef aztec
#define DEFEXT
#define getc(fp) getch(fp)
#define kbin() CPM(6,0xFF)
#define malloc alloc
#endif
/* useful definitions */
#define TRUE 1
#define FALSE 0
/* program limits */
#define STRMAX 100 /* maximum length of a string constant */
#define NNODES 200 /* number of nodes to allocate in each request */
#define TDEPTH 100 /* trace stack depth */
/* node types */
#define FREE 0
#define SUBR 1
#define LIST 2
#define SYM 3
#define INT 4
#define STR 5
#define OBJ 6
#define FPTR 7
#define KMAP 8
/* node flags */
#define MARK 1
#define LEFT 2
/* string types */
#define DYNAMIC 0
#define STATIC 1
/* symbol structure */
struct xsym {
char *xsy_name; /* symbol name */
struct node *xsy_value; /* the current value */
};
/* subr node structure */
struct xsubr {
struct node *(*xsu_subr)(); /* pointer to an internal routine */
};
/* list node structure */
struct xlist {
struct node *xl_value; /* value at this node */
struct node *xl_next; /* next node */
};
/* integer node structure */
struct xint {
int xi_int; /* integer value */
};
/* string node structure */
struct xstr {
int xst_type; /* string type */
char *xst_str; /* string pointer */
};
/* object node structure */
struct xobj {
struct node *xo_obclass; /* class of object */
struct node *xo_obdata; /* instance data */
};
/* file pointer node structure */
struct xfptr {
FILE *xf_fp; /* the file pointer */
};
/* keymap structure */
struct xkmap {
struct node *(*xkm_map)[]; /* selection pointer */
};
/* shorthand macros for accessing node substructures */
/* symbol node */
#define n_symname n_info.n_xsym.xsy_name
#define n_symvalue n_info.n_xsym.xsy_value
/* subr node */
#define n_subr n_info.n_xsubr.xsu_subr
/* list node (and message node and binding node) */
#define n_listvalue n_info.n_xlist.xl_value
#define n_listnext n_info.n_xlist.xl_next
#define n_msg n_info.n_xlist.xl_value
#define n_msgcode n_info.n_xlist.xl_next
#define n_bndsym n_info.n_xlist.xl_value
#define n_bndvalue n_info.n_xlist.xl_next
#define n_left n_info.n_xlist.xl_value
#define n_right n_info.n_xlist.xl_next
#define n_ptr n_info.n_xlist.xl_value
/* integer node */
#define n_int n_info.n_xint.xi_int
/* string node */
#define n_str n_info.n_xstr.xst_str
#define n_strtype n_info.n_xstr.xst_type
/* object node */
#define n_obclass n_info.n_xobj.xo_obclass
#define n_obdata n_info.n_xobj.xo_obdata
/* file pointer node */
#define n_fname n_info.n_xfptr.xf_name
#define n_fp n_info.n_xfptr.xf_fp
/* key map node */
#define n_kmap n_info.n_xkmap.xkm_map
/* node structure */
struct node {
char n_type; /* type of node */
char n_flags; /* flag bits */
union { /* value */
struct xsym n_xsym; /* symbol node */
struct xsubr n_xsubr; /* subr node */
struct xlist n_xlist; /* list node */
struct xint n_xint; /* integer node */
struct xstr n_xstr; /* string node */
struct xobj n_xobj; /* object node */
struct xfptr n_xfptr; /* file pointer node */
struct xkmap n_xkmap; /* key map node */
} n_info;
};
/* external procedure declarations */
extern struct node *xlread(); /* read an expression */
extern struct node *xleval(); /* evaluate an expression */
extern struct node *xlarg(); /* fetch an argument */
extern struct node *xlevarg(); /* fetch and evaluate an argument */
extern struct node *xlmatch(); /* fetch an typed argument */
extern struct node *xlevmatch(); /* fetch and evaluate a typed arg */
extern struct node *xlsend(); /* send a message to an object */
extern struct node *xlmfind(); /* find the method for a message */
extern struct node *xlxsend(); /* execute a message method */
extern struct node *xlenter(); /* enter a symbol into the oblist */
extern struct node *xlsave(); /* generate a stack frame */
extern struct node *xlobsym(); /* find an object's class or instance
variable */
extern struct node *xlclass(); /* enter a class definition */
extern struct node *xlivar(); /* get an instance variable */
extern struct node *xlcvar(); /* get an instance variable */
extern struct node *newnode(); /* allocate a new node */
extern char *stralloc(); /* allocate string space */
extern char *strsave(); /* make a safe copy of a string */
<<<<<<<<<< junk.c >>>>>>>>>>
#include "stdio.h"
#include "xlisp.h"
char *fgetname()
{
return ("a file");
}
char *strchr(str,ch)
char *str; int ch;
{
for (; *str; str++)
if (*str == ch)
return (str);
return (NULL);
}
int getch(fp)
FILE *fp;
{
int ch;
if ((ch = agetc(fp)) == '\032')
return (EOF);
else
return (ch);
}
char *calloc(n,size)
unsigned n,size;
{
char *str;
unsigned nsize,i;
if ((str = malloc(nsize = n * size)) == NULL)
return (NULL);
for (i = 0; i < nsize; i++)
str[i] = 0;
return (str);
}
<<<<<<<<<< setjmp.h >>>>>>>>>>
typedef int jmp_buf[14];
<<<<<<<<<< setjmp.asm >>>>>>>>>>
;setjmp/longjmp support for Aztec C
;Mark E. Mallett 830127
;
public setjmp_
public longjmp_
;
; setjmp i = setjmp(env)
;
; returns 0 if setting
; val if longjmping
;
setjmp_:
DB 0EDH,073H ; LD (nn),SP
DW osp ; nn..
pop h ; Get return address
shld raddr ; Save it
pop h ; get address of env buffer
shld envadr ; Save it
DB 011H ; ld de,nn .. Find the end of the jmp buffer
DW 10 ; nn
DB 019H ; ADD HL,DE
shld nsp ; Save so I can pick it up...
DB 0EDH,07BH ; ... here ( ld sp,(nn) )
DW nsp ; ..NN..
push b ; save things in jmp buffer
db 0DDH,0E5H ; push ix
db 0FDH,0E5H ; push iy
lhld raddr ; save return address
push h
lhld osp ; save original stack pointer
push h
lxi h,0 ; set return value to 0
shld val
jp ljret ; go return as if from longjump
; longjmp longjmp (env,val)
; returns val to where setjmp was called
;
longjmp_:
lxi h,2 ; Find addr of env
dad sp ; .
mov e,m ; get it in de
inx h
mov d,m
inx h
DB 0EDH,053H ; ld (nn),de
DW envadr
mov e,m ; get value
inx h
mov d,m
DB 0EDH,053H ; LD (nn),de
DW val ; NN
; Here to return from setjmp/longjmp
ljret:
DB 0EDH,07BH ; LD SP,(NN)... Get jmp buffer address
DW envadr ; ..NN..
pop h ; Get old stack pointer value
shld osp ; Save it
pop d ; Get old return address
mov m,e ; Put it on the old stack
inx h
mov m,d
db 0FDH,0E1H ; pop iy
db 0DDH,0E1H ; pop ix
pop b
lhld val ; Get value to return
DB 0EDH,07BH ; LD sp,(nn)
DW osp ; NN
ret ; Return to setjmp caller
envadr: ds 2 ; Address of jmp buffer
nsp: ds 2 ; New stack pointer
osp: ds 2 ; Old stack pointer
raddr: ds 2 ; Return address
val: ds 2 ; Value to return
end