/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/***********************************\
*                                   *
*  KlO  Subr, FSubr, Expr and FExpr *
*  BODY                             *
*                                   *
\***********************************/

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

KlO KlLambda();
KlO KlMHookSelectorPos();
void KlParseLambdaList();

/* Constructors:
 * For Subr and FSubr: KlDeclareAnySubr
 * takes as arguments:
 *  1-  the type (KlSubrType or KlFSubrType)
 *  2-  the (pointer to) C function associated
 *  3-  the string which will be its KLONE name
 *  4-  the number of arguments: 0,1,2 or NARY
 * Returns the (F)Subr.
 * 
 * For the Expr and FExpr: KlDoDefun
 * takes as arguments:
 *  1-  the type (KlExprType or KlFExprType)
 *  2-  the argc,
 *  3-  the argv
 *  	of the list (funcname (list of args) stat1 stat2 ... statn)
 *  	corresponding to the KLONE definition.
 * Returns the (F)Expr.
 */

KlO
KlDoDefun(type, argc, argv)
    KlType type;			/* KlExprType or KlFExprType */
    int argc;				/* the list without the "de" or "df" */
    KlAtom *argv;
{
    KlO func;

    if (argc < 2)
	return KlError(KlE_BAD_DEFUN,
		       (argc > 0 ? *(argv) : (KlAtom) KlNilString));
    KlMustBeAtom(argv[0], 0);
    func = KlLambda(argc - 1, argv + 1);
    func->type = type;
#ifdef KLPROFILER
    KlDecRef(((KlExpr) func)->profiling_name);
    KlIncRef(((KlExpr) func)->profiling_name = (KlO) argv[0]);
#endif

    return KlSend_setq(argv[0], func);
}


/*
 * function definition: defun, defmacro & defunq are wrappers to KlDoDefun
 * returns  the atom pointing to the subr
 */

KlO
KlDefun(argc, argv)
    int argc;
    KlO *argv;
{
    return KlDoDefun(KlExprType, argc, argv);
}

KlO
KlDefunq(argc, argv)
    int argc;
    KlO *argv;
{
    return KlDoDefun(KlFExprType, argc, argv);
}

KlO
KlDefunm(argc, argv)
    int argc;
    KlO *argv;
{
    return KlDoDefun(KlMExprType, argc, argv);
}

KlO
KlDeclareAnySubr(type, C_function, KlName, arity)
    KlType type;
    KlMethod C_function;
    char *KlName;
    int arity;
{
    KlO func = (KlO)
	KlSubrMake(type, C_function, arity);
    KlAtom object = KlIntern(KlName);

#ifdef CONSTANT_BUILTINS
    object->type = KlConstantType;
#endif

    if (arity > KlMAX_ARITY) {
	KlError(KlE_MAX_ARITY, object);
    }
    KlDecRefNonNull(object->c_val);
    KlIncRef(object->c_val = func);
    return (KlO) object;
}

KlO
KlDeclareSubr(C_function, KlName, arity)
    KlMethod C_function;
    char *KlName;
    int arity;
{
    return KlDeclareAnySubr(KlSubrType, C_function, KlName, arity);
}

KlO
KlDeclareFSubr(C_function, KlName, arity)
    KlMethod C_function;
    char *KlName;
    int arity;
{
    return KlDeclareAnySubr(KlFSubrType, C_function, KlName, arity);
}

/*
 * KlSubrMake:
 * makes a (F)Subr (without knowing its name)
 */

KlSubr
KlSubrMake(type, C_function, arity)
    KlType type;
    KlMethod C_function;
    int arity;
{
    KlSubr object = (KlSubr) KlOMake(KlSubrType);

    object->type = type;
    object->arity = arity;
    object->body = C_function;
    return object;
}

KlSubr
KlSubrMakeKl(arity, C_function, quote_args)
    KlNumber arity;
    KlNumber C_function;
    KlO quote_args;
{
    KlMustBeNumber(arity, 0);
    KlMustBeNumber(C_function, 1);
    return KlSubrMake(KlTrueP(quote_args) ? KlFSubrType : KlSubrType,
		      C_function->number,
		      arity->number);
}

/*
 * the real creator of Exprs, lambda
 */

KlO
KlLambda(argc, argv)
    int argc;				/* the list without the "defun" */
    KlO *argv;
{
    KlExpr object;
    KlList parameters = (KlList) argv[0];

    if (argc < 1)
	return KlError(KlE_BAD_DEFUN, KlNilString);

    KlMustBeList(parameters, 0);

    object = (KlExpr) KlOMake(KlExprType);

    /* look for documentation string, and set it to the lambda itself */
    if (argc > 2 && argv[1]->type == KlStringType) {
	KlO name;			/* TODO: look if we were defining a
					   function, and sets the doc to
					   this name */
	if (((Int) KlStack[KlStackPtr]) == KlSFID_subr
	    && ((KlList) KlStack[KlStackPtr - KlSFO_call])->size > 2
	    && KlIsASymbol(((KlList) KlStack[KlStackPtr - KlSFO_call])
			   ->list[1])) {
	    KlDocumentationSet(((KlList) KlStack[KlStackPtr - KlSFO_call])
			       ->list[1],
			       argv[1]);
	    argv++;
	    argc--;
	}
    }
    if (object->body_size = argc - 1) {
	KlDuplicateNObjects(argv + 1, &(object->body), object->body_size);
    } else {				/* fill with 0 for purify */
	object->body = 0;
    }

    KlParseLambdaList(object, parameters->size, parameters->list);

#ifdef KLPROFILER
    KlProfilerInitFunc(object);
#endif
    return (KlO) object;
}

KlO
KlLambdaq(argc, argv)
    int argc;				/* the list without the "de" or "df" */
    KlO *argv;
{
    KlO lambda = KlLambda(argc, argv);

    lambda->type = KlFExprType;
    return lambda;
}

KlO
KlLambdam(argc, argv)
    int argc;				/* the list without the "de" or "df" */
    KlO *argv;
{
    KlO lambda = KlLambda(argc, argv);

    lambda->type = KlMExprType;
    return lambda;
}

/* KlParseLambdaList
 * parses a Common-lisp lambda list:
 * {var}* 		n fixed arguments
 * &optional {var|(var initform)}+     optional args
 * &rest var		the rest of args as a list
 * &whole var		the whole call as a list (never evaluated)
 * &key {var|({var|(keyword var)} [initform])}}+ keywords
 *      NOTE: &rest is incompatible with &key
 * &allow-other-keys
 * &aux {var|(var initform)}
 */

#define KlParseLambdaListError(expr, argv, i) \
    if (expr){KlError2(KlE_BAD_LAMBDALIST, argv[i], KlNumberMake(i));}
#define KlIsNotALambdaSymbol(s) \
    !(KlIsASymbol(s) && ((KlAtom)(s))->p_name[0] != '&')

