/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/**************************\
* 			   *
*  KlO Collection  *
*  BODY			   *
* 			   *
\**************************/

#include "EXTERN.h"
#include "klone.h"
#include "kl_number.h"
#include "kl_atom.h"
#include "kl_list.h"
#include "kl_string.h"
#include "kl_stream.h"
#include "kl_func.h"
#include "INTERN.h"
#include "kl_coll.h"

#define INITIAL_COLLECTION_SIZE 7	/* initial size allocated in
					 * KlCollectionMake */

KlO KlCollectionRelease();

/*
 * klcf (klone collection free)
 * 
 * management of an stack of free collections to avoid calls to malloc
 */

#define KlCF_LIMIT 32
#if KlCF_LIMIT
static KlCollection klcf[KlCF_LIMIT];

#else
static KlCollection klcf[1];

#endif
static KlCollection *klcf_last = klcf;
static int klcf_size, klcf_limit = KlCF_LIMIT;

/* to be called once */

#ifdef STATS
KlO
KlCfstats()
{
    KlPrintf("klone-coll-free (klcf)  has %d", klcf_size);
    KlPrintf("/%d slots\n", klcf_limit);
    return NIL;
}

#endif					/* STATS */

/* to release klcf  */

KlCfFlush()
{
    KlCollection *p = klcf_last - 1;

    while (p >= klcf) {
	KlCollectionRelease(*p);
	p--;
    }
    klcf_size = 0;
    klcf_last = klcf;
}

/* put in klcf */

KlO
KlCollectionFree(col)
    KlCollection col;
{
    if (klcf_size >= klcf_limit) {
	KlCollectionRelease(col);
    } else {
	klcf_size++;
	*klcf_last++ = col;
	col->size = 0;
    }
    return (KlO) col;
}

/*
 * Constructor:
 * KlCollectionMake
 * do a klcf_get in fact...
 */

KlCollection
KlCollectionMake()
{
    KlCollection col;

    if (klcf_size) {
	col = *(--klcf_last);
	klcf_size--;
	KlZrtPut(col);
    } else {
	col = (KlCollection) KlOMake(KlCollectionType);
	col->size = 0;
	col->limit = INITIAL_COLLECTION_SIZE;
	col->list = (KlO *) Malloc(col->limit * KLSO);
    }
    return col;
}

/* 
 * KlCollectionPrint:
 * Normally, never to be called.
 */

KlO
KlCollectionPrint(obj, stream)
    KlCollection obj;
    KlO stream;
{
    KlSequencePrint(obj, stream, "{ }");
    return (KlO) obj;
}

/*
 * KlCollectionFree
 */

KlO
KlCollectionRelease(col)
    KlCollection col;
{
    Free(col->list);
    Free(col);
    return (KlO) col;
}

/*
 * KlCollectionAdd:
 * Adds arg2 to arg1, just catenating if there is room, increasing limit
 * of collection if not.
 * (we know we have KLSO bytes of overhead, thats the reason for our
 * growing scheme: )
 * WARNING: since a KlZrtGc cannot occur during parsing, we do not set
 * the reference count on the sons!
 */

KlCollection
KlCollectionAdd(col, obj)
    KlCollection col;
    KlO obj;
{
    /* special case for Assigns: var = value
     * if last elt of col is '=, create an assign, dont concat
     */
    if ((col->size >= 2) && (col->list[col->size - 1] == (KlO) KlA_equal)
	&& KlInfixAssigns) {
	col->size--;
	col->list[col->size - 1] = (KlO)
	    KlAssignMake(col->list[col->size - 1], obj);
	return col;
    }
    if (col->size >= col->limit) {
	col->limit = col->limit << 1 + 1;
	col->list = (KlO *) Realloc(col->list, (col->limit) * KLSO);
    }
    *(col->list + (col->size)++) = obj;
    return col;
}

/* evaluates a {<list>} on-line call
   returns 0 in case of error
 */

