/* xldmem - xlisp dynamic memory management routines */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"
#include <stdlib.h>
#include <string.h>

/* node flags */
#ifdef JGC
#define MARK	0x20
#define LEFT	0x40
#else
#define MARK	1
#define LEFT	2
#endif

/* macro to compute the size of a segment */
#define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))

/* external variables */
extern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
extern LVAL xlenv,xlfenv,xldenv;
extern char buf[];

/* variables local to xldmem.c and xlimage.c */
SEGMENT *segs,*lastseg,*fixseg,*charseg;
int anodes,nsegs,gccalls;
long nnodes,nfree,total;
LVAL fnodes = NIL;

/* forward declarations */
#ifdef ANSI
#ifdef JMAC
FORWARD LVAL Newnode(int type);
#else
FORWARD LVAL newnode(int type);
#endif
FORWARD char *stralloc(int size);
FORWARD VOID mark(LVAL ptr);
FORWARD VOID sweep(void);
FORWARD VOID findmem(void);
FORWARD int  addseg(void);
#else
#ifdef JMAC
FORWARD LVAL Newnode();
#else
FORWARD LVAL newnode();
#endif
FORWARD char *stralloc();
FORWARD VOID mark();
FORWARD VOID sweep();
FORWARD VOID findmem();
#endif


#ifdef JMAC
LVAL _nnode = 0;
FIXTYPE _tfixed = 0;
int _tint = 0;

#define	newnode(type) (((_nnode = fnodes) != NIL) ? \
 			((fnodes = cdr(_nnode)), \
 			 nfree--, \
 			 (_nnode->n_type = type), \
 			 rplacd(_nnode,NIL), \
 			 _nnode) \
 		    : Newnode(type))
 
#endif


/* xlminit - initialize the dynamic memory module */
VOID xlminit()
{
	LVAL p;
	int i;

	/* initialize our internal variables */
	segs = lastseg = NULL;
	nnodes = nfree = total = 0L;
	nsegs = gccalls = 0;
	anodes = NNODES;
	fnodes = NIL;

	/* allocate the fixnum segment */
	if ((fixseg = newsegment(SFIXSIZE)) == NULL)
		xlfatal("insufficient memory");

	/* initialize the fixnum segment */
	p = &fixseg->sg_nodes[0];
	for (i = SFIXMIN; i <= SFIXMAX; ++i) {
		p->n_type = FIXNUM;
		p->n_fixnum = i;
		++p;
	}

	/* allocate the character segment */
	if ((charseg = newsegment(CHARSIZE)) == NULL)
		xlfatal("insufficient memory");

	/* initialize the character segment */
	p = &charseg->sg_nodes[0];
	for (i = CHARMIN; i <= CHARMAX; ++i) {
		p->n_type = CHAR;
		p->n_chcode = i;
		++p;
	}

	/* initialize structures that are marked by the collector */
	obarray = xlenv = xlfenv = xldenv = NIL;
	s_gcflag = s_gchook = NIL;

	/* allocate the evaluation stack */
	if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
		xlfatal("insufficient memory");
	xlstack = xlstktop = xlstkbase + EDEPTH;

	/* allocate the argument stack */
	if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
		xlfatal("insufficient memory");
	xlargstktop = xlargstkbase + ADEPTH;
	xlfp = xlsp = xlargstkbase;
	*xlsp++ = NIL;
}

/* cons - construct a new cons node */
LVAL cons(x,y)
  LVAL x,y;
{
	LVAL nnode;

	/* get a free node */
	if ((nnode = fnodes) == NIL) {
		xlstkcheck(2);
		xlprotect(x);
		xlprotect(y);
		findmem();
		if ((nnode = fnodes) == NIL)
			xlabort("insufficient node space");
		xlpop();
		xlpop();
	}

	/* unlink the node from the free list */
	fnodes = cdr(nnode);
	--nfree;

	/* initialize the new node */
	nnode->n_type = CONS;
	rplaca(nnode,x);
	rplacd(nnode,y);

	/* return the new node */
	return (nnode);
}

/* cvstring - convert a string to a string node */
LVAL cvstring(str)
  char *str;
{
	LVAL val;
	xlsave1(val);
	val = newnode(STRING);
	val->n_strlen = strlen(str) + 1;
	val->n_string = stralloc(getslength(val));
	strcpy((char *)getstring(val),str);
	xlpop();
	return (val);
}