void
KlParseLambdaList(func, argc, argv)
    KlExpr func;			/* the built Expr*/
    int argc;				/* the list of params */
    KlAtom *argv;
{
    int i = 0;
    KlAtom *p, *q, *end;
    KlO init;

    /* we set things to for not breaking when GCing a func half-made if we
     * jump out of it by an error or throw
     */
    func->lambdalist = 0;
    if (func->arity = argc) {
	int par = 0;

	for (par = 0; par < argc; par++) { /* count out the &-markers */
	    if (KlIsASymbol(argv[par]) && argv[par]->p_name[0] == '&') {
		func->arity--;
	    }
	}
	p = func->parameters = (KlAtom *) Calloc((size_t) func->arity,
						 sizeof(KlO));
		
    } else {
	func->parameters = 0;
	return;
    }

    for (;;) {				/* fixed arguments */
        if (i == argc) {		/* no &, job done. */
	    goto end_of_parsing;
	}
	KlParseLambdaListError(!KlIsASymbol(argv[i]), argv, i);
	if (argv[i]->p_name[0] == '&') {
	    func->lambdalist = (KlLambdaList)
		Calloc((size_t) 1, sizeof(struct _KlLambdaList));
	    func->lambdalist->nfixed = i;
	    break;
	}
	KlIncRef(*p++ = argv[i]);
	i++;
    }
    
    if (i != argc && argv[i] == KlA_Moptional) {	/* &optional */
	int j = 0;

	func->lambdalist->variable_arity = 1;
	i++;
	for (;;) {
	    if (i == argc) {
		goto end_of_parsing;
	    }
	    if (KlIsAList(argv[i])) {
		KlParseLambdaListError(((KlList)argv[i])->size < 2, argv, i);
		KlIncRef(*p++ = (KlAtom) ((KlList)argv[i])->list[0]);
		init = ((KlList)argv[i])->list[1];
	    } else {
		KlParseLambdaListError(!KlIsASymbol(argv[i]), argv, i);
		if (argv[i]->p_name[0] == '&') {
		    break;
		}
		KlIncRef(*p++ = argv[i]);
		init = NIL;
	    }
	    KlAppendToArray(func->lambdalist->optionals, j, init);
	    i++;
	}
    } 
    if (i != argc && argv[i] == KlA_Mrest) {		/* &rest */
	KlParseLambdaListError(i+1 >= argc, argv, i);
	i++;
	KlParseLambdaListError(!KlIsASymbol(argv[i]), argv, i);
	KlIncRef(*p++ = argv[i]);
	KlIncRef(func->lambdalist->rest = argv[i]);
	i++;
	func->lambdalist->variable_arity = 1;
    }
    if (i != argc && argv[i] == KlA_Mwhole) {	/* &whole */
	KlParseLambdaListError(i+1 >= argc, argv, i);
	i++;
	KlParseLambdaListError(!KlIsASymbol(argv[i]), argv, i);
	KlIncRef(*p++ = argv[i]);
	KlIncRef(func->lambdalist->whole = argv[i]);
	i++;
	func->lambdalist->variable_arity = 1;
    }
    if (i != argc && argv[i] == KlA_Mkey) {		/* &key */
	int j = 0;
	KlKeyword key;
	KlAtom var;

	KlParseLambdaListError(i+1 >= argc, argv, i);
	i++;
	func->lambdalist->variable_arity = 1;
	func->lambdalist->key = (KlKeyDecls)
	    Malloc(sizeof(struct _KlKeyDecls));
	func->lambdalist->key[0].key = 0; /* set end marker */

	for (;;) {
	    if (i == argc) {
		goto end_of_parsing;
	    }
	    if (KlIsAList(argv[i])) {
		KlList decl = ((KlList)argv[i]);
		
		KlParseLambdaListError(decl->size < 1, argv, i);
		if (decl->size == 1) {
		    init = NIL;
		} else {
		    init = decl->list[1];
		}
		if (KlIsAList(decl->list[0])) {
		    KlList dec2 = ((KlList) (decl->list[0]));
		    KlParseLambdaListError(dec2->size < 2, argv, i);
		    KlParseLambdaListError
			(!KlIsASymbol(dec2->list[1]), argv, i);
		    KlParseLambdaListError
			(!KlIsASymbol(dec2->list[0]), argv, i);
		    key = KlKeyFromAtom(dec2->list[0]);
		    var = (KlAtom) dec2->list[1];
		} else {
		    KlParseLambdaListError(KlIsNotALambdaSymbol(decl->list[0]),
					   argv, i);
		    key = KlKeyFromAtom(decl->list[0]);
		    var = key->atom;
		}
	    } else {
		if (argv[i] == KlA_Maux) {
		    break;
		} else if (argv[i] == KlA_Mallow_other_keys) {
		    func->lambdalist->variable_arity = 3;
		    i++;
		    continue;
		}
		KlParseLambdaListError(KlIsNotALambdaSymbol(argv[i]), argv, i);
		key = KlKeyFromAtom(argv[i]);
		var = key->atom;
		init = NIL;
	    }
	    KlIncRef(*p++ = var);
	    func->lambdalist->key = (KlKeyDecls)
		Realloc(func->lambdalist->key,
			(j+2) * sizeof(struct _KlKeyDecls));
	    KlIncRef(func->lambdalist->key[j].key = key);
	    KlIncRef(func->lambdalist->key[j].init = init);
	    j++;
	    i++;
	    func->lambdalist->key[j].key = 0; /* set end marker */
}
	if (j > KLMAX_KEYWORDS) {
	    KLMAX_KEYWORDS = j + 1;
	    KlValidKeywords = (KlKeyword *) Realloc(KlValidKeywords,
						    KLSO * KLMAX_KEYWORDS);
	}
	
    }
    if (i != argc && argv[i] == KlA_Maux) {		/* &aux */
	int j = 0;
	
	i++;
	for (;;) {
	    if (i == argc) {
		goto end_of_parsing;
	    }
	    if (KlIsAList(argv[i])) {
		KlParseLambdaListError(!((((KlList)argv[i])->size == 2)
					 || ((KlList)argv[i])->size == 1),
				       argv, i);
		KlIncRef(*p++ = (KlAtom) ((KlList)argv[i])->list[0]);
		init = (((KlList)argv[i])->size == 1) ? NIL
		    : ((KlList)argv[i])->list[1];
	    } else {
		KlParseLambdaListError(!KlIsASymbol(argv[i]), argv, i);
		if (argv[i]->p_name[0] == '&') {
		    break;
		}
		KlIncRef(*p++ = argv[i]);
		init = NIL;
	    }
	    KlAppendToArray(func->lambdalist->aux, j, init);
	    i++;
	}
    }
    
    KlParseLambdaListError(i != argc, argv, i);

 end_of_parsing:			/* check duplication of variables */
    end = func->parameters + func->arity;
    for (p = func->parameters; p < end; p++) {
	for (q = p + 1; q < end; q++) {
	    KlParseLambdaListError(*p == *q, func->parameters,
				   q - func->parameters);
	}
    }
}

/*
 * printing a function is pretty-printing its definition.
 */

KlO
KlSubrPrint(obj, stream)
    KlFSubr obj;
    KlO stream;
{
    KlSPrintf(stream, "{^ Subr 0x%x ", obj);
    KlSPutc((obj->type == KlSubrType ? 'E' : 'Q'), stream);
    if (obj->arity == NARY)
	KlSPuts(" N-ary}", stream);
    else
	KlSPrintf(stream, " %dargs}", obj->arity);
    return (KlO) obj;
}

/* accessory function for lambda list printing
 */

KlPutItem(list, obj, def)
    KlList list;
    KlO obj;
    KlO def;
{
    KlListAppend(list, def == NIL ? obj : (KlO) KlListPairMake(obj, def));
}

KlList
KlUnparseLambdaList(func)
    KlExpr func;
{
    int i = 0;
    KlO *p;
    KlList list = KlListNMake(0);

    if (func->lambdalist) {
    	for (i = 0; i < func->lambdalist->nfixed; i++) {
	    KlListAppend(list, func->parameters[i]);
    	}

	if (p = (KlO *) func->lambdalist->optionals) {
	    KlListAppend(list, KlA_Moptional);
	    while (*p) {
		KlPutItem(list, func->parameters[i], *p);
		i++;
		p++;
	    }
	}
	
	if (func->lambdalist->rest) {
	    KlListAppend2(list, KlA_Mrest, func->lambdalist->rest);
	    i++;
	}
	
	if (func->lambdalist->whole) {
	    KlListAppend2(list, KlA_Mwhole, func->lambdalist->whole);
	    i++;
	}
    	
	if (func->lambdalist->key) {
	    KlKeyDecls kd = func->lambdalist->key;
	    KlListAppend(list, KlA_Mkey);
	    while (kd->key) {
		if (kd->key->atom == func->parameters[i]) {
		    KlPutItem(list, kd->key, kd->init);
		} else {
		    KlPutItem(list,
			      KlListPairMake(kd->key, func->parameters[i]),
			      kd->init);
		}
		kd++;
		i++;
	    }
	}	    	

	if (p = (KlO *) func->lambdalist->aux) {
	    KlListAppend(list, KlA_Maux);
	    while (*p) {
		KlPutItem(list, func->parameters[i], *p);
		i++;
		p++;
	    }
	}
    } else {
    	for (i = 0; i < func->arity; i++) {
	    KlListAppend(list, func->parameters[i]);
    	}
    }
    return list;
}


KlO
KlExprPrintHeader(func, stream)
    KlExpr func;
    KlO stream;
{
    KlList lambdalist = KlUnparseLambdaList(func);
    KlSend_print(lambdalist, stream);
    return (KlO) func;
}

KlO
KlExprPrintBody(obj, stream)
    KlExpr obj;
    KlO stream;
{
    int i = 0;

    if (KlPrintReadably) {
	for (i = 0; i < obj->body_size; i++) {
	    KlSPuts(" ", stream);
	    KlSend_print(*(obj->body + i), stream);
	}
    } else {
	KlSPuts("...", stream);
    }
    KlSPuts(")", stream);
    return (KlO) obj;
}


KlO
KlExprPrint(obj, stream)
    KlExpr obj;
    KlO stream;
{
    KlSPuts("(lambda ", stream);
    KlExprPrintHeader(obj, stream);
    return KlExprPrintBody(obj, stream);
}

KlO
KlFExprPrint(obj, stream)
    KlFExpr obj;
    KlO stream;
{
    KlSPuts("(lambdaq ", stream);
    KlExprPrintHeader(obj, stream);
    return KlExprPrintBody(obj, stream);
}

KlO
KlMExprPrint(obj, stream)
    KlExpr obj;
    KlO stream;
{
    KlSPuts("(lambdam ", stream);
    KlExprPrintHeader(obj, stream);
    return KlExprPrintBody(obj, stream);
}

/* acces to functions internals are done via get/put on keys
 * lambda & body
 */

KlO
KlSubrGet(func, key, def)
    KlSubr func;
    KlAtom key;
    KlO def;
{
    if (key == KlA_lambda) {
	return (KlO) KlNumberMake(func->arity);
    } else if (key == KlA_body) {
	return (KlO) KlNumberMake(func->body);
    } else
	return KlExecuteGetDefault(func, key, def);
}

KlO
KlSubrPut(func, key, val)
    KlSubr func;
    KlAtom key;
    KlNumber val;
{
    KlMustBeNumber(val, 2);
    if (key == KlA_lambda) {
	func->arity = val->number;
    } else if (key == KlA_body) {
	func->body = (KlMethod) val->number;
    }
    return (KlO) func;
}

KlO
KlSubrCopy(func)
    KlSubr func;
{
    return (KlO) KlSubrMake(func->type, func->body, func->arity);
}


KlO
KlExprGet(func, key, def)
    KlExpr func;
    KlAtom key;
    KlO def;
{
    if (key == KlA_lambda) {
	return (KlO) KlUnparseLambdaList(func);
    } else if (key == KlA_body) {
	    return (KlO) KlListKl(func->body_size, func->body);
    } else
	return KlExecuteGetDefault(func, key, def);
}

KlO
KlExprPut(func, key, val)
    KlExpr func;
    KlAtom key;
    KlList val;
{
    KlMustBeList(val, 2);
    if (key == KlA_lambda) {
	KlExprLambdaListFree(func);
	KlParseLambdaList(func, val->size, val->list);
    } else if (key == KlA_body) {
	KlDecRefList(func->body_size, func->body);
	if (func->body_size)
	    Free(func->body);
	func->body_size = val->size;
	KlDuplicateNObjects(val->list, &func->body, val->size);
    } 
    return (KlO) func;
}

/* copying an expr is evaluating its definition form
 */

KlO
KlExprCopy(func)
    KlExpr func;
{
    KlList l = (KlList) KlListCoerce(KlListType, func);
    return KlSend_eval(l);
}

/****************************************************** displacing functions */

