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

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

extern KlO KlCollectionPrint();

/*
 * Constructor:
 * used mainly in parser, called by KlListMake
 */

KlList
KlListMake(col)
    KlCollection col;
{
    if (col->size) {
	KlList object = (KlList) KlOMake(KlListType);

	object->list = (KlO *) Malloc((col->size) *
				      sizeof(KlO));
	KlCopyNObjects(col->list, object->list, col->size);
	object->size = col->size;
	return object;
    } else {				/* a list of size 0 is just NIL */
	return (KlList) NIL;
    }
}

/* makes a list with size slots, to be filled by the C programmer */

KlList
KlListNMake(size)
    int size;
{
    KlList kl_list;

    kl_list = (KlList) KlOMake(KlListType);

    kl_list->list = (size > 0 ? (KlO *) Malloc(size * sizeof(KlO)) :
	(KlO *) (size = 0));

    kl_list->size = size;
    return kl_list;
}

/* externally callable list-make:
 * (make-list n &key :initial-element)
 * or (make-list (n [initial-element])
 */

KlO
KlListNMakeKl(argc, argv)
    int argc;
    KlO argv[];
{
    KlList kl_list;
    int i;
    KlO initial_value;

    if (argc == 2) {
	initial_value = argv[1];
    } else {
	KlParseKeywords(argc, argv, 1);
	initial_value = KlKeyVal(KlK_initial_element, NIL);
	KlCheckUnvalidKeywords(argc, argv, 1);
    }

    KlMustBeNumber(argv[0], 0);
    kl_list = KlListNMake(((KlNumber) argv[0])->number);
    for (i = 0; i < kl_list->size; i++)
	KlIncRef(kl_list->list[i] = initial_value);
    return (KlO) kl_list;
}

/* makes a list of argc, argv KlOS 
 * EVALUATES all the arguments
 */

KlList
KlListNEvalAndMakeFromArray(argc, argv)
    int argc;
    KlO argv[];

{
    KlList kl_list;
    int i;

    kl_list = (KlList) KlOMake(KlListType);

    kl_list->list = (argc > 0 ? (KlO *) Malloc(argc * sizeof(KlO)) :
	(KlO *) (argc = 0));

    kl_list->size = argc;
    for (i = 0; i < argc; i++)
	KlIncRef(kl_list->list[i] = KlSend_eval(argv[i]));
    return kl_list;
}


/*
 * list: makes a list of its evaluated arguments
 */

KlList
KlListKl(argc, argv)
    int argc;
    KlO argv[];

{
    KlList list = KlListNMake(argc);
    KlO *q = list->list, *last = argv + argc;

    while (argv < last)
	KlIncRef(*q++ = *argv++);
    return list;
}

/*
 * makes a list of its evaluated arguments (null-terminated C array)
 */

KlList
KlListNullTerminated(argv)
    KlO argv[];
{
    KlO *p;
    
    for (p = argv; *p; p++)
	;
    return KlListKl(p - argv, argv);
}

/****************************************** VARARGS version, very convenient */
/* must be called by:  KlListMakeV(number_of_elements, elements...)
 * with number_of_elements being a normal "int", not a "Int".
 */

KlList
#if __STDC__
KlListMakeV(int size, ...)
#else
KlListMakeV(va_alist)
    va_dcl
#endif
{
    va_list argList;
    KlList list;
    KlO *p;

#if __STDC__
    va_start(argList, size);
#else
    int size;

    va_start(argList);
    size = va_arg(argList, int);
#endif
    list = KlListNMake(size);
    for (p = list->list; size > 0; size--) {
	*p = va_arg(argList, KlO);
	KlIncRef(*p++);
    }
    va_end(argList);
    return list;
}

/*
 * KlListEval:
 * the heart of the interpreter:
 * evaluating a list is calling the function associated with car by
 * sending KlSelExecute to the CAR, with the list of parameters.
 * 
 * the code could be just:
 * return (obj->size ? KlSend_execute(*(obj->list), obj) : NIL);
 * The conditionals are there to optimize ~15% of speed
 */

KlO
KlListEval(obj)
    KlList obj;
{
    KlO func;

#ifdef DEBUG
    KlO result =
#else  /* DEBUG */
	return
#endif /* DEBUG */
	    (obj->size ?
	     (((obj->list[0])->type == KlAtomType
	       && KlHasTrait(func=((KlAtom) (obj->list[0]))->c_val,
			     KlTrait_function))
	      ? KlSend_execute(func, obj)
	      : KlSend_execute(*(obj->list), obj))
	     : NIL);
#ifdef DEBUG
    ASSERT(KlObjectIsValid(result));
    return result;
#endif /* DEBUG */
}

/*
 * KlListPrint:
 * classical: "(a b c d)"
 * looks for print property in first element's p-list
 */

KlO
KlListPrint(obj, stream)
    KlList obj;
    KlO stream;
{
    KlSequencePrint(obj, stream, "( )");
    return (KlO) obj;
}

/* base implementation 
 */