/* newstring - allocate and initialize a new string */
LVAL newstring(size)
  int size;
{
	LVAL val;
	xlsave1(val);
	val = newnode(STRING);
	val->n_strlen = size;
	val->n_string = stralloc(getslength(val));
	strcpy((char *)getstring(val),"");
	xlpop();
	return (val);
}

/* cvsymbol - convert a string to a symbol */
LVAL cvsymbol(pname)
  char *pname;
{
	LVAL val;
	xlsave1(val);
	val = newvector(SYMSIZE);
	val->n_type = SYMBOL;
	setvalue(val,s_unbound);
	setfunction(val,s_unbound);
	setpname(val,cvstring(pname));
	xlpop();
	return (val);
}

/* cvsubr - convert a function to a subr or fsubr */
#ifdef ANSI
LVAL cvsubr(LVAL (*fcn)(void), int type, int offset)
#else
LVAL cvsubr(fcn,type,offset)
  LVAL (*fcn)(); int type,offset;
#endif
{
	LVAL val;
	val = newnode(type);
	val->n_subr = fcn;
	val->n_offset = offset;
	return (val);
}

/* cvfile - convert a file pointer to a stream */
LVAL cvfile(fp)
  FILE *fp;
{
	LVAL val;
	val = newnode(STREAM);
	setfile(val,fp);
	setsavech(val,'\0');
#ifdef BETTERIO
	val->n_sflags = 0;
#endif
	return (val);
}

#ifdef JMAC
 
/* cvfixnum - convert an integer to a fixnum node */
LVAL Cvfixnum(n)
  FIXTYPE n;
{
	LVAL val;
	val = newnode(FIXNUM);
	val->n_fixnum = n;
	return (val);
}
#else
/* cvfixnum - convert an integer to a fixnum node */
LVAL cvfixnum(n)
  FIXTYPE n;
{
	LVAL val;
	if (n >= SFIXMIN && n <= SFIXMAX)
		return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
	val = newnode(FIXNUM);
	val->n_fixnum = n;
	return (val);
}
#endif

/* cvflonum - convert a floating point number to a flonum node */
LVAL cvflonum(n)
  FLOTYPE n;
{
	LVAL val;
	val = newnode(FLONUM);
	val->n_flonum = n;
	return (val);
}

/* cvchar - convert an integer to a character node */
#ifdef JMAC
LVAL Cvchar(n)
  int n;
{
	xlerror("character code out of range",cvfixnum((FIXTYPE)n));
	return(NIL);	/* never executed */
}
#else
LVAL cvchar(n)
  int n;
{
	if (n >= CHARMIN && n <= CHARMAX)
		return (&charseg->sg_nodes[n-CHARMIN]);
	xlerror("character code out of range",cvfixnum((FIXTYPE)n));
	return 0;	/* never executed but gets rid of warning message */
}
#endif

/* newustream - create a new unnamed stream */
LVAL newustream()
{
	LVAL val;
	val = newnode(USTREAM);
	sethead(val,NIL);
	settail(val,NIL);
	return (val);
}

/* newobject - allocate and initialize a new object */
LVAL newobject(cls,size)
  LVAL cls; int size;
{
	LVAL val;
	val = newvector(size+1);
	val->n_type = OBJECT;
	setelement(val,0,cls);
	return (val);
}

/* newclosure - allocate and initialize a new closure */
LVAL newclosure(name,type,env,fenv)
  LVAL name,type,env,fenv;
{
	LVAL val;
	val = newvector(CLOSIZE);
	val->n_type = CLOSURE;
	setname(val,name);
	settype(val,type);
	setenvi(val,env);
	setfenv(val,fenv);
	return (val);
}

#ifdef STRUCTS
/* newstruct - allocate and initialize a new structure node */
LVAL newstruct(type,size)
 LVAL type; int size;
{
	LVAL val;
	val = newvector(size+1);
	val->n_type = STRUCT;
	setelement(val,0,type);
	return (val);
}
#endif


/* newvector - allocate and initialize a new vector node */
LVAL newvector(size)
  int size;
{
	LVAL vect;
	int bsize;
	xlsave1(vect);
	vect = newnode(VECTOR);
	vect->n_vsize = 0;
	if ((bsize = size * sizeof(LVAL)) != 0) {
		if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
			findmem();
			if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
				xlfail("insufficient vector space");
		}
		vect->n_vsize = size;
		total += (long) bsize;
	}
	xlpop();
	return (vect);
}