KlO
KlDisplaceFunction(to, from)
    KlExpr to;
    KlExpr from;
{
    KlMustBeFunction(to, 0);
    KlMustBeFunction(from, 1);
    if (KlIsALambda(to)) {		/* clean destination first */
	if (to->body_size) {
	    KlDecRefList(to->body_size, to->body);
	    Free(to->body);
	}
	KlExprLambdaListFree(to);
    }
    to->type = from->type;		/* then copy in place */
    to->arity = from->arity;
    if (KlIsACFunc(from)) {
	((KlSubr) to)->body = ((KlSubr) from)->body;
    } else {
	KlList lambdalist = KlUnparseLambdaList(from);
	KlDuplicateNObjects(from->body, &to->body, from->body_size);
	to->body_size = from->body_size;
	KlParseLambdaList(to, lambdalist->size, lambdalist->list);
    }	
    return (KlO) to;
}

/*
 * freeing:
 */

KlExprLambdaListFree(obj)
    KlExpr obj;
{
    if (obj->arity) {
	KlDecRefList(obj->arity, obj->parameters);
	Free(obj->parameters);
    }
    if (obj->lambdalist) {
	KlKeyDecls pk = obj->lambdalist->key;
	KlO *p;

	if (p = obj->lambdalist->optionals) {
	    while (*p) {
		KlDecRef(*p);
		p++;
	    }
	    Free(obj->lambdalist->optionals);
	}
	KlDecRef(obj->lambdalist->rest);
	KlDecRef(obj->lambdalist->whole);
	if (pk) {
	    while (pk->key) {
	    	KlDecRef(pk->key);
		KlDecRef(pk->init);
		pk++;
	    }
	    Free(obj->lambdalist->key);
	}
	if (p = obj->lambdalist->aux) {
	    while (*p) {
		KlDecRef(*p);
		p++;
	    }
	    Free(obj->lambdalist->aux);
	}

    	Free(obj->lambdalist);
    }
}

KlO
KlExprFree(obj)
    KlExpr obj;
{
#ifdef KLPROFILER
    KlProfilerFreeFunc(obj);
#endif
    if (obj->body_size) {
	KlDecRefList(obj->body_size, obj->body);
	Free(obj->body);
    }
    KlExprLambdaListFree(obj);
    Free(obj);
    return (KlO) obj;
}

/*****************************************************************************\
* main routines: execution!                                                   *
\*****************************************************************************/

/*
 * Note: for NARY function, a list of evaluated args is created.
 */

KlO
KlSubrExecute(obj, list)
    KlSubr obj;				/* the function */
    KlList list;
{
    KlO result;
    int argc = list->size - 1;
    KlO *argv = list->list + 1;

    KlDebugStackDecls;

    KlStackFramePushSpecialHold(KlSFID_subr, list, obj);
    KlDebugStackPush(KlSFID_subr, list);

    /* NARY FUNCTIONS */
    if (obj->arity == NARY) {
	if (argc) {
	    KlStackSpace space = 
		(KlStackSpace) KlAlloca(KlStackSpaceSizeof(argc));
	    KlO *dest = space->list;
	    KlO *last = dest + argc;
	    space->type = 0;
	    space->obj = (KlO) obj;
	    KlStack[KlStackPtr - KlSFO_ref] = (KlO) space;
	    
	    *dest = 0;
	    for (;;) {			/* argc is >0, we always go through */
		KlIncRef(*dest++ = KlSend_eval(*argv));
		*dest = 0;
		argv++;
		if (dest >= last)	/* faster than a naive while */
		    break;
	    } 
	    result = CFAPPLY((obj->body),  (argc, space->list));
	    KlStack[KlStackPtr - KlSFO_ref] = (KlO) obj;
	    for (dest = space->list;dest<last;dest++) {
		KlDecRefNonNull(*dest);
	    }
	} else {
	    result = CFAPPLY((obj->body),  (0, 0));
	}
    } else if (obj->arity == argc) {
	/* FIXED ARITY */
	switch (argc) {
	case 0:
	    result = CFAPPLY((obj->body),  ());
	    break;
	case 1:
	    result = CFAPPLY((obj->body),  (KlSend_eval(*argv)));
	    break;
	case 2:
	    {
		struct _KlStackSpace2 space;
		space.type = 0;
		space.obj = (KlO) obj;
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) &space;
		space.list[0] = 0;
		KlIncRef(space.list[0] = KlSend_eval(*argv));
		space.list[1] = 0;
		KlIncRef(space.list[1] = KlSend_eval(*(argv + 1)));
		space.list[2] = 0;
		result = CFAPPLY((obj->body),  (space.list[0], space.list[1]));
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) obj;
		KlDecRefNonNull(space.list[0]);
		KlDecRefNonNull(space.list[1]);
	    }
	    break;
	case 3:
	    {
		struct _KlStackSpace3 space;
		space.type = 0;
		space.obj = (KlO) obj;
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) &space;
		space.list[0] = 0;
		KlIncRef(space.list[0] = KlSend_eval(*argv));
		space.list[1] = 0;
		KlIncRef(space.list[1] = KlSend_eval(*(argv + 1)));
		space.list[2] = 0;
		KlIncRef(space.list[2] = KlSend_eval(*(argv + 2)));
		space.list[3] = 0;
		result = CFAPPLY((obj->body),  (space.list[0], space.list[1],
						space.list[2]));
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) obj;
		KlDecRefNonNull(space.list[0]);
		KlDecRefNonNull(space.list[1]);
		KlDecRefNonNull(space.list[2]);
	    }
	    break;
	case 4:
	    {
		struct _KlStackSpace4 space;
		space.type = 0;
		space.obj = (KlO) obj;
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) &space;
		space.list[0] = 0;
		KlIncRef(space.list[0] = KlSend_eval(*argv));
		space.list[1] = 0;
		KlIncRef(space.list[1] = KlSend_eval(*(argv + 1)));
		space.list[2] = 0;
		KlIncRef(space.list[2] = KlSend_eval(*(argv + 2)));
		space.list[3] = 0;
		KlIncRef(space.list[3] = KlSend_eval(*(argv + 3)));
		space.list[4] = 0;
		result = CFAPPLY((obj->body),  (space.list[0], space.list[1],
						space.list[2], space.list[3]));
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) obj;
		KlDecRefNonNull(space.list[0]);
		KlDecRefNonNull(space.list[1]);
		KlDecRefNonNull(space.list[2]);
		KlDecRefNonNull(space.list[3]);
	    }
	    break;
	case 5:
	    {
		struct _KlStackSpace5 space;
		space.type = 0;
		space.obj = (KlO) obj;
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) &space;
		space.list[0] = 0;
		KlIncRef(space.list[0] = KlSend_eval(*argv));
		space.list[1] = 0;
		KlIncRef(space.list[1] = KlSend_eval(*(argv + 1)));
		space.list[2] = 0;
		KlIncRef(space.list[2] = KlSend_eval(*(argv + 2)));
		space.list[3] = 0;
		KlIncRef(space.list[3] = KlSend_eval(*(argv + 3)));
		space.list[4] = 0;
		KlIncRef(space.list[4] = KlSend_eval(*(argv + 4)));
		space.list[5] = 0;
		result = CFAPPLY((obj->body),  (space.list[0], space.list[1],
						space.list[2], space.list[3],
						space.list[4]));
		KlStack[KlStackPtr - KlSFO_ref] = (KlO) obj;
		KlDecRefNonNull(space.list[0]);
		KlDecRefNonNull(space.list[1]);
		KlDecRefNonNull(space.list[2]);
		KlDecRefNonNull(space.list[3]);
		KlDecRefNonNull(space.list[4]);
	    }
	    break;
	default:
	    result = NIL;		/* should not be reached */
	}
    } else {
	return KlBadNumberOfArguments(argc);
    }
    KlDebugStackPop();
    KlStackFramePopSpecial();
    return result;
}

KlO
KlFuncApply(func, argc, argv)
    KlMethod func;
    int argc;
    KlO *argv;
{
    switch (argc) {
    case 0:
	return CFAPPLY(func,  ());
    case 1:
	return CFAPPLY(func,  (*argv));
    case 2:
	return CFAPPLY(func,  (*argv, *(argv + 1)));
    case 3:
	return CFAPPLY(func,  (*argv, *(argv + 1), *(argv + 2)));
    case 4:
	return CFAPPLY(func,  (*argv, *(argv + 1), *(argv + 2),
					*(argv + 3)));
    case 5:
	return CFAPPLY(func,  (*argv, *(argv + 1), *(argv + 2),
					*(argv + 3), *(argv + 4)));
    default:
	return NIL;			/* should not be reached */
    }
}

KlO
KlFSubrExecute(obj, list)
    KlFSubr obj;			/* the function */
    KlList list;
{
    KlO result;
    KlDebugStackDecls;

    KlStackFramePushSpecialHold(KlSFID_subr, list, obj);
    KlDebugStackPush(KlSFID_subr, list);
    if (obj->arity == NARY) {
	result = CFAPPLY(obj->body,  (list->size - 1, list->list + 1));
    } else if (obj->arity == (list->size - 1)) {
	result = KlFuncApply(obj->body, list->size - 1, list->list + 1);
    } else {
	return KlBadNumberOfArguments(list->size - 1);
    }
    KlDebugStackPop();
    KlStackFramePopSpecial();
    return result;
}

/* execution of Exprs
 * parsing the provided argument with the CommonLisp LambdaList info
 * embedded in the Expr
 */

KlO
KlFExprExecute(obj, list)
    KlFExpr obj;
    KlList list;
{
    return KlExecuteLocalCode(list, 0, list->size - 1, list->list + 1, obj);
}

KlO
KlMExprExecute(obj, list)
    KlFExpr obj;
    KlList list;
{
    KlO expr = KlExecuteLocalCode(list, 0, list->size - 1, list->list + 1, obj);
    return KlSend_eval(expr);
}

KlO
KlExprExecute(obj, list)
    KlExpr obj;
    KlList list;
{
    return KlExecuteLocalCode(list, 1, list->size - 1, list->list + 1, obj);
}

/*****************************************************************************\
* 				   Equality                                   *
\*****************************************************************************/
/* Equality of two exprs is equality of their printed representation
 * this does not makes (lambda (x) x) and (lambda (y) y) equal, however no
 * known lispes know how to do this.
 */