KlSequencePrint(obj, stream, pars)
    KlList obj;
    KlO stream;
    char *pars;				/* string of "( )" */
{
    int i;
    KlO *p = obj->list;
    KlList plist;
    KlO printer;

    if (++KlPrintLevel > KlMaxPrintLevel) {
	KlSPuts("...", stream);
    } else {
	KlSPutc(pars[0], stream);
	for (i = 0; i < obj->size; i++, p++) {
	    if (i)
		KlSPutc(pars[1], stream);
	    KlSend_print(*p, stream);
	}
	if ((!obj->size) && (obj != (KlList) NIL) && (obj->type == KlListType)) 
	    /* (list) prints as ( ), nil as () */
	    KlSPutc(pars[1], stream);
	KlSPutc(pars[2], stream);
    }
    KlPrintLevel--;
}


/*
 * freeing a list decreases the reference count of all the elements before
 * freeing itself!
 */

KlO
KlListFree(obj)
    KlList obj;
{
    if (obj->list) {
	KlO *last = obj->list + obj->size, *list = obj->list;

	while (list < last) {
	    KlDecRef(*list);
	    list++;
	}
	Free(obj->list);
    }
    Free(obj);
    return (KlO) obj;
}

/*
 * executing a list is evaluating it and sending execute to the result
 */

KlO
KlListExecute(obj, list)
    KlList obj;
    KlList list;
{
    KlO evalobj = KlListEval(obj);

    if (evalobj->type != KlListType) {
	return KlSend_execute(evalobj, list);
    } else if (KlFalseP(evalobj)) {
	return NIL;
    } else {				/* we stop here not to recurse */
	evalobj = KlError(KlE_UNDEFINED_FUNCTION, obj);
	return KlSend_execute(evalobj, list);
    }
}

/*
 * applying a list is evaluating it and sending apply to the result
 */

KlO
KlListApply(obj, list)
    KlList obj;
    KlList list;
{
    KlO evalobj = KlListEval(obj);

    if (evalobj->type != KlListType) {
	return KlSend_apply(evalobj, list);
    } else if (KlFalseP(evalobj)) {
	return NIL;
    } else {				/* we stop here not to recurse */
	evalobj = KlError(KlE_UNDEFINED_FUNCTION, obj);
	return KlSend_apply(evalobj, list);
    }
}

/*
 * equality of two lists is equality of their elements
 */

KlO
KlListEqual(l1, l2)
    KlList l1, l2;
{
    int i;

    if (!KlIsAList(l2)			/* we know l1 is a list or vector */
	|| (l2->size != l1->size))
	return NIL;
    for (i = 0; i < l1->size; i++) {
	if (KlSend_equal(l1->list[i], l2->list[i]) == NIL)
	    return NIL;
    }
    return (KlO) (l1->size ? (KlO) l1 : TRU);
}

/* comparison is alphabetical comparison of elements
 */

int
KlListCompare(l1, l2)
    KlList l1, l2;
{
    int i, res = 0, size;

    if (l1 == l2) return 0;/* shortcut */

    KlMustBeList(l2, 1);
    size = Min(l1->size, l2->size);
    for (i = 0; i < size; i++) {
	if (res = KlSend_compare(l1->list[i], l2->list[i])) {
	    return res;
	}
    }
    return l1->size - l2->size;
}


KlO
KlListLength(list)
    KlList list;
{
    return (KlO) KlNumberMake(list->size);
}

/* memberq function: seekq */
KlO
KlSeekQ(argc, argv)
    int argc;
    KlList *argv;
{
    KlList list;
    KlO elt;
    register KlO *p, *last;
    int offset;

    switch (argc) {
    case 2:
	offset = 0;
	break;
    case 3:
	KlMustBeNumber(argv[2], 2);
	offset = ((KlNumber)argv[2])->number;
	if (offset < 0) offset = 0;
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }

    list = argv[0];
    elt = (KlO) argv[1];
    KlMustBeList(list, 0);
    p = list->list + offset;
    last = p + list->size;
    while (p < last)
	if (*p++ == elt)
	    return (KlO) KlNumberMake((p - list->list) - 1);
    return NIL;
}

/* delete-nth is perhaps the handiest form of delete, but is not Common-lisp 
 * (delete-nth list N) deletes Nth element and returns it (the deleted element)
 * or () if not found or if N is not a number, () for instance
 */

KlO
KlListDeleteNth(list, key)
    KlList list;
    KlNumber key;
{
    UInt i;
    KlO *p, *end, result = NIL;

    KlMustBeList(list, 0);
    if (KlIsANumber(key) &&
	(i = (UInt) key->number) < list->size) {		/* array */
	result = list->list[i];
	KlDecRefNonNull(result);
	list->size--;
	p = list->list + i;
	end = list->list + list->size;
	while (p < end) {
	    *p = *(p+1);
	    p++;
	}
    }
    return result;
}

/**************\
*              *
* List methods *
*              *
\**************/
/* we are sure first arg is a list (we come from KlSend), so we don't check  
 */

/* KlListAdd
 * returns a new list, argument strings not touched
 */

KlO
KlListAdd(argc, argv)
    int argc;
    KlList argv[];

{
    KlList newlist;
    int i, newsize = argv[0]->size, size;

    for (i = 1; i < argc; i++) {
	KlMustBeList(argv[i], i);
	newsize += argv[i]->size;
    }
    if (!newsize)
	return NIL;
    newlist = KlListNMake(newsize);
    newlist->type = argv[0]->type;
    newsize = 0;
    for (i = 0; i < argc; i++) {
	if (size = argv[i]->size) {
	    KlCopyNObjects(argv[i]->list,
		&(newlist->list)[newsize],
		size);
	    newsize += size;
	}
    }
    return (KlO) newlist;
}

