/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/***********************************\
*                                   *
*  KlO  Subr, FSubr, Expr and FExpr *
*  DEFINITIONS                      *
*                                   *
\***********************************/
/* WARNING: ALL FUNCTIONAL TYPES MUST BE AT LEAST AS BIG AS KlExpr!!! 
 */

#ifndef INCLUDE_Kl_FUNC_H
#define INCLUDE_Kl_FUNC_H

#define KlMAX_ARITY 5

#ifdef KLPROFILER
#define KlProfilerInfo KlMethod profiling; int profiling_offset; KlO profiling_name;
#else
#define KlProfilerInfo
#endif

typedef struct _KlKeyDecls {
    KlKeyword key;
    KlO init;
} *KlKeyDecls;

typedef struct _KlLambdaList {
    int nfixed;
    int variable_arity;			/* 0 fixed, 1 var, 3 allow-other-key */
    KlO *optionals;			/* null-terminated */
    KlAtom rest;
    KlAtom whole;
    KlKeyDecls key;			/* null-terminated */
    KlO *aux;				/* null-terminated */
} *KlLambdaList;

/* type */

typedef struct _KlSubr {
    KlKLONE_HEADER;
    int arity;
    KlO(*body) ();
    int dummy1;				/* placeholders for Expr size */
    KlO dummy2;
    KlO dummy3;
    KlProfilerInfo			/* only for profiling */
} *KlSubr;

typedef struct _KlFSubr {
    KlKLONE_HEADER;
    int arity;
    KlO(*body) ();
    int dummy1;				/* placeholders for Expr size */
    KlO dummy2;
    KlO dummy3;
    KlProfilerInfo			/* only for profiling */
} *KlFSubr;

typedef struct _KlExpr {
    KlKLONE_HEADER;
    int arity;
    KlAtom *parameters;
    int body_size;
    KlO *body;
    KlLambdaList lambdalist;
    KlProfilerInfo			/* only for profiling */
} *KlExpr;

typedef struct _KlFExpr {
    KlKLONE_HEADER;
    int arity;
    KlAtom *parameters;
    int body_size;
    KlO *body;
    KlLambdaList lambdalist;
    KlProfilerInfo
} *KlFExpr;

typedef struct _KlMExpr {
    KlKLONE_HEADER;
    int arity;
    KlAtom *parameters;
    int body_size;
    KlO *body;
    KlLambdaList lambdalist;
    KlProfilerInfo
} *KlMExpr;

/* macros */

/* exported functions */

EXT KlSubr KlSubrMake();
EXT KlO KlLambda();
EXT KlO KlLambdaq();
EXT KlO KlLambdam();
EXT KlO KlSubrPrint();
EXT KlO KlFSubrPrint();
EXT KlO KlExprPrint();
EXT KlO KlFExprPrint();
EXT KlO KlExprFree();
EXT KlO KlSubrExecute();
EXT KlO KlFSubrExecute();
EXT KlO KlExprExecute();
EXT KlO KlFExprExecute();
EXT KlO KlAddDefun();
extern KlO KlDeclareAnySubr();
extern Int KlStackFrameLookForCatch();
extern KlO KlStackFrameLookForTag();

EXT KlO local_variables();
EXT KlO KlApply();
EXT KlO KlApplyN();
#if __STDC__
EXT KlO KlApplyV(KlO func, int size, ...);
#else
EXT KlO KlApplyV _ANSI_ARGS_(VARARGS);
#endif
EXT KlO KlEvalHookOneShot();
EXT KlO KlEvalHookGetKl();
EXT KlO KlEvalHookSetKl();
EXT KlO KlFixEvalHookMethods();

#define KlApply1(func, a1) KlApplyN((KlO) func, 1, &a1)
#define KlApply2(func, a1, a2) KlApplyV((KlO) func, 2, a1, a2)
#define KlApply3(func, a1, a2, a3) KlApplyV((KlO) func, 3, a1, a2, a3)
#define KlApply4(func, a1, a2, a3, a4) KlApplyV((KlO) func, 4, a1, a2, a3, a4)
#define KlApply5(func, a1, a2, a3, a4, a5) KlApplyV((KlO) func, 5, a1, a2, a3, a4, a5)

/* methods */

EXT KlType KlFunctionType;
EXT KlType KlSubrType;
EXT KlType KlFSubrType;
EXT KlType KlExprType;
EXT KlType KlFExprType;
EXT KlType KlMExprType;