KlO
KlExprEqual(e1, e2)
    KlExpr e1;
    KlExpr e2;
{
    KlList p1, p2;
    int i;

    /* check type, it could be a Expr, FExpr, Mexpr */
    if (e1->type != e2->type
    /* then compares lambda list, then body like lists */
        || e1->arity != e2->arity
	|| e1->body_size != e2->body_size
	) {
	return NIL;
    }
    /* general comparison: compares external representation */
    p1 = KlUnparseLambdaList(e1);
    p2 = KlUnparseLambdaList(e2);
    if (!KlListEqElements(p1, p2))
	return NIL;
    for (i = 0; i < e1->body_size; i++) {
	if (KlSend_equal(e1->body[i], e2->body[i]) == NIL)
	    return NIL;
    }
    return (KlO) e1;
}

KlO
KlExprHash(obj)				/* hashes on its list */
    KlExpr obj;
{
    return (KlO) KlListHash((KlList) KlListCoerce(KlListType, obj));
}

int
KlListEqElements(l1, l2)
    KlList l1, l2;
{
    int i;

    if (l2->size != l1->size)
	return 0;
    for (i = 0; i < l1->size; i++) {
	if (l1->list[i] != l2->list[i])
	    return 0;
    }
    return 1;
}

/* equality on Subrs is equality of arity and body */

KlO
KlSubrEqual(s1, s2)
    KlSubr s1;
    KlSubr s2;
{
    if (s2->type == s1->type
	&& s2->arity == s1->arity
	&& s2->body == s1->body)
	return (KlO) s1;
    else
	return NIL;
}

KlO
KlSubrHash(obj)
    KlSubr obj;
{
    return (KlO) ((UInt) (obj->arity) + (UInt) (obj->body));
}

/***********************************************\
* 					        *
*  Accessory functions for evaluation purposes  *
* 					        *
\***********************************************/

/*
 * here goes all the stuff really needed to operate the evaluation
 * mecanism of KLONE.
 */

/* 
 * KlExecuteLocalCode:
 * main program for all EXPR function calls.
 */

KlO
#ifdef KLPROFILER			/* the klprofiler hooks it */
Kl__ELC(call, eval_args, values_size, valuesi, func)
#else
KlExecuteLocalCode(call, eval_args, values_size, valuesi, func)
#endif
    KlO call;				/* the call itself to store in stack */
    int eval_args;			/* do we need to eval args? */
    int values_size;			/* number of local vars */
    KlO *valuesi;			/* init values for local vars*/
    KlExpr func;			/* the function itself: [FM]Expr */
{
    KlO *values;
    KlO result;
    KlStackSpace space = 0;
    KlSend_setq_protectDECL;
    KlDebugStackDecls;

    if (func->arity) {
	KlAtom *parameters = func->parameters;
	KlAtom *endparam;
	int stackptr = KlStackPtr;

	KlStackFramePush(func->arity, parameters, call, func);
	KlDebugStackPush(KlSFID_normal, call);

	/* eval arguments if needed */
	if (eval_args && values_size) {
	    KlO *dest = values = (
		space = (KlStackSpace) 
		KlAlloca(KlStackSpaceSizeof(values_size)))
		->list;
	    KlO *last = dest + values_size;
	    space->type = 0;
	    space->obj = (KlO) func;
	    KlStack[KlStackPtr - KlSFO_ref] = (KlO) space;

	    *dest = 0;
	    for (;;) {
		KlIncRef(*dest++ = KlSend_eval(*valuesi));
		*dest = 0;
		valuesi++;
		if (dest >= last)	/* faster than a naive while */
		    break;
	    }
	} else {
	    values = valuesi;
	}
	if (func->lambdalist) {
	    KlO *inits;
	    KlO *endvalues = values + values_size;

					/* fixed */
	    if (values_size < func->lambdalist->nfixed) {
		return KlBadNumberOfArguments(values_size);
	    }
	    endparam = parameters + func->lambdalist->nfixed;
	    while (parameters < endparam) {
		KlSend_setq(*parameters, *values);
		parameters++;
		values++;
	    }
					/* optionals */
	    if (inits = func->lambdalist->optionals) {
		while (*inits) {
		    if (values >= endvalues) {
			KlSend_setq_protect(*parameters, KlSend_eval(*inits));
		    } else {
			KlSend_setq(*parameters, *values);
			values++;
		    }
		    parameters++;
		    inits++;
		}
	    }
					/* rest */
	    if (func->lambdalist->rest) {
		KlSend_setq(*parameters,
			    KlListKl(endvalues - values, values));
		parameters++;
	    }
					/* whole */
	    if (func->lambdalist->whole) {
		KlSend_setq(*parameters, call);
		parameters++;
	    }
					/* keys */
	    if (func->lambdalist->key) {
		KlKeyDecls kd = func->lambdalist->key;
		KlO *values_orig = endvalues - values_size;
		int start = values - values_orig;

		KlParseKeywords(values_size, values_orig, start);
		while (kd->key) {
		    KlO temp = KlSend_eval(kd->init);
		    KlSend_setq(*parameters, KlKeyVal(kd->key, temp));
		    parameters++;
		    kd++;
		}
		if (func->lambdalist->variable_arity == 1) {
		    KlCheckUnvalidKeywords(values_size, values_orig, start);
		}
	    }
		
					/* aux */
	    if (inits = func->lambdalist->aux) {
		while (*inits) {
		    KlSend_setq_protect(*parameters, KlSend_eval(*inits));
		    parameters++;
		    inits++;
		}
	    }
	    
	    if (!(values == endvalues || func->lambdalist->variable_arity)) {
		return KlBadNumberOfArguments(values_size);
	    }
	    
	} else {
	    if (values_size != func->arity) {
		return KlBadNumberOfArguments(values_size);
	    }
	    endparam = parameters + func->arity;
	    while (parameters < endparam) {
		KlSend_setq(*parameters, *values);
		parameters++;
		values++;
	    }
	}

	result = (KlO) KlProgn(func->body_size, func->body); 

	if (space) {
	    KlO *dest = space->list;
	    KlO *last = dest + values_size;
	    KlStack[KlStackPtr - KlSFO_ref] = (KlO) func;
	    for (;dest<last;dest++) {
		KlDecRefNonNull(*dest);
	    }
	}

	KlDebugStackPop();
	KlStackFramePopNormal(stackptr);

    } else {
	KlStackFramePushSpecialHold(KlSFID_subr, call, func);
	KlDebugStackPush(KlSFID_subr, call);
	if (values_size) {
	    result = KlBadNumberOfArguments(values_size);
	} else {
	    result = (KlO) KlProgn(func->body_size, func->body);
	}
	KlDebugStackPop();
	KlStackFramePopSpecial();
    }
    return result;
}

/*****************************\
* 			      *
* Local variables management  *
* 			      *
\*****************************/

/*
 * the simpler local variable declarations "WITH"
 * used as in (with (x 1 y 2) ...insts...)
 */

KlO
KlWith(argc, argv)
    int argc;
    KlO *argv;
{
    KlO result;
    KlList vars = (KlList) argv[0];
    KlO *parameters, *endparm;
    int stackptr = KlStackPtr;

    KlSend_setq_protectDECL;
    KlDebugStackDecls;

    if (argc < 1)
	return KlBadNumberOfArguments((char *) argc);
    if (KlIsAQuotedExpr(vars) && ((KlQuotedExpr)vars)->symbol == KlA_unquote) {
	vars = (KlList) KlSend_eval(((KlQuotedExpr)vars)->expr);
    } else if (KlIsASymbol(vars)) {
	vars = (KlList) KlSend_eval(vars);
    }

    KlMustBeList(vars, 0);
    KlMustBeEvenList(vars, 0);

    if (KlFalseP(vars)) {
	return (KlO) KlProgn(argc - 1, argv + 1);
    }
    KlStackFramePushSpacedValues(vars->size, vars->list);
    KlDebugStackPush(KlSFID_normal, NIL);
    parameters = vars->list;
    endparm = parameters + vars->size;
    while (parameters < endparm) {
	KlSend_setq_protect(*parameters, KlSend_eval(*(parameters + 1)));
	parameters += 2;
    }
    result = (KlO) KlProgn(argc - 1, argv + 1);
    KlDebugStackPop();
    KlStackFramePopNormal(stackptr);
    return result;
}

/*
 * with_eval evaluates first its first argument	before calling KlWith
 */

KlO
KlWithEval(argc, argv)
    int argc;
    KlO *argv;
{
    KlO *eval_args, result;
    int i;

    if (argc == 0)
	return KlError0(KlE_BAD_LOCAL_SYNTAX);
    eval_args = KlAlloca(argc);
    eval_args[0] = KlSend_eval(argv[0]);
    for (i = 1; i < argc; i++) {
	eval_args[i] = argv[i];
    }
    result = KlWith(argc, eval_args);
    return result;
}

/* the let*
 * (sequential let)
 */

KlO
KlLetSeq(argc, argv)
    int argc;
    KlList *argv;
{
    KlO result;
    KlList decs, vars;
    int i;
    KlO *parameters, *endparm;
    int stackptr = KlStackPtr;

    KlSend_setq_protectDECL;
    KlDebugStackDecls;

    if (!argc)
	return NIL;
    KlMustBeList(argv[0], 0);
    decs = (KlList) argv[0];
    vars = KlListNMake(2 * decs->size);
    vars->size = 0;			/* in case of abort due to error */
    for (i = 0; i < decs->size; i++) {
	if (decs->list[i]->type == KlListType) {
            if (((KlList) (decs->list[i]))->size != 2)
                return KlError0(KlE_BAD_LOCAL_SYNTAX);
	    KlIncRef(vars->list[2 * i] =
		((KlList) (decs->list[i]))->list[0]);
	    KlIncRef(vars->list[2 * i + 1] =
		(((KlList) (decs->list[i]))->size > 1) ?
		((KlList) (decs->list[i]))->list[1] :
		NIL);

	} else {
	    KlIncRef(vars->list[2 * i] = decs->list[i]);
	    KlIncRef(vars->list[2 * i + 1] = NIL);
	}
	vars->size +=2;
    }

    KlStackFramePushSpacedValues(vars->size, vars->list);
    KlDebugStackPush(KlSFID_normal, NIL);
    parameters = vars->list;
    endparm = parameters + vars->size;
    while (parameters < endparm) {
	KlSend_setq_protect(*parameters, KlSend_eval(*(parameters + 1)));
	parameters += 2;
    }
    result = (KlO) KlProgn(argc - 1, argv + 1);
    KlDebugStackPop();
    KlStackFramePopNormal(stackptr);
    return result;
}