KlO
KlListAppend(list, obj)
    KlList list;
    KlO obj;
{
    list->size++;
    list->list = (KlO *) Realloc(list->list, KLSO * list->size);
    KlIncRef(list->list[list->size - 1] = obj);
    return (KlO) list;
}

/* append a multiple number of elements
 * KlListAppendV(list, N, obj1,..., objN)
 */
KlO
#if __STDC__
KlListAppendV(KlList list, int size, ...)
#else
KlListAppendV(va_alist)
    va_dcl
#endif
{
    va_list argList;
    KlO *p, *last;
#if __STDC__
    va_start(argList, size);
#else
    int size;
    KlList list;

    va_start(argList);
    list = va_arg(argList, KlList);
    size = va_arg(argList, int);
#endif

    list->list = (KlO *) Realloc(list->list, KLSO * (list->size + size));
    p = list->list + list->size;
    list->size += size;
    last = p + size;
    for (; p < last; p++) {
	 KlIncRef(*p = va_arg(argList, KlO));
    }
    return (KlO) list;
}
 
/* A special case for adding a pair, useful in many cases (plists)
 */

KlO
KlListAppend2(list, obj1, obj2)
    KlList list;
    KlO obj1;
    KlO obj2;
{
    list->size += 2;
    list->list = (KlO *) Realloc(list->list, KLSO * list->size);
    KlIncRef(list->list[list->size - 2] = obj1);
    KlIncRef(list->list[list->size - 1] = obj2);
    return (KlO) list;
}

/* Klone-callable version
 */

KlO
KlListAppendKl(list, obj)
    KlList list;
    KlO obj;
{
    KlMustBeList(list, 0);
    if (list == (KlList) NIL) {
	return KlError(KlE_NO_PUT, list);
    } else {
	return KlListAppend(list, obj);
    }
}

/* KlListGet
 */

KlO
KlListGet(list, key, def)
    KlList list;
    KlNumber key;
    KlO def;
{
    int i;

    if (KlIsANumber(key)) {		/* array */
	i = key->number;
	if (i < 0 ) {
	    return list->size ? list->list[list->size - 1] : 
		KlExecuteGetDefault(list, key, def);
	} else if (i < list->size) {
	    return list->list[i];
	} else {
	    return KlExecuteGetDefault(list, key, def);
	}
    } else {				/* p-list */
	KlMustBeEvenList(list, 0);
	if (KlHasTrait(key, KlTrait_hasheq)) { /* hasheq ==> eq-search */
	    for (i = 1; i < list->size; i += 2) {
		if (list->list[i - 1] == (KlO) key) {
		    return list->list[i];
		}
	    }
	} else {			/* else equal-search */
	    for (i = 1; i < list->size; i += 2) {
		if (NIL != KlSend_equal(key, list->list[i - 1])) {
		    return list->list[i];
		}
	    }
	}
	return KlExecuteGetDefault(list, key, def);
    }
}

/* KlListPut
 * returns list
 */

KlO
KlListPut(list, key, val)
    KlList list;
    KlNumber key;
    KlO val;
{
    int i;

    if (list == (KlList) NIL) {
	KlError(KlE_NO_PUT, list);
    }
    if (KlIsANumber(key)) {		/* array */
	i = key->number;
	if (i < 0) {			/* negative = append to list */
	    i = list->size;
	}
	if (i < list->size) {
	    KlDecRef(list->list[i]);
	    KlIncRef(list->list[i] = val);
	} else {			/* extend to add */
	    int j = list->size;

	    list->size = i + 1;
	    list->list = (KlO *) Realloc(list->list, (i + 1) * sizeof(KlO));
	    for (; j < i; j++)
		KlIncRef(list->list[j] = NIL);
	    KlIncRef(list->list[i] = val);
	}
    } else {				/* p-list */
	KlMustBeEvenList(list, 0);
	if (KlHasTrait(key, KlTrait_hasheq)) { /* hasheq ==> eq-search */
	    for (i = 1; i < list->size; i += 2) {
		if (list->list[i - 1] == (KlO) key) {
		    KlDecRef(list->list[i]);
		    KlIncRef(list->list[i] = val);
		    return (KlO) list;
		}
	    }
	} else {			/* else equal-search */
	    for (i = 1; i < list->size; i += 2) {
		if (NIL != KlSend_equal(key, list->list[i - 1])) {
		    KlDecRef(list->list[i]);
		    KlIncRef(list->list[i] = val);
		    return (KlO) list;
		}
	    }
	}
	/* add to end */
	list->size = i = list->size + 2;
	list->list = (KlO *) Realloc(list->list, i * sizeof(KlO));
	KlIncRef(list->list[i - 2] = (KlO) key);
	KlIncRef(list->list[i - 1] = val);
    }
    return (KlO) list;
}

/* KlListDelete
 * pb: can return a list of size 0, different from () !!!
 */