/* newnode - allocate a new node */
#ifdef JMAC
LOCAL LVAL Newnode(type)
  int type;
{
	LVAL nnode;

	/* get a free node */
	findmem();
	if ((nnode = fnodes) == NIL)
		xlabort("insufficient node space");

	/* unlink the node from the free list */
	fnodes = cdr(nnode);
	nfree -= 1L;

	/* initialize the new node */
	nnode->n_type = type;
	rplacd(nnode,NIL);

	/* return the new node */
	return (nnode);
}
#else
LOCAL LVAL newnode(type)
  int type;
{
	LVAL nnode;

	/* get a free node */
	if ((nnode = fnodes) == NIL) {
		findmem();
		if ((nnode = fnodes) == NIL)
			xlabort("insufficient node space");
	}

	/* unlink the node from the free list */
	fnodes = cdr(nnode);
	nfree -= 1L;

	/* initialize the new node */
	nnode->n_type = type;
	rplacd(nnode,NIL);

	/* return the new node */
	return (nnode);
}
#endif

/* stralloc - allocate memory for a string adding a byte for the terminator */
LOCAL char *stralloc(size)
  int size;
{
	char *sptr;

	/* allocate memory for the string copy */
	if ((sptr = malloc(size)) == NULL) {
		gc();  
		if ((sptr = malloc(size)) == NULL)
			xlfail("insufficient string space");
	}
	total += (long)size;

	/* return the new string memory */
	return (sptr);
}

/* findmem - find more memory by collecting then expanding */
LOCAL VOID findmem()
{
	gc();
	if (nfree < (long)anodes)
		addseg();
}

/* gc - garbage collect (only called here and in xlimage.c) */
VOID gc()
{
	register LVAL **p,*ap,tmp;
	char buf[STRMAX+1];
	LVAL *newfp,fun;

	/* print the start of the gc message */
	if (s_gcflag && getvalue(s_gcflag)) {
		sprintf(buf,"[ gc: total %ld, ",nnodes);
		stdputstr(buf);
	}

	/* mark the obarray, the argument list and the current environment */
	if (obarray)
		mark(obarray);
	if (xlenv)
		mark(xlenv);
	if (xlfenv)
		mark(xlfenv);
	if (xldenv)
		mark(xldenv);

	/* mark the evaluation stack */
	for (p = xlstack; p < xlstktop; ++p)
		if ((tmp = **p) != 0)
			mark(tmp);

	/* mark the argument stack */
	for (ap = xlargstkbase; ap < xlsp; ++ap)
		if ((tmp = *ap) != 0)
			mark(tmp);

	/* sweep memory collecting all unmarked nodes */
	sweep();

	/* count the gc call */
	++gccalls;

	/* call the *gc-hook* if necessary */
	if (s_gchook && ((fun = getvalue(s_gchook)) != 0) ) {
		newfp = xlsp;
		pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
		pusharg(fun);
		pusharg(cvfixnum((FIXTYPE)2));
		pusharg(cvfixnum((FIXTYPE)nnodes));
		pusharg(cvfixnum((FIXTYPE)nfree));
		xlfp = newfp;
		xlapply(2);
	}

	/* print the end of the gc message */
	if (s_gcflag && getvalue(s_gcflag)) {
		sprintf(buf,"%ld free ]\n",nfree);
		stdputstr(buf);
	}
}