#define KlIsAFunction(obj) KlHasTrait(obj, KlTrait_function)
#define KlMustBeFunction(o, n) KlArgumentMustHaveTrait(o, n, KlTrait_function)
#define KlIsAnExpr(obj) ((obj)->type == KlExprType)
#define KlMustBeExpr(o, n) KlArgumentMustBe(o, n, KlExprType)
#define KlIsAFExpr(obj) ((obj)->type == KlFExprType)
#define KlMustBeFExpr(o, n) KlArgumentMustBe(o, n, KlFExprType)
#define KlIsAMExpr(obj) ((obj)->type == KlMExprType)
#define KlMustBeMExpr(o, n) KlArgumentMustBe(o, n, KlMExprType)
#define KlIsASubr(obj) ((obj)->type == KlSubrType)
#define KlMustBeSubr(o, n) KlArgumentMustBe(o, n, KlSubrType)
#define KlIsAFSubr(obj) ((obj)->type == KlFSubrType)
#define KlMustBeFSubr(o, n) KlArgumentMustBe(o, n, KlFSubrType)
#define KlIsALambda(o) (KlIsAnExpr(o) || KlIsAFExpr(o) || KlIsAMExpr(o))
#define KlIsACFunc(o) (KlIsASubr(o) || KlIsAFSubr(o))

#ifdef KLPROFILER
#define KlExecuteLocalCode(c,e,s,v,f) (CFAPPLY(((f)->profiling), (c,e,s,v,f)))
#else
EXT KlO KlExecuteLocalCode();
#endif

#include <setjmp.h>
/* the file "kl_evalorder.h" is created at compile time */
#include "kl_evalorder.h"
#ifdef POINTERS_BIGGER_THAN_INTEGERS
/* then we cannot give a KlO as argument to longjmp! dammn! */
EXT KlO Kllongjmp_value;
#define Klsetjmp(buf) (setjmp(buf) ? Kllongjmp_value : 0)
#define Kllongjmp(buf, obj) (Kllongjmp_value = (KlO) obj, longjmp(buf, 1))
#else /* !POINTERS_BIGGER_THAN_INTEGERS */
#define Klsetjmp(buf) ((KlO) setjmp(buf))
#define Kllongjmp(buf, obj) longjmp(buf, (int) obj)
#endif /* !POINTERS_BIGGER_THAN_INTEGERS */

 /* KlNonCaughtError handlers */
EXT Int KlNonCaughtErrorVerbose INIT(0);
EXT Int KlNonCaughtErrorFrame INIT(-1);
EXT jmp_buf KlNonCaughtErrorJumpPoint;
extern void KlNonCaughtErrorHandlerDefault();
EXT void (*KlNonCaughtErrorHandler) () INIT(KlNonCaughtErrorHandlerDefault);

#define KlSetNonCaughtErrorPoint(s) \
    (KlNonCaughtErrorVerbose = (s), \
     KlNonCaughtErrorFrame = KlStackPtr, \
     Klsetjmp(KlNonCaughtErrorJumpPoint))

#define KlUnsetNonCaughtErrorPoint() KlNonCaughtErrorFrame = -1

#ifndef DEBUG2				/* stack coherence checks */
#define KlDebugStackDecls
#define KlDebugStackPush(t,d)
#define KlDebugStackPop()
#else					/* DEBUG2 */
#define KlDebugStackDecls int klds_t,klds_p; KlO klds_d
#define KlDebugStackPush(t,d) klds_t=t,klds_p=KlStackPtr,klds_d=(KlO)d
#define KlDebugStackPop() \
    ASSERT(KlStackPtr == klds_p && \
	   KlStack[KlStackPtr] == (KlO) klds_t && \
	   KlStack[KlStackPtr-1] == (KlO) klds_d)
#endif					/* DEBUG2 */

/*****************************************************************************\
* 			     Environnement Stack                              *
\*****************************************************************************/

/* catch & throw
 */

typedef struct _JumpingPoint {
    KlO tag;				/* catch name != 0 */
    jmp_buf jump_buffer;
}            *JumpingPoint;

typedef struct _UnwindPoint {
    KlO tag;				/* catch name != 0 */
        KlO(*func) ();			/* function of 2 args */
    KlO arg1;
    KlO arg2;
}           *UnwindPoint;

EXT KlO KlLastCaughtTag INIT(0);
EXT int KlIsCleaningStack INIT(0);

#ifndef KL_MAX_STACK_SIZE_INIT
#ifdef DEBUG				/* MUST be 2^n - 1 */
#define KL_MAX_STACK_SIZE_INIT 8191
#else /* DEBUG */
#define KL_MAX_STACK_SIZE_INIT 32767
#endif /* DEBUG */
#endif /* !KL_MAX_STACK_SIZE_INIT */

EXT int KlStackMaxSize			/* max value in words (recovered) */
INIT(KL_MAX_STACK_SIZE_INIT);

EXT int KlStackMaxFatalSize		/* over this one ==> fatal */
INIT(2*KL_MAX_STACK_SIZE_INIT - 1);