KlO
KlCollectionEvalOnLine(col)
    KlCollection col;
{
    int normal;
    KlO result;

    if (KlQuoteInlines) {
	KlList l = col->size ? KlListMake(col) : KlListNMake(0);
	l->type = KlListInlineType;
	return (KlO) l;
    } else {
	KlCatch(KlA_ALL, KlListEval(col), result, normal);
	return (normal ? result : 0);
    }
}

/*****************************************************************************\
*                                                                             *
* 	     QuotedExpr package for speeding up quoted constructs             *
*                                                                             *
\*****************************************************************************/
/* Quoted Expr are a subtype of lists 
 */

KlQuotedExpr
KlAnyQuotedExprMake(symbol, expr, eval)
    KlAtom symbol;
    KlO expr;
    KlMethod eval;
{
    KlQuotedExpr object = (KlQuotedExpr) KlOMake(KlQuotedExprType);

    KlIncRef(object->expr = expr);
    object->symbol = symbol;
    object->eval = eval;
    object->size = 2;
    object->list = (KlO *) &(object->symbol);
    return (KlQuotedExpr) object;
}

KlO
KlQuotedExprCopy(obj)
    KlQuotedExpr obj;
{
    return (KlO) KlAnyQuotedExprMake(obj->symbol, obj->expr, obj->eval);
}

/* the generic eval method */

KlO
KlQuotedExprEval(obj)
    KlQuotedExpr obj;
{
    return (KlO) CFAPPLY(obj->eval, (obj->expr));
}

KlO
KlQuotedExprPrint(obj, stream)
    KlQuotedExpr obj;
    KlO stream;
{
    KlSend_print(obj->symbol, stream);
    KlSend_print(obj->expr, stream);
    return (KlO) obj;
}

KlO
KlQuotedExprFree(obj)
    KlQuotedExpr obj;
{
    KlDecRef(obj->expr);
    Free(obj);
    return (KlO) obj;
}

/*ARGSUSED*/
KlO
KlQuotedExprPut(o, n, expr)
    KlQuotedExpr o;
    KlNumber n;
    KlAtom expr;
{
    if (KlIsANumber(n) && n->number == 0) { /* first arg = symbol */
	KlMustBeAtom(expr, 2);
	if ((KlIsASubr(expr->c_val) || KlIsAFSubr(expr->c_val))
	    && ((KlSubr) expr->c_val)->arity == 1){
	    o->eval = ((KlSubr) expr->c_val)->body;
	} else {
	    return KlError(KlE_NO_PUT, o);
	}
    } else {				/* other = expr */
	KlDecRef(o->expr);
	KlIncRef(o->expr = (KlO) expr);
    }
    return (KlO) o;
}

/****************************************** specialized methods for ' ` , ,@ */

/* the eval method for ' : KlQuote */

KlO
KlQuote(obj)
    KlO obj;
{
    return obj;
}

/* the eval method for ` : KlBackquote */

/* backquoting:
 * parses argument (must be list) and expands only (, foo) and (,@ foo)
 * sublists
 */

