betz (01/06/83)
::::::::::::::
xlisp.mem
::::::::::::::
XLISP code and documentation
Copyright 1983, by David M. Betz
114 Davenport Ave.
Manchester, NH 03103
603-625-4691
UUCP: decvax!betz
All rights reserved
Permission granted for unrestricted non-commercial use
XLISP is an experimental programming language combining some of the features
of LISP with an object oriented extension capability. All of the builtin
functions of XLISP are LISP like functions. The only builtin object class
is "class". This is sufficient to allow the language to be extended in an
object oriented manner. XLISP is very slow because of the way that it handles
dynamic memory allocation, hence it isn't a practical language for serious
applications. It was implemented to allow experimentation with object
oriented programming before Smalltalk-80 becomes available from Xerox.
Utility functions:
(load <fname>) LOAD AN XLISP SOURCE FILE
<fname> the filename string (default extension is ".lsp") (evaluated)
returns the filename
(mem) SHOW MEMORY ALLOCATION STATISTICS
returns nil
(gc) FORCE GARBAGE COLLECTION
returns nil
(alloc <num>) CHANGE THE NUMBER OF NODES TO ALLOCATE IN EACH SEGMENT
<num> the number of nodes to allocate (evaluated)
returns the old number of nodes to allocate
(expand <num>) EXPAND MEMORY BY ADDING SEGMENTS
<num> the number of segments to add (evaluated)
returns the number of segments added
Functions:
(eval <list>) EVALUATE A LIST AS XLISP CODE
<list> the list to be evaluated as an xlisp expression (evaluated)
returns the result of evaluating the expression
(set <sym> <expr>) SET THE VALUE OF A SYMBOL
<sym> the symbol being set (evaluated)
<expr> the new value (evaluated)
returns the new value
(setq <qsym> <expr>) SET THE VALUE OF A SYMBOL
<qsym> the symbol being set (quoted)
<expr> the new value (evaluated)
returns the new value
(print <expr>...) PRINT A LIST OF VALUES
<expr> the expressions to be printed (evaluated)
returns null
(quote <expr>) RETURN AN EXPRESSION UNEVALUATED
<expr> the expression to be quoted (quoted)
returns <expr> unevaluated
(if <expr> <expr1> [ <expr2> ]) EXECUTE EXPRESSIONS CONDITIONALLY
<texpr> test expression (evaluated)
<expr1> expression evaluated if texpr is non-null or non-zero
<expr2> expression evaluated if texpr is null or zero
returns the valued of the expression evaluated
(while <texpr> <expr>...) ITERATE WHILE AN EXPRESSION IS TRUE
<texpr> test expression evaluated at start of each iteration
<expr> expressions evaluated as long as <texpr> evaluates to
non-null or non-zero
returns the result of the last expression evaluated
(defun <qsym> <qfargs> <expr>...) DEFINE A NEW FUNCTION
<qsym> symbol to be defined (quoted)
<qfargs> list of formal arguments (quoted)
this list is of the form:
( <farg>... [ / <local>... ] )
where
<farg> is a formal argument
<local> is a local variable
<expr> expressions constituting the body of the function (quoted)
returns the function symbol
I/O Functions:
(readchr) READ A CHARACTER WITHOUT ECHO
returns one character string with next input character
(getnum) READ A SIGNED NUMBER WITHOUT ECHO
returns number as read from input (gobbles terminator)
String Functions:
(concat <expr>...) CONCATENATE STRINGS
<expr> string expressions (must be strings)
returns string with concatenation
(substr <expr> <sexpr> [<lexpr>]) RETURN SUBSTRING
<expr> string expressin
<sexpr> starting position (first char is 1)
<lexpr> optional length (default is rest of string)
returns substring starting at <sexpr> for <lexpr>
(makestr <expr> <sexpr>) MAKE STRING OF CHARS
<expr> length of result string
<sexpr> string, fill new string with first char
returns string <expr> long all of <sexpr>
(ascii <expr>) NUMERIC VALUE OF CHARACTER
<expr> string exprssion
returns numeric value of first character (according to ASCII)
(chr <expr>) CHARACTER EQUIVALENT OF ASCII VALUE
<expr> numeric expression
returns one character string with ASCII equivalent of <expr>
List Functions:
(head <expr>) RETURN THE HEAD ELEMENT OF A LIST (CAR sortof)
<expr> the list (evaluated)
returns the first element of the list
(tail <expr>) RETURN THE TAIL ELEMENTS OF A LIST (CDR sortof)
<expr> the list (evaluated)
returns the list minus the first element
(list <expr>...) CREATE A LIST OF VALUES
<expr> evaluated expressions to be combined into a list
returns the new list
(nth <n> <list>) RETURN THE NTH ELEMENT OF A LIST
<n> the number (zero origin) of the element to return (evaluated)
<list> the list to return the nth element of
returns the nth element or nil if the list isn't that long
(append <list> <expr>...) APPEND TO A LIST
<list> the initial list (evaluated)
<expr> expressions to be appended to the list (evaluated)
returns the new list
(prepend <list> <expr>...) APPEND TO THE FRONT OF A LIST
<list> the initial list (evaluated)
<expr> expressions to be prepended to the list (evaluated)
returns the new list
Arithmetic Functions:
(+ <expr>...) ADD A LIST OF VALUES
<expr> expressions to be added (evaluated)
returns the result of the addition
(- <expr>...) SUBTRACT A LIST OF VALUES
<expr> expressions to be subtracted (evaluated)
returns the result of the subtraction
(* <expr>...) MULTIPLY A LIST OF VALUES
<expr> expressions to be multiplied (evaluated)
returns the result of the multiplication
(/ <expr>...) DIVIDE A LIST OF VALUES
<expr> expressions to be divided (evaluated)
returns the result of the division
(% <expr>...) MODify A LIST OF VALUES? (the mod function)
<expr> expressions to be MODified? (evaluated)
returns the result of mod
(&& <expr>...) THE LOGICAL AND OF A LIST OF VALUES
<expr> expressions to be ANDed (evaluated)
returns the result of anding the expressions
(evaluation of expressions stops after the first expression
that evaluates to false)
(|| <expr>...) THE LOGICAL OR OF A LIST OF VALUES
<expr> expressions to be ORed (evaluated)
returns the result of oring the expressions
(evaluation of expressions stops after the first expression
that evaluates to true)
(! <expr>) THE LOGICAL NOT OF A VALUE
<expr> expression to be NOTed (evaluated)
return logical not of <expr>
(< <e1> <e2>) TEST WHETHER AN EXPRESSION IS LESS THAN ANOTHER
<e1> the left operand of the comparison (evaluated)
<e2> the right operand of the comparison (evaluated)
returns the result of comparing <e1> with <e2>
(<= <e1> <e2>) TEST WHETHER AN EXPRESSION IS LESS THAN OR EQUAL TO ANOTHER
<e1> the left operand of the comparison (evaluated)
<e2> the right operand of the comparison (evaluated)
returns the result of comparing <e1> with <e2>
(== <e1> <e2>) TEST WHETHER AN EXPRESSION IS EQUAL TO ANOTHER
<e1> the left operand of the comparison (evaluated)
<e2> the right operand of the comparison (evaluated)
returns the result of comparing <e1> with <e2>
(!= <e1> <e2>) TEST WHETHER AN EXPRESSION IS NOT EQUAL TO ANOTHER
<e1> the left operand of the comparison (evaluated)
<e2> the right operand of the comparison (evaluated)
returns the result of comparing <e1> with <e2>
(>= <e1> <e2>) TEST WHETHER AN EXPRESSION IS GREATER THAN OR EQUAL TO ANOTHER
<e1> the left operand of the comparison (evaluated)
<e2> the right operand of the comparison (evaluated)
returns the result of comparing <e1> with <e2>
(> <e1> <e2>) TEST WHETHER AN EXPRESSION IS GREATER THAN ANOTHER
<e1> the left operand of the comparison (evaluated)
<e2> the right operand of the comparison (evaluated)
returns the result of comparing <e1> with <e2>
(& <expr>...) THE BITWISE AND OF A LIST OF VALUES
<expr> expressions to be ANDed (evaluated)
returns the bit by bit ANDing of expressions
(| <expr...) THE BITWISE OR OF A LIST OF VALUES
<expr> expressions to be ORed (evaluated)
returns the bit by bit ORing of expressions
(~ <expr>) THE BITWISE NOT OF A VALUE
<expr> expression to be NOTed (evaluated)
returns the bit by bit inversion of expression
(min <expr>...) THE SMALLEST OF A LIST OF VALUES
<expr> expressions to be checked (evaluated)
returns the smallest value of the list
(max <expr>...) THE LARGEST OF A LIST OF VALUES
<expr> expressions to be checked (evaluated)
returns the largest value of the list
Keymap Functions:
(keymap) CREATE A NEW KEYMAP
returns a new keymap
(key <km> <kstr> <ksym>) ADD A KEY DEFINITION TO A KEYMAP
<km> the keymap (evaluated)
<kstr> the string defining the key (evaluated)
<ksym> the symbol for the message (evaluated)
returns the keymap
(kmprocess <km> <envlist>) PROCESS INPUT USING A KEYMAP
<km> the keymap (evaluated)
<envlist> list of active objects (evaluated)
returns (never returns)
SDB Database Functions:
(select <sstr>) SELECT RECORDS FROM AN SDB DATABASE
<sstr> SDB selection expression string (evaluated)
returns a database pointer
(fetch <dbptr) FETCH THE NEXT RECORD IN A SELECTION
<dbptr> the database pointer (evaluated)
returns the database pointer if a record was fetched
null otherwise
(update <dbptr>) UPDATE THE CURRENT RECORD
<dbptr> the database pointer (evaluated)
returns the database pointer
(store <dbptr>) STORE A NEW RECORD
<dbptr> the database pointer (evaluated)
returns the database pointer
(done <dbptr>) CLOSE A DATABASE SELECTION
<dbptr> the database pointer (evaluated)
returns null
(get <dbptr> <fname>) GET THE VALUE OF A FIELD IN THE CURRENT RECORD
<dbptr> the database pointer (evaluated)
<fname> the field name string (evaluated)
returns the database pointer
(put <dbptr> <fname> <vstr>) STORE A FIELD VALUE INTO THE CURRENT RECORD
<dbptr> the database pointer (evaluated)
<fname> the field name string (evaluated)
<vstr> the new value string (evaluated)
returns the database pointer
Symbols:
newline the newline character
tab the tab character
bell the bell character
self the current object (within a message context)
Classes:
class THE CLASS OF ALL OBJECT CLASSES (including itself)
Messages:
new CREATE A NEW INSTANCE OF A CLASS
returns the new class object
isnew INITIALIZE A NEW CLASS
returns the new class object
answer <msg> <fargs> <code> ADD A MESSAGE TO A CLASS
<msg> the message symbol (evaluated)
<fargs> the formal argument list (evaluated)
this list is of the form:
( <farg>... [ / <local>... ] )
where
<fargs> is a list of formal arguments
<locals> is a list of local variables
<code> a list of executable expressions (evaluated)
returns the object
ivars <vars> DEFINE THE LIST OF INSTANCE VARIABLES
<vars> the list of instance variable symbols (evaluated)
returns the object
(Note: When a new instance of a class is created by sending the message "new"
to an existing class, the message "isnew" followed by whatever parameters
were passed to the "new" message is send to the newly created object)
::::::::::::::
keymap.mem
::::::::::::::
KEYMAPS
A keymap is data structure that translates a sequence of keystrokes into
a message.
In order to create a keymap:
(setq km (keymap))
In order to add a key definition to a keymap (km):
(key km "\eA" 'up)
(key km "\eB" 'down)
(key km "\eC" 'right)
(key km "\eD" 'left)
In order to invoke a keymap:
(setq env (list ob1 ob2 ob3 ob4))
(kmprocess km env)
When kmprocess is called, it enters a character input loop calling kbin to
get single unechoed characters from the keyboard (note that you'll have to
figure out how to do single character input on your system and write a new
version of xlkbin.c to implement it). When a sequence of characters is found
that matches one of the sequences defined in a key function call, the
corresponding message is sent. Kmprocess tries to send the message to each
of the objects in the environment list. It stops when it finds an object
that knows how to answer the message. Along with the message selector given
in the key definition, kmprocess also sends the sequence of characters that
matched as a single string parameter.
I got this idea from emacs, but thought that it might be interesting to
implement it in a more general way to allow for experimenting with uses
other than text editors. I have used it to implement a form processing
system at DEC, but that code is proprietary.
::::::::::::::
xlisp.h
::::::::::::::
/* xlisp - a small subset of lisp */
/* useful definitions */
#define TRUE 1
#define FALSE 0
#define NULL 0
/* program limits */
#define STRMAX 100 /* maximum length of a string constant */
#define NNODES 2000 /* number of nodes to allocate in each request */
/* node types */
#define FREE 0
#define SUBR 1
#define LIST 2
#define MSG 2
#define BND 2
#define SYM 3
#define INT 4
#define STR 5
#define DBPTR 6
#define KMAP 7
#define FUN 8
#define OBJ 9
/* 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 {
int (*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 */
};
/* database pointer structure */
struct xdbptr {
char *xdb_sptr; /* selection pointer */
int xdb_flags; /* flag bits */
};
/* keymap structure */
struct xkmap {
struct node *(*xkm_map)[]; /* selection pointer */
};
/* function node structure */
struct xfun {
struct node *xf_funargs; /* list of formal arguments */
struct node *xf_funcode; /* function code */
};
/* object node structure */
struct xobj {
struct node *xo_obclass; /* class of object */
struct node *xo_obdata; /* instance data */
};
/* 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
/* database pointer node */
#define n_dbsptr n_info.n_xdbptr.xdb_sptr
#define n_dbflags n_info.n_xdbptr.xdb_flags
/* key map node */
#define n_kmap n_info.n_xkmap.xkm_map
/* function node */
#define n_funargs n_info.n_xfun.xf_funargs
#define n_funcode n_info.n_xfun.xf_funcode
/* object node */
#define n_obclass n_info.n_xobj.xo_obclass
#define n_obdata n_info.n_xobj.xo_obdata
/* 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 xdbptr n_xdbptr; /* database pointer node */
struct xkmap n_xkmap; /* key map node */
struct xfun n_xfun; /* function node */
struct xobj n_xobj; /* object node */
} n_info;
};
::::::::::::::
xlisp.c
::::::::::::::
/* xlisp - a small subset of lisp */
#include <setjmp.h>
#include "xlisp.h"
/* global variables */
jmp_buf xljmpbuf;
extern struct node *xlread();
extern struct node *xleval();
/* external variables */
extern struct node *xlenv;
extern struct node *xlstack;
extern int xlpvals;
/* inhibit the argv prompt */
int $$narg = 1;
/* main - the main routine */
main(argc,argv)
int argc; char *argv[];
{
struct node expr;
/* initialize the dynamic memory module (must be first) */
xldmeminit();
/* initialize xlisp */
xlinit();
xleinit(); xllinit(); xlminit();
xlkinit(); xloinit(); xlsinit();
/* initialize terminal input */
xltin();
/* read the input file if specified */
if (argc > 1)
xlfin(argv[1]);
/* main command processing loop */
while (TRUE) {
/* setup the error return */
setjmp(xljmpbuf);
/* free any previous expression and leftover context */
xlstack = xlenv = NULL;
/* create a new stack frame */
xlsave(&expr,NULL);
/* read an expression */
expr.n_ptr = xlread();
/* evaluate the expression */
expr.n_ptr = xleval(expr.n_ptr);
/* print it if necessary */
if (xlpvals) {
xlprint(expr.n_ptr);
putchar('\n');
}
}
}
::::::::::::::
xlread.c
::::::::::::::
/* xlread - xlisp expression input routine */
#include <stdio.h>
#include <ctype.h>
#include "xlisp.h"
/* global variables */
struct node *oblist;
/* external variables */
extern struct node *xlstack;
extern int (*xlgetc)();
/* local variables */
static int savech;
/* forward declarations (the extern hack is for decusc) */
extern struct node *parse();
extern struct node *plist();
extern struct node *pstring();
extern struct node *pnumber();
extern struct node *pquote();
extern struct node *pname();
/* xlread - read an xlisp expression */
struct node *xlread()
{
struct node *val;
int ch;
/* initialize */
savech = -1;
/* parse an expression */
val = parse();
/* skip to end of line */
while ((ch = thisch()) > 0 && ch != '\n') {
if (!isspace(ch))
xlfail("extra characters after expression");
savech = -1;
}
/* return the result value */
return (val);
}
/* parse - parse an xlisp expression */
static struct node *parse()
{
int ch;
/* keep looking for a node skipping comments */
while (TRUE)
/* check next character for type of node */
switch (ch = nextch()) {
case '\'': /* a quoted expression */
return (pquote());
case '(': /* a sublist */
return (plist());
case ')': /* closing paren - shouldn't happen */
xlfail("extra right paren");
case ';': /* a comment */
pcomment();
break;
case '"': /* a string */
return (pstring());
default:
if (isdigit(ch)) /* a number */
return (pnumber());
else /* a name */
return (pname());
}
}
/* pcomment - parse a comment */
static pcomment()
{
int ch;
/* skip to end of line */
while ((ch = getch()) > 0)
if (ch == '\n')
break;
}
/* plist - parse a list */
static struct node *plist()
{
struct node *oldstk,val,*lastnptr,*nptr;
int ch;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* skip the opening paren */
savech = -1;
/* keep appending nodes until a closing paren is found */
for (lastnptr = NULL; (ch = nextch()) > 0 && ch != ')'; lastnptr = nptr) {
/* allocate a new node and link it into the list */
nptr = newnode(LIST);
if (lastnptr == NULL)
val.n_ptr = nptr;
else
lastnptr->n_listnext = nptr;
/* initialize the new node */
nptr->n_listvalue = parse();
}
/* skip the closing paren */
savech = -1;
/* restore the previous stack frame */
xlstack = oldstk;
/* return successfully */
return (val.n_ptr);
}
/* pstring - parse a string */
static struct node *pstring()
{
struct node *oldstk,val;
char sbuf[STRMAX+1];
int ch,i,d1,d2,d3;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* skip the opening quote */
savech = -1;
/* loop looking for a closing quote */
for (i = 0; i < STRMAX && (ch = getch()) > 0 && ch != '"'; i++) {
switch (ch) {
case '\\':
switch (ch = getch()) {
case 'e':
ch = '\033';
break;
case 'n':
ch = '\n';
break;
case 'r':
ch = '\r';
break;
case 't':
ch = '\t';
break;
default:
if (ch >= '0' && ch <= '7') {
d1 = ch - '0';
d2 = getch() - '0';
d3 = getch() - '0';
ch = (d1 << 6) + (d2 << 3) + d3;
}
break;
}
}
sbuf[i] = ch;
}
sbuf[i] = 0;
/* initialize the node */
val.n_ptr = newnode(STR);
val.n_ptr->n_str = strsave(sbuf);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val.n_ptr);
}
/* pnumber - parse a number */
static struct node *pnumber()
{
struct node *val;
int ch,ival;
/* loop looking for a closing quote */
for (ival = 0; (ch = thisch()) > 0 && isdigit(ch); savech = -1)
ival = ival * 10 + ch - '0';
/* initialize the node */
val = newnode(INT);
val->n_int = ival;
/* return the new number */
return (val);
}
/* xlenter - enter a symbol into the symbol table */
struct node *xlenter(sname)
char *sname;
{
struct node *sptr;
/* check for nil */
if (strcmp(sname,"nil") == 0)
return (NULL);
/* check for symbol already in table */
for (sptr = oblist; sptr != NULL; sptr = sptr->n_listnext)
if (sptr->n_listvalue == NULL)
printf("bad oblist\n");
else if (sptr->n_listvalue->n_symname == NULL)
printf("bad oblist symbol\n");
else
if (strcmp(sptr->n_listvalue->n_symname,sname) == 0)
return (sptr->n_listvalue);
/* enter a new symbol and link it into the symbol list */
sptr = newnode(LIST);
sptr->n_listnext = oblist;
oblist = sptr;
sptr->n_listvalue = newnode(SYM);
sptr->n_listvalue->n_symname = strsave(sname);
/* return the new symbol */
return (sptr->n_listvalue);
}
/* pquote - parse a quoted expression */
static struct node *pquote()
{
struct node *oldstk,val;
/* create a new stack frame */
oldstk = xlsave(&val,NULL);
/* skip the quote character */
savech = -1;
/* allocate two nodes */
val.n_ptr = newnode(LIST);
val.n_ptr->n_listvalue = xlenter("quote");
val.n_ptr->n_listnext = newnode(LIST);
/* initialize the second to point to the quoted expression */
val.n_ptr->n_listnext->n_listvalue = parse();
/* restore the previous stack frame */
xlstack = oldstk;
/* return the quoted expression */
return (val.n_ptr);
}
/* pname - parse a symbol name */
static struct node *pname()
{
char sname[STRMAX+1];
int ch,i;
/* get symbol name */
for (i = 0; i < STRMAX && (ch = thisch()) > 0 && issym(ch); i++)
sname[i] = getch();
sname[i] = 0;
/* initialize value */
return (xlenter(sname));
}
/* nextch - look at the next non-blank character */
static int nextch()
{
int ch;
/* look for a non-blank character */
while ((ch = thisch()) > 0)
if (isspace(ch))
savech = -1;
else
break;
/* return the character */
return (ch);
}
/* thisch - look at the current character */
static int thisch()
{
/* return and save the current character */
return (savech = getch());
}
/* getch - get the next character */
static int getch()
{
int ch;
/* check for a saved character */
if ((ch = savech) >= 0)
savech = -1;
else
ch = (*xlgetc)();
/* return the character */
return (ch);
}
/* issym - check whether a character if valid in a symbol name */
static int issym(ch)
int ch;
{
if (isspace(ch) || ch == '(' || ch == ')' || ch == ';' || ch == '\'')
return (FALSE);
else
return (TRUE);
}
::::::::::::::
xleval.c
::::::::::::::
/* xleval - xlisp evaluator */
#include <setjmp.h>
#include "xlisp.h"
/* global variables */
struct node *xlstack;
/* debugging stuff */
#define TRACE_DEPTH 1024
static struct node *trace_stack[TRACE_DEPTH];
static int trace_pointer;
/* external variables */
extern jmp_buf xljmpbuf;
extern struct node *xlenv;
extern struct node *self;
/* local variables */
static struct node *slash;
/* forward declarations (the extern hack is for decusc) */
extern struct node *evlist();
extern struct node *evsym();
extern struct node *evfun();
/* xleval - evaluate an xlisp expression */
struct node *xleval(expr)
struct node *expr;
{
/* evaluate null to itself */
if (expr == NULL)
return (NULL);
/* check type of value */
switch (expr->n_type) {
case LIST:
return (evlist(expr));
case SYM:
return (evsym(expr));
case INT:
case STR:
case SUBR:
return (expr);
default:
xlfail("can't evaluate expression");
}
}
/* xlsave - save nodes on the stack */
struct node *xlsave(n)
struct node *n;
{
struct node **nptr,*oldstk;
/* save the old stack pointer */
oldstk = xlstack;
/* save each node */
for (nptr = &n; *nptr != NULL; nptr++) {
(*nptr)->n_type = LIST;
(*nptr)->n_listvalue = NULL;
(*nptr)->n_listnext = xlstack;
xlstack = *nptr;
}
/* return the old stack pointer */
return (oldstk);
}
/* evlist - evaluate a list */
static struct node *evlist(nptr)
struct node *nptr;
{
struct node *oldstk,fun,args,*val;
/* create a stack frame */
oldstk = xlsave(&fun,&args,NULL);
/* get the function and the argument list */
fun.n_ptr = nptr->n_listvalue;
args.n_ptr = nptr->n_listnext;
/* add trace entry */
xltpush(nptr);
/* evaluate the first expression */
if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL)
xlfail("null function");
/* evaluate the function */
switch (fun.n_ptr->n_type) {
case SUBR:
val = (*fun.n_ptr->n_subr)(args.n_ptr);
break;
case FUN:
case LIST:
val = evfun(fun.n_ptr,args.n_ptr);
break;
case OBJ:
val = xlsend(fun.n_ptr,args.n_ptr);
break;
default:
xlfail("bad function");
}
/* restore the previous stack frame */
xlstack = oldstk;
/* remove trace entry */
xltpop();
/* return the result value */
return (val);
}
/* evsym - evaluate a symbol */
static struct node *evsym(sym)
struct node *sym;
{
struct node *optr,*lptr,*bptr;
/* 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)
return (bptr->n_bndvalue);
/* return the current symbol value */
return (sym->n_symvalue);
}
/* evfun - evaluate a function */
static struct node *evfun(fun,args)
struct node *fun,*args;
{
struct node *oldenv,*oldstk,cptr,*val;
/* create a stack frame */
oldstk = xlsave(&cptr,NULL);
/* bind the formal parameters */
oldenv = xlenv;
xlabind(fun->n_funargs,args);
xlfixbindings(oldenv);
/* execute the code */
for (cptr.n_ptr = fun->n_funcode; cptr.n_ptr != NULL; )
val = xlevarg(&cptr.n_ptr);
/* restore the environment */
xlunbind(oldenv);
/* restore the previous stack frame */
xlstack = oldstk;
/* return the result value */
return (val);
}
/* xlabind - bind the arguments for a function */
int xlabind(fargs,aargs)
struct node *fargs,*aargs;
{
struct node *oldstk,farg,aarg,val;
/* create a stack frame */
oldstk = xlsave(&farg,&aarg,&val,NULL);
/* initialize the pointers */
farg.n_ptr = fargs;
aarg.n_ptr = aargs;
/* evaluate and bind each argument */
while (farg.n_ptr != NULL && aarg.n_ptr != NULL) {
/* check for local variable separator */
if (farg.n_ptr->n_listvalue == slash)
break;
/* evaluate the argument */
val.n_ptr = xlevarg(&aarg.n_ptr);
/* bind the formal variable to the argument value */
xlbind(farg.n_ptr->n_listvalue,val.n_ptr);
/* move the formal argument list pointer ahead */
farg.n_ptr = farg.n_ptr->n_listnext;
}
/* check for local variables */
if (farg.n_ptr != NULL && farg.n_ptr->n_listvalue == slash)
while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
xlbind(farg.n_ptr->n_listvalue,NULL);
/* restore the previous stack frame */
xlstack = oldstk;
/* make sure the correct number of arguments were supplied */
if (farg.n_ptr != aarg.n_ptr)
xlfail("incorrect number of arguments to a function");
}
/* xlfail - error handling routine */
xlfail(err)
char *err;
{
/* print the error message */
printf("error: %s\n",err);
/* unbind bound symbols */
xlunbind(NULL);
/* restore input to the terminal */
xltin();
/* do the back trace */
xltrace();
trace_pointer = -1;
/* restart */
longjmp(xljmpbuf,1);
}
/* xltpush - add an entry to the trace stack */
xltpush(nptr)
struct node *nptr;
{
if (trace_pointer >= TRACE_DEPTH)
xlfail("trace stack overflow");
trace_stack[++trace_pointer] = nptr;
}
/* xltpop - pop an entry from the trace stack */
xltpop()
{
if (trace_pointer >= 0) --trace_pointer;
}
/* xltrace - do a back trace */
xltrace()
{
int tptr;
for (tptr=trace_pointer;
tptr>=0;
tptr-- ) {
xlprint(trace_stack[tptr]);
puts("\n");
}
}
/* xleinit - initialize the evaluator */
xleinit()
{
/* enter the local variable separator symbol */
slash = xlenter("/");
/* initialize debugging stuff */
trace_pointer = -1;
}
::::::::::::::
xlprin.c
::::::::::::::
/* xlprint - xlisp print routine */
#include "xlisp.h"
/* xlprint - print an xlisp value */
xlprint(vptr)
struct node *vptr;
{
struct node *nptr,*next;
/* print null as the empty list */
if (vptr == NULL) {
printf("()");
return;
}
/* check value type */
switch (vptr->n_type) {
case SUBR:
printf("#%o",vptr->n_subr);
break;
case FUN:
case LIST:
putchar('(');
for (nptr = vptr; nptr != NULL; nptr = next) {
xlprint(nptr->n_listvalue);
if ((next = nptr->n_listnext) != NULL)
if (next->n_type == LIST)
putchar(' ');
else {
putchar('.');
xlprint(next);
break;
}
}
putchar(')');
break;
case SYM:
printf("%s",vptr->n_symname);
break;
case INT:
printf("%d",vptr->n_int);
break;
case STR:
printf("%s",vptr->n_str);
break;
}
}