/* mark - mark all accessible nodes */
LOCAL VOID mark(ptr)
  LVAL ptr;
{
	register LVAL this,prev,tmp;
#ifdef JGC
	int i,n;
#else
	int type,i,n;
#endif
	/* initialize */
	prev = NIL;
	this = ptr;

	/* mark this list */
	for (;;) {
#ifdef JGC
  
/* descend as far as we can */
	while (!(this->n_type & MARK))
  
		/* check cons and symbol nodes */
		if (((i = (this->n_type |= MARK) & TYPEFIELD) == CONS)||
			(i == USTREAM)) {
			if ((tmp = car(this)) != 0) {
				this->n_type |= LEFT;
				rplaca(this,prev);
			}
			else if ((tmp = cdr(this)) != 0)
				rplacd(this,prev);
			else				/* both sides nil */
				break;
			prev = this;			/* step down the branch */
			this = tmp;
		}
		else {
			if ((i & ARRAY) != 0)
				for (i = 0, n = getsize(this); i < n;)
					if ((tmp = getelement(this,i++)) != 0)
						if ((tmp->n_type & (ARRAY|MARK)) == ARRAY ||
							tmp->n_type == CONS ||
							tmp->n_type == USTREAM)
							mark(tmp);
						else tmp->n_type |= MARK;
						break;
		}

		/* backup to a point where we can continue descending */
		for (;;)

			/* make sure there is a previous node */
			if (prev) {
				if (prev->n_type & LEFT) {		/* came from left side */
					prev->n_type &= ~LEFT;
					tmp = car(prev);
					rplaca(prev,this);
					if ((this = cdr(prev)) != 0) {
						rplacd(prev,tmp);						
						break;
					}
				}
				else {							/* came from right side */
					tmp = cdr(prev);
					rplacd(prev,this);
				}
				this = prev;					/* step back up the branch */
				prev = tmp;
			}
#else
		/* descend as far as we can */
		while (!(this->n_flags & MARK))

			/* check cons and symbol nodes */
			if ((type = ntype(this)) == CONS || type == USTREAM ) { /* TAA fix*/
				if ((tmp = car(this)) != 0) {
					this->n_flags |= MARK|LEFT;
					rplaca(this,prev);
				}
				else if ((tmp = cdr(this)) != 0) {
					this->n_flags |= MARK;
					rplacd(this,prev);
				}
				else {							/* both sides nil */
					this->n_flags |= MARK;
					break;
				}
				prev = this;					/* step down the branch */
				this = tmp;
			}

			/* mark other node types */
			else {
				this->n_flags |= MARK;
				switch (type) {
				case SYMBOL:
				case OBJECT:
				case VECTOR:
				case CLOSURE:
#ifdef STRUCTS
				case STRUCT:
#endif
					for (i = 0, n = getsize(this); --n >= 0; ++i)
						if ((tmp = getelement(this,i)) != 0)
							mark(tmp);
					break;
				}
				break;
			}

		/* backup to a point where we can continue descending */
		for (;;)

			/* make sure there is a previous node */
			if (prev) {
				if (prev->n_flags & LEFT) {		/* came from left side */
					prev->n_flags &= ~LEFT;
					tmp = car(prev);
					rplaca(prev,this);
					if ((this = cdr(prev)) != 0) {
						rplacd(prev,tmp);						
						break;
					}
				}
				else {							/* came from right side */
					tmp = cdr(prev);
					rplacd(prev,this);
				}
				this = prev;					/* step back up the branch */
				prev = tmp;
		}
#endif

			/* no previous node, must be done */
			else
				return;
	}
}

