john@x.UUCP (John Woods) (08/27/84)
This represents part 4 of 5 of my modified XLISP. Tear at the dotted line,
and run "sh" over it to extract.
Thanks to Dave Betz for providing the original XLISP.
________________________________________________________________
echo extract with /bin/sh, not /bin/csh
echo x xllist.c
sed -n -e 's/^X//p' > xllist.c << '!Funky!Stuff!'
X /* xllist - xlisp list builtin functions */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include "xlisp.h"
X#endif
X
X
X /* external variables */
X
Xextern struct node *xlstack;
Xextern struct node *xlapply();
X
X /* local variables */
Xstatic struct node *t;
Xstatic struct node *a_subr;
Xstatic struct node *a_fsubr;
Xstatic struct node *a_list;
Xstatic struct node *a_sym;
Xstatic struct node *a_int;
Xstatic struct node *a_real;
Xstatic struct node *a_str;
Xstatic struct node *a_obj;
Xstatic struct node *a_fptr;
Xstatic struct node *a_kmap;
Xstatic struct node *NCONC;
X
X /**********************************
X * xlist - builtin function list *
X **********************************/
X
Xstatic struct node *xlist(args)
X struct node *args;
X{
X struct node *oldstk,arg,list,val,*last,*lptr;
X
X oldstk = xlsave(&arg,&list,&val,NULL);
X arg.n_ptr = args;
X
X for (last = NULL; arg.n_ptr != NULL; last = lptr)
X {
X val.n_ptr = xlarg(&arg.n_ptr);
X lptr = newnode(LIST);
X if (last == NULL)
X list.n_ptr = lptr;
X else
X last->n_listnext = lptr;
X lptr->n_listvalue = val.n_ptr;
X }
X
X xlstack = oldstk;
X return (list.n_ptr);
X}
X
X
X /*********************************
X * cond - builtin function cond *
X *********************************/
X
Xstatic struct node *cond(args)
X struct node *args;
X{
X struct node *oldstk,arg,list,*val;
X
X oldstk = xlsave(&arg,&list,NULL);
X arg.n_ptr = args;
X
X val = NULL;
X while (arg.n_ptr != NULL)
X {
X list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X if ((val = xlevarg(&list.n_ptr)) != NULL)
X {
X while (list.n_ptr != NULL)
X val = xlevarg(&list.n_ptr);
X break;
X }
X }
X
X xlstack = oldstk;
X return (val);
X}
X
X
X /****************************
X * atom - is this an atom? *
X ****************************/
X
Xstatic struct node *atom(args)
X struct node *args;
X{
X struct node *arg;
X
X if ((arg = xlarg(&args)) == NULL || arg->n_type != LIST)
X return (t);
X else
X return (NULL);
X}
X
X
X /*************************
X * null - is this null? *
X *************************/
X
Xstatic struct node *null(args)
X struct node *args;
X{
X if (xlarg(&args) == NULL)
X return (t);
X else
X return (NULL);
X}
X
X /*********************************
X * numberp - is this a number? *
X ********************************/
X
Xstatic struct node *numberp(args)
X struct node *args;
X{
X struct node *arg;
X
X if (!(arg = xlarg(&args)))
X return NULL;
X if (arg->n_type == INT || arg->n_type == REAL)
X return (t);
X return NULL;
X}
X
X
X /**********************************
X * type - return type of a thing *
X **********************************/
X
Xstatic struct node *type(args)
X struct node *args;
X{
X struct node *arg;
X
X if (!(arg = xlarg(&args)))
X return (NULL);
X
X switch (arg->n_type)
X {
X case SUBR: return (a_subr);
X case FSUBR: return (a_fsubr);
X
X case LIST: return (a_list);
X
X case SYM: return (a_sym);
X
X case INT: return (a_int);
X#ifdef REALS
X case REAL: return (a_real);
X#endif
X case STR: return (a_str);
X
X case OBJ: return (a_obj);
X
X case FPTR: return (a_fptr);
X
X case KMAP: return (a_kmap);
X
X default: xlfail("Bad node.");
X
X }
X}
X
X
X /****************************
X * listp - is this a list? *
X ****************************/
X
Xstatic struct node *listp(args)
X struct node *args;
X{
X if (xlistp(xlarg(&args)))
X return (t);
X else
X return (NULL);
X}
X
X
X /*************************************
X * xlistp - internal listp function *
X *************************************/
X
Xstatic int xlistp(arg)
X struct node *arg;
X{
X return (arg == NULL || arg->n_type == LIST);
X}
X
X
X /**************************
X * eq - are these equal? *
X **************************/
X
Xstatic struct node *eq(args)
X struct node *args;
X{
X struct node *oldstk,arg,arg1,arg2,*val;
X
X oldstk = xlsave(&arg,&arg1,&arg2,NULL);
X arg.n_ptr = args;
X
X arg1.n_ptr = xlarg(&arg.n_ptr);
X arg2.n_ptr = xlarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X
X if (xeq(arg1.n_ptr,arg2.n_ptr))
X val = t;
X else
X val = NULL;
X
X xlstack = oldstk;
X return (val);
X}
X
X
X /*******************************
X * xeq - internal eq function *
X *******************************/
X
Xint xeq(arg1,arg2)
X struct node *arg1,*arg2;
X{
X if (arg1 != NULL && arg1->n_type == INT &&
X arg2 != NULL && arg2->n_type == INT)
X return (arg1->n_int == arg2->n_int);
X else
X return (arg1 == arg2);
X}
X
X
X /*****************************
X * equal - are these equal? *
X *****************************/
X
Xstatic struct node *equal(args)
X struct node *args;
X{
X struct node *oldstk,arg,arg1,arg2,*val;
X
X oldstk = xlsave(&arg,&arg1,&arg2,NULL);
X arg.n_ptr = args;
X
X arg1.n_ptr = xlarg(&arg.n_ptr);
X arg2.n_ptr = xlarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X
X if (xequal(arg1.n_ptr,arg2.n_ptr))
X val = t;
X else
X val = NULL;
X
X xlstack = oldstk;
X return (val);
X}
X
X
X /*************************************
X * xequal - internal equal function *
X *************************************/
X
Xint xequal(arg1,arg2)
X struct node *arg1,*arg2;
X{
X if (xeq(arg1,arg2))
X return (TRUE);
X else
X if (xlistp(arg1) && xlistp(arg2))
X return (xequal(arg1->n_listvalue,arg2->n_listvalue) &&
X xequal(arg1->n_listnext, arg2->n_listnext));
X else
X return (FALSE);
X}
X
X /*************************************
X * rplaca - damage the car of a cons *
X *************************************/
Xstatic struct node *rplaca(args)
X struct node *args;
X{
X struct node *list, *with;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X xlfail("null list");
X with = xlarg(&args);
X xllastarg(args);
X list->n_listvalue = with;
X return list;
X}
X
X /*************************************
X * rplacd - damage the cdr of a cons *
X *************************************/
Xstatic struct node *rplacd(args)
X struct node *args;
X{
X struct node *list, *with;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X xlfail("null list");
X with = xlarg(&args);
X xllastarg(args);
X list->n_listnext = with;
X return list;
X}
X
X /*************************************
X * head - return the head of a list *
X *************************************/
X
Xstatic struct node *head(args)
X struct node *args;
X{
X struct node *list;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X/* xlfail("null list"); */
X return NULL; /* (car ()) => () */
X
X xllastarg(args);
X
X return (list->n_listvalue);
X}
X
X
X /*************************************
X * tail - return the tail of a list *
X *************************************/
X
Xstatic struct node *tail(args)
X struct node *args;
X{
X struct node *list;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X/* xlfail("null list"); */
X return NULL; /* (cdr () ) => () */
X
X xllastarg(args);
X
X return (list->n_listnext);
X}
X
X /*************************************
X * caar - return the caar of a list *
X *************************************/
X
Xstatic struct node *caar(args)
X struct node *args;
X{
X struct node *list;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X return NULL;
X xllastarg(args);
X if (list->n_listvalue->n_type != LIST)
X xlfail("car of non-list");
X return (list->n_listvalue->n_listvalue);
X}
X
X
X /*************************************
X * cadr - return the cadr of a list *
X *************************************/
X
Xstatic struct node *cadr(args)
X struct node *args;
X{
X struct node *list;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X return NULL;
X xllastarg(args);
X
X if (list->n_listnext->n_type != LIST)
X xlfail("car of non-list");
X return (list->n_listnext->n_listvalue);
X}
X
X /*************************************
X * cdar - return the cdar of a list *
X *************************************/
X
Xstatic struct node *cdar(args)
X struct node *args;
X{
X struct node *list;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X return NULL;
X xllastarg(args);
X
X if (list->n_listvalue->n_type != LIST)
X xlfail("cdr of non-list");
X return (list->n_listvalue->n_listnext);
X}
X
X /*************************************
X * cddr - return the cddr of a list *
X *************************************/
X
Xstatic struct node *cddr(args)
X struct node *args;
X{
X struct node *list;
X
X if ((list = xlmatch(LIST,&args)) == NULL)
X return NULL;
X xllastarg(args);
X
X if (list->n_listnext->n_type != LIST)
X xlfail("cdr of non-list");
X return (list->n_listnext->n_listnext);
X}
X
X
X /*******************************************
X * nth - return the nth element of a list *
X *******************************************/
X
Xstatic struct node *nth(args)
X struct node *args;
X{
X struct node *oldstk,arg,list;
X int n;
X
X oldstk = xlsave(&arg,&list,NULL);
X arg.n_ptr = args;
X
X if ((n = xlmatch(INT,&arg.n_ptr)->n_int) < 1)
X xlfail("invalid argument");
X
X if ((list.n_ptr = xlmatch(LIST,&arg.n_ptr)) == NULL)
X xlfail("invalid argument");
X
X xllastarg(arg.n_ptr);
X
X for (; n > 1; n--)
X {
X list.n_ptr = list.n_ptr->n_listnext;
X if (list.n_ptr == NULL || list.n_ptr->n_type != LIST)
X xlfail("invalid argument");
X }
X
X xlstack = oldstk;
X return (list.n_ptr->n_listvalue);
X}
X
X /*********************************************
X * last - return the last element of a list *
X *********************************************/
X
Xstatic struct node *last(args)
X struct node *args;
X{
X struct node *oldstk,arg,list;
X
X oldstk = xlsave(&arg,&list,NULL);
X arg.n_ptr = args;
X
X if ((list.n_ptr = xlmatch(LIST,&arg.n_ptr)) == NULL)
X xlfail("invalid argument");
X xllastarg(arg.n_ptr);
X
X for (; list.n_ptr->n_listnext; )
X {
X list.n_ptr = list.n_ptr->n_listnext;
X if (list.n_ptr == NULL || list.n_ptr->n_type != LIST)
X xlfail("invalid argument");
X }
X
X xlstack = oldstk;
X return (list.n_ptr->n_listvalue);
X}
X
X /**********************************************
X * memq - is a thing eq to a member of a list *
X ***********************************************/
X
Xstatic struct node *memq(args)
X struct node *args;
X{
X struct node *oldstk,list,*val = NULL,thing;
X
X oldstk = xlsave(&list,&thing,NULL);
X
X thing.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X for (; list.n_ptr != NULL; list.n_ptr = list.n_ptr->n_listnext)
X { if (xeq(list.n_ptr->n_listvalue,thing.n_ptr))
X { val = t;
X break;
X }
X if (!xlistp(list.n_ptr->n_listnext))
X break;
X }
X xlstack = oldstk;
X return (val);
X}
X
X /*******************************************
X * member - is a thing a member of a list *
X ********************************************/
X
Xstatic struct node *member(args)
X struct node *args;
X{
X struct node *oldstk,list,*val = NULL,thing;
X
X oldstk = xlsave(&list,&thing,NULL);
X
X thing.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X for (; list.n_ptr != NULL; list.n_ptr = list.n_ptr->n_listnext)
X if (xequal(list.n_ptr->n_listvalue,thing.n_ptr))
X { val = t;
X break;
X }
X else if (!xlistp(list.n_ptr->n_listnext))
X break;
X
X xlstack = oldstk;
X return (val);
X}
X
X /************************************************
X * subst - subst one sexp for another in a list *
X *************************************************/
X
Xstatic struct node *subst(args)
X struct node *args;
X{
X struct node *oldstk,list,*val = NULL,ptr,from,to;
X
X oldstk = xlsave(&list,&from,&to,&ptr,NULL);
X
X to.n_ptr = xlarg(&args);
X from.n_ptr = xlarg(&args);
X list.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X for (; list.n_ptr != NULL; list.n_ptr = list.n_ptr->n_listnext)
X {
X if (val == NULL) val = ptr.n_ptr = newnode(LIST);
X else {
X ptr.n_ptr->n_listnext = newnode(LIST);
X ptr.n_ptr = ptr.n_ptr->n_listnext;
X ptr.n_ptr->n_listnext = NULL;
X }
X if (xequal(list.n_ptr->n_listvalue,from.n_ptr))
X ptr.n_ptr->n_listvalue = to.n_ptr;
X else
X ptr.n_ptr->n_listvalue = list.n_ptr->n_listvalue;
X }
X xlstack = oldstk;
X return (val);
X}
X
X /************************************************
X * efface - splice an s-expression from a list *
X *************************************************/
X
Xstatic struct node *efface(args, fun)
X struct node *args;
X int (*fun)();
X{
X struct node *oldstk,*list,*val = NULL,*kill, *last = NULL;
X
X kill = xlarg(&args);
X val = list = xlmatch(LIST,&args);
X xllastarg(args);
X
X for (; list != NULL; list = list->n_listnext)
X {
X if ((*fun)(list->n_listvalue,kill)) {
X if (last == NULL) {
X /* delete from top of list */
X val = val->n_listnext;
X continue;
X }
X last->n_listnext = list->n_listnext;
X continue;
X }
X last = list;
X }
X xlstack = oldstk;
X return (val);
X}
X
X /******************************************************
X * delete - delete an s-expression (equal) from a list *
X *******************************************************/
X
Xstatic struct node *delete(args)
X struct node *args;
X{
X return efface(args,xequal);
X}
X
X /*************************************************
X * delq - delete an s-expression (eq) from a list *
X **************************************************/
X
Xstatic struct node *delq(args)
X struct node *args;
X{
X return efface(args,xeq);
X}
X
X /*****************************************
X * length - return the length of a list *
X *****************************************/
X
Xstatic struct node *length(args)
X struct node *args;
X{
X struct node *list,*val;
X int n;
X
X list = xlmatch(LIST,&args);
X xllastarg(args);
X
X for (n = 0; list != NULL; n++)
X list = list->n_listnext;
X
X val = newnode(INT);
X val->n_int = n;
X return (val);
X}
X
X
X /***********************************
X * nconc - builtin function nconc *
X ***********************************/
X
Xstatic struct node *nconc(args)
X struct node *args;
X{
X struct node *oldstk,arg,*list,**last = NULL,val;
X
X oldstk = xlsave(&arg,&val,NULL);
X arg.n_ptr = args;
X
X while (arg.n_ptr != NULL)
X {
X list = xlmatch(LIST,&arg.n_ptr);
X if (!val.n_ptr)
X val.n_ptr = list;
X else
X *last = list; /* hook this list onto last one */
X
X while (list != NULL && list->n_type == LIST)
X {
X if (list->n_listnext == NULL)
X last = &list->n_listnext;
X list = list->n_listnext;
X }
X
X if (list != NULL)
X xlfail("bad list");
X }
X
X xlstack = oldstk;
X return (val.n_ptr);
X}
X
X /*************************************
X * append - builtin function append *
X *************************************/
X
Xstatic struct node *append(args)
X struct node *args;
X{
X struct node *oldstk,arg,list,last,val,*lptr;
X
X oldstk = xlsave(&arg,&list,&last,&val,NULL);
X arg.n_ptr = args;
X
X while (arg.n_ptr != NULL)
X {
X list.n_ptr = xlmatch(LIST,&arg.n_ptr);
X while (list.n_ptr != NULL && list.n_ptr->n_type == LIST)
X {
X lptr = newnode(LIST);
X if (last.n_ptr == NULL)
X val.n_ptr = lptr;
X else
X last.n_ptr->n_listnext = lptr;
X lptr->n_listvalue = list.n_ptr->n_listvalue;
X last.n_ptr = lptr;
X list.n_ptr = list.n_ptr->n_listnext;
X }
X
X if (list.n_ptr != NULL)
X xlfail("bad list");
X }
X
X xlstack = oldstk;
X return (val.n_ptr);
X}
X
X /***************************************
X * reverse - builtin function reverse *
X ***************************************/
X
Xstatic struct node *reverse(args)
X struct node *args;
X{
X struct node *oldstk,list,val,*lptr;
X
X oldstk = xlsave(&list,&val,NULL);
X
X list.n_ptr = xlmatch(LIST,&args);
X xllastarg(args);
X
X while (list.n_ptr != NULL && list.n_ptr->n_type == LIST)
X {
X lptr = newnode(LIST);
X lptr->n_listvalue = list.n_ptr->n_listvalue;
X lptr->n_listnext = val.n_ptr;
X val.n_ptr = lptr;
X
X list.n_ptr = list.n_ptr->n_listnext;
X }
X
X if (list.n_ptr != NULL)
X xlfail("bad list");
X
X xlstack = oldstk;
X return (val.n_ptr);
X}
X
X
X /*************************************
X * cons - construct a new list cell *
X *************************************/
X
Xstatic struct node *cons(args)
X struct node *args;
X{
X struct node *oldstk,arg,arg1,arg2,*lptr;
X
X oldstk = xlsave(&arg,&arg1,&arg2,NULL);
X arg.n_ptr = args;
X
X arg1.n_ptr = xlarg(&arg.n_ptr);
X arg2.n_ptr = xlarg(&arg.n_ptr);
X xllastarg(arg.n_ptr);
X
X lptr = newnode(LIST);
X lptr->n_listvalue = arg1.n_ptr;
X lptr->n_listnext = arg2.n_ptr;
X
X xlstack = oldstk;
X return (lptr);
X}
X
X /*************************************
X * mapcar - builtin function mapcar *
X *************************************/
X
Xstatic struct node *mapcar(args)
X struct node *args;
X{
X struct node *oldstk,fun,arglist,list,val,thisarg,
X *argtop,*arg,*last,*lptr, *buildptr, *buildlast;
X oldstk = xlsave(&fun,&arglist,&thisarg,&list,&val,NULL);
X
X fun.n_ptr = xlarg(&args);
X
X arglist.n_ptr = xlist(args); /* copy arglist */
X
X for (last = NULL; arglist.n_ptr->n_listvalue != NULL; last = lptr)
X {
X /* build list of args for this pass */
X for (buildlast = NULL, buildptr = arglist.n_ptr; buildptr != NULL;
X buildptr = buildptr->n_listnext)
X {
X /* get a cell */
X if (buildlast == NULL)
X buildlast = thisarg.n_ptr = newnode(LIST);
X else {
X buildlast->n_listnext = newnode(LIST);
X buildlast = buildlast->n_listnext;
X }
X /* from the list now pointed to by buildptr, pop the top
X item from that sublist */
X buildlast->n_listvalue = xlarg(&buildptr->n_listvalue);
X }
X val.n_ptr = xlapply(fun.n_ptr,thisarg.n_ptr);
X lptr = newnode(LIST);
X if (last == NULL)
X list.n_ptr = lptr;
X else
X last->n_listnext = lptr;
X lptr->n_listvalue = val.n_ptr;
X thisarg.n_ptr = NULL; /* ensure storage is reclaimed */
X }
X
X xlstack = oldstk;
X return (list.n_ptr);
X}
X
Xstatic struct node *mapcan(args) struct node *args;
X{
X struct node *oldstk, list, *val;
X oldstk = xlsave(&list,NULL);
X list.n_ptr = mapcar(args);
X val = xlapply(NCONC,list.n_ptr);
X xlstack = oldstk;
X return val;
X}
X
X /************************************************
X * xllinit - xlisp list initialization routine *
X ************************************************/
X
Xxllinit()
X{
X /* define some symbols */
X t = xlenter("t");
X a_fsubr = xlenter("FSUBR");
X a_subr = xlenter("SUBR");
X a_list = xlenter("LIST");
X a_sym = xlenter("SYM");
X a_int = xlenter("INT");
X a_real = xlenter("REAL");
X a_str = xlenter("STR");
X a_obj = xlenter("OBJ");
X a_fptr = xlenter("FPTR");
X a_kmap = xlenter("KMAP");
X
X /* functions with reasonable names */
X xlsubr("head",head);
X xlsubr("tail",tail);
X xlsubr("nth",nth);
X
X /* real lisp functions */
X xlsubr("atom",atom);
X xlsubr("eq",eq);
X xlsubr("equal",equal);
X xlsubr("null",null);
X xlsubr("type",type);
X xlsubr("listp",listp);
X xlsubr("numberp",numberp);
X xlfsubr("cond",cond);
X xlsubr("list",xlist);
X xlsubr("cons",cons);
X xlsubr("car",head);
X xlsubr("cdr",tail);
X xlsubr("caar",caar);
X xlsubr("cadr",cadr);
X xlsubr("cdar",cdar);
X xlsubr("cddr",cddr);
X xlsubr("rplaca",rplaca);
X xlsubr("rplacd",rplacd);
X xlsubr("member",member);
X xlsubr("memq",memq);
X xlsubr("subst",subst);
X xlsubr("append",append);
X xlsubr("nconc",nconc);
X NCONC = xlget(xlenter("nconc"),a_subr);
X xlsubr("reverse",reverse);
X xlsubr("length",length);
X xlsubr("last",last);
X xlsubr("mapcar",mapcar);
X xlsubr("mapcan",mapcan);
X xlsubr("delete",delete);
X xlsubr("delq",delq);
X}
!Funky!Stuff!
echo x xlobj.c
sed -n -e 's/^X//p' > xlobj.c << '!Funky!Stuff!'
X /* xlobj - xlisp object functions */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X
X#ifdef unix
X#include <stdio.h>
X#include "xlisp.h"
X#endif
X
X
X /* global variables */
X
Xstruct node *self;
X
X
X /* external variables */
X
Xextern struct node *xlstack;
Xextern struct node *xlenv;
Xextern int (*xlofun)();
X
X /* local variables */
X
Xstatic struct node *class;
Xstatic struct node *object;
Xstatic struct node *new;
Xstatic struct node *isnew;
Xstatic struct node *msgcls;
Xstatic struct node *msgclass;
Xstatic struct node *lambda;
Xstatic int varcnt;
X
X /* instance variable numbers for the class 'Class' */
X
X#define MESSAGES 0 /* list of messages */
X#define IVARS 1 /* list of instance variable names */
X#define CVARS 2 /* list of class variable names */
X#define CVALS 3 /* list of class variable values */
X#define SUPERCLASS 4 /* pointer to the superclass */
X#define IVARCNT 5 /* number of class instance variables */
X#define IVARTOTAL 6 /* total number of instance variables */
X
X
X /* number of instance variables for the class 'Class' */
X
X#define CLASSSIZE 7
X
X
X#ifdef HACK
X /* forward declarations (the extern hack is because of decusc) */
X
Xextern struct node *findmsg();
Xextern struct node *findvar();
Xextern struct node *defvars();
Xextern struct node *makelist();
X#endif
X
X /*****************************
X * xlclass - define a class *
X *****************************/
X
Xstruct node *xlclass(name,vcnt)
X char *name; int vcnt;
X{
X struct node *sym,*cls;
X
X sym = xlenter(name); /* Create the class */
X cls = sym->n_symvalue = newnode(OBJ);
X cls->n_obclass = class;
X cls->n_obdata = makelist(CLASSSIZE);
X
X if (vcnt > 0) /* Set instance var count */
X {
X (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = vcnt;
X (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = vcnt;
X }
X
X xlivar(cls,SUPERCLASS)->n_listvalue = object; /* superclass = object */
X
X return (cls);
X}
X
X
X /******************************************************************
X * xlmfind - find the message binding for a message to an object *
X ******************************************************************/
X
Xstruct node *xlmfind(obj,msym)
X struct node *obj,*msym;
X{
X return (findmsg(obj->n_obclass,msym));
X}
X
X
X /******************************************
X * xlxsend - send a message to an object *
X ******************************************/
X
Xstruct node *xlxsend(obj,msg,args)
X struct node *obj,*msg,*args;
X{
X struct node *oldstk,method,cptr,val,*isnewmsg,*oldenv;
X
X oldenv = xlenv; /* Save old environment */
X oldstk = xlsave(&method,&cptr,&val,NULL);
X
X method.n_ptr = msg->n_msgcode; /* Get method for this msg */
X if (method.n_ptr->n_type != FSUBR && method.n_ptr->n_type != SUBR
X && method.n_ptr->n_type != LIST)
X xlfail("bad method");
X
X xlbind(self,obj); /* Bind 'self' and 'msgclass' */
X xlbind(msgclass,msgcls);
X
X if (method.n_ptr->n_type == FSUBR) /* Evaluate function */
X {
X xlfixbindings(oldenv); /* make above bindings visible */
X val.n_ptr = (*method.n_ptr->n_subr)(args);
X }
X else if (method.n_ptr->n_type == SUBR)
X {
X cptr.n_ptr = xlevlis(args); /* evaluate args in old env */
X xlfixbindings(oldenv); /* make above bindings visible */
X val.n_ptr = (*method.n_ptr->n_subr)( cptr.n_ptr );
X }
X else
X { /* cons up a lambda to apply */
Xprintf("XLEVLIS[ "); xlprint(args,TRUE); printf(" ]\n");
X val.n_ptr = xlevlis(args); /* evaluate args in old env */
X xlfixbindings(oldenv); /* now make above bindings visible */
X cptr.n_ptr = newnode(LIST);
X cptr.n_ptr->n_listvalue = lambda;
X cptr.n_ptr->n_listnext = method.n_ptr;
X val.n_ptr = xlapply(cptr.n_ptr,val.n_ptr);
X }
X xlunbind(oldenv); /* Restore environment */
X
X /* after creating an object, send it the "isnew" message */
X if (msg->n_msg == new && val.n_ptr != NULL)
X {
X if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NULL)
X xlfail("no method for the isnew message");
X val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
X }
X
X xlstack = oldstk; /* Restore old stack frame */
X return (val.n_ptr);
X}
X
X
X /***************************************************************
X * xlsend - send a message to an object (message in arg list) *
X ***************************************************************/
X
Xstruct node *xlsend(obj,args)
X struct node *obj,*args;
X{
X struct node *msg;
X
X if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NULL)
X xlfail("no method for this message");
X
X return (xlxsend(obj,msg,args));
X}
X
X
X /***********************************************************************
X * xlobsym - find a class or instance variable for the current object *
X ***********************************************************************/
X
Xstruct node *xlobsym(sym)
X struct node *sym;
X{
X struct node *obj;
X
X if ((obj = self->n_symvalue) != NULL && obj->n_type == OBJ)
X return (findvar(obj,sym));
X else
X return (NULL);
X}
X
X /****************************************
X * mnew - create a new object instance *
X ****************************************/
X
Xstatic struct node *mnew()
X{
X struct node *oldstk,obj,*cls;
X
X oldstk = xlsave(&obj,NULL); /* New stack frame */
X
X cls = self->n_symvalue; /* Get class name */
X
X obj.n_ptr = newnode(OBJ); /* Generate new object */
X obj.n_ptr->n_obclass = cls;
X obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
X
X xlstack = oldstk; /* Restore old stack frame */
X return (obj.n_ptr);
X}
X
X
X /************************************
X * misnew - initialize a new class *
X ************************************/
X
Xstatic struct node *misnew(args)
X struct node *args;
X{
X struct node *oldstk,super,*obj;
X
X oldstk = xlsave(&super,NULL); /* Create new stack frame */
X
X if (args != NULL) /* Get superclass is present */
X super.n_ptr = xlevmatch(OBJ,&args);
X else
X super.n_ptr = object;
X
X xllastarg(args); /* Check no more args */
X
X obj = self->n_symvalue; /* Get the object */
X xlivar(obj,SUPERCLASS)->n_listvalue = super.n_ptr;
X (xlivar(obj,IVARTOTAL)->n_listvalue = newnode(INT))->n_int =
X getivcnt(super.n_ptr,IVARTOTAL);
X
X xlstack = oldstk; /* Restore stack frame */
X return (obj);
X}
X
X
X /*******************************************
X * xladdivar - enter an instance variable *
X *******************************************/
X
Xxladdivar(cls,var)
X struct node *cls; char *var;
X{
X struct node *ivar,*lptr;
X
X ivar = xlivar(cls,IVARS); /* Find 'ivars' instance var */
X
X lptr = newnode(LIST); /* add instance var */
X lptr->n_listnext = ivar->n_listvalue;
X ivar->n_listvalue = lptr;
X lptr->n_listvalue = xlenter(var);
X}
X
X
X /****************************************
X * entermsg - add a message to a class *
X ****************************************/
X
Xstatic struct node *entermsg(cls,msg)
X struct node *cls,*msg;
X{
X struct node *ivar,*lptr,*mptr;
X
X ivar = xlivar(cls,MESSAGES); /* Find 'messages' iv */
X
X for (lptr = ivar->n_listvalue; lptr != NULL; lptr = lptr->n_listnext)
X if ((mptr = lptr->n_listvalue)->n_msg == msg)
X return (mptr);
X
X /* allocate a new message entry if one wasn't found */
X lptr = newnode(LIST);
X lptr->n_listnext = ivar->n_listvalue;
X ivar->n_listvalue = lptr;
X lptr->n_listvalue = mptr = newnode(LIST);
X mptr->n_msg = msg;
X
X return (mptr); /* Return the symbol node */
X}
X
X
X /*****************************************************
X * answer - define a method for answering a message *
X *****************************************************/
X
Xstatic struct node *answer(args)
X struct node *args;
X{
X struct node *oldstk,arg,msg,fargs,code;
X struct node *obj,*mptr,*fptr;
X
X oldstk = xlsave(&arg,&msg,&fargs,&code,NULL); /* New stack frame */
X arg.n_ptr = args;
X
X msg.n_ptr = xlevmatch(SYM,&arg.n_ptr); /* Message symbol */
X
X fargs.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* Formal arg list */
X code.n_ptr = xlevmatch(LIST,&arg.n_ptr); /* the code */
X xllastarg(arg.n_ptr); /* End of args */
X
X obj = self->n_symvalue; /* Object node */
X mptr = entermsg(obj,msg.n_ptr); /* New message list entry */
X
X mptr->n_msgcode = fptr = newnode(LIST); /* Set up message node */
X fptr->n_listvalue = fargs.n_ptr;
X fptr->n_listnext = code.n_ptr;
X
X xlstack = oldstk; /* Restore old stack frame */
X return (obj);
X}
X
X
X /***************************************************
X * mivars - define the list of instance variables *
X ***************************************************/
X
Xstatic struct node *mivars(args)
X struct node *args;
X{
X struct node *cls,*super;
X int scnt;
X
X cls = defvars(args,IVARS); /* Define list of ivs */
X
X if ((super = xlivar(cls,SUPERCLASS)->n_listvalue) != NULL)
X scnt = getivcnt(super,IVARTOTAL);
X else
X scnt = 0;
X
X (xlivar(cls,IVARCNT)->n_listvalue = newnode(INT))->n_int = varcnt;
X (xlivar(cls,IVARTOTAL)->n_listvalue = newnode(INT))->n_int = scnt+varcnt;
X
X return (cls);
X}
X
X
X
X /****************************************************************
X * getivcnt - get the number of instance variables for a class *
X ****************************************************************/
X
Xstatic int getivcnt(cls,ivar)
X struct node *cls; int ivar;
X{
X struct node *cnt;
X
X if ((cnt = xlivar(cls,ivar)->n_listvalue) != NULL)
X if (cnt->n_type == INT)
X return (cnt->n_int);
X else
X xlfail("bad value for instance variable count");
X else
X return (0);
X}
X
X
X
X /************************************************
X * mcvars - define the list of class variables *
X ************************************************/
X
Xstatic struct node *mcvars(args)
X struct node *args;
X{
X struct node *cls;
X
X cls = defvars(args,CVARS); /* define list of class vars */
X xlivar(cls,CVALS)->n_listvalue = makelist(varcnt); /* make new list */
X
X return (cls);
X}
X
X
X
X /*******************************************************
X * defvars - define a class or instance variable list *
X *******************************************************/
X
Xstatic struct node *defvars(args,varnum)
X struct node *args; int varnum;
X{
X struct node *oldstk,vars,*vptr,*cls,*sym;
X
X oldstk = xlsave(&vars,NULL); /* Create new stack frame */
X vars.n_ptr = xlevmatch(LIST,&args); /* Get ivar list */
X xllastarg(args); /* Last argument ! */
X
X cls = self->n_symvalue; /* Class node */
X
X varcnt = 0; /* Check each var in list */
X for (vptr = vars.n_ptr;
X vptr != NULL && vptr->n_type == LIST;
X vptr = vptr->n_listnext)
X {
X /* make sure this is a valid symbol in the list */
X if ((sym = vptr->n_listvalue) == NULL || sym->n_type != SYM)
X xlfail("bad variable list");
X
X if (checkvar(cls,sym)) /* Check not already defined */
X xlfail("multiply defined variable");
X varcnt++; /* Count the variable */
X }
X
X if (vptr != NULL) /* Check for correct end */
X xlfail("bad variable list");
X
X xlivar(cls,varnum)->n_listvalue = vars.n_ptr; /* Define new list */
X
X xlstack = oldstk; /* Restore old stack frame */
X return (cls);
X}
X
X
X
X /****************************************
X * xladdmsg - add a message to a class *
X ****************************************/
X
Xxladdmsg(cls,msg,code)
X struct node *cls; char *msg; struct node *(*code)();
X{
X struct node *mptr;
X
X mptr = entermsg(cls,xlenter(msg)); /* enter message selector */
X mptr->n_msgcode = newnode(FSUBR); /* Store the method */
X mptr->n_msgcode->n_subr = code;
X}
X
X
X
X /******************************************
X * getclass - get the class of an object *
X ******************************************/
X
Xstatic struct node *getclass(args)
X struct node *args;
X{
X xllastarg(args); /* Check no arguments */
X return (self->n_symvalue->n_obclass);
X}
X
X
X
X /******************************
X * obprint - print an object *
X ******************************/
X
Xstatic struct node *obprint(args)
X struct node *args;
X{
X char buf[20];
X xllastarg(args); /* Check no arguments */
X
X sprintf(buf,"<Object: #%o>",self->n_symvalue);
X (*xlofun)(buf);
X return (self->n_symvalue);
X}
X
X
X
X /******************************************************
X * obshow - show the instance variables of an object *
X ******************************************************/
X
Xstatic struct node *obshow(args)
X struct node *args;
X{
X xllastarg(args); /* Check no arguments */
X
X xlprint(self->n_symvalue->n_obdata,TRUE);
X return (self->n_symvalue);
X}
X
X
X
X /**************************************
X * defisnew - default 'isnew' method *
X **************************************/
X
Xstatic struct node *defisnew(args)
X struct node *args;
X{
X xllastarg(args); /* Check for null arg list */
X return (self->n_symvalue);
X}
X
X
X
X /*********************************************************
X * sendsuper - send a message to an object's superclass *
X *********************************************************/
X
Xstatic struct node *sendsuper(args)
X struct node *args;
X{
X struct node *obj,*super,*msg;
X
X obj = self->n_symvalue; /* Get the object and its super class */
X super = xlivar(obj->n_obclass,SUPERCLASS)->n_listvalue;
X
X /* Find message binding */
X if ((msg = findmsg(super,xlevmatch(SYM,&args))) == NULL)
X xlfail("no method for this message");
X
X return (xlxsend(obj,msg,args)); /* and send it */
X}
X
X
X /*******************************************************************
X * findmsg - find the message binding given an object and a class *
X *******************************************************************/
X
Xstatic struct node *findmsg(cls,sym)
X struct node *cls,*sym;
X{
X struct node *lptr,*msg;
X
X msgcls = cls; /* Start at specified class */
X while (msgcls != NULL) /* Look for the message */
X {
X for (lptr = xlivar(msgcls,MESSAGES)->n_listvalue;
X lptr != NULL;
X lptr = lptr->n_listnext)
X if ((msg = lptr->n_listvalue) != NULL && msg->n_msg == sym)
X return (msg);
X
X msgcls = xlivar(msgcls,SUPERCLASS)->n_listvalue;
X }
X
X return (NULL); /* Message not found */
X}
X
X
X /************************************************
X * findvar - find a class or instance variable *
X ************************************************/
X
Xstatic struct node *findvar(obj,sym)
X struct node *obj,*sym;
X{
X struct node *cls,*lptr;
X int base,varnum;
X int found;
X
X cls = obj->n_obclass; /* Get class of object */
X base = getivcnt(cls,IVARTOTAL); /* Get number of ivs */
X found = FALSE; /* Find the var */
X for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue)
X {
X if ((base -= getivcnt(cls,IVARCNT)) < 0)
X xlfail("error finding instance variable");
X
X if (!found && cls == msgclass->n_symvalue)
X found = TRUE;
X
X varnum = 0; /* Lookup the iv */
X for (lptr = xlivar(cls,IVARS)->n_listvalue;
X lptr != NULL;
X lptr = lptr->n_listnext) {
X if (found && lptr->n_listvalue == sym)
X return (xlivar(obj,base + varnum));
X else
X varnum++;
X }
X
X if (!found) /* Skip class vars if found */
X continue;
X
X varnum = 0; /* Lookup class vars */
X for (lptr = xlivar(cls,CVARS)->n_listvalue;
X lptr != NULL;
X lptr = lptr->n_listnext)
X if (lptr->n_listvalue == sym)
X return (xlcvar(cls,varnum));
X else
X varnum++;
X }
X
X return (NULL); /* Var not found */
X}
X
X
X /****************************************************************
X * checkvar - check for an existing class or instance variable *
X ****************************************************************/
X
Xstatic int checkvar(cls,sym)
X struct node *cls,*sym;
X{
X struct node *lptr;
X
X for (; cls != NULL; cls = xlivar(cls,SUPERCLASS)->n_listvalue)
X {
X for (lptr = xlivar(cls,IVARS)->n_listvalue; /* Lookup instance var */
X lptr != NULL;
X lptr = lptr->n_listnext)
X if (lptr->n_listvalue == sym)
X return (TRUE);
X
X for (lptr = xlivar(cls,CVARS)->n_listvalue; /* Lookup class var */
X lptr != NULL;
X lptr = lptr->n_listnext)
X if (lptr->n_listvalue == sym)
X return (TRUE);
X }
X
X return (FALSE); /* Var not found */
X}
X
X
X /**************************************
X * xlivar - get an instance variable *
X **************************************/
X
Xstruct node *xlivar(obj,num)
X struct node *obj; int num;
X{
X struct node *ivar;
X
X for (ivar = obj->n_obdata; num > 0; num--) /* Get instance var */
X if (ivar != NULL)
X ivar = ivar->n_listnext;
X else
X xlfail("bad instance variable list");
X
X return (ivar);
X}
X
X
X /**********************************
X * xlcvar - get a class variable *
X **********************************/
X
Xstruct node *xlcvar(cls,num)
X struct node *cls; int num;
X{
X struct node *cvar;
X
X for (cvar = xlivar(cls,CVALS)->n_listvalue; num > 0; num--)
X if (cvar != NULL)
X cvar = cvar->n_listnext;
X else
X xlfail("bad class variable list");
X
X return (cvar);
X}
X
X
X
X /************************************
X * makelist - make a list of nodes *
X ************************************/
X
Xstatic struct node *makelist(cnt)
X int cnt;
X{
X struct node *oldstk,list,*lnew;
X
X oldstk = xlsave(&list,NULL); /* Create a new stack frame */
X
X for (; cnt > 0; cnt--) /* Make the list */
X {
X lnew = newnode(LIST);
X lnew->n_listnext = list.n_ptr;
X list.n_ptr = lnew;
X }
X
X xlstack = oldstk; /* Restore the old stack frame */
X return (list.n_ptr);
X}
X
X
X /*****************************************************
X * xloinit - object function initialization routine *
X *****************************************************/
X
Xxloinit()
X{
X class = NULL; /* Dont confuse gc */
X object = NULL;
X
X new = xlenter("new"); /* Enter object realtaed symbols */
X isnew = xlenter("isnew");
X self = xlenter("self");
X msgclass = xlenter("msgclass");
X lambda = xlenter("lambda");
X
X class = xlclass("Class",CLASSSIZE); /* Create 'Class' object */
X class->n_obclass = class;
X
X object = xlclass("Object",0); /* Create 'Object class */
X
X xlivar(class,SUPERCLASS)->n_listvalue = object;
X xladdivar(class,"ivartotal"); /* ivar number 6 */
X xladdivar(class,"ivarcnt"); /* ivar number 5 */
X xladdivar(class,"superclass"); /* ivar number 4 */
X xladdivar(class,"cvals"); /* ivar number 3 */
X xladdivar(class,"cvars"); /* ivar number 2 */
X xladdivar(class,"ivars"); /* ivar number 1 */
X xladdivar(class,"messages"); /* ivar number 0 */
X xladdmsg(class,"new",mnew);
X xladdmsg(class,"answer",answer);
X xladdmsg(class,"ivars",mivars);
X xladdmsg(class,"cvars",mcvars);
X xladdmsg(class,"isnew",misnew);
X
X xladdmsg(object,"class",getclass);
X xladdmsg(object,"print",obprint);
X xladdmsg(object,"show",obshow);
X xladdmsg(object,"isnew",defisnew);
X xladdmsg(object,"sendsuper",sendsuper);
X}
!Funky!Stuff!
echo x xlprin.c
sed -n -e 's/^X//p' > xlprin.c << '!Funky!Stuff!'
X
X /* xlprint - xlisp print routine */
X
X#ifdef CI_86
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef AZTEC
X#include "a:stdio.h"
X#include "xlisp.h"
X#endif
X
X#ifdef unix
X#include <stdio.h>
X#include "xlisp.h"
X#include <ctype.h>
X#endif
X
X
X /* external variables */
X
Xextern struct node *xlstack;
Xextern FILE *ofp;
Xextern xlfout();
X /* global variables */
Xextern int (*xlofun)() = xlstrout; /* current output function */
X
X /* local variables */
Xstatic struct node *printsym;
X
X
X /***********************************
X * print - builtin function print *
X ***********************************/
X
Xstatic struct node *print(args)
X struct node *args;
X{ struct node *r;
X r = xprint(args,TRUE);
X (*xlofun)("\n");
X return r;
X}
X
Xstatic struct node *prin1(args)
X struct node *args;
X{
X return xprint(args,TRUE);
X}
X
X /***********************************
X * princ - builtin function princ *
X ***********************************/
X
Xstatic struct node *princ(args)
X struct node *args;
X{
X return xprint(args,FALSE);
X}
X
X
X /***********************************
X * xprint - common print function *
X ***********************************/
X
Xxprint(args,flag)
X struct node *args; int flag;
X{
X struct node *oldstk,arg,val;
X
X oldstk = xlsave(&arg,&val,NULL); /* New stack frame */
X arg.n_ptr = args;
X
X while (arg.n_ptr != NULL) /* Evaluate an print each arg */
X xlprint(xlarg(&arg.n_ptr),flag);
X xlstack = oldstk; /* Restore old stack frame */
X return (NULL);
X}
X
X /*****************************************************************
X * anyfunny - do any of the characters deserve to be |protected| *
X *****************************************************************/
Xstatic anyfunny(s) char *s;
X{
X if (isallnumeric(s)) return 1; /* see xlread.c */
X while (*s) {
X if (isspace(*s)) return 1;
X if (index("() .'\";\\",*s))
X return 1;
X s++;
X }
X return 0;
X}
X /***********************************
X * xlprint - print an xlisp value *
X ***********************************/
X
Xxlprint(vptr,flag)
X struct node *vptr; int flag;
X{
X struct node *nptr,*next,*msg;
X char obuf[512];
X#ifdef FGETNAME
X char buffer[128];
X#endif
X
X if (vptr == NULL) /* Print NULL as the empty list */
X {
X (*xlofun)("()");
X return;
X }
X
X switch (vptr->n_type) /* Check value type */
X {
X case FSUBR:
X sprintf(obuf,"<FSUBR: #%o>",vptr);
X (*xlofun)(obuf);
X break;
X
X case SUBR:
X sprintf(obuf,"<SUBR: #%o>",vptr);
X (*xlofun)(obuf);
X break;
X
X case LIST:
X (*xlofun)("(");
X for (nptr = vptr; nptr != NULL; nptr = next)
X {
X xlprint(nptr->n_listvalue,flag);
X if ((next = nptr->n_listnext) != NULL)
X if (next->n_type == LIST)
X (*xlofun)(" ");
X else
X {
X (*xlofun)(" . ");
X xlprint(next,flag);
X break;
X }
X }
X (*xlofun)(")");
X break;
X
X case SYM:
X if (flag && anyfunny(vptr->n_symname)) {
X if (vptr->n_symname[1] == 0 || isallnumeric(vptr->n_symname))
X sprintf(obuf,"\\%s",vptr->n_symname);
X else
X sprintf(obuf,"|%s|",vptr->n_symname);
X }
X else
X sprintf(obuf,"%s",vptr->n_symname);
X (*xlofun)(obuf);
X break;
X
X case INT:
X sprintf(obuf,"%d",vptr->n_int);
X (*xlofun)(obuf);
X break;
X
X#ifdef REALS
X case REAL:
X sprintf(obuf,"%g",vptr->n_real);
X (*xlofun)(obuf);
X break;
X#endif
X
X case STR:
X if (flag)
X putstring(vptr->n_str);
X else {
X sprintf(obuf,"%s",vptr->n_str);
X (*xlofun)(obuf);
X }
X break;
X
X case FPTR:
X
X#ifdef FGETNAME
X sprintf(obuf,"<File: %s>",fgetname(vptr->n_fp, buffer));
X#else
X sprintf(obuf,"<File: #%o>",vptr);
X#endif
X (*xlofun)(obuf);
X break;
X
X case OBJ:
X if ((msg = xlmfind(vptr,printsym)) == NULL)
X xlfail("no print message");
X xlxsend(vptr,msg,NULL);
X break;
X
X case KMAP:
X sprintf(obuf,"<Kmap: #%o>",vptr);
X (*xlofun)(obuf);
X break;
X
X default:
X printf("Invalid node type %d", vptr->n_type);
X break;
X }
X}
X
X
X /********************************
X * putstring - output a string *
X ********************************/
X
Xstatic putstring(str)
X char *str;
X{
X int ch;
X char obuf[6];
X
X (*xlofun)("\"");
X while (ch = *str++)
X if (ch < 040 || ch == '\\') /* Check for control char */
X {
X (*xlofun)("\\");
X switch (ch)
X {
X case '\033':
X (*xlofun)("e");
X break;
X
X case '\n':
X (*xlofun)("n");
X break;
X
X case '\r':
X (*xlofun)("r");
X break;
X
X case '\t':
X (*xlofun)("t");
X break;
X
X case '\\':
X (*xlofun)("\\");
X break;
X
X default:
X sprintf(obuf,"%03o",ch);
X (*xlofun)(obuf);
X break;
X }
X }
X else /* Output a normal char */
X { obuf[0] = ch; obuf[1] = 0;
X (*xlofun)(obuf);
X }
X
X (*xlofun)("\"");
X}
X
Xstatic struct node *terpri(args) struct node *args; {
X xllastarg(args);
X (*xlofun)("\n");
X return NULL;
X}
X
X /**********************************************
X * temporarily redirect the standard output *
X **********************************************/
X
Xstatic struct node *redirect(args) struct node *args; {
X struct node *argp;
X if (args == NULL)
X xlfout(0);
X else {
X argp = xlmatch(STR,&args);
X xllastarg(args);
X xlfout(argp->n_str);
X }
X return NULL;
X}
X
X /*********************************
X * normal output routine *
X ********************************/
Xxlstrout(s) char *s;
X{
X fputs(s,ofp);
X}
X
X /********************************************
X * xlpinit - initialize the print routines *
X ********************************************/
X
Xxlpinit()
X{
X printsym = xlenter("print"); /* Find the print symbol */
X
X xlsubr("prin1",prin1);
X xlsubr("print",print); /* Enter the built in functions */
X xlsubr("princ",princ);
X xlsubr("terpri",terpri);
X xlsubr("redirect",redirect);
X}
X
!Funky!Stuff!
exit 0
--
John Woods, Charles River Data Systems, Framingham MA, (617) 626-1114
...!decvax!frog!john, ...!mit-eddie!jfw, JFW@MIT-XX.ARPA
I have absolutely nothing clever to say in this signature.