// ==========================================================================
// METHOD updatesource::list
// ==========================================================================
const value &updatesource::list (void)
{
value list;
value outargs;
list = getlist ();
foreach (update, list)
{
if (cache.exists (update.id()))
{
update = cache[update.id()];
}
else
{
update["description"] = getdesc (update.id());
resolvedeps (update.id(), list);
}
}
cache = list;
cache.saveshox (PATH_CACHEFILE);
return cache;
}
/* xlprint - print an xlisp value */
void xlprint(LVAL fptr, LVAL vptr, int flag)
{
LVAL nptr,next;
int n,i;
/* print nil */
if (vptr == NIL) {
putsymbol(fptr,"NIL",flag);
return;
}
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putsubr(fptr,"Subr",vptr);
break;
case FSUBR:
putsubr(fptr,"FSubr",vptr);
break;
case CONS:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NIL; nptr = next) {
xlprint(fptr,car(nptr),flag);
if (next = cdr(nptr))
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYMBOL:
putsymbol(fptr,(char *) getstring(getpname(vptr)),flag);
break;
case FIXNUM:
putfixnum(fptr,getfixnum(vptr));
break;
case FLONUM:
putflonum(fptr,getflonum(vptr));
break;
case CHAR:
putchcode(fptr,getchcode(vptr),flag);
break;
case STRING:
if (flag)
putqstring(fptr,vptr);
else
putstring(fptr,vptr);
break;
case STREAM:
putatm(fptr,"File-Stream",vptr);
break;
case USTREAM:
putatm(fptr,"Unnamed-Stream",vptr);
break;
case OBJECT:
putatm(fptr,"Object",vptr);
break;
case VECTOR:
xlputc(fptr,'#');
xlputc(fptr,'(');
for (i = 0, n = getsize(vptr); n-- > 0; ) {
xlprint(fptr,getelement(vptr,i++),flag);
if (n) xlputc(fptr,' ');
}
xlputc(fptr,')');
break;
case CLOSURE:
putclosure(fptr,vptr);
break;
case EXTERN:
if (getdesc(vptr)) {
(*(getdesc(vptr)->print_meth))(fptr, getinst(vptr));
}
break;
case FREE_NODE:
putatm(fptr,"Free",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}
/* dmazzoni: was LOCAL void sweep(void) */
void sweep(void)
{
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) /* don't sweep the fixnum segment */
continue;
else if (seg == charseg) /* don't sweep the character segment */
continue;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; --n >= 0; ++p) {
#ifdef DEBUG_MEM
if (xldmem_trace &&
ntype(p) == EXTERN &&
xldmem_trace == getinst(p)) {
printf("sweep: EXTERN node %lx is %smarked, points to %lx\n",
p, (p->n_flags & MARK ? "" : "un"), getinst(p));
}
#endif
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STRING:
if (getstring(p) != NULL) {
total -= (long)getslength(p);
free(getstring(p));
}
break;
case STREAM:
if (getfile(p))
osclose(getfile(p));
break;
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
if (p->n_vsize) {
total -= (long) (p->n_vsize * sizeof(LVAL));
free((void *) p->n_vdata);
}
break;
case EXTERN:
/* printf("GC about to free %x\n", p);
* fflush(stdout);
*/
if (getdesc(p)) { (*(getdesc(p)->free_meth))(getinst(p));
}
break;
}
p->n_type = FREE_NODE;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree += 1L;
}
else
p->n_flags &= ~MARK;
}
}
}
/* mark - mark all accessible nodes */
void mark(LVAL ptr)
{
register LVAL this,prev,tmp;
int type,i,n;
/*
if (ptr == test_mark) {
printf("\n\nFound test_mark\n\n");
}
*/
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
for (;;) {
/* descend as far as we can */
while (!(this->n_flags & MARK))
/* check cons and symbol nodes */
if ((type = ntype(this)) == CONS || type == USTREAM) {
if (tmp = car(this)) {
this->n_flags |= MARK|LEFT;
rplaca(this,prev);
}
else if (tmp = cdr(this)) {
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:
for (i = 0, n = getsize(this); --n >= 0; ++i)
if (tmp = getelement(this,i))
mark(tmp);
break;
case EXTERN:
if (getdesc(this)->mark_meth) { (*(getdesc(this)->mark_meth))(getinst(this));
}
}
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)) {
rplacd(prev,tmp);
break;
}
}
else { /* came from right side */
tmp = cdr(prev);
rplacd(prev,this);
}
this = prev; /* step back up the branch */
prev = tmp;
}
/* no previous node, must be done */
else
return;
}
}