/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL VOID sweep()
{
	SEGMENT *seg;
	LVAL p;
	int n;

	/* empty the free list */
	fnodes = NIL;
	nfree = 0L;

	/* add all unmarked nodes */
	for (seg = segs; seg; seg = seg->sg_next) {
		if (seg == fixseg || seg == charseg)
#ifdef JGC
			{
			/* remove marks from segments */
			p = &seg->sg_nodes[0];
			for (n = seg->sg_size; --n >= 0;)
				(p++)->n_type &= ~MARK;
			continue;
		}
#else
			continue; /* don't sweep fixed segments */
#endif
		p = &seg->sg_nodes[0];
#ifdef JGC
		for (n = seg->sg_size; --n >= 0;)
			if (p->n_type & MARK)
				(p++)->n_type &= ~MARK;
			else {
				switch (ntype(p)&TYPEFIELD) {
#else
		for (n = seg->sg_size; --n >= 0; ++p)
			if (!(p->n_flags & MARK)) {
				switch (ntype(p)) {
#endif
				case STRING:
						if (getstring(p) != NULL) {
							total -= (long)getslength(p);
							free(getstring(p));
						}
						break;
				case STREAM:
						if (getfile(p) 
							&& getfile(p) != stdin
							&& getfile(p) != stdout
							&& getfile(p) != stderr)/* taa fix - dont close stdio */
							osclose(getfile(p));
						break;
				case SYMBOL:
				case OBJECT:
				case VECTOR:
				case CLOSURE:
#ifdef STRUCTS
				case STRUCT:
#endif
						if (p->n_vsize) {
							total -= (long) (p->n_vsize * sizeof(LVAL));
							free(p->n_vdata);
						}
						break;
				}
				p->n_type = FREE;
				rplaca(p,NIL);
				rplacd(p,fnodes);
#ifdef JGC
				fnodes = p++;
				nfree++;
			}
#else
				fnodes = p;
				nfree += 1L;
			}
			else
				p->n_flags &= ~MARK;
#endif
	}
}

/* addseg - add a segment to the available memory */
LOCAL int addseg()
{
	SEGMENT *newseg;
	LVAL p;
	int n;

	/* allocate the new segment */
	if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
		return (FALSE);

	/* add each new node to the free list */
	p = &newseg->sg_nodes[0];
	for (n = anodes; --n >= 0; ++p) {
		rplacd(p,fnodes);
		fnodes = p;
	}
	
	/* return successfully */
	return (TRUE);
}

/* newsegment - create a new segment (only called here and in xlimage.c) */
SEGMENT *newsegment(n)
  int n;
{
	SEGMENT *newseg;

	/* allocate the new segment */
	if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
		return (NULL);

	/* initialize the new segment */
	newseg->sg_size = n;
	newseg->sg_next = NULL;
	if (segs)
		lastseg->sg_next = newseg;
	else
		segs = newseg;
	lastseg = newseg;

	/* update the statistics */
	total += (long)segsize(n);
	nnodes += (long)n;
	nfree += (long)n;
	++nsegs;

	/* return the new segment */
	return (newseg);
}
 
/* stats - print memory statistics */
#ifdef ANSI
static void stats(void)
#else
LOCAL VOID stats()
#endif
{
	sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
	sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
	sprintf(buf,"Segments:    %d\n",nsegs);	  stdputstr(buf);
	sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
	sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
	sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
}

/* xgc - xlisp function to force garbage collection */
LVAL xgc()
{
	/* make sure there aren't any arguments */
	xllastarg();

	/* garbage collect */
	gc();

	/* return nil */
	return (NIL);
}

/* xexpand - xlisp function to force memory expansion */
LVAL xexpand()
{
	LVAL num;
	FIXTYPE n,i;

	/* get the new number to allocate */
	if (moreargs()) {
		num = xlgafixnum();
		n = getfixnum(num);
	}
	else
		n = 1;
	xllastarg();

	/* allocate more segments */
	for (i = 0; i < n; i++)
		if (!addseg())
			break;

	/* return the number of segments added */
	return (cvfixnum((FIXTYPE)i));
}

/* xalloc - xlisp function to set the number of nodes to allocate */
LVAL xalloc()
{
	int n,oldn;
	LVAL num;

	/* get the new number to allocate */
	num = xlgafixnum();
	n = (int) getfixnum(num);	/* if it doesn't fit in an int, we are in
									trouble anyway! */

	/* make sure there aren't any more arguments */
	xllastarg();

	/* set the new number of nodes to allocate */
	oldn = anodes;
	anodes = n;

	/* return the old number */
	return (cvfixnum((FIXTYPE)oldn));
}

/* xmem - xlisp function to print memory statistics */
LVAL xmem()
{
	/* allow one argument for compatiblity with common lisp */
	if (moreargs()) xlgetarg();
	xllastarg();

	/* print the statistics */
	stats();

	/* return nil */
	return (NIL);
}

#ifdef SAVERESTORE
/* xsave - save the memory image */
LVAL xsave()
{
	char *name;

	/* get the file name, verbose flag and print flag */
	name = getstring(xlgetfname());
	xllastarg();

	/* save the memory image */
	return (xlisave(name) ? true : NIL);
}

#ifdef MSC6
/* no optimization which interferes with setjmp */
#pragma optimize("elg",off)
#endif

/* xrestore - restore a saved memory image */
LVAL xrestore()
{
	extern jmp_buf top_level;
	char *name;

	/* get the file name, verbose flag and print flag */
	name = getstring(xlgetfname());
	xllastarg();

	/* restore the saved memory image */
	if (!xlirestore(name))
		return (NIL);

	/* return directly to the top level */
	stdputstr("[ returning to the top level ]\n");
	longjmp(top_level,1);
	return (NIL);	/* never executed, but avoids warning message */
}
#ifdef MSC6
#pragma optimize("",on)
#endif

#endif