/* the let
 * (parallel evalaution of arguments)
 */

KlO
KlLet(argc, argv)
    int argc;
    KlList *argv;
{
    KlO result;
    KlList decs, vars;
    int i;
    KlO *parameters, *endparm;
    int stackptr = KlStackPtr;
    KlO *newvalues, *pnv;			/* // */
    KlStackSpace space;

    KlSend_setq_protectDECL;
    KlDebugStackDecls;

    if (!argc)
	return NIL;
    KlMustBeList(argv[0], 0);
    decs = (KlList) argv[0];
    vars = KlListNMake(2 * decs->size);
    vars->size = 0;			/* in case of abort due to error */
    for (i = 0; i < decs->size; i++) {
	if (decs->list[i]->type == KlListType) {
            if (((KlList) (decs->list[i]))->size != 2)
                return KlError0(KlE_BAD_LOCAL_SYNTAX);
	    KlIncRef(vars->list[2 * i] =
		((KlList) (decs->list[i]))->list[0]);

	    KlIncRef(vars->list[2 * i + 1] =
		(((KlList) (decs->list[i]))->size > 1) ?
		((KlList) (decs->list[i]))->list[1] :
		NIL);

	} else {
	    KlIncRef(vars->list[2 * i] = decs->list[i]);
	    KlIncRef(vars->list[2 * i + 1] = NIL);
	}
	vars->size +=2;
    }

    KlStackFramePushSpacedValues(vars->size, vars->list);
    KlDebugStackPush(KlSFID_normal, NIL);
    parameters = vars->list;
    endparm = parameters + vars->size;
    space = (KlStackSpace) KlAlloca(KlStackSpaceSizeof(vars->size / 2));
    pnv = newvalues = space->list; /* BEGIN // */
    space->type = 0;
    space->obj = (KlO) NIL;
    KlStack[KlStackPtr - KlSFO_ref] = (KlO) space;
    *pnv = 0;
    while (parameters < endparm) {
	KlIncRef(*pnv++ = KlSend_eval(*(parameters + 1)));
	*pnv = 0;
	parameters += 2;
    }
    parameters = vars->list;
    pnv = newvalues;
    while (parameters < endparm) {
	KlSend_setq_protect(*parameters, *pnv);
	pnv++;
	parameters += 2;
    }					/* END // */
    result = (KlO) KlProgn(argc - 1, argv + 1);
    KlStack[KlStackPtr - KlSFO_ref] = (KlO) NIL;
    for (pnv = space->list;*pnv;pnv++) {
	KlDecRefNonNull(*pnv);
    }
    KlDebugStackPop();
    KlStackFramePopNormal(stackptr);
    return result;
}

/* Apply
 * eval a list but do not evaluate args
 * KlApply do not check args, cannot be sent on nil
 * KlApplyKl is the klone-callable function
 * (apply func arg1 arg2...)
 */

KlO
KlApply(call)
    KlList call;
{
    KlO func = call->list[0];

    if (KlIsUndefinedMethod(func, KlSelApply)) {
	if (!KlIsUndefinedMethod(func, KlSelExecute)) {
	    /* then we execute (approximation) */
	    return (func->type[KlSelExecute])(func, call);
	}
	/* else try to correct things by one eval */
	func = KlSend_eval(func);
	if ((KlIsUndefinedMethod(func, KlSelApply))) {
	    if (!KlIsUndefinedMethod(func, KlSelExecute)) {
		/* then we execute (approximation) */
		return (func->type[KlSelExecute])(func, call);
	    } else {
		/* else, approximate by evaluating the list.
		   may evaluate too much */
		return KlSend_eval(call);
	    }
	}
    }
	    
    /* there is a specially devised apply method */
    return (func->type[KlSelApply])(func, call);
}

/*********************************************************** argc, argv form */

KlO
KlApplyN(func, argc, argv)
    KlO func;
    int argc;
    KlO *argv;
{
    KlList call;

    call = KlListNMake(argc + 1);
    KlListStore(call, 0, func);
    KlCopyNObjects(argv, call->list + 1, argc);

    return KlApply(call);
}

/************************************************************** VARARGS form */
/*  KlApplyV(KlO func, int number_of_args, KlO args...)
 */
KlO
#if __STDC__
KlApplyV(KlO func, int size, ...)
#else
KlApplyV(va_alist)
    va_dcl
#endif
{
    va_list argList;
    KlList call;
    KlO *p;

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

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

    return KlApply(call);
}

/************************************************************ Klone-callable */

KlO
KlApplyKl(func, arglist)
    KlO func;
    KlList arglist;
{
    KlMustBeList(arglist, 1);

    return KlApplyN(func, arglist->size, arglist->list);
}

/*****************************************************************************\
* 				 saverestore                                  *
\*****************************************************************************/
/* should be done as a macro TODO: see if can not incref saved value
 */

#define KlSaveValue(obj) \
    ((obj)->type == KlAtomType ? ((KlAtom)(obj))->c_val : KlSend_eval((obj)))

/*************************************\
*                                     *
* Environment Stack frames management *
*                                     *
\*************************************/

/* initialize env stack */

KlEnvStackInit()
{
    KlStackLimit = 1023;
    KlStack = (KlO *) Malloc(KlStackLimit * sizeof(KlO));
    KlStack[0] = 0;
}

/* KlEnvStackGrow
 * makes stack grow (doubles size) when needed
 */

KlEnvStackGrow()
{
    KlO *newstack;

    KlStackLimit = KlStackLimit * 2 + 1;
    if ((!KlStackMaxSize || KlStackLimit < KlStackMaxSize) &&
	(newstack = (KlO *) Realloc(KlStack, sizeof(KlO) * KlStackLimit))) {
	KlStack = newstack;
    } else {				/* print meaningful error mess */
	int bytes = KlStackLimit;

	if (((KlStackLimit-1)/2) > KlStackMaxSize) {
	    CFAPPLY(KlFatalError, (4, KlStackLimit));
	} else {
	    int stackptr = KlStackPtr;

	    KlStack = (KlO *) Realloc(KlStack, sizeof(KlO) *
				      Max(KlStackLimit, KlStackMaxFatalSize));
	    KlStackFramePush(1, &KlA_StackMaxSize, NIL, NIL);
	    KlStackMaxSize = KlStackLimit;

	    KlError1i(KlE_STACK_OVERFLOKl, bytes);
	    
	    KlStackFramePopNormal(stackptr);
	}
    }

}

/* function to set the active value *max-stack-size*
 */

KlO
KlStackMaxSizeSet(num, data)
    KlNumber num;			/* the new number */
    KlO data;				/* ptr to KlStackMaxSize */
{
    int size = num->number;

    KlMustBeNumber(num, 0);

    KlStackLimit = (size - 1) / 2;
    KlStackMaxSize = Min(size, KlStackMaxFatalSize);
    if (KlStackPtr < KlStackLimit) {
	KlStack = (KlO *) Realloc(KlStack, sizeof(KlO) * KlStackLimit);
    }

    return (KlO) num;	
}

#ifdef DEBUG2
KlVerifyStack(p)
    int p;
{
    Int offset;
    static int n;

    n++;				/* counter, only used to breakpoint */

    while (p) {				/* p==0 ==> end of stack */
	/* normal frame */
	if ((Int) (KlStack[p]) == KlSFID_normal) {
	    Int i;
	    KlMustBeList(KlStack[p - KlSFO_call], 0);
	    offset = (Int) (KlStack[p - KlSFO_previous]);
	    if (!(((unsigned int) (p - offset)) < 64) && ((p - offset) % 2)) {
		fprintf(stderr, "assertion failed: %s",
			"(((unsigned int) (p - offset)) < 64) && ((p - offset) % 2)");
		stop_if_in_dbx("bad normal stack frame");
	    }
	    for (i = p - (KlSFS_normal + 1);
		 i > offset; i -= 2) {
		if (!KlObjectIsValid(KlStack[i]))
		    stop_if_in_dbx("Non klone object as stack frame variable");
		if (!KlObjectIsValid(KlStack[i+1]))
		    stop_if_in_dbx("Non klone object as stack frame value");
	    }
	    /* catch point */
	} else if ((Int) (KlStack[p]) == KlSFID_catch) {
	    offset = p - KlSFS_special;
	    /* Subr call */
	} else if ((Int) (KlStack[p]) == KlSFID_subr) {
	    KlMustBeList(KlStack[p - KlSFO_call], 0);
	    offset = p - KlSFS_special;
	    /* Hook marker */
	} else if ((Int) (KlStack[p]) == KlSFID_hook) {
	    if (((UInt) (KlStack[p-KlSFO_framehook])) > KlStackPtr) {
		fprintf(stderr, "assertion failed: %s",
			"KlStack[p-KlSFO_framehook] < KlStackPtr");
		stop_if_in_dbx("invalid stack framehook");
	    }	
	    offset = p - KlSFS_special;
	    /* unknown stackframe type */
	} else {
	    fprintf(stderr, "bad stack frame at %d: %d\n", p, KlStack[p]);
	    stop_if_in_dbx("bad stack frame");
	}
	p = offset;
    }
}

#else
#define KlVerifyStack(p)
#endif

/* pushes arguments on stack (functional call) */

