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