xldmem.c

Audacity是一款用於錄音和編輯聲音的、免費的開放源碼軟體。它可以執行於Mac OS X、Microsoft Windows、GNU/Linux和其它作業系統

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

 * HISTORY
 * 28-Apr-03    Mazzoni
 *  eliminate some compiler warnings
 * 14-Apr-88	Dannenberg
 *	Call free method when an EXTERN node is garbage collected
 */


/* #define DEBUG_MEM 1 */

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

/* node flags */
#define MARK	1
#define LEFT	2

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


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

#ifdef DEBUG_MEM
long xldmem_trace = 0;	/* debugging */
#endif

/* forward declarations */
FORWARD LOCAL void findmem(void);
FORWARD LVAL newnode(int type);
FORWARD LOCAL unsigned char *stralloc(int size);
FORWARD LOCAL int addseg(void);
FORWARD void mark(LVAL ptr);
FORWARD LOCAL void sweep(void);

#ifdef DEBUG_GC
static long dbg_gc_n = 0;	/* counts save operations */
long dbg_gc_count = 0;	        /* says when to stop */
LVAL *dbg_gc_addr = NULL;	/* says what we're looking for */

void dbg_gc_xlsave(LVAL *n)
{
    dbg_gc_n++;
    if (n == dbg_gc_addr) {
        printf("dbg_gc_xlsave: %x at count %d\n",
               dbg_gc_addr, dbg_gc_n);
    }
    if (dbg_gc_count == dbg_gc_n) {
        printf("dbg_gc_xlsave: reached %d\n",
               dbg_gc_count);
    }
}


#endif


/* cons - construct a new cons node */
LVAL cons(LVAL x, LVAL 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(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);
}

/* new_string - allocate and initialize a new string */
LVAL new_string(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(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 */
LVAL cvsubr(LVAL (*fcn)(void), int type, int offset)
{
    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(FILE *fp)
{
    LVAL val;
    val = newnode(STREAM);
    setfile(val,fp);
    setsavech(val,'\0');
    return (val);
}

/* cvfixnum - convert an integer to a fixnum node */
LVAL cvfixnum(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);
}

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

/* cvchar - convert an integer to a character node */
LVAL cvchar(int n)
{
    if (n >= CHARMIN && n <= CHARMAX)
        return (&charseg->sg_nodes[n-CHARMIN]);
    xlerror("character code out of range",cvfixnum((FIXTYPE)n));
    return NIL; /* won't reach this line */
}

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

/* newobject - allocate and initialize a new object */
LVAL newobject(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(LVAL name, LVAL type, LVAL env, LVAL fenv)
{
    LVAL val;
    val = newvector(CLOSIZE);
    val->n_type = CLOSURE;
    setname(val,name);
    settype(val,type);
    setenv(val,env);
    setfenv(val,fenv);
    return (val);
}

/* newvector - allocate and initialize a new vector node */
LVAL newvector(int size)
{
    LVAL vect;
    int bsize;
    xlsave1(vect);
    vect = newnode(VECTOR);
    vect->n_vsize = 0;
    if ((bsize = size * sizeof(LVAL))) {
        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 */
LVAL newnode(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);
}

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

    /* allocate memory for the string copy */
    if ((sptr = (unsigned char *)malloc(size)) == NULL) {
        gc();  
        if ((sptr = (unsigned char *)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(void)
{
    gc();
    if (nfree < (long)anodes)
        addseg();
}

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

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

    /* mark the fixnum used by profiler */
    if (!null(profile_fixnum)) mark(profile_fixnum);

    /* 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))
            mark(tmp);

    /* mark the argument stack */
    for (ap = xlargstkbase; ap < xlsp; ++ap)
        if ((tmp = *ap))
            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))) {
        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", nfree);
        stdputstr(buf);
        /* print additional info (e.g. sound blocks in Nyquist) */
        print_local_gc_info();
        stdputstr(" ]\n");
    }
}

/* mark - mark all accessible nodes */
void mark(LVAL ptr)
{
    register LVAL this,prev,tmp;
    int type,i,n;

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

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

        /* descend as far as we can */
        while (!(this->n_flags & MARK))