KlO
KlListDelete(list, key)
    KlList list;
    KlNumber key;
{
    int i;
    KlO *p, *end;

    if (KlIsANumber(key)) {		/* array */
	i = key->number;
	if (i < 0) {
	    i = (list->size ? list->size - 1 : 0);
	} 
	if (i < list->size) {
	    KlDecRef(list->list[i]);
	    list->size--;
	    p = list->list + i;
	    end = list->list + list->size;
	    while (p < end) {
		*p = *(p+1);
		p++;
	    }
	}
    } else {				/* p-list */
	KlO *q;
	KlMustBeEvenList(list, 0);
	if (KlHasTrait(key, KlTrait_hasheq)) { /* hasheq ==> eq-search */
	    for (i = 0; i < list->size; i += 2) {
		if (list->list[i] == (KlO) key) {
		    KlDecRef(list->list[i]);
		    KlDecRef(list->list[i + 1]);
		    list->size -= 2;
		    p = list->list + i;
		    q = p + 2;
		    end = list->list + list->size;
		    while (p < end) {
			*p++ = *q++;
		    }
		}
	    }
	} else {			/* else equal-search */
	    for (i = 0; i < list->size; i += 2) {
		if (NIL != KlSend_equal(key, list->list[i])) {
		    KlDecRef(list->list[i]);
		    KlDecRef(list->list[i + 1]);
		    list->size -= 2;
		    p = list->list + i;
		    q = p + 2;
		    end = list->list + list->size;
		    while (p < end) {
			*p++ = *q++;
		    }
		}
	    }
	}
    }
    return (KlO) list;
}


/* KlListInsert
 */

KlO
KlListInsert(list, key, val)
    KlList list;
    KlNumber key;
    KlO val;
{
    int i;
    KlO *p, *start;

    if (list == (KlList) NIL) {
	KlError(KlE_NO_PUT, list);
    }
    KlMustBeNumber(key, 1);
    i = key->number;
    if (i < 0 || i >= list->size) {	/* outside list ==> put */
	return KlListPut(list, key, val);
    }
					/* make room */
    list->size++;
    list->list = (KlO *) Realloc(list->list, list->size * sizeof(KlO));
    p = list->list + (list->size - 1);
    start = list->list + i;
    while (p > start) {
	*p = *(p-1);
	p--;
    }
    KlIncRef(list->list[i] = val);

    return (KlO) list;
}

/* KlListNth
 * quick & dirty get
 */

KlO
KlListNth(obj, i, value)
    KlList obj;
    UInt i;
    KlO value;
{
    if (i >= obj->size)
	return NIL;
    if (value) {
	KlDecRefNonNull(obj->list[i]);
	KlIncRef(obj->list[i] = value);
	return (KlO) obj;
    } else {
	return obj->list[i];
    }
}


/* Coerce
 */
 
/*ARGSUSED*/
KlO
KlListCoerce(totype, obj)
    KlType totype;
    KlO obj;
{
    if (KlIsAString(obj)) {
	KlUString s = (KlUString) obj;
	int len = KlStringLength(s);
	KlList l = KlListNMake(len);
	int i;
	KlListStoreDReset(l);

	for (i = 0; i < len; i++) {
	    KlListStoreAdd(KlNumberMake(s->string[i]));
	}
	l->type = totype;
	return (KlO) l;
    } else if (KlIsAHash(obj)) {
	KlList l = KlListNMake(((KlHash) obj)->size * 2);
	KlListStoreDReset(l);

	KlHashFORBEGIN(((KlHash) obj), cell) {
	    KlListStoreAdd(cell->key);
	    KlListStoreAdd(cell->object);
	} KlHashFOREND;
	l->type = totype;
	return (KlO) l;
    } else if (KlIsAFunction(obj)) {
	int i;
	KlList l;

	if (KlIsACFunc(obj)) {
	    KlSubr func = (KlSubr) obj;
	    l = KlListMakeV(4,
			    KlA_make_subr,
			    KlNumberMake(func->arity),
			    KlNumberMake(func->body),
			    KlIsAFSubr(func) ? TRU : NIL);
	} else {
	    KlExpr func = (KlExpr) obj;
	    l = KlListPairMake(obj->type == KlExprType
			       ? KlA_lambda :
			       (obj->type == KlFExprType
				? KlA_lambdaq : KlA_lambdam),
			       KlUnparseLambdaList(obj));
	    for (i = 0; i< func->body_size; i++) {
		KlListAppend(l, func->body[i]);
	    }
	}
	return (KlO) l;
    } else if (KlIsAList(obj)) {
	KlO l = KlListCopy(obj);
	l->type = totype;
	return l;
    }
    return 0;
}

KlO
KlListHash(list)
    KlList list;
{
    KlO *p = list->list;
    KlO *last = p + list->size;
    UInt hash = 0;
    int inc;

    if (list->size > 4) 
	for (hash = 0, inc = ((list->size)>>2) ; p < last; p += inc) 
	    hash += (UInt) KlSend_hash(*p);
    else 
	for (hash = 0; p < last; p++)
	    hash += (UInt) KlSend_hash(*p);
    return (KlO) hash;
}

/********************************************************************* loops */
/* we must guard against list size variation, use indexes not ptrs */

KlListDolist(list, var, argc, argv)
    KlList list;
    KlO var;
    int argc;
    KlO *argv;
{
    int i;
    KlGCMark();
    for (i = 0; i < list->size; i++) {
	KlSend_setq(var, list->list[i]);
	KlProgn(argc, argv);
	KlGC();
    }
}

void
KlListDohash(list, var, val, argc, argv)
    KlList list;
    KlO var;
    KlO val;
    int argc;
    KlO *argv;
{
    int i;
    KlGCMark();
    for (i = 1; i < list->size; i += 2) {
	KlSend_setq(var, list->list[i-1]);
	KlSend_setq(val, list->list[i]);
	KlProgn(argc, argv);
	KlGC();
    }
}

