[net.sources] Modified XLISP, Part 1 of 5

john@x.UUCP (John Woods) (08/27/84)

This represents part 1 of 5 of my modified XLISP.  Tear at the dotted line,
and run "sh" over it to extract.  Part 1 here includes a list of most of
the differences in this XLISP and the original.

Thanks to Dave Betz for providing the original XLISP.
________________________________________________________________
echo extract with /bin/sh, not /bin/csh
echo x differences
sed -n -e 's/^X//p' > differences << '!Funky!Stuff!'
XA ROUGH LIST OF DIFFERENCES BETWEEN MY XLISP AND THE ORIGINAL
X
XThe first change was to have subrs not evaluate their own arguments; there
Xare now two kinds of machine routines, SUBR and FSUBR;  SUBRs get their
Xarguments evaluated already (in a list, which makes them also equivalent
Xto MACLISP LSUBRs at no extra cost), FSUBRs are handed the raw list of
Xarguments.  (This enabled me to create the APPLY and FUNCALL routines).
XNext, I changed DEFUN to put the symbol LAMBDA in front of function lists
X(just for compatibility), and recoded DEFUN to check the second argument for
Xbeing a keyword of FEXPR or MACRO; FEXPRs are like ordinary defined functions
X(EXPRs) except that they don't evaluate their arguments; the argument list is
Xbound to the single formal parameter and handed to the function code.  MACROs
Xget the entire _form_ (s-expression) bound to their formal parameter, and their
Xreturn value is re-interpreted by eval (thus, macros create code which is to
Xsubstitute for the original).
X
XThen, I implemented property lists (see GET, PUTPROP, DEFPROP, REMPROP), and
Xmodified eval to expect function definitions to be on one of the following
Xproperties of a symbol:  SUBR EXPR FSUBR FEXPR MACRO (the last three get the
Xappropriate special treatment).  As a last resort, the symbol is evaluated to
Xfind a function (which must be a SUBR, FSUBR, or lambda EXPR) (I actually like
Xthat kind of functionality, but I wanted to be somewhat compatible with
XMACLISP).
X
XInteresting note:  putprop (which gets evaluated arguments) and defprop (which
Xgets quoted arguments) are exactly the same internal function, but are
Xdistinguished by one being a SUBR, and the other an FSUBR.  I thought it was
Xneat.
X
XI also implemented RPLACA and RPLACD (and other destructive functions).  I
Xhaven't seen any problems yet, and the garbage collector looks like it can
Xhandle it.  Also, the main loop of XLISP traps SIGINT in case you create a
Xcircular list (thus allowing you to get out of the infinite printing).
X
XI devised a way of redirecting the (print) output stream (see REDIRECT). I
Xalso implemented a way of redirecting output into a string, but it isn't made
Xavailable to LISP programs (it is used by EXPLODE and EXPLODEC). 
X
XLastly, I created PROG and DO (old-style MACLISP do), and their associated
Xhairy routines RETURN and GO.  I don't like the way I implemented these, so
Xwatch out for bugs.
X
XThe following is a list of functions which I have created (some are old, but
Xhave additional names, such as ! also becoming not).  Some of them have been
Xslightly modified (i.e., and, or).
X----------------------------------------------------------------
X
X( ! arg)
X( not arg)
X	not takes one argument, returning t if the argument is
Xnil, nil otherwise.
X
X( % arg1 arg2)
X( remainder arg1 arg2)
X	remainder takes two arguments, returning the remainder of
Xarg1 / arg2.
X
X( && forms...)							Special form
X( and forms...)							Special form
X	and takes a number of forms, and evaluates the forms sequentially
Xuntil a form evaluates to nil, at which point and returns nil. If
Xno form evaluates to nil, t is returned.
X
X( * number...)
X(times number...)
X	* takes a sequence of numerical values and returns the product
Xof all of them.  If any value is of type REAL, the result is REAL, otherwise
Xthe result is an integer.
X
X( + number...)
X(plus number...)
X	+ takes a sequence of numerical values and returns the sum of all
Xof them.  If any value is of type REAL, the result is REAL, otherwise the
Xresult is an integer.
X
X
X( - number...)
X(difference number...)
X	The value of - is the value of the first argument, less the value
Xof each successive argument.  If any value is of type REAL, the result is
XREAL, otherwise the result is an integer.
X
X( / number...)
X( quotient number...)
X	The value of / is the value of the first argument divided by the
Xvalue of each successive argument.  If any value is of type REAL, the result
Xis REAL, otherwise the result is an integer.
X
X( < number1 number2)
X( lessp number1 number2)
X	If \fInumber1 is numerically less than \fInumber2, lessp returns
Xt, else nil.
X
X( = number1 number2)
X( == number1 number2)
X	If \fInumber1 and \fInumber2 are numerically equal, = returns t,
Xelse nil.
X
X( > number1 number2)
X( greaterp number1 number2)
X	If \fInumber1 > \fInumber2, greaterp returns t.
X
X( apply fun arglist)
X	apply applies the given function to the argument list.  The
X	argument list is evaluated by eval before handing to apply, and
X	apply does not further evaluate it.  (apply fun args) is roughly
X	equivalent to (fun args).  apply only works properly on SUBRs and
X	EXPRs; the results from MACROs, FSUBRs, and FEXPRs may not be what you
X	expect.
X	(apply 'cons '(a b)) ==> (a.b)
X
X(arg number)
X	This returns the \fInumberth argument to the current lexpr
X	invocation.  See defun.
X
X( assoc thing a-list)
X	assoc looks up the value of a thing according to an association
X	list which is formatted as follows:
X		( ( BOUND_TO . BINDING) (next . pair) ...)
X	assoc searches the association list for a list cell whose car is
X	equal to the thing to search for, and returns that cell.  The
X	"binding" of the object is the cdr of that cell.  If no such cell is
X	found, assoc returns ().
X	( assoc 'fred '( (barney . rubble) (fred . flintstone) (questor)))
X		==> (fred . flintstone)
X	( assoc 'john '( (barney . rubble) (fred . flintstone) (questor)))
X  		==> ()
X
X( assq thing a-list)
X	assq is like assoc, but uses the comparator eq rather than
X	equal.
X
X( atan value [ value ])
X	atan returns the arc tangent of its argument.  If two arguments
X	are given, atan returns the result of the C/FORTRAN function
X	atan2(value1,value2).
X
X( atom thing)
X( atomp thing)
X	atomp returns t if the argument is not a list cell.
X
X( caar thing)
X( cadr thing)
X( cdar thing)
X( cddr thing)
X	These functions return the functional composition of a pair of car's
X	or cdr's; (cadr foo) is exactly equivalent to (car (cdr foo)).
X
X( comment any arbitrary list structure)				Special Form
X	comment returns t without evaluating its arguments.  Its intended
X	use is to comment LISP code in such a way that the comment does not
X	vanish.
X
X( cos number)
X	cos returns the cosine of the argument.	
X
X( defprop symbol value prop)					Special Form
X	defprop does not evaluate its arguments.  defprop puts the
X	value on the prop property indicator of the atom given.  See also
X	putprop.
X
X( defun symbol [ tag ] formalargs [ forms ] )			Special Form
X	defun defines a function by creating a lambda expression (e.g.,
X	(lambda (args) forms...) ), and placing it in the property list of
X	the symbol (which is the "name" of the function).  The \fIformalargs
X	parameter must be a list of symbols, which will be bound to the actual
X	parameters at evaluation time, or it must be a single atom, which will
X	be bound to the number of arguments at invocation time (this defines
X	a lexpr. See also arg).  If an atom comes between the function
X	name and the parameter list, it declares the type of function being
X	defined, and must be one of the atoms expr, fexpr, and macro.
X	A fexpr does not evaluate its arguments at evaluation time; rather,
X	its (single) formal parameter is bound to a list which is the rest
X	of the form being evaluated.  A macro also does not evaluate its
X	arguments; its single formal parameter is bound to the actual form in
X	which the macro is invoked.  The macro code should create a form which
X	will then be evaluated upon return; the value of the macro form is
X	the value of evaluating the result.
X
X	>(defun second (arg1) (cadr arg1))
X	second
X	>(second '(a b c))
X	b
X	>(defun quot fexpr (rest) (car rest))	; a quote synonym
X	quot
X	>(quot (some list))
X	(some list)
X	>(defun nquot macro (form) (cons 'quote (cadr form))) ; also ' synonym
X	nquot
X	>(nquot (some list))
X	(some list)
X	>(apply 'nquot '( (nquot (some list)))
X	(quote (some list))
X	> ; now a definition of a lexpr
X	>(defun third alist
X	1>	(cond	(( < alist 3) nil)
X	2>		(t (arg 3))))
X	third
X	>(third 'a 'b 'c 'd)
X	c
X
X	The lambda expression is placed on either the EXPR, FEXPR, or MACRO
X	property of the symbolic name of the function.  lexpr expressions
X	are placed on the EXPR property.
X
X( delete from list)
X	delete creates a new list whose elements are the elements of list,
X	except those which are equal to form.
X
X( delq from list)
X	delq is like delete, but uses eq rather than equal.
X
X(do var init repeat endtest forms...)				Special form
X	This implements the MACLISP style old do.  \fIvar is first
X	bound to the result of evaluating \fIinit, then the following loop
X	is performed:
X		if \fIendtest is nil, return nil.
X		evaluate the forms in sequence as per prog.
X		rebind \fIvar to the result of \fIrepeat and test again.
X	do returns nil unless a return is evaluated.
X
X( exp number)
X	Returns antilog of the number.
X
X( explode thing)
X	Returns the list of single-character-atoms representing the printed
X	representation of thing.  The printed representation is determined
X	by prin1.
X	(explode 'foo)	==> ( f o o )
X	(explode '(foo)) ==> ( \( f o o \) )
X	(explode '(1 \2)) ==> ( \( \1 \  \\ \2 \) )
X			      Note: this is the list of the atoms (, 1,
X			      space, backslash, 2, ).  The backslashes may
X			      render it unreadable by humans, but the xlisp
X			      reader understands it perfectly.
X
X( explodec thing)
X	Like explode, but without slashification (uses princ).
X	(explode '(foo)) ==> ( \( f o o \) )
X	(explode '(1 \2)) ==> ( \( \1 \  \2 \) )
X
X( expt number1 number2)
X	expt raises number1 to the power number2.  If both numbers
X	are integers, the result is an integer.
X
X( funcall fun arg1...)
X	funcall applies the function fun to the rest of the arguments.
X	(funcall 'fun 'a 'b 'c) is a lot like (apply 'fun '(a b c)).
X
X( gcd number1 number2)
X	The arguments must be integers.  Returns the greatest common divisor.
X
X( gensym [ symbol-or-string-or-number ] )
X	If gensym is given no argument, returns a newly created symbol which
X	is not interned on the oblist.  The name of the symbol will be
X	of the form G00001, where the numeric part is incremented each time
X	gensym is called.  If gensym is given a symbol or a string, the
X	'G' in the atoms will be replaced by the first character of the print-
X	name of the atom or string on subsequent calls.  If gensym is given
X	an integer, it replaces the current value of the gensym-counter.
X	Note that each invocation of gensym results in a new, unique
X	symbol which is not eq to any previously created object, and is not
X	eq to any atom on the oblist.
X
X( get atom prop)
X	Returns the value of the given property on the atom's property list.
X	Returns nil if the atom does not have the property (or if the
X	property-indicator has a value of nil, thus making nil a poor
X	choice for a property value).
X
X( go label)							Special Form
X	go causes prog to resume interpretation at the intended label.
X	If go is given a symbol as an argument, it is taken as a label
X	to go to, and the most recently invoked prog is told to reset to that
X	label.  If that label is not found, that prog tells the next most
X	recently invoked prog to go to the label, and so on out.  If the label
X	is not found, an error results.
X	If the argument is not a symbol, it is evaluated to obtain a symbol
X	(evaluation is repeated until a symbol results).
X	go does not ever return.
X
X( implode list)
X	implode takes its input list, which must be a list of atoms, and
X	creates a new interned symbol (see intern) whose printname is formed
X	by concatenating the first letters of all the symbols in the list.
X	(implode '(f o o)) ==> foo
X
X( intern symbol)
X	intern returns a symbol on the oblist whose printname is the same
X	as that of the given symbol.  If no such symbol already exists, the
X	given symbol is placed on the oblist and returned, else the symbol
X	which is on the oblist is returned.
X
X( log number)
X	Returns the natural logarithm of the number.
X
X( maknam list)
X	Creates a new symbol, not on the oblist, out of the symbols in the
X	list.  See implode.
X
X( mapcar fun list-of-first-args list-of-second-args...)
X	mapcar creates a list by successively applying the function to
X	successive car's of each list; the list returned is the list of results
X	of the applications.
X	(mapcar 'atom '( sym thing (list) )) ==> (t t () )
X	(mapcar '+ '(1 2 3) '(4 5 6)) ==> (5 7 9)
X	(mapcar 'list '(a a a) '(b b b) '(c c c)) ==>
X			( (a b c) (a b c) (a b c))
X
X( mapcan fun list-of-firsts list-of-seconds...)
X	mapcan is like mapcar, but takes the values returned by fun (which
X	must be lists) and applies nconc to them.
X
X( member thing list)
X	Returns t if thing is equal to a top-level element of list,
X	nil otherwise.
X	(member 'yes '(yes no maybe))	==> t
X	(member '(yes) '( (no) (maybe) (yes))) ==> t
X	(member 'no '( (no) (maybe) (yes))) ==> ()
X
X( memq thing list)
X	Like member, but uses eq for the comparison.
X
X( minus number)
X	Returns number * (-1).
X
X( minusp number)
X	Returns t if the number is less than zero.
X
X( nconc list...)
X	Like append, but modifies the existing lists to string them together.
X	>(setq x '(a b c))
X	(a b c)
X	>(setq y '(d e f))
X	(d e f)
X	>(nconc x y)
X	(a b c d e f)
X	>x
X	(a b c d e f)			NOTE that the list x is bound to has
X					been modified!
X
X(or forms...)							Special form
X(|| forms...)							Special form
X	Evaluates forms until one returns non-nil; the value of that form is
X	returned.  If no form evaluates non-nil, returns t.
X
X( prin1 value...)
X	prin1 is like print but does not follow with a newline.
X
X( princ value...)
X	princ is like prin1 but does not slashify.  Also, strings are
X	output without quotation marks or escape expansion.
X
X( print value...)
X	print prints the printed representation of each value to the current
X	output stream, followed by a newline.  Printed representations are not
X	separated on output.  Symbols whose names are funny are printed with
X	slashification.  The slashification algorithm is:  If the symbol is
X	a single character not normally found in symbols, or if the symbol
X	name looks like a valid number, it is printed preceeded by backslash;
X	else if the symbol contains any funny characters, it is printed with
X	vertical bars surrounding it; else it is normal and just printed.
X	print returns ().
X
X( prog ...)							Special Form
X	prog sets up an iterative programming construct.  The general
X	sequence is:
X	(prog ( list of local variables )
X		(form1)
X		label
X		(form2)
X		...
X	)
X	prog works by first binding the local variables to (), then it
X	evaluates each form in turn.  Forms which are just lone atoms (such
X	as label above) are treated as labels and not evaluated.  If prog
X	gets to the end of the list of forms, it returns nil.  If go is
X	executed, it will cause prog to resume interpretation right after
X	the label.  If return is executed, it will cause the immediately
X	enclosing prog to immediately return the value given (rather than
X	nil).
X	; fragment to print the numbers 1 through 10
X	(prog (count)
X		(setq count 1)
X		loop
X		(print count)
X		(cond ((eq count 10) (return t))
X		      ( t (setq count (add1 count))
X			  (go loop))))
X	1
X	...
X	10
X	t
X
X( prog2 forms...)						Special Form
X	prog2 evaluates all of the forms given it, returning the value
X	of the second one evaluated.
X
X( progn forms...)						Special Form
X	progn evaluates all of the forms given it, returning the value
X	of the last one.
X
X( putprop atom value prop)
X	putprop puts the value on the prop property indicator of
X	the atom given.  See also defprop.
X
X( read [ string ])
X	read now accepts symbols of the form \( (the single character "("),
X	\1243 (the characters 1243, NOT interpreted numerically), or
X	|any darn funny thing ()()())))) you please, including \007 |.
X	If a symbol has any quotation in it (\ or |), it cannot be taken as
X	a number.  Also, excess ))))))))))))))))))))))))))))) characters are
X	completely ignored!!!!!
X
X( redirect string)
X	redirect causes the standard output stream to be replaced with
X	an output stream to the filename given in the string string.
X	This redirects print and other standard output routines.
X
X( remprop atom prop)
X	removes the property (with its value) from the atom's property list.
X	Returns nil.
X
X( return value)
X	Causes the immediately enclosing prog to return the value.
X
X( rplaca with cell)
X	Replaces the "car" of the list cell cell with the value with.
X	THIS MODIFIED EXISTING LIST STRUCTURE.  This can create circular
X	list structures.
X	>(setq x '(baz bam))
X	(baz bam)
X	>(rplaca 'foo x)
X	(foo bam)
X	>x
X	(foo bam)
X
X( rplacd with cell)
X	Replaces the "cdr" of the list cell.
X
X( shell string)
X	Executes string as a shell command, via the UNIX subroutine
X	system().
X
X( sin value)
X	returns the sine of the argument.
X
X( sqrt value)
X	returns the square root of the argument.  If the argument is an INT,
X	returns the integer square root of the argument.
X
X( sub1 number)
X	Returns one less than the argument.
X
X( subst to from list)
X	Builds a list in which all top level occurances of from in the
X	list are replaced with to.
X
X( tan number)
X	Returns the tangent of the argument.
X
X( terpri )
X	Prints a newline.
X
X( zerop value)
X	Returns t if the argument is zero.
X
!Funky!Stuff!
echo x Makefile
sed -n -e 's/^X//p' > Makefile << '!Funky!Stuff!'
X
Xxlisp:  xlisp.o xldmem.o xleval.o xlread.o xlio.o xlprin.o xlbind.o xlstr.o\
X       	xlfio.o xlsubr.o xlfmath.o xllist.o xlobj.o xlkmap.o xldebug.o \
X	xlext.o
X	cc -o xlisp \
X	xlisp.o xldmem.o xleval.o xlread.o xlio.o xlprin.o xlbind.o xlstr.o\
X       	xlfio.o xlsubr.o xlfmath.o xllist.o xlobj.o xlkmap.o xldebug.o \
X	xlext.o
X
!Funky!Stuff!
echo x longjmp.asm
sed -n -e 's/^X//p' > longjmp.asm << '!Funky!Stuff!'
X
XCODE          SEGMENT   BYTE PUBLIC
X	      ASSUME    CS:CODE
X
X	      PUBLIC    setjmp, longjmp
X
Xsetjmp        PROC      NEAR
X
X	      POP       AX             ; Fetch return address from stack
X	      POP       BX             ; Buffer pointer
X
X	      MOV       [BX],BP        ; Save BP
X	      MOV       [BX+2],SP      ; , SP at return
X	      MOV       [BX+4],AX      ; and IP
X
X	      PUSH      BX             ; Restore stack
X	      PUSH      AX
X	      RET
X
Xsetjmp        ENDP
X
X
Xlongjmp       PROC      NEAR
X
X	      POP       AX
X	      POP       BX
X	      MOV       BP,[BX]
X	      MOV       SP,[BX+2]
X	      PUSH      AX
X
X	      MOV       AX,[BX+4]
X	      JMP       AX
X
Xlongjmp       ENDP
X
XCODE          ENDS
X	      END
!Funky!Stuff!
echo x xlbind.c
sed -n -e 's/^X//p' > xlbind.c << '!Funky!Stuff!'
X		  /* xlbind - xlisp symbol binding routines */
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			     /* global variables */
X
Xstruct node *xlenv;
X
X
X	    /********************************************************
X	    *  xlunbind - unbind symbols bound in this environment  *
X	    ********************************************************/
X
Xxlunbind(env)
X  struct node *env;
X{
X    struct node *bnd;
X
X    for (; xlenv != env; xlenv = xlenv->n_listnext)
X    {
X	bnd = xlenv->n_listvalue;
X	bnd->n_bndsym->n_symvalue = bnd->n_bndvalue;
X    }
X}
X
X
X		     /**************************************
X		     *  xlbind - bind a symbol to a value  *
X		     **************************************/
X
Xxlbind(sym,val)
X  struct node *sym,*val;
X{
X    struct node *lptr,*bptr;
X
X    lptr = newnode(LIST);              /* Create new environment list entry */
X    lptr->n_listnext = xlenv;
X    xlenv = lptr;
X
X    lptr->n_listvalue = bptr = newnode(LIST);    /* New variable binding */
X    bptr->n_bndsym = sym;
X    bptr->n_bndvalue = val;
X}
X
X
X	    /*******************************************************
X	    *  xlfixbindings - make a new set of bindings visible  *
X	    *******************************************************/
X
Xxlfixbindings(env)
X  struct node *env;
X{
X    struct node *eptr,*bnd,*sym,*oldvalue;
X
X    for (eptr = xlenv; eptr != env; eptr = eptr->n_listnext) {
X	bnd = eptr->n_listvalue;
X	sym = bnd->n_bndsym;
X	oldvalue = sym->n_symvalue;
X	sym->n_symvalue = bnd->n_bndvalue;
X	bnd->n_bndvalue = oldvalue;
X    }
X}
!Funky!Stuff!
echo x xldebug.c
sed -n -e 's/^X//p' > xldebug.c << '!Funky!Stuff!'
X		       /* xldebug - some debug routines */
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
Xint debug_level = 0;
XFILE *debug_fp = NULL;
X
X
X
X	      /***************************************************
X	      *  xldbgmsg : Display a message in the debug file  *
X	      ***************************************************/
X
Xxldbgmsg(s)
X    char *s;
X{
X    if (debug_fp)
X	 fprintf(debug_fp, "\n%s", s);
X}
X
X
X		  /*******************************************
X		  *  xldump : dump a node to the debug file  *
X		  *******************************************/
X
Xxldump(nptr)
X    struct node *nptr;
X{
X
X    if (debug_fp == NULL)              /* Debug file open ? */
X	 return;
X
X    fprintf(debug_fp, "\n@%4x : %2x   ", nptr, nptr->n_flags);
X
X    switch(nptr->n_type)
X    {
X    case FREE:
X	 fprintf(debug_fp, "FREE node");
X	 return;
X
X    case SYM:
X	 fprintf(debug_fp, "SYM %s = @%4x", nptr->n_symname, nptr->n_symvalue);
X	 return;
X
X    case LIST:
X	 fprintf(debug_fp, "LIST @%4x , @%4x", nptr->n_listvalue,
X		 nptr->n_listnext);
X	 return;
X
X    case FSUBR:
X	 fprintf(debug_fp, "FSUBR %4x", nptr->n_subr);
X	 return;
X
X    case SUBR:
X	 fprintf(debug_fp, "SUBR %4x", nptr->n_subr);
X	 return;
X
X    case INT:
X	 fprintf(debug_fp, "INT = %d", nptr->n_int);
X	 return;
X
X    case STR:
X	 fprintf(debug_fp, "STRING = %s", nptr->n_str);
X	 return;
X
X    case OBJ:
X	 fprintf(debug_fp, "OBJ @%4x , @%4x", nptr->n_obclass,
X		 nptr->n_obdata);
X	 return;
X
X    case FPTR:
X	 fprintf(debug_fp, "FILE  %4x", nptr->n_fp);
X	 return;
X
X    case KMAP:
X	 fprintf(debug_fp, "KMAP");
X	 return;
X
X#ifdef REALS
X    case REAL:
X	 fprintf(debug_fp, "REAL = %g", nptr->n_real);
X	 return;
X#endif
X
X    default:
X	 fprintf(debug_fp, "Type %d ?????????", nptr->n_type);
X	 return;
X    }
X}
X
X
X		/************************************************
X		*  debug : xlisp function to set debug options  *
X		************************************************/
X
Xstatic struct node *debug(args)
X    struct node *args;
X{
X    debug_level = xlmatch(INT, &args)->n_int;
X
X    if (args != NULL)
X    {
X	 if (debug_fp)
X	      fclose(debug_fp);
X	 if ((debug_fp = fopen(xlmatch(STR, &args)->n_str, "w")) == NULL)
X	      xlfail("Cannot open debug file");
X	 xllastarg(args);
X    }
X
X    return (NULL);
X}
X
X
X		  /*******************************************
X		  *  xldebuginit : initialize debug package  *
X		  *******************************************/
X
Xxldebuginit()
X{
X    debug_level = 0;
X    debug_fp = NULL;
X
X    xlsubr("debug", debug);
X}
!Funky!Stuff!
echo x xldmem.c
sed -n -e 's/^X//p' > xldmem.c << '!Funky!Stuff!'
X	     /* xldmem - xlisp dynamic memory management routines */
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
X			    /* useful definitions */
X
X#define ALLOCSIZE (sizeof(struct segment) + anodes * sizeof(struct node))
X
X
X		    /* memory segment structure definition */
X
Xstruct segment {
X    int sg_size;
X    struct segment *sg_next;
X    struct node sg_nodes[1];
X};
X
X			    /* external variables */
X
Xextern struct node *oblist;
Xextern struct node *xlstack;
Xextern struct node *xlenv;
Xextern struct node *strstk;
X
X			    /* external procedures */
X
Xextern char *malloc();
Xextern char *calloc();
X
X
X			      /* local variables */
X
Xint anodes,nnodes,nsegs,nfree,gccalls;
Xstatic struct segment *segs = NULL;
Xstatic struct node *fnodes = NULL;
X
X
X		       /**********************************
X		       *  newnode - allocate a new node  *
X		       **********************************/
X
Xstruct node *newnode(type)
X  int type;
X{
X    struct node *nnode;
X
X    /* get a free node */
X    if ((nnode = fnodes) == NULL) {
X	gc();
X	if ((nnode = fnodes) == NULL)
X	    xlfail("insufficient node space");
X    }
X
X    /* unlink the node from the free list */
X    fnodes = nnode->n_right;
X    nfree -= 1;
X
X    /* initialize the new node */
X    nnode->n_type = type;
X    nnode->n_left = NULL;
X    nnode->n_right = NULL;
X
X    /* return the new node */
X    return (nnode);
X}
X
X
X /*****************************************************************************
X *  stralloc - allocate memory for a string adding a byte for the terminator  *
X *****************************************************************************/
X
Xchar *stralloc(size)
X  int size;
X{
X    char *sptr;
X
X    /* allocate memory for the string copy */
X    if ((sptr = malloc(size+1)) == NULL) {
X	gc();
X	if ((sptr = malloc(size+1)) == NULL)
X	    xlfail("insufficient string space");
X    }
X
X    /* return the new string memory */
X    return (sptr);
X}
X
X
X	       /**************************************************
X	       *  strsave - generate a dynamic copy of a string  *
X	       **************************************************/
X
Xchar *strsave(str)
X  char *str;
X{
X    char *sptr;
X
X    /*     */
X    sptr = stralloc(strlen(str));
X    strcpy(sptr,str);
X
X    /* return the new string */
X    return (sptr);
X}
X
X
X		       /*********************************
X		       *  strfree - free string memory  *
X		       *********************************/
X
Xstrfree(str)
X  char *str;
X{
X    free(str);
X}
X
X
X			   /*************************
X			   *  gc - garbage collect  *
X			   *************************/
X
Xstatic gc()
X{
X    unmark();                          /* Unmark all nodes */
X
X#ifdef DEBUG
X    xldbgmsg("\n\tOBLIST mark");
X    mark(oblist);
X    xldbgmsg("\n\tSTACK mark");
X    mark(xlstack);
X    xldbgmsg("\n\tENVIRONMENT");
X    mark(xlenv);
X    xldbgmsg("\n\tSTRING STACK");
X    mark(strstk);
X#else
X    mark(oblist);                      /* Mark all accessible nodes */
X    mark(xlstack);
X    mark(xlenv);
X    mark(strstk);
X#endif
X
X    sweep();                           /* Sweep up the grabage */
X
X    if (fnodes == NULL)                /* Allocate more if necessary */
X	addseg();
X
X    gccalls += 1;
X}
X
X
X			 /******************************
X			 *  unmark - unmark each node  *
X			 ******************************/
X
Xstatic unmark()
X{
X    struct node *n = xlstack;
X
X    while (n != NULL)                       /* Unmark the stack */
X    {
X	n->n_flags &= ~(MARK | LEFT);
X	n = n->n_listnext;
X    }
X}
X
X		     /*************************************
X		     *  mark - mark all accessible nodes  *
X		     *************************************/
X
Xstatic mark(ptr)
X  struct node *ptr;
X{
X    struct node *this,*prev,*tmp;
X
X    if (ptr == NULL)                   /* Return on null */
X	return;
X
X    prev = NULL;                       /* Initialize */
X    this = ptr;
X
X    while (TRUE)                       /* Mark this list */
X    {
X	while (TRUE)                   /* Descend as far as we can */
X	{
X	    if (this->n_flags & MARK)  /* Node already marked ? */
X		break;
X	    else                       /* NO : mark it and its descendents */
X	    {
X
X#ifdef DEBUG
X		xldump(this);
X#endif
X		this->n_flags |= MARK; /* This node ...*/
X
X		if (left(this))        /* .. the left sublist */
X		{
X		    this->n_flags |= LEFT;
X		    tmp = prev;
X		    prev = this;
X		    this = prev->n_left;
X		    prev->n_left = tmp;
X		}
X		else
X		if (right(this))       /* .. the right sublist */
X		{
X		    this->n_flags &= ~LEFT;
X		    tmp = prev;
X		    prev = this;
X		    this = prev->n_right;
X		    prev->n_right = tmp;
X		}
X		else
X		    break;
X	    }
X	}
X
X	while (TRUE)                   /* Backup to last restart point */
X	{
X	    if (prev == NULL)          /* Finished yet ? */
X		return;
X
X	    if (prev->n_flags & LEFT)  /* Coming from left side ? */
X	    {
X		if (right(prev))
X		{
X		    prev->n_flags &= ~LEFT;
X		    tmp = prev->n_left;
X		    prev->n_left = this;
X		    this = prev->n_right;
X		    prev->n_right = tmp;
X		    break;
X		}
X		else
X		{
X		    tmp = prev;
X		    prev = tmp->n_left;
X		    tmp->n_left = this;
X		    this = tmp;
X		}
X	    }
X	    else                       /* came from the right side */
X	    {
X		tmp = prev;
X		prev = tmp->n_right;
X		tmp->n_right = this;
X		this = tmp;
X	    }
X	}
X    }
X}
X
X
X      /*******************************************************************
X      *  sweep - sweep all unmarked nodes and add them to the free list  *
X      *******************************************************************/
X
Xstatic sweep()
X{
X    struct segment *seg;
X    struct node *n;
X    int i;
X
X    fnodes = NULL;                               /* Empty the free list */
X    nfree = 0;
X
X    /* add all unmarked nodes */
X    for (seg = segs; seg != NULL; seg = seg->sg_next)
X	for (i = 0; i < seg->sg_size; i++)
X	    if (!((n = &seg->sg_nodes[i])->n_flags & MARK))
X	    {
X		switch (n->n_type)
X		{
X		case STR:
X			if (n->n_strtype == DYNAMIC && n->n_str != NULL)
X			    strfree(n->n_str);
X			break;
X
X		case SYM:
X			if (n->n_symname != NULL)
X			    strfree(n->n_symname);
X			break;
X
X#ifdef KEYMAPCLASS
X		case KMAP:
X			xlkmfree(n);
X			break;
X#endif
X		}
X
X		n->n_type = FREE;
X		n->n_left = NULL;
X		n->n_right = fnodes;
X		fnodes = n;
X		nfree += 1;
X	    }
X	    else
X		n->n_flags &= ~MARK;
X}
X
X
X	      /***************************************************
X	      *  addseg - add a segment to the available memory  *
X	      ***************************************************/
X
Xstatic int addseg()
X{
X    struct segment *newseg;
X    int i;
X
X				       /* allocate a new segment */
X    if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL)
X    {
X	newseg->sg_size = anodes;      /* Initialize the new segment */
X	newseg->sg_next = segs;
X	segs = newseg;
X				       /* add each new node to the free list */
X	for (i = 0; i < newseg->sg_size; i++)
X	{
X	    newseg->sg_nodes[i].n_right = fnodes;
X	    fnodes = &newseg->sg_nodes[i];
X	}
X
X	nnodes += anodes;              /* Update the statistics */
X	nfree += anodes;
X	nsegs += 1;
X
X	return (TRUE);                 /* return success */
X    }
X    else
X	return (FALSE);
X}
X
X
X		      /************************************
X		      *  left - check for a left sublist  *
X		      ************************************/
X
Xstatic int left(n)
X  struct node *n;
X{
X    switch (n->n_type)
X    {
X    case FSUBR:
X    case SUBR:
X    case INT:
X    case STR:
X    case FPTR:
X    case REAL:
X    case PROGSTK:
X	    return (FALSE);
X
X#ifdef KEYMAPCLASS
X    case KMAP:
X	    xlkmmark(n);
X	    return (FALSE);
X#endif
X
X    case SYM:			/* now has name ptr last */
X    case LIST:
X    case OBJ:
X	    return (n->n_left != NULL);
X
X    default:
X	    printf("bad node type (%d) found during left scan\n",n->n_type);
X	    exit();
X    }
X}
X
X
X		     /**************************************
X		     *  right - check for a right sublist  *
X		     **************************************/
X
Xstatic int right(n)
X  struct node *n;
X{
X    switch (n->n_type)
X    {
X    case FSUBR:
X    case SUBR:
X    case INT:
X    case REAL:
X    case STR:
X    case FPTR:
X    case KMAP:
X	    return (FALSE);
X
X    case PROGSTK:
X    case SYM:
X    case LIST:
X    case OBJ:
X	    return (n->n_right != NULL);
X
X    default:
X	    printf("bad node type (%d) found during right scan\n",n->n_type);
X	    exit();
X    }
X}
X
X
X		      /************************************
X		      *  stats - print memory statistics  *
X		      ************************************/
X
Xstatic stats()
X{
X    printf("\nNodes:       %d\n",nnodes);
X    printf("Free nodes:  %d\n",nfree);
X    printf("Segments:    %d\n",nsegs);
X    printf("Allocate:    %d\n",anodes);
X    printf("Collections: %d\n\n",gccalls);
X}
X
X
X	     /*****************************************************
X	     *  fgc - xlisp function to force garbage collection  *
X	     *****************************************************/
X
Xstatic struct node *fgc(args)
X  struct node *args;
X{
X    xllastarg(args);                   /* No arguments */
X    gc();                              /* Collect that garbage */
X    return (NULL);
X}
X
X
X	    /*******************************************************
X	    *  fexpand - xlisp function to force memory expansion  *
X	    *******************************************************/
X
Xstatic struct node *fexpand(args)
X  struct node *args;
X{
X    struct node *val;
X    int n,i;
X
X				       /* get new number to allocate */
X    n = (args == NULL) ? 1 : xlmatch(INT, &args)->n_int;
X    xllastarg(args);                   /* No more arguments */
X
X    for (i = 0; i < n; i++)            /* Allocate more segments */
X	if (!addseg())
X	    break;
X
X    val = newnode(INT);                /* Return number of segments added */
X    val->n_int = i;
X    return (val);
X}
X
X      /*******************************************************************
X      *  falloc - xlisp function to set the number of nodes to allocate  *
X      *******************************************************************/
X
Xstatic struct node *falloc(args)
X  struct node *args;
X{
X    struct node *val;
X    int n,oldn;
X
X    n = xlmatch(INT,&args)->n_int;   /* new number to allocate */
X    xllastarg(args);                   /* No more arguments */
X
X    oldn = anodes;                     /* Set new number */
X    anodes = n;
X
X    val = newnode(INT);                /* Return old value */
X    val->n_int = oldn;
X    return (val);
X}
X
X
X	     /*****************************************************
X	     *  fmem - xlisp function to print memory statistics  *
X	     *****************************************************/
X
Xstatic struct node *fmem(args)
X  struct node *args;
X{
X    xllastarg(args);                   /* No arguments */
X    stats();                           /* Print statistics */
X    return (NULL);
X}
X
X
X	     /******************************************************
X	     *  xldmeminit - initialize the dynamic memory module  *
X	     ******************************************************/
X
Xxldmeminit()
X{
X    anodes = NNODES;                   /* Default number of nodes */
X    nnodes = nsegs = nfree = gccalls = 0;
X
X    xlfsubr("gc",fgc);                  /* Define some xlisp functions */
X    xlsubr("expand",fexpand);
X    xlsubr("alloc",falloc);
X    xlfsubr("mem",fmem);
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.