KlO
KlBackquote(obj)
    KlList obj;
{
    KlList result;
    int i, j;
    KlO *p;

    if (KlIsAList(obj)) {		/* `(...) */
	if (!obj->size)			/* `() = () */
	    return (KlO) obj;
	if (obj->list[0] == (KlO) KlA_unquote) /* `,a = a */
	    return KlSend_eval(obj->list[1]);
	if (obj->list[0] == (KlO) KlA_backquote) /* ``a = `a */
	    return (KlO) obj;

	KlListNMakeZ(result, (size_t) obj->size);
	p = result->list;
	for (i = 0; i < obj->size; i++) {
	    KlQuotedExpr l = (KlQuotedExpr) obj->list[i];

	    if (KlIsAQuotedExpr(l)) {

		if (l->symbol == KlA_quote) { /* recurse into 'foo */
		    KlIncRef(*p++ = (KlO)
			     KlQuotedExprMake(KlBackquote(l->expr)));

		} else if (l->symbol == KlA_unquote) { /* ,foo */
		    KlIncRef(*p++ = KlSend_eval(l->list[1]));


		} else if (l->symbol == KlA_unquotesplicing) { /* ,@(foo) */
		    KlList el = (KlList) KlSend_eval(l->list[1]);

		    if (KlIsAList(el)) {
			result->size += el->size - 1;
			if (el->size > 1) {
			    int offset = p - result->list;

			    result->list = (KlO *)
				Realloc(result->list, result->size
					* sizeof(KlO));
			    p = result->list + offset;
			}
			for (j = 0; j < el->size; j++) {
			    KlIncRef(*p++ = el->list[j]);
			}

		    } else {		/* verbatim copy other objects */
			KlIncRef(*p++ = (KlO) el);
		    }

		} else if (l->symbol == KlA_backquote) { /* ``() */
		    KlIncRef(*p++ = (KlO) l);

		} else {
		    KlIncRef(*p++ = (KlO) l); /* unknown quote char? */
		}
	    } else if (KlIsAList(l) && l->size) { /* non-nil list */
		KlIncRef(*p++ = KlBackquote(l));
	    } else {			/* other KlOs */
		KlIncRef(*p++ = (KlO) l);
	    }
	}
	if (obj->type != KlListType) {
	    if (obj->type == KlVectorType || obj->type == KlLocatorType)
		result->type = obj->type; /* optim */
	    else			/* regular case */
		result = (KlList) KlCoerce(result, obj->type);
	}
    } else {				/* `a = 'a */
	return (KlO) obj;
    }
    return (KlO) result;
}

/* create a quoted expr from pair */

KlO
KlQuotedExprCoerce(totype, obj)
    KlType totype;
    KlList obj;
{
    if (KlIsAList(obj) && obj->size == 2) {
	KlAtom qc = (KlAtom) obj->list[0];
	KlMethod func = 0;
	if (qc == KlA_quote) 
	    func = KlQuote;
	else if (qc == KlA_backquote)
	    func = KlBackquote;
	else if (qc == KlA_unquote)
	    func = KlQuotedExprCommaEval;
	else if (qc == KlA_unquotesplicing)
	    func = KlQuotedExprCommaEval;
	else
	    return 0;
	return (KlO) KlAnyQuotedExprMake(qc, obj->list[1], func);
    } else {
	return 0;
    }
}


/* the eval method for , and ,@ : error KlE_COMMA_OUTSIDE_BACKQUOTE */

KlO
KlQuotedExprCommaEval(obj)
    KlO obj;
{
    return KlError0(KlE_COMMA_OUTSIDE_BACKQUOTE);
}

/*****************************************************************************\
* 				  TYPE INIT                                   *
\*****************************************************************************/

KlCollectionInit()
{
    KlDeclareSubType(&KlCollectionType, "Collection", KlListType,
		     sizeof(struct _KlCollection));

    KlDeclareMethod1(KlCollectionType, KlSelPrint, KlCollectionPrint);
    KlDeclareMethod1(KlCollectionType, KlSelFree, KlCollectionFree);

    KlDeclareSubType(&KlQuotedExprType, "QuotedExpr", KlListType,
		     sizeof(struct _KlQuotedExpr));

    KlDeclareMethod1(KlQuotedExprType, KlSelEval, KlQuotedExprEval);
    KlDeclareMethod1(KlQuotedExprType, KlSelPrint, KlQuotedExprPrint);
    KlDeclareMethod1(KlQuotedExprType, KlSelFree, KlQuotedExprFree);
    KlDeclareMethod1(KlQuotedExprType, KlSelPut, KlQuotedExprPut);
    KlDeclareMethod1(KlQuotedExprType, KlSelCopy, KlQuotedExprCopy);

    KlDeclareMethodUndefined(KlQuotedExprType, KlSelInsert);
    KlDeclareMethodUndefined(KlQuotedExprType, KlSelDelete);
}