/*************************\
*                         *
* the quicksort of a list *
*                         *
\*************************/

static KlList KlListQsortCompareCall;
#ifdef PROTOTYPES
/* correct typing for the actual call to qsort */
typedef int (*KlListQsortCompareFuncType) (const void *, const void *);
#endif

int
KlListQsortCompareFunc(o1, o2)
    KlO *o1, *o2;
{
    KlNumber kl_num;

    KlListQsortCompareCall->list[1] = *o1;
    KlListQsortCompareCall->list[2] = *o2;
    kl_num = (KlNumber) KlApply(KlListQsortCompareCall);

    if (!KlIsANumber(kl_num))
	KlError(KlE_BAD_COMPARE_CALL, kl_num);
    return kl_num->number;
}

KlO
KlListQsort(list, compare_func)
    KlList list;
    KlO compare_func;			/* any function */
{
    KlMustBeList(list, 0);
    if (!KlListQsortCompareCall) {
	KlIncRef(KlListQsortCompareCall = KlListNMake(3));
    }
    KlListQsortCompareCall->list[0] = compare_func;
    qsort((char *) list->list, (size_t) list->size, (size_t) sizeof(KlO),
#ifdef PROTOTYPES
	(KlListQsortCompareFuncType) 
#endif
	  KlListQsortCompareFunc);
    return (KlO) list;
}

/* copy of a list (but not of its elements)
 */

KlO
KlListCopy(list)
    KlList list;
{
    KlList newlist = KlListNMake(list->size);
    int i;

    for (i = 0; i < list->size; i++) {
	KlIncRef(newlist->list[i] = list->list[i]);
    }
    /* copying type is safe here, as extended list types (QuotedExprs) have
       their own Copy methods */
    newlist->type = list->type;
    return (KlO) newlist;
}

/* displacing a list by another
 */

KlO
KlListDisplace(old, newer)
    KlList old;
    KlList newer;
{
    KlO *p, *q, *last;

    KlMustBeList(old, 0);
    KlMustBeList(newer, 1);
    if (old == (KlList) NIL) {
	KlError(KlE_NO_PUT, NIL);
    }
    for (p = old->list, last = p + old->size; p < last; p++) {
	KlDecRefNonNull(*p);
    }
    old->list = (KlO *) Realloc(old->list, newer->size * sizeof(KlO));
    old->size = newer->size;
    for (p = old->list, last = p + old->size, q = newer->list; p < last;
	 p++, q++) {
	KlIncRef(*p = *q);
    }
    return (KlO) old;
}    

/**************************************************************************\
* 				   Vectors                                 *
\**************************************************************************/

KlVector
KlVectorMakeQ(col)
    KlCollection col;
{
    KlVector vector = (col->size ? KlListMake(col) : KlListNMake(0));
    if (KlVectorIsAStructure(vector))
	vector->type = KlStructureType;
    else
    vector->type = KlVectorType;
    return vector;
}

KlVector
KlVectorMake(argc, argv)
    int argc;
    KlO argv[];
{
    KlVector vector = (KlVector) KlListKl(argc, argv);
    if (KlVectorIsAStructure(vector))
	vector->type = KlStructureType;
    else
    vector->type = KlVectorType;
    return vector;
}

KlO
KlVectorPrint(vector, stream)
    KlVector vector;
    KlStream stream;
{
    KlSequencePrint(vector, stream, "[ ]");
    return (KlO) vector;
}

KlO
KlVectorCast(obj)
    KlList obj;
{
    KlMustBeList(obj, 0);
    if (NIL == (KlO) obj)
	obj = KlListNMake(0);
    if (KlVectorIsAStructure(obj))
	obj->type = KlStructureType;
    else
    obj->type = KlVectorType;
    return (KlO) obj;
}

KlO
KlListCast(obj)
    KlO obj;
{
    KlMustBeList(obj, 0);
    obj->type = KlListType;
    return obj;
}

/**************************************************************************\
* 				   Locators                                 *
\**************************************************************************/

KlLocator
KlLocatorMakeFromColl(col)
    KlCollection col;
{
    KlLocator locator = (col->size ? KlListMake(col) : KlListNMake(0));
    locator->type = KlLocatorType;
    /* WARNING: this should not trigger an error (by calling KlLocatorCheck), 
     * since it is called by the non-reentrant parser (yacc). Thus errors are 
     * trapped earlier in parser
     */
    return locator;
}

KlLocator
KlLocatorMake(argc, argv)
    int argc;
    KlO argv[];
{
    KlLocator locator = (KlLocator) KlListKl(argc, argv);
    locator->type = KlLocatorType;
    return KlLocatorCheck(locator);
}

KlO
KlLocatorPrint(obj, stream)
    KlLocator obj;
    KlStream stream;
{
    KlSPutc('#', stream);
    KlSequencePrint(obj, stream, "[ ]");
    return (KlO) obj;
}

KlO
KlLocatorCast(obj)
    KlO obj;
{
    KlMustBeList(obj, 0);
    if (obj == NIL)
	obj = (KlO) KlListNMake(0);
    obj->type = KlLocatorType;
    return (KlO) KlLocatorCheck(obj);
}

KlO
KlLocatorCoerce(totype, obj)
    KlType totype;
    KlO obj;
{
    KlLocator res = (KlLocator) KlListCoerce(totype, obj);
    return (KlO) KlLocatorCheck(res);
}