/* A stack frame is: (in words from top)
 * - the type: KlSFID
 * - normal, subr: the (printable) expression which triggered the call (list)
 *   catch: a pointer to a struct containing info on the catch (marker)
 *   hook: an int: 1 if we were already in evalhook code, 0 otherwise
 * - RefInc: for all stacks, a KlO which is pointed to (KlIncRef) by the stack
 *           for preventing it being freed, and KlDecRef-ed on frame exit
 *           The KlO being the object activating the frame (func, ExO)
 *       or: a ptr to a KlStackSpace structure, allocated on the C stack
 * - normal, offset of previous stack
 * - normal: then <size> pairs of (variable, old_value)
 *           stacked in ascending order.
 */

					/* KlSFID: ID of stack frames */
#define KlSFID_normal 1
#define KlSFID_subr 2
#define KlSFID_catch 4
#define KlSFID_hook 8
					/* KlSFIM: mask of props on IDs */
#define KlSFIM_call 3		/* is there a call list in stack? */
#define KlSFIM_listable 19	/* showable in dumps */

					/* KlSFHS: size of stack frames */
#define KlSFS_normal 4
#define KlSFS_special 3
					/* KlSFO: various offsets in frames */
#define KlSFO_call 1
#define KlSFO_ref 2
#define KlSFO_previous 3
#define KlSFO_catch 1
#define KlSFO_framehook 1
#define KlSFO_data 1			/* data means all these */

/* first frame and pointer to the last/current one */

EXT KlO *KlStack;
EXT Int KlStackLimit;
EXT Int KlStackPtr INIT(0);
EXT int KlIsInFrameHook INIT(0);	/* are we in debugger/error code? */
EXT int KlStackPtrInHook INIT(0);	/* last value before entering debug */

#define KlStackFramePushUnsetHook() \
    KlStackFramePushSpecial(KlSFID_hook, KlIsInFrameHook); \
    KlIsInFrameHook = 0
    

/* KlStackAdjust: once KlEnvStackSize is set, adjust limits and
 * allocates space (+1 for security)
 */
#define KlStackAdjust(newptr) if ((newptr) >= KlStackLimit) KlEnvStackGrow()

#ifdef DEBUG2
#define KlStackFramePopSpecial()    KlStackFramePop()
#else /* !DEBUG2 */
#define KlStackFramePopSpecial() \
    KlDecRefNonNull(KlStack[KlStackPtr - KlSFO_ref]); \
    KlStackPtr -= KlSFS_special

#define KlStackFramePopSpecialOrSpace() \
    if (KlStack[KlStackPtr - KlSFO_ref]->type) {\
        KlDecRefNonNull(KlStack[KlStackPtr - KlSFO_ref]); \
    } else { \
        KlStackSpaceFree(KlStack[KlStackPtr - KlSFO_ref]); \
    } \
    KlStackPtr -= KlSFS_special
#endif /* !DEBUG2 */

#define KlStackFramePushSpecial(type, call) \
	KlStackFramePushSpecialHold(type, call, NIL)

#define KlStackFramePrevious(ptr) \
    (((Int) (KlStack[ptr]) & KlSFID_normal) \
     ? (Int) (KlStack[(ptr) - KlSFO_previous]) \
     : (Int) (ptr) - KlSFS_special)

typedef struct _KlStackSpace {
    KlO type;				/* 0 */
    KlO obj;				/* IncRefed object */
    KlO list[1];			/* stacked elements, null terminated */
} *KlStackSpace;

#define KlStackSpaceSizeof(n)  ((n)+3)  /* adds space for null terminator */

typedef struct _KlStackSpace2 {KlO type; KlO obj; KlO list[3];} *KlStackSpace2;
typedef struct _KlStackSpace3 {KlO type; KlO obj; KlO list[4];} *KlStackSpace3;
typedef struct _KlStackSpace4 {KlO type; KlO obj; KlO list[5];} *KlStackSpace4;
typedef struct _KlStackSpace5 {KlO type; KlO obj; KlO list[6];} *KlStackSpace5;

/*****************************************************************************\
* 		     catch, throw, unwind-protect macros                      *
\*****************************************************************************/

/* you must provide two local variables:
 * KlO result will be the result of the call
 * int normal will be 1 if caught expression returned normally
 */
#define KlCatch(tagname, expression, result, normal) \
{struct _JumpingPoint catch_jp; \
    KlDebugStackDecls;\
    KlStackFramePushSpecial(KlSFID_catch, &catch_jp); \
    KlDebugStackPush(KlSFID_catch, &catch_jp);\
 \
    catch_jp.tag = (KlO) tagname; \
 \
    if (result = (KlO) Klsetjmp(catch_jp.jump_buffer)) { \
	normal = 0;			/* coming from a throw */ \
    } else { \
	KlDoJmpbufAddCheck(catch_jp.jump_buffer); \
	result = (KlO) expression; \
	normal = 1; \
    } \
    KlDebugStackPop(); KlStackFramePopSpecial(); \
}

