/* 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);
}
syntax highlighted by Code2HTML, v. 0.9.1