/* auxiliary function to set value of locator */

KlO
KlLocatorPutValue(obj, value, p, size)
    KlO obj;
    KlO value;
    KlO *p;
    int size;
{
    KlO key;
    KlO *last = p + size;
    while (p < last) {
	key = KlSend_eval(*p);
	obj = KlSend_get(obj, key, NIL);
	p++;
    }
    key = KlSend_eval(*p);
    KlSend_put(obj, key, value);
    return value;
}

/* evaluating a locator is making a GET */

KlO
KlLocatorEval(locator)
    KlLocator locator;
{
    int i, size = locator->size;
    if (locator->list[size - 2] == (KlO) KlA_assign) {
	if (size == 3) {
	    return KlSetq(locator->list[0], locator->list[2]);
	} else {
	    return KlLocatorPutValue(KlSend_eval(locator->list[0]),
				     KlSend_eval(locator->list[size - 1]),
				     &(locator->list[1]), size - 4);
	}
    } else {
	KlO key, obj = KlSend_eval(locator->list[0]);
	for (i = 1; i < size; i++) {
	    key = KlSend_eval(locator->list[i]);
	    obj = KlSend_get(obj, key, NIL);
	}
	return obj;
    }
}

/* setq-ing a locator is making a PUT */

KlO
KlLocatorSetq(locator, value)
    KlLocator locator;
    KlO value;
{
    int i;
    KlO obj = KlSend_eval(locator->list[0]);
    return KlLocatorPutValue(obj, value, &(locator->list[1]),
			     locator->size - 2);
}

/* executing a locator is putting val in it */

KlO
KlLocatorExecuteOrApply(locator, list, eval)
    KlLocator locator;
    KlList list;
    int eval;
{
    if (list->size == 2) {
	KlO val = list->list[1];
	if (eval)
	    val = KlSend_eval(val);
	return KlLocatorSetq(locator, val);
    } else {
	return CFAPPLY((KlSelectorUndefmethod(eval ? KlSelExecute : KlSelApply)),
		       (locator, list));
    }
}

KlO
KlLocatorExecute(locator, list)
    KlLocator locator;
    KlList list;
{
    return KlLocatorExecuteOrApply(locator, list, 1);
}

KlO
KlLocatorApply(locator, list)
    KlLocator locator;
    KlList list;
{
    return KlLocatorExecuteOrApply(locator, list, 0);
}



/*****************************************************************************\
* 				  Structures                                  *
\*****************************************************************************/
/* fast dynamic look-ahead for "defstruct" Common-Lisp compatible structures 
 * of the form [# Structure-name field-values...]
 * Structure-name (Atom) has for value the description of the fields:
 * [# Structure-name field-names...]
 */

KlStructure
KlStructureMake(argc, argv)
    int argc;
    KlO argv[];
{
    KlVector vector = (KlVector) KlListKl(argc, argv);
    vector->type = KlStructureType;
    return vector;
}

KlO
KlStructureGet(obj, key, def)
    KlStructure obj;
    KlAtom key;
    KlO def;
{
    KlVector fields = (KlVector) ((KlAtom) obj->list[1])->c_val;
    KlAtom *p = (KlAtom *) fields->list + 2;
    KlAtom *last = (KlAtom *) fields->list + fields->size;
    if (KlIsAKeyword(key)) key = ((KlKeyword) key)->atom;
    while (p < last) {
	if (*p == key) {
	    int i = p - (KlAtom *) fields->list;
	    if ((i < fields->size) && (i < obj->size)) {
		return obj->list[p - (KlAtom *) fields->list];
	    } else {
		return KlExecuteGetDefault(obj, key, KlE_NO_ELEMENT);
	    }
	}
	p++;
    }
    return KlExecuteGetDefault(obj, key, def);
}

KlO
KlStructurePut(obj, key, value)
    KlStructure obj;
    KlAtom key;
    KlO value;
{
    KlVector fields = (KlVector) ((KlAtom) obj->list[1])->c_val;
    KlAtom *p = (KlAtom *) fields->list + 2;
    KlAtom *last = (KlAtom *) fields->list + fields->size;
    if (KlIsAKeyword(key)) key = ((KlKeyword) key)->atom;
    while (p < last) {
	if (*p == key) {
	    int i = p - (KlAtom *) fields->list;
	    if ((i < fields->size) && (i < obj->size)) {
		KlDecRef(obj->list[i]);
		KlIncRef(obj->list[i] = value);
		return value;
	    } else {
		return KlExecuteGetDefault(obj, key, KlE_NO_ELEMENT);
	    }
	}
	p++;
    }
    return KlExecuteGetDefault(obj, key, KlE_NO_ELEMENT);
}

/* Executing a structure is creating a new one, with default field values
 * () if the structure is a class (name = itself), and the value of the fields
 * of the structure we are kloning if an instance
 * the default val are not evaluated, except if prefixed by a comma
 */

