/* 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 "flp1_xlisp_h"

/* useful definitions */
#define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))

/* external variables */
extern NODE *obarray,*s_gcflag;
extern NODE *xlenv;
extern long nnodes,nfree,total;
extern int anodes,nsegs,gccalls;
extern struct segment *segs;
extern NODE *fnodes;
extern char buf[];

/* external procedures */
extern char *malloc();
extern char *calloc();

/* forward declarations */
FORWARD NODE *newnode();
FORWARD char *strsave();
FORWARD char *stralloc();

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

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

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

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

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

/* cvstring - convert a string to a string node */
NODE *cvstring(str)
  char *str;
{
    NODE ***oldstk,*val;
    oldstk = xlstack;
    xlsave1(val);
    val = newnode(STR);
    val->n_str = strsave(str);
    val->n_strtype = DYNAMIC;
    xlstack = oldstk;
    return (val);
}

/* cvcstring - convert a constant string to a string node */
NODE *cvcstring(str)
  char *str;
{
    NODE *val;
    val = newnode(STR);
    val->n_str = str;
    val->n_strtype = STATIC;
    return (val);
}

/* cvsymbol - convert a string to a symbol */
NODE *cvsymbol(pname)
  char *pname;
{
    NODE ***oldstk,*val;
    oldstk = xlstack;
    xlsave1(val);
    val = newnode(SYM);
    val->n_symplist = newnode(LIST);
    rplaca(val->n_symplist,cvstring(pname));
    xlstack = oldstk;
    return (val);
}

/* cvcsymbol - convert a constant string to a symbol */
NODE *cvcsymbol(pname)
  char *pname;
{
    NODE ***oldstk,*val;
    oldstk = xlstack;
    xlsave1(val);
    val = newnode(SYM);
    val->n_symplist = newnode(LIST);
    rplaca(val->n_symplist,cvcstring(pname));
    xlstack = oldstk;
    return (val);
}

/* cvsubr - convert a function to a subr or fsubr */
NODE *cvsubr(fcn,type)
  NODE *(*fcn)(); int type;
{
    NODE *val;
    val = newnode(type);
    val->n_subr = fcn;
    return (val);
}

/* cvfile - convert a file pointer to a file */
NODE *cvfile(fp)
  FILE *fp;
{
    NODE *val;
    val = newnode(FPTR);
    setfile(val,fp);
    setsavech(val,0);
    return (val);
}

/* cvfixnum - convert an integer to a fixnum node */
NODE *cvfixnum(n)
  FIXNUM n;
{
    NODE *val;
    val = newnode(INT);
    val->n_int = n;
    return (val);
}

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

/* newstring - allocate and initialize a new string */
NODE *newstring(size)
  int size;
{
    NODE ***oldstk,*val;
    oldstk = xlstack;
    xlsave1(val);
    val = newnode(STR);
    val->n_str = stralloc(size);
    *getstring(val) = 0;
    val->n_strtype = DYNAMIC;
    xlstack = oldstk;
    return (val);
}

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

/* newvector - allocate and initialize a new vector node */
NODE *newvector(size)
  int size;
{
    NODE ***oldstk,*vect;
    int bsize;

    /* establish a new stack frame */
    oldstk = xlstack;
    xlsave1(vect);

    /* allocate a vector node and set the size to zero (in case of gc) */
    vect = newnode(VECT);
    vect->n_vsize = 0;

    /* allocate memory for the vector */
    bsize = size * sizeof(NODE *);
    if ((vect->n_vdata = (NODE **)calloc(1,bsize)) == NULL) {
          findmem();
          if ((vect->n_vdata = (NODE **)calloc(1,bsize)) == NULL)
              xlfail("insufficient vector space");
    }
    vect->n_vsize = size;
    total += (long) bsize;

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the new vector */
    return (vect);
}

/* newnode - allocate a new node */
LOCAL NODE *newnode(type)
  int type;
{
    NODE *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);
}