/* returns expression in result
 * you will know no errors occured since code after this call won't be `
 * executed in case of a throw
 */

#define KlUnwindProtect(expression, result, guardfunc, guardarg1, guardarg2) \
{struct _UnwindPoint jp; KlDebugStackDecls;\
 \
    KlStackFramePushSpecial(KlSFID_catch, &jp); \
    KlDebugStackPush(KlSFID_catch, &jp); \
    jp.tag = 0; \
    jp.func = (KlMethod) guardfunc; \
    jp.arg1 = (KlO) (guardarg1); \
    jp.arg2 = (KlO) (guardarg2); \
 \
    result = (KlO) expression; \
    KlDebugStackPop();KlStackFramePopSpecial(); \
    CFAPPLY(guardfunc, (guardarg1, guardarg2)); /* always execute guard */ \
}
	
/* same for statements (no return value expected)
*/

#define KlUnwindProtectStatement(expression, guardfunc, guardarg1, guardarg2) \
{struct _UnwindPoint jp; KlDebugStackDecls;\
 \
    KlStackFramePushSpecial(KlSFID_catch, &jp); \
    KlDebugStackPush(KlSFID_catch, &jp); \
    jp.tag = 0; \
    jp.func = (KlMethod) guardfunc; \
    jp.arg1 = (KlO) (guardarg1); \
    jp.arg2 = (KlO) (guardarg2); \
 \
    expression; \
    KlDebugStackPop();KlStackFramePopSpecial(); \
    CFAPPLY(guardfunc, (guardarg1, guardarg2)); /* always execute guard */ \
}

/* same for statements (no return value expected), but splitted in two
*/

#define KlUnwindProtectStatementBefore(guardfunc, guardarg1, guardarg2) \
{struct _UnwindPoint jp; KlDebugStackDecls;\
 \
    KlStackFramePushSpecial(KlSFID_catch, &jp); \
    KlDebugStackPush(KlSFID_catch, &jp); \
    jp.tag = 0; \
    jp.func = (KlMethod) guardfunc; \
    jp.arg1 = (KlO) (guardarg1); \
    jp.arg2 = (KlO) (guardarg2)

#define KlUnwindProtectStatementAfter(guardfunc, guardarg1, guardarg2) \
    KlDebugStackPop();KlStackFramePopSpecial(); \
    CFAPPLY(guardfunc, (guardarg1, guardarg2)); /* always execute guard */ \
}
	
/* never returns */

#define KlThrow(tagname, expression) \
    KlThrowAux1(tagname, expression); \
    KlStackFramePopTo(KlThrowAux_frame); \
    KlThrowAux2(tagname, expression)

/* KlO dummyKlO; int dummyint; must be defined in enclosing block */
#define KlThrowFromError(tagname, expression) \
    KlThrowAux1(tagname, expression); \
    KlIsCleaningStack = 1;\
    KlStackFramePopTo(KlThrowAux_frame); \
    KlIsCleaningStack = 0;\
    KlThrowAux2(tagname, expression)

/* WARNING: if you change this, update KlThrowKl in kl_func.c for DEBUG2 */
#define KlThrowAux1(tagname, expression) \
{ \
    KlO     KlThrowAux_result; \
    Int KlThrowAux_frame = KlStackFrameLookForCatch(tagname); \
 \
    if (!KlThrowAux_frame) { \
	if (KlA_ERROR == (KlAtom) tagname) { \
            if (KlNonCaughtErrorHandler) \
                CFAPPLY(KlNonCaughtErrorHandler, ()); \
	    CFAPPLY(KlFatalError, (1, 0)); \
	} \
	KlError(KlE_NO_CATCH, tagname); \
    } \
    KlThrowAux_result = (KlO) expression

#define KlThrowAux2(tagname, expression) \
    KlDoJmpbufCheck(((JumpingPoint)(KlStack[KlStackPtr - KlSFO_catch])) \
	      ->jump_buffer); \
    KlLastCaughtTag = (KlO) tagname; \
    Kllongjmp(((JumpingPoint)(KlStack[KlStackPtr - KlSFO_catch])) \
	      ->jump_buffer, KlThrowAux_result); \
}

#ifdef DEBUG2
#define KlDoJmpbufCheck(t) KlJmpbufCheck(t)
#define KlDoJmpbufAddCheck(t) KlJmpbufAddCheck(t)
#else
#define KlDoJmpbufCheck(t)
#define KlDoJmpbufAddCheck(t)
#endif
					/* obsolete function */

#define KlStackFramePopForFunctionCalls KlStackFramePop

#endif /* INCLUDE_Kl_FUNC_H */