KlO
KlStructureExecuteOrApply(obj, list, eval)
    KlStructure obj;
    KlList list;			/* the call list */
    int eval;				/* must we eval args? */
{
    KlKeyword *argv = (KlKeyword *) list->list, *arg, *arg_last;
    KlO *p, *fields_last;
    int argc = list->size, i = 0, fieldnum;
    KlStructure new = (KlStructure) KlListNMake(obj->size);
    KlStructure objclass = (KlStructure) ((KlAtom) obj->list[1])->c_val;

    new->type = KlStructureType;
    KlIncRef(new->list[0] = (KlO) KlA_SHARP);
    KlIncRef(new->list[1] = obj->list[1]);
    arg_last = argv + argc;
    /* unset fields will be 0, to be filled with defaults afterwards */
    bzero((char *) (new->list + 2), KLSO * (obj->size - 2));
    if ((argc & 1) == 0)
	return KlBadNumberOfArguments(i); /* even number of args */
    /* fill slots with provided args */
    for (arg = argv + 1; arg < arg_last; arg += 2) {
	if (!KlIsAKeyword(*arg)) {
	    KlMustBeKeyword(*arg, (arg - argv));
	}
	if (fieldnum = 
	    KlStructureSlotIndex(objclass, ((KlKeyword) *arg)->atom)) {
	    KlIncRef(new->list[fieldnum] = 
		     (eval ? KlSend_eval(*(arg+1)) : (KlO) *(arg+1)));
	} else {
	    KlError2(KlE_INVALID_KEYWORD, *arg,
		     KlListKl(objclass->size - 2, objclass->list + 2));
	}
    }
    /* now complete the blanks with default values */
    fields_last = KlListLastElt(new);
    for (p = new->list + 2; p < fields_last; p++) {
	if (!*p) {
	    if (obj == objclass) {
		KlIncRef(*p = NIL);
	    } else {
		KlO def = obj->list[p - new->list];
		if (KlIsAQuotedExpr(def) &&
		    (((KlQuotedExpr) def)->symbol == KlA_unquote)) {
		    KlIncRef(*p = KlSend_eval(((KlQuotedExpr) def)->list[1]));
		} else {
		    KlIncRef(*p = def);
		}
	    }
	}
    }
    return (KlO) new;
}


KlO
KlStructureExecute(obj, list)
    KlStructure obj;
    KlList list;
{
    return KlStructureExecuteOrApply(obj, list, 1);
}

KlO
KlStructureApply(obj, list)
    KlStructure obj;
    KlList list;
{
    return KlStructureExecuteOrApply(obj, list, 0);
}

/****************************************************** fast access to slots */

int					/* 0 = not found */
KlStructureSlotIndex(obj, key)
    KlStructure obj;			/* class of the struct */
    KlO key;
{
    register KlO *p = obj->list + 2;
    register KlO *last = obj->list + obj->size;
    while (p < last)
	if (*p == key)
	    return p - obj->list;
	else
	    p++;
    return 0;
}

KlO
KlStructureField(obj, selector)
    KlVector obj;
    KlO selector;
{
    KlAtom name;
    int offset;

    KlMustBeStructure(obj, 0);

    if (selector->type == KlKeywordType)
	selector = (KlO) ((KlKeyword) selector)->atom;
    if (offset = KlStructureSlotIndex(((KlAtom) obj->list[1])->c_val, 
				      selector))
	return (KlO) KlNumberMake(offset);
    else
	return NIL;
}

/*****************************************************************************\
* 		Assign: optimisation and short form for setqs                 *
\*****************************************************************************/
/* Assigns are actually lists (setq var val), but tagged to be printed
 * like they were parsed: var = val
 */
KlAssign
KlAssignMake(var, value)
    KlO var;
    KlO value;
{
    KlAssign obj;
    if (KlIsAnAssign(var)) {		
	/* (setq (setq x y) z) ==> (setq x (setq y z)) */
	obj = KlListTripletMake(KlA_setq, 
				KlAssignVar(var),
				KlAssignMake(KlAssignVal(var), value));
    } else {
	obj = KlListTripletMake(KlA_setq, var, value);
    }
    obj->type = KlAssignType;
    return obj;
}

KlO
KlAssignPrint(obj, stream)
    KlAssign obj;
    KlStream stream;
{
    if (KlPrintReadably) {		/* (setq var val) */
	KlListPrint(obj, stream);
    } else {				/* var = val */
	KlSend_print(obj->list[1], stream);
	KlSPuts(" = ", stream);
	KlSend_print(obj->list[2], stream);
    }
    return (KlO) obj;
}

/* And this is just to gain some speed */
KlO
KlAssignEval(obj)
    KlAssign obj;
{
    KlO atom = obj->list[1];
    KlO value = obj->list[2];
    KlSend_setq_protectDECL;
#ifdef NO_SETQ_ON_UNDEFS
    if (KlIsAnAtom(atom) && atom->c_val == KlUndef) {
	return KlError(KlE_UNDEFINED_VARIABLE, atom);
    }
#endif
    return KlSend_setq_protect(atom, KlSend_eval(value));
}

/* if we try to do: (setq x = y z) we mean (setq x (setq y z)) */
KlO
KlAssignSetq(obj, value)
    KlAssign obj;
    KlO value;
{
    value = KlSend_setq(KlAssignVal(obj), value);
    return KlSend_setq(KlAssignVar(obj), value);
}


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

KlListInit()
{
    KlDeclareType(&KlSequenceType, "Sequence", 0);

    KlDeclareSubType(&KlListType, "List", KlSequenceType,
		     sizeof(struct _KlList));
    KlDeclareIsTrait(KlListType, KlTrait_list);
    KlDeclareTrait(KlListType, KlTrait_table);

    KlDeclareMethod1(KlListType, KlSelEval, KlListEval);
    KlDeclareMethod1(KlListType, KlSelPrint, KlListPrint);
    KlDeclareMethod1(KlListType, KlSelFree, KlListFree);
    KlDeclareMethod1(KlListType, KlSelExecute, KlListExecute);
    KlDeclareMethod1(KlListType, KlSelApply, KlListApply);
    KlDeclareMethod1(KlListType, KlSelEqual, KlListEqual);
    KlDeclareMethod1(KlListType, KlSelCopy, KlListCopy);
    KlDeclareMethod1(KlListType, KlSelAdd, KlListAdd);
    KlDeclareMethod1(KlListType, KlSelGet, KlListGet);
    KlDeclareMethod1(KlListType, KlSelPut, KlListPut);
    KlDeclareMethod1(KlListType, KlSelInsert, KlListInsert);
    KlDeclareMethod1(KlListType, KlSelDelete, KlListDelete);
    KlDeclareMethod1(KlListType, KlSelNth, KlListNth);
    KlDeclareMethod1(KlListType, KlSelHash, KlListHash);
    KlDeclareMethod1(KlListType, KlSelLength, KlListLength);
    KlDeclareMethod1(KlListType, KlSelDolist, (KlMethod) KlListDolist);
    KlDeclareMethod1(KlListType, KlSelDohash, (KlMethod) KlListDohash);
    KlDeclareMethod1(KlListType, KlSelCompare, (KlMethod) KlListCompare);

    KlDeclareSubType(&KlVectorType, "Vector", KlListType,
		     sizeof(struct _KlList));
    KlDeclareMethod1(KlVectorType, KlSelPrint, KlVectorPrint);
    KlDeclareMethod1(KlVectorType, KlSelEval, KlQuote);
    KlDeclareMethodUndefined(KlVectorType, KlSelExecute);
    KlDeclareMethodUndefined(KlVectorType, KlSelApply);
    KlDeclareSubType(&KlAssignType, "Assign", KlListType,
		     sizeof(struct _KlList));
    KlDeclareMethod1(KlAssignType, KlSelPrint, KlAssignPrint);
    KlDeclareMethod1(KlAssignType, KlSelEval, KlAssignEval);
    KlDeclareMethod1(KlAssignType, KlSelSetq, KlAssignSetq);

    KlDeclareSubType(&KlStructureType, "Structure", KlVectorType,
		     sizeof(struct _KlList));
    KlDeclareMethod1(KlStructureType, KlSelGet, KlStructureGet);
    KlDeclareMethod1(KlStructureType, KlSelPut, KlStructurePut);
    KlDeclareMethod1(KlStructureType, KlSelExecute, KlStructureExecute);
    KlDeclareMethod1(KlStructureType, KlSelApply, KlStructureApply);
    KlDeclareMethodUndefined(KlStructureType, KlSelInsert);
    KlDeclareMethodUndefined(KlStructureType, KlSelDelete);

    KlDeclareSubType(&KlLocatorType, "Locator", KlListType,
		     sizeof(struct _KlList));
    KlDeclareMethod1(KlLocatorType, KlSelPrint, KlLocatorPrint);
    KlDeclareMethod1(KlLocatorType, KlSelEval, KlLocatorEval);
    KlDeclareMethod1(KlLocatorType, KlSelSetq, KlLocatorSetq);
    KlDeclareMethod1(KlLocatorType, KlSelExecute, KlLocatorExecute);
    KlDeclareMethod1(KlLocatorType, KlSelApply, KlLocatorApply);

    KlDeclareSubType(&KlListInlineType, "ListInline", KlListType,
		     sizeof(struct _KlList));
    KlDeclareMethod1(KlListInlineType, KlSelEval, KlQuote);
    KlDeclareMethodUndefined(KlListInlineType, KlSelExecute);
    KlDeclareMethodUndefined(KlListInlineType, KlSelApply);
    KlDeclareMethod1(KlListInlineType, KlSelPrint, KlCollectionPrint);

    /* create NIL */
    NIL = (KlO) KlOMake(KlListType);
    ((KlList) NIL)->size = 0;
    ((KlList) NIL)->list = 0;
    KlIncRef(NIL);
    KlConstantMake("nil", NIL);		/* nil is alias to () */

    KlSend_setq(KlA_load_path, KlListNMake(0));
    KlSend_setq(KlA_load_ext, KlListNMake(0));

    /* functions */
    KlDeclareSubr(KlListKl, "list", NARY);
    KlDeclareSubr(KlListNMakeKl, "make-list", NARY);
    KlDeclareSubr(KlListQsort, "sort", 2);
    KlDeclareSubr(KlListDisplace, "replace-list", 2); 
    KlDeclareSubr(KlListAppendKl, "lappend", 2);
    KlDeclareSubr(KlVectorCast, "vector!", 1);
    KlDeclareSubr(KlListCast, "list!", 1);
    KlDeclareSubr(KlVectorMake, "vector", NARY);
    KlDeclareSubr(KlSeekQ, "seekq", NARY);
    KlDeclareSubr(KlListDeleteNth, "delete-nth", 2);
    KlDeclareSubr(KlStructureMake, "structure", NARY);
    KlDeclareSubr(KlStructureField, "structure-field", 2);

    KlDeclareSubr(KlLocatorCast, "locator!", 1);
    KlDeclareSubr(KlVectorMake, "locator", NARY);
}