/* 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+1)) == NULL) {
          findmem();
          if ((sptr = malloc(size+1)) == NULL)
              xlfail("insufficient string space");
    }
    total += (long) (size+1);

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

/* strsave - generate a dynamic copy of a string */
LOCAL char *strsave(str)
  char *str;
{
    char *sptr;

    /* create a new string */
    sptr = stralloc(strlen(str));
    strcpy(sptr,str);

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

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

/* gc - garbage collect */
gc()
{
    NODE ***p;

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

    /* mark the obarray and the current environment */
    mark(obarray);
    mark(xlenv);

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

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

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

    /* 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 mark(ptr)
  NODE *ptr;
{
    register NODE *this,*prev,*tmp;
    int type,i,n;

    /* just return on nil */
    if (ptr == NIL)
          return;

    /* initialize */
    prev = NIL;
    this = ptr;

    /* mark this list */
    for (;;) {

          /* descend as far as we can */
          for (;;) {

              /* check for this node being marked */
              if (this->n_flags & MARK)
                    break;

              /* mark it and its descendants */
              else {

                    /* mark the node */
                    this->n_flags |= MARK;

                    /* follow the left sublist if there is one */
                    if ((type = ntype(this)) == LIST || type == SYM) {
                        if (car(this)) {
                              this->n_flags |= LEFT;
                              tmp = prev;
                              prev = this;
                              this = car(prev);
                              rplaca(prev,tmp);
                        }
                        else if (cdr(this)) {
                              this->n_flags &= ~LEFT;
                              tmp = prev;
                              prev = this;
                              this = cdr(prev);
                              rplacd(prev,tmp);
                        }
                    }
                    else {
                        if (type == OBJ || type == VECT)
                              for (i = 0, n = getsize(this); --n >= 0; ++i)
                                  mark(getelement(this,i));
                        break;
                    }
              }
          }

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

              /* check for termination condition */
              if (prev == NIL)
                    return;

              /* check for coming from the left side */
              if (prev->n_flags & LEFT)
                    if (cdr(prev)) {
                        prev->n_flags &= ~LEFT;
                        tmp = car(prev);
                        rplaca(prev,this);
                        this = cdr(prev);
                        rplacd(prev,tmp);
                        break;
                    }
                    else {
                        tmp = prev;
                        prev = car(tmp);
                        rplaca(tmp,this);
                        this = tmp;
                    }

              /* otherwise, came from the right side */
              else {
                    tmp = prev;
                    prev = cdr(tmp);
                    rplacd(tmp,this);
                    this = tmp;
              }
          }
    }
}

/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL sweep()
{
    struct segment *seg;
    NODE *p;
    int n;

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

    /* add all unmarked nodes */
    for (seg = segs; seg != NULL; seg = seg->sg_next) {
          p = &seg->sg_nodes[0];
          for (n = seg->sg_size; --n >= 0; ++p)
              if (!(p->n_flags & MARK)) {
                    switch (ntype(p)) {
                    case STR:
                            if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
                                  total -= (long) (strlen(p->n_str)+1);
                                  free(p->n_str);
                              }
                              break;
                    case FPTR:
                              if (p->n_fp)
                                  fclose(p->n_fp);
                              break;
                    case VECT:
                              if (p->n_vsize) {
                               total -= (long) (p->n_vsize * sizeof(NODE **));
                                  free(p->n_vdata);
                              }
                              break;
                    }
                    p->n_type = FREE;
                    p->n_flags = 0;
                    rplaca(p,NIL);
                    rplacd(p,fnodes);
                    fnodes = p;
                    nfree += 1L;
              }
              else
                    p->n_flags &= ~(MARK | LEFT);
    }
}

/* addseg - add a segment to the available memory */
int addseg()
{
    struct segment *newseg;
    NODE *p;
    int n;

    /* check for zero allocation */
    if (anodes == 0)
          return (FALSE);

    /* allocate a new segment */
    if ((newseg = (struct segment *)calloc(1,ALLOCSIZE)) != NULL) {

          /* initialize the new segment */
          newseg->sg_size = anodes;
          newseg->sg_next = segs;
          segs = newseg;

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

          /* update the statistics */
          total += (long)ALLOCSIZE;
          nnodes += (long)anodes;
          nfree += (long)anodes;
          ++nsegs;

          /* return successfully */
          return (TRUE);
    }
    else
          return (FALSE);
}

/* stats - print memory statistics */
stats()
{
    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);
}

/* xlminit - initialize the dynamic memory module */
xlminit()
{
    /* initialize our internal variables */
    anodes = NNODES;
    nnodes = nfree = total = 0L;
    nsegs = gccalls = 0;
    fnodes = NIL;
    segs = NULL;

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

    /* allocate the evaluation stack */
    if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
          printf("insufficient memory");
          wrapup();
    }
    total += (long)(EDEPTH * sizeof(NODE **));
    xlstack = xlstktop = xlstkbase + EDEPTH;
}