KlStackFramePush(size, parameters, call, hold)
    int size;
    KlO *parameters;
    KlO call;
    KlO hold;
{
    int newptr;
    KlO *stack, *frameheader;
    KlO *values = KlAlloca(size);

    {
	KlO *p = parameters, *end = parameters+size, *v = values;
	while(p<end) {
	    *v++ = KlSaveValue(*p);
	    p++;			/* KlSaveValue macro:no side effects */
	}
    }

    KlVerifyStack(KlStackPtr);
    newptr = KlStackPtr + (size *= 2) + KlSFS_normal;
    KlStackAdjust(newptr);
    stack = KlStack + KlStackPtr;
    frameheader = stack + size;
    while (stack < frameheader) {
	*++stack = *parameters++;
	KlIncRef(*++stack = *values++);
    }
    *++frameheader = (KlO) KlStackPtr;
    KlIncRef(*++frameheader = hold);
    *++frameheader = call;
    *++frameheader = (KlO) KlSFID_normal;

    KlStackPtr = newptr;		/* last in case of errors in eval */
    ASSERT(KlStack[KlStackPtr]);
}

/* pushes arguments on stack (declarative (with) call)
 * parameters and new_values are set to point in the old_value space
 * size is size of list (= 2 * number-of-parameters)
 * this is EXACTLY the same code except for size and parameter incr
 */

KlStackFramePushSpacedValues(size, parameters)
    int size;
    KlO *parameters;
{
    int newptr;
    KlO *stack, *frameheader;
    KlO *values = KlAlloca(size/2);
    {
	KlO *p = parameters, *end = parameters+size, *v = values;
	while(p<end) {
	    *v++ = KlSaveValue(*p);
	    p += 2;			/* KlSaveValue macro:no side effects */
	}
    }

    KlVerifyStack(KlStackPtr);
    newptr = KlStackPtr + (size) + KlSFS_normal;
    KlStackAdjust(newptr);
    stack = KlStack + KlStackPtr;
    frameheader = stack + size;
    while (stack < frameheader) {
	*++stack = *parameters++;
	parameters++;			/* only difference with push */
	KlIncRef(*++stack = *values++);
    }

    *++frameheader = (KlO) KlStackPtr;
    KlIncRef(*++frameheader = NIL);
    *++frameheader = NIL;
    *++frameheader = (KlO) KlSFID_normal;

    KlStackPtr = newptr;		/* last in case of errors in eval */
    ASSERT(KlStack[KlStackPtr]);
}

/* useful variable-number-of args call: a "with in C"
 * KlStackFramePushValues(N, var1, newval1, ... varN, newvalN);
 */

#if __STDC__
KlStackFramePushValuesV(int size, ...)
#else
KlStackFramePushValuesV(va_alist)
    va_dcl
#endif
{
    va_list argList;
    KlO *p, *q, *end;
    KlSend_setq_protectDECL;
#if __STDC__
    va_start(argList, size);
    size = 2 * size;
#else
    int size;

    va_start(argList);
    size = 2 * va_arg(argList, int);
#endif

    p = KlAlloca(size);
    for (q = p, end = p + size; q < end; q++) {
	*q = va_arg(argList, KlO);
    }
    va_end(argList);
    KlStackFramePushSpacedValues(size, p);
    for (q = p, end = p + size; q < end; q += 2) {
	KlSend_setq_protect(*q, KlSend_eval(*(q + 1)));
    }
}
 
/* pushes a special stack frame */

KlStackFramePushSpecialHold(type, call, held)
    Int type;
    KlO call;
    KlO held;
{
    KlO *newptr;

    KlVerifyStack(KlStackPtr);
    KlStackAdjust(KlStackPtr + KlSFS_special); /* make room */

    newptr = KlStack + KlStackPtr;
    KlIncRef(*(++newptr) = held);	/* KlStack[newptr - KlSFO_ref] */
    *(++newptr) = call;			/* KlStack[newptr - KlSFO_call] */
    *(++newptr) = (KlO) type;		/* KlStack[newptr] */

    KlStackPtr += KlSFS_special;	/* last in case of errors in eval */
    ASSERT(KlStack[KlStackPtr]);
}

/* pushes a Hook flag, and set it */
/* Note: the value of KlIsInFrameHook indicates the number of stacked
 * _KlError calls
 */

KlStackFramePushSetHook()
{
    if (!KlIsInFrameHook)  		/* entering hook 1rst time, snapshot */
        KlStackPtrInHook = KlStackPtr; 
    KlStackFramePushSpecial(KlSFID_hook, KlIsInFrameHook); 
    KlIsInFrameHook++;
}

/* restores old parameters values and de-pop 1 frame stack */

KlStackFramePop()
{
    ASSERT(KlStack[KlStackPtr]);
    KlVerifyStack(KlStackPtr);
    if (KlStack[KlStackPtr - KlSFO_ref]->type) {
        KlDecRefNonNull(KlStack[KlStackPtr - KlSFO_ref]);
    } else { 
        KlStackSpaceFree(KlStack[KlStackPtr - KlSFO_ref]);
    } 
    if ((Int) (KlStack[KlStackPtr]) & KlSFID_normal) {
	Int previous = (Int) (KlStack[KlStackPtr - KlSFO_previous]);
	int i;

	for (i = KlStackPtr - (KlSFS_normal + 1);
	    i > previous; i -= 2) {
	    if (KlStack[i]->type == KlAtomType) {
		KlDecRefNonNull(((KlAtom)KlStack[i])->c_val);
		((KlAtom)KlStack[i])->c_val = KlStack[i + 1];
	    } else {
		KlSend_setq(KlStack[i], KlStack[i + 1]);
		KlDecRefNonNull(KlStack[i + 1]);
	    }
	}
	KlStackPtr = previous;
    } else {
	if ((Int) (KlStack[KlStackPtr]) & KlSFID_hook) {
	    KlIsInFrameHook = (int) KlStack[KlStackPtr - KlSFO_framehook];
	    if (!KlIsInFrameHook && 
		KlStackPtrInHook == (KlStackPtr - KlSFS_special))
		KlStackPtrInHook = 0;
	}
	KlStackPtr -= KlSFS_special;
    }
    ASSERT(KlStackPtr >= 0);
}

#ifdef DEBUG

/* KlDoStackFramePointedObs
 * applies predicate on all objects stored (IncRef-ed) in stack
 * as f(obj, stackptr)
 */

KlDoStackFramePointedObs(f)
    int (*f)();
{
    Int frame = KlStackPtr;
    while (frame) {
	if (KlStack[frame - KlSFO_ref]->type)
	    CFAPPLY(f, (KlStack[frame - KlSFO_ref], frame, 0));
	
	if ((Int) (KlStack[frame]) & KlSFID_normal) {
	    Int i, previous = (Int) (KlStack[frame - KlSFO_previous]);
	    for (i = frame - (KlSFS_normal + 1); i > previous; i -= 2)
		CFAPPLY(f, (KlStack[i + 1], frame, KlStack[i]));
	    frame = previous;
	} else {
	    frame -= KlSFS_special;
	}
    }
}
#endif /* DEBUG */

/* specialized faster version
 */

KlStackFramePopNormal(previous)
    Int previous;
{
    int i;
    ASSERT(KlStack[KlStackPtr]);
    KlVerifyStack(KlStackPtr);

    if (KlStack[KlStackPtr - KlSFO_ref]->type) {
        KlDecRefNonNull(KlStack[KlStackPtr - KlSFO_ref]);
    } else { 
        KlStackSpaceFree(KlStack[KlStackPtr - KlSFO_ref]);
    } 
    for (i = KlStackPtr - (KlSFS_normal + 1);
	 i > previous; i -= 2) {
	if (KlStack[i]->type == KlAtomType) {
	    KlDecRefNonNull(((KlAtom)KlStack[i])->c_val);
	    ((KlAtom)KlStack[i])->c_val = KlStack[i + 1];
	} else {
	    KlSend_setq(KlStack[i], KlStack[i + 1]);
	    KlDecRefNonNull(KlStack[i + 1]);
	}
    }
    KlStackPtr = previous;
    ASSERT(KlStackPtr >= 0);
}

/* specialized version for hook frames */

KlStackFramePopHook()
{
    ASSERT(KlStack[KlStackPtr]);
    ASSERT((Int) (KlStack[KlStackPtr]) & KlSFID_hook);
    if (KlStack[KlStackPtr - KlSFO_ref]->type) {
        KlDecRefNonNull(KlStack[KlStackPtr - KlSFO_ref]);
    } else { 
        KlStackSpaceFree(KlStack[KlStackPtr - KlSFO_ref]);
    } 
    KlIsInFrameHook = (int) KlStack[KlStackPtr - KlSFO_framehook];
    KlStackPtr -= KlSFS_special;
    if (!KlIsInFrameHook && KlStackPtrInHook == KlStackPtr)
	KlStackPtrInHook = 0;
    ASSERT(KlStackPtr >= 0);
}

/* pop all the frames from current to given one 
 * execute all unwind-protects set in the stack in the process
 */

KlStackFramePopTo(to_frame)
    Int to_frame;
{
    UnwindPoint up;

    while (KlStackPtr != to_frame) {
	if (((Int) KlStack[KlStackPtr]) == KlSFID_catch) {
	    up = (UnwindPoint) (KlStack[KlStackPtr - KlSFO_catch]);
	    /* we hit an u-p */
	    if (!up->tag) {
		CFAPPLY((up->func),  (up->arg1, up->arg2));
	    }
	}
	KlStackFramePop();
    }
}

/* checks for the existence of a tag named tag into the stack
 * just not to jump blindly
 */

Int
KlStackFrameLookForCatch(tag)
    KlO tag;
{
    Int frame = KlStackPtr;

    while (frame) {
	if ((Int) (KlStack[frame]) & KlSFID_normal) {
	    frame = (Int) (KlStack[frame - KlSFO_previous]);
	} else if (((Int) (KlStack[frame]) & KlSFID_catch)
		&& ((((JumpingPoint) (KlStack[frame - KlSFO_catch]))
			->tag == tag)
		    || (((JumpingPoint) (KlStack[frame - KlSFO_catch]))
			->tag == (KlO) KlA_ALL))
	    ) {
	    return frame;
	} else {
	    frame -= KlSFS_special;
	}
    }
    return 0;
}

/* generic version of the above: look for a marker in the stack and return
 * first data found, or 0 if nothing found
 * (used for method activation records now, but could be used by future stack
 *  markers)
 */

