240 lines
4.6 KiB
C
240 lines
4.6 KiB
C
/* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
|
|
* Copyright 1989 Massachusetts Institute of Technology
|
|
*/
|
|
/**************************\
|
|
* *
|
|
* WOOL_OBJECT Collection *
|
|
* BODY *
|
|
* *
|
|
\**************************/
|
|
|
|
#include "EXTERN.h"
|
|
#include <stdio.h>
|
|
#include "wool.h"
|
|
#include "wl_number.h"
|
|
#include "wl_atom.h"
|
|
#include "wl_list.h"
|
|
#include "INTERN.h"
|
|
#include "wl_coll.h"
|
|
|
|
WOOL_OBJECT WLCollection_release();
|
|
|
|
/*
|
|
* wlcf (wool collection free)
|
|
*
|
|
* management of an stack of free collections to avoid calls to malloc
|
|
*/
|
|
|
|
#define WLCF_LIMIT 32
|
|
#if WLCF_LIMIT
|
|
static WOOL_Collection wlcf[WLCF_LIMIT];
|
|
#else
|
|
static WOOL_Collection wlcf[1];
|
|
#endif
|
|
static WOOL_Collection *wlcf_last = wlcf;
|
|
static int wlcf_size, wlcf_limit = WLCF_LIMIT;
|
|
|
|
/* to be called once */
|
|
|
|
#ifdef STATS
|
|
WOOL_OBJECT
|
|
wlcfstats()
|
|
{
|
|
wool_printf("wool-coll-free (wlcf) has %d", wlcf_size);
|
|
wool_printf("/%d slots\n", wlcf_limit);
|
|
return NIL;
|
|
}
|
|
#endif /* STATS */
|
|
|
|
/* to release wlcf */
|
|
|
|
wlcf_flush()
|
|
{
|
|
WOOL_Collection *p = wlcf_last - 1;
|
|
|
|
while (p >= wlcf) {
|
|
WLCollection_release(*p);
|
|
p--;
|
|
}
|
|
wlcf_size = 0;
|
|
wlcf_last = wlcf;
|
|
}
|
|
|
|
/* put in wlcf */
|
|
|
|
WOOL_OBJECT
|
|
WLCollection_free(col)
|
|
WOOL_Collection col;
|
|
{
|
|
if (wlcf_size >= wlcf_limit) {
|
|
WLCollection_release(col);
|
|
} else {
|
|
wlcf_size++;
|
|
*wlcf_last++ = col;
|
|
col -> size = 0;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
/*
|
|
* Constructor:
|
|
* WLCollection_make
|
|
* do a wlcf_get in fact...
|
|
*/
|
|
|
|
WOOL_Collection
|
|
WLCollection_make()
|
|
{
|
|
WOOL_Collection col;
|
|
|
|
if (wlcf_size) {
|
|
col = *(--wlcf_last);
|
|
wlcf_size--;
|
|
zrt_put(col);
|
|
} else {
|
|
col = (WOOL_Collection)
|
|
Malloc(sizeof(struct _WOOL_Collection));
|
|
zrt_put(col);
|
|
col -> type = WLCollection;
|
|
col -> size = 0;
|
|
col -> limit = INITIAL_COLLECTION_SIZE;
|
|
col -> list = (WOOL_OBJECT *) Malloc(col -> limit * sizeof(WOOL_OBJECT));
|
|
}
|
|
return col;
|
|
}
|
|
|
|
/*
|
|
* WLCollection_print:
|
|
* Normally, never to be called.
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLCollection_print(obj)
|
|
WOOL_Collection obj;
|
|
{
|
|
int i;
|
|
WOOL_OBJECT *p = obj -> list;
|
|
|
|
wool_puts("{COLLECTION ");
|
|
for (i = 0; i < obj -> size; i++, p++) {
|
|
if (i)
|
|
wool_putchar(' ');
|
|
WOOL_send(WOOL_print, *p, (*p));
|
|
}
|
|
wool_putchar('}');
|
|
return (WOOL_OBJECT) obj;
|
|
}
|
|
|
|
/*
|
|
* WLCollection_free
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLCollection_release(col)
|
|
WOOL_Collection col;
|
|
{
|
|
Free(col -> list);
|
|
Free(col);
|
|
return NULL;
|
|
}
|
|
|
|
/*
|
|
* trying to execute an collection is the same error than executing an atom.
|
|
*/
|
|
|
|
/*
|
|
* WLCollection_add:
|
|
* Adds arg2 to arg1, just catenating if there is room, increasing limit
|
|
* of collection if not.
|
|
* (we know we have 4 bytes of overhead, thats the reason for our
|
|
* growing scheme: * 2 +4)
|
|
* WARNING: since a zrt_gc cannot occur during parsing, we do not set
|
|
* the reference count on the sons!
|
|
*/
|
|
|
|
WOOL_Collection
|
|
WLCollection_add(col, obj)
|
|
WOOL_Collection col;
|
|
WOOL_OBJECT obj;
|
|
{
|
|
if (col -> size >= col -> limit) {
|
|
WOOL_OBJECT *oldlist = col -> list;
|
|
|
|
col -> limit = col -> limit << 1 + 1;
|
|
col -> list = (WOOL_OBJECT *) Malloc((col -> limit) * sizeof(WOOL_OBJECT));
|
|
bcopy(oldlist, col -> list, col -> size * sizeof(WOOL_OBJECT));
|
|
Free(oldlist);
|
|
}
|
|
*(col -> list + (col -> size)++) = obj;
|
|
return col;
|
|
}
|
|
|
|
/* makes a (progn <list>) of a collection
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLCollection_progn(col)
|
|
WOOL_Collection col;
|
|
{
|
|
if (col -> size) {
|
|
WOOL_List object = wool_list_make(col->size +1);
|
|
|
|
copy_n_objects(col -> list, object -> list + 1, col -> size);
|
|
increase_reference(object -> list[0] = WA_progn);
|
|
return (WOOL_OBJECT) object;
|
|
} else { /* a list of size 0 is just NIL */
|
|
return NIL;
|
|
}
|
|
}
|
|
|
|
/*******************************************************\
|
|
* *
|
|
* QuotedExpr package for speeding up quoted constructs *
|
|
* *
|
|
\*******************************************************/
|
|
|
|
WOOL_QuotedExpr
|
|
WLQuotedExpr_make(expr)
|
|
WOOL_OBJECT expr;
|
|
{
|
|
WOOL_QuotedExpr object = (WOOL_QuotedExpr)
|
|
Malloc(sizeof(struct _WOOL_QuotedExpr));
|
|
|
|
zrt_put(object);
|
|
object -> type = WLQuotedExpr;
|
|
increase_reference(object -> expr = expr);
|
|
return (WOOL_QuotedExpr) object;
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLQuotedExpr_eval(obj)
|
|
WOOL_QuotedExpr obj;
|
|
{
|
|
return (WOOL_OBJECT) obj -> expr;
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLQuotedExpr_print(obj)
|
|
WOOL_QuotedExpr obj;
|
|
{
|
|
wool_putchar('\'');
|
|
WOOL_send(WOOL_print, obj -> expr, (obj -> expr));
|
|
return (WOOL_OBJECT) obj;
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLQuotedExpr_free(obj)
|
|
WOOL_QuotedExpr obj;
|
|
{
|
|
decrease_reference(obj -> expr);
|
|
Free(obj);
|
|
return NULL;
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLQuotedExpr_equal(o1, o2)
|
|
WOOL_QuotedExpr o1, o2;
|
|
{
|
|
return WOOL_send(WOOL_equal, o1 -> expr, (o1 -> expr, o2 -> expr));
|
|
}
|