KlO
KlStackFrameLookForTag(tag)
    KlO tag;
{
    Int frame = KlStackPtr;

    while (frame) {
	if ((Int) (KlStack[frame]) & KlSFID_normal) {
	    frame = (Int) (KlStack[frame - KlSFO_previous]);
	} else if (KlStack[frame] == tag) {
		return KlStack[frame - KlSFO_data];
	} else {
	    frame -= KlSFS_special;
	}
    }
    return 0;
}

KlStackSpaceFree(space)
    KlStackSpace space;
{
    KlO *p;
    KlDecRefNonNull(space->obj);	/* was increfed on push */
    for (p = space->list;*p;p++) {
	KlDecRefNonNull(*p);
    }
}

/*****************************************************************************\
* 				catch & throw                                 *
\*****************************************************************************/

/* (catch tag insts...)
 */

KlO
KlCatchKl(argc, argv)
    int argc;
    KlO *argv;
{
    KlO tag;
    KlO result;
    int normal;

    if (argc < 2)
	return KlBadNumberOfArguments((char *) argc);
    tag = KlSend_eval(argv[0]);

    KlCatch(tag, KlProgn(argc - 1, argv + 1), result, normal);

    return result;
}

KlO
KlUnwindProtectKl(argc, argv)
    int argc;
    KlO *argv;
{
    KlO result;

    if (argc < 2)
	return KlBadNumberOfArguments((char *) argc);

    KlUnwindProtect(KlSend_eval(argv[0]), result, KlProgn, argc - 1, argv + 1);

    return result;
}

KlO
KlThrowKl(argc, argv)
    int argc;
    KlO *argv;
{
    KlO tag;

    if (argc < 1)
	return KlBadNumberOfArguments((char *) argc);
    tag = KlSend_eval(argv[0]);

#ifndef DEBUG2
    KlThrow(tag, KlProgn(argc - 1, argv + 1));
#else					/* DEBUG: generated from the above */
    {
	KlO     KlThrowAux_result;
	Int KlThrowAux_frame = KlStackFrameLookForCatch(tag);

	if (!KlThrowAux_frame) {
	    if (KlA_ERROR == (KlAtom) tag) {
		if (KlNonCaughtErrorHandler)
		    CFAPPLY(KlNonCaughtErrorHandler, ());
		CFAPPLY(KlFatalError, (1, 0));
	    }
	    KlError(KlE_NO_CATCH, tag);
	}
	KlThrowAux_result = (KlO) KlProgn(argc - 1, argv + 1);
	KlStackFramePopTo(KlThrowAux_frame);
	KlDoJmpbufCheck(((JumpingPoint)(KlStack[KlStackPtr - KlSFO_catch]))
			->jump_buffer);
	KlLastCaughtTag = (KlO) tag;
	Kllongjmp(((JumpingPoint)(KlStack[KlStackPtr - KlSFO_catch]))
		  ->jump_buffer, KlThrowAux_result);

    }
#endif					/* DEBUG */
    return NIL;				/* not reached */
}


/*****************************************************************************\
* 			   Stack handling from klone                           *
\*****************************************************************************/
/* KlStackFrameKl 
 * returns the stack frame
 * a stack frame is a list with KlStackFrameWSize elements:
 * [0] the call itself
 * [1] the actual stack pointer (number)
 * [2] next stack pointer or 0
 * [3] a p-list pairs variablesold values saved on the stack, or ()
 * [4] the type of the stack: (atom)  Expr, Subr, GenericFunction
 *     (may be extended by the C application to indicate the caller nature)
 * [5] a p-list of parameters to describe info pertaining to the specific
 *     caller
 *     In the bare klone, only the GenericFunction type has a p-list with keys:
 *       - selector    the name of the selector used for the call 
 *       - object      the object the method was sent to
 *       - class       the class used to find the method, may not be the
 *                     class of object in case of call-next-method
 * 
 * skips debugging frames and non-fonctional ones (catches, var decls)
 */

#define KlStackFrameWSize 6
int KlShowDebuggerStack = 0;

Int
KlStackFrameInfo(ptr, pcall, pactual_ptr, pvars, pvarsize)
    int ptr;
    KlO *pcall;
    int *pactual_ptr;
    KlO **pvars;
    int *pvarsize;
{
    int hidden_frame = 0;
    Int previous;

    if (ptr == 0) {
	if (KlIsInFrameHook && !KlShowDebuggerStack) {
	    hidden_frame = 1;
	}
	ptr = KlStackPtr;
    }

    /* skip frames of the debugger itself */
    while (ptr > 0
	   && (hidden_frame
	       || !((Int)(KlStack[ptr]) & KlSFIM_listable))) {
	if (((int) KlStack[ptr]) == KlSFID_hook && !KlShowDebuggerStack) {
		hidden_frame = (int) KlStack[ptr - KlSFO_framehook];
	}
	ptr = KlStackFramePrevious(ptr);
    }

    if (ptr == 0) {			/* we are at toplevel, exit */
	return -1;
    }
    if ((Int) (KlStack[ptr]) & KlSFID_normal) {
	*pvars = KlStack + ((Int) (KlStack[ptr - KlSFO_previous])) + 1;
	previous = (Int) (KlStack[ptr - KlSFO_previous]);
	*pvarsize = ptr - KlSFS_normal - previous;

	while (ptr > 0
	       && ((Int) (KlStack[ptr]) & KlSFID_normal)
	       && (KlStack[ptr - KlSFO_call] == NIL)) { /* skip nil frames */
	    ptr = previous;
	    previous = KlStackFramePrevious(ptr);
	}
	if (ptr == 0 || previous == 0) {
	    return -1;
	}
    } else {
	previous = ptr - KlSFS_special;
	*pvars = 0;
	*pvarsize = 0;
    }
    /* when directly called from C, we must trap the case of this not
       being a "call" frame */
    if ((Int) (KlStack[ptr]) & KlSFIM_call) { /* Expr */
	*pcall = KlStack[ptr - KlSFO_call];
    } else {				/* Subr */
	*pcall = NIL;
    }
    *pactual_ptr = ptr;
    return previous;
}

/* how to get the good number from klone */

KlO
KlStackPtrInHookGet(data)
    char *data;
{
    int hidden_frame =  (KlIsInFrameHook && !KlShowDebuggerStack);
    Int ptr = KlStackPtr;

    /* skip frames of the debugger itself */
    while (ptr > 0
	   && (hidden_frame
	       || !((Int)(KlStack[ptr]) & KlSFIM_listable))) {
	if (((int) KlStack[ptr]) == KlSFID_hook && !KlShowDebuggerStack) {
		hidden_frame = (int) KlStack[ptr - KlSFO_framehook];
	}
	ptr = KlStackFramePrevious(ptr);
    }

    if (ptr) {			/* we are at toplevel, exit */
	Int previous = ((Int) (KlStack[ptr]) & KlSFID_normal)
	    ? (Int) (KlStack[ptr - KlSFO_previous])
	    : ptr - KlSFS_special;
	while (ptr > 0
	       && ((Int) (KlStack[ptr]) & KlSFID_normal)
	       && (KlStack[ptr - KlSFO_call] == NIL)) { /* skip nil frames */
	    ptr = previous;
	    previous = KlStackFramePrevious(ptr);
	}
    }
    return (KlO) KlNumberMake(ptr);
}

KlO
KlStackFrameKl(klptr)
    KlNumber klptr;
{
    KlList res;
    int ptr;
    int actual_ptr;
    KlO call;
    KlO *vars;
    int next_ptr;
    int varsize;

    KlMustBeNumber(klptr, 0);
    ptr = klptr->number;

    if ((next_ptr =
	 KlStackFrameInfo(ptr, &call, &actual_ptr, &vars, &varsize)) == -1 ||
 	!KlObjectIsValid(KlStack[actual_ptr - KlSFO_call])) {
	return NIL;
    } else {
	KlListStoreDecl;

	res = KlListNMake(KlStackFrameWSize);
	KlListStoreReset(res);

	KlListStoreAdd(call);
	KlListStoreAdd(KlNumberMake(actual_ptr));
	KlListStoreAdd(KlNumberMake(next_ptr));
	KlListStoreAdd(varsize ? (KlO) KlListKl(varsize, vars) : NIL);
	KlListStoreAdd(((Int) (KlStack[actual_ptr])) & KlSFID_normal
		    ? (KlO) KlA_Expr : (KlO) KlA_Subr);	
	KlListStoreAdd(NIL);
	return (KlO) res;
    }		    
}


/*****************************************************************************\
* 			debugging hooks: method hooks                         *
\*****************************************************************************/
/* method hooks are a generalization of CL evalhooks
 * with this, hooks can be set for any internal method and for each type
 * separately
 * In types, two fields MHooks and MCalls points to a shadow array of the
 * type itself, with MHooks being just a backup copy of the original methods
 * which should stay untouched after first initialisation, and MCall being
 * a Klone expressing that will be applied by a caller function to perform the 
 * hook, this caller having overriden the original method
 */

/* KlMHooks(type, method, hook) sets the hook to be called around the 
 *     actual call
 *     hook = NIL means remove
 *     hook = 0 (not given from the klone interface) means get
 */

KlO
KlMHooks(type, method, hook)
    KlType type;
    KlNumber method;			/* number or string */
    KlO hook;
{
    int method_num = KlMHookMethodNum(method);

    type = KlFindType(type);		/* args check */

    if (!hook) {			/* get value */
	if (KlTypeMHooksGet(type)) {
	    if (KlTypeSlotGet(type, method_num) !=
		KlTypeSlotGet(KlTypeMHooksGet(type), method_num)) {
		if (KlTypeSlotGet(KlTypeMCallsGet(type), method_num)) {
		    return (KlO) 
			KlTypeSlotGet(KlTypeMCallsGet(type), method_num);
		} 
	    }
	}
	return NIL;
    } 

    if (KlTrueP(hook)) {		/* set hook */
	if (!KlTypeMHooksGet(type)) {	/* need to set up things */
	    /* allocate shadows of the main type array  */
	    KlTypeMHooksSet(type, Malloc(sizeof(KlMethod) * KlSelectorsSize));
	    KlTypeMCallsSet(type, Malloc(sizeof(KlMethod) * KlSelectorsSize));
	    bcopy(type, KlTypeMHooksGet(type),
		  (size_t) (sizeof(KlMethod) * KlSelectorsSize)); 
	    bzero(KlTypeMCallsGet(type), (size_t) 
		  (sizeof(KlMethod) * KlSelectorsSize));
	}
	if ((KlIsASubr(hook) || KlIsAFSubr(hook))
	    && ((KlSubr) hook)->arity == KlSelectorArity(method_num)) {
	    /* optimisation for subrs: directly use the C func as method, and
	     * set the MCall part to the subr for gets */
	    KlTypeSlotSet(type, method_num, ((KlSubr) hook)->body);
	    KlDecRef(KlTypeSlotGet(KlTypeMCallsGet(type), method_num));
	    KlIncRef(hook);
	    KlTypeSlotSet(KlTypeMCallsGet(type), method_num, hook);
	} else {
	    /* general case: store in MCall */
	    KlTypeSlotSet(type, method_num, KlSelectorHooker(method_num));
	    KlIncRef(hook);
	    KlTypeSlotSet(KlTypeMCallsGet(type), method_num, hook);
	}
    } else {				/* remove hook */
	if (KlTypeMHooksGet(type)) {
	    /* retreive backup copy of method and set MCall to 0 */
	    KlTypeSlotSet(type, method_num,
			  KlTypeSlotGet(KlTypeMHooksGet(type), method_num));
	    KlDecRef(KlTypeSlotGet(KlTypeMCallsGet(type), method_num));
	    KlTypeSlotSet(KlTypeMCallsGet(type), method_num, 0);
	    KlTypeMHooksClean(type);
	}
    }
    return hook;
}

/* klone version
 */

KlO
KlMHooksKl(argc, argv)
    int argc;
    KlO *argv;
{
    KlO hook = 0;

    switch (argc) {
    case 3:
	hook = argv[2];
	/* no break intentional */
    case 2:
	return KlMHooks(argv[0], argv[1], hook);
    default:
	return KlBadNumberOfArguments((char *) argc);
    }
}

/* KlTypeMHooksClean
 * fully frees memory from hooks if no more left
 */

KlTypeMHooksClean(type)
    KlType type;
{
    if (!bcmp(KlTypeMHooksGet(type), type,
	      sizeof(KlMethod) * KlSelectorsSize)) { /* no hooks left, free! */
	Free(KlTypeMHooksGet(type));
	Free(KlTypeMCallsGet(type));
	KlTypeMHooksSet(type, 0);
	KlTypeMCallsSet(type, 0);
    }
}

/* KlMHooksRaw
 * applies the method unhooked but in such a way that if it triggers evaluation
 * of other hooked methods the hook is applied, called from Klone
 * (*:mhook-raw method-number args...)
 */

KlO
KlMHooksRaw(argc, argv)
    int argc;
    KlO *argv;
{
    int method_num;
    KlO result;
    KlType type;

    if (argc < 2)
	return KlBadNumberOfArguments(argc);
    method_num = KlMHookMethodNum(argv[0]);

    KlStackFramePushUnsetHook();
    type = argv[1]->type;
    result = (*(KlSelectorsProps[KlSelectors[method_num].arity].bypass_once))
	(KlUnHookedMethod(type, method_num) ,argc - 1, argv + 1);
    KlStackFramePopHook();
    return result;
}

/* KlMHookSelectorPos "*:mhooks-number"
 * from a name of a selector returns a number (offset)
 * from a number returns name (string) or () if outside range
 *
 * listing of all possible mhook names can be done by:
   (progn (setq i (*:mhook-number "eval"))
   (while (*:mhook-number i) (PF "%0\n" (*:mhook-number i))(incf i)) i)
or a list:
   (with (i (*:mhook-number "eval") l (list))
   (while (*:mhook-number i) (put l -1 (*:mhook-number i))(incf i))l)
 */

KlO
KlMHookSelectorPos(name)
    KlString name;
{
    int i;
    if (KlIsANumber(name)) {
	if (((KlNumber)name)->number >= KlSelEval
	    && ((KlNumber)name)->number < KlSelectorsSize) {
	    return (KlO)
		KlStringMake(KlSelectors[((KlNumber)name)->number].name);
	} else {
	    return NIL;
	}
    } else {
	KlMustBeString(name, 0);
	for (i = KlSelEval; i < KlSelectorsSize; i++) {
	    if (!strcmp(name->string, KlSelectors[i].name)) {
		return (KlO) KlNumberMake(i);
	    }
	}
    }
    return NIL;
}

int
KlMHookMethodNum(name)
    KlNumber name;
{
    int method_num;

    if (!KlIsANumber(name))
	if (KlFalseP(name = (KlNumber) KlMHookSelectorPos(name)))
	    method_num = -1;
    method_num = name->number;
    if (method_num < KlSelEval || method_num >= KlSelectorsSize)
	KlError1(KlE_UNDEFINED_INTERNAL_METHOD, name);
    return method_num;
}

KlO
KlMHookSelectorArity(name)
    KlNumber name;
{
    int method_num = KlMHookMethodNum(name);

    return (KlO) KlNumberMake(KlSelectors[method_num].arity);
}

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

KlFuncInit()
{
    KlDeclareType(&KlFunctionType, "Function", 0);
    KlDeclareIsTrait(KlFunctionType, KlTrait_function);

    KlA_Subr = KlDeclareType(&KlSubrType, "Subr", sizeof(struct _KlSubr));
    KlDeclareTrait(KlSubrType, KlTrait_function);

    KlDeclareMethod1(KlSubrType, KlSelPrint, KlSubrPrint);
    KlDeclareMethod1(KlSubrType, KlSelExecute, KlSubrExecute);
    KlDeclareMethod1(KlSubrType, KlSelApply, KlFSubrExecute);
    KlDeclareMethod1(KlSubrType, KlSelGet, KlSubrGet);
    KlDeclareMethod1(KlSubrType, KlSelPut, KlSubrPut);
    KlDeclareMethod1(KlSubrType, KlSelCopy, KlSubrCopy);
    KlDeclareMethod1(KlSubrType, KlSelEqual, KlSubrEqual);
    KlDeclareMethod1(KlSubrType, KlSelHash, KlSubrHash);

    KlDeclareSubType(&KlFSubrType, "FSubr", KlSubrType,
		     sizeof(struct _KlFSubr));

    KlDeclareMethod1(KlFSubrType, KlSelExecute, KlFSubrExecute);

    KlA_Expr = KlDeclareSubType(&KlExprType, "Expr", KlSubrType,
				sizeof(struct _KlExpr));

    KlDeclareMethod1(KlExprType, KlSelPrint, KlExprPrint);
    KlDeclareMethod1(KlExprType, KlSelEqual, KlExprEqual);
    KlDeclareMethod1(KlExprType, KlSelHash, KlExprHash);
    KlDeclareMethod1(KlExprType, KlSelFree, KlExprFree);
    KlDeclareMethod1(KlExprType, KlSelExecute, KlExprExecute);
    KlDeclareMethod1(KlExprType, KlSelApply, KlFExprExecute);
    KlDeclareMethod1(KlExprType, KlSelGet, KlExprGet);
    KlDeclareMethod1(KlExprType, KlSelPut, KlExprPut);
    KlDeclareMethod1(KlExprType, KlSelCopy, KlExprCopy);

    KlDeclareSubType(&KlFExprType, "FExpr", KlExprType,
		     sizeof(struct _KlFExpr));

    KlDeclareMethod1(KlFExprType, KlSelPrint, KlFExprPrint);
    KlDeclareMethod1(KlFExprType, KlSelExecute, KlFExprExecute);

    KlDeclareSubType(&KlMExprType, "Macro", KlExprType,
		     sizeof(struct _KlMExpr));

    KlDeclareMethod1(KlMExprType, KlSelPrint, KlMExprPrint);
    KlDeclareMethod1(KlMExprType, KlSelExecute, KlMExprExecute);
    KlDeclareMethod1(KlMExprType, KlSelApply, KlMExprExecute);

    /* init stack */

    KlEnvStackInit();

    /* klone functions */

    KlDeclareFSubr(KlDefun, "defun", NARY);
    KlDeclareFSubr(KlDefunq, "defunq", NARY);
    KlDeclareFSubr(KlDefunm, "defmacro", NARY);
    KlDeclareFSubr(KlCatchKl, "catch", NARY);
    KlDeclareFSubr(KlThrowKl, "throw", NARY);
    KlDeclareFSubr(KlUnwindProtectKl, "unwind-protect", NARY);
    KlDeclareFSubr(KlLet, "let", NARY);
    KlDeclareFSubr(KlLetSeq, "let*", NARY);
    KlA_apply = (KlAtom) KlDeclareSubr(KlApplyKl, "apply", 2);
    KlDeclareSubr(KlStackFrameKl, "stack-frame", 1);

    KlDeclareSubr(KlMHookSelectorPos, "*:mhook-number", 1);
    KlDeclareSubr(KlMHooksKl, "*:mhook", NARY);
    KlDeclareSubr(KlMHooksRaw, "*:mhook-apply", NARY);
    KlDeclareSubr(KlMHookSelectorArity, "*:mhook-arity", 1);
    KlA_make_subr = (KlAtom) KlDeclareSubr(KlSubrMakeKl, "*:make-subr", 3);
    KlDeclareSubr(KlDisplaceFunction, "replace-lambda", 2);

    KlActiveMake("*:stackptr", KlStackPtrInHookGet, 0, 0);
    KlActiveMake("*:stacked-errors", KlActivePointerToIntGet, 0,
		 &KlIsInFrameHook);
    KlA_StackMaxSize =
	KlActiveMake("*max-stack-size*",
		     KlActivePointerToIntGet,
		     KlStackMaxSizeSet,
		     &KlStackMaxSize);
		     
    KlActivePointerToIntMake("*:dsp", &KlShowDebuggerStack);

#ifdef DEBUG
    {
	extern KlO PSFKl();
	KlDeclareSubr(PSFKl, "*:psf", 1);
    }
#endif
}