/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/*****************************************************************************\
* *
* main .h for klone *
* *
\*****************************************************************************/
/*****************************************************************************\
* setting up global modes *
\*****************************************************************************/
#ifndef INCLUDE_KLONE_H
#define INCLUDE_KLONE_H
#include <stdio.h>
#ifdef SYSV
#include <stdlib.h>
#endif /* SYSV */
#ifndef EXT /* EXTERN.h */
#ifdef EXT
#undef EXT
#endif
#define EXT extern
#ifdef INIT
#undef INIT
#endif
#define INIT(x)
#ifdef DO_INIT
#undef DO_INIT
#endif
#endif /* EXT */
#include "klconfig.h"
#include "klmachine.h"
#ifdef DEBUG2
#define DEBUGREF
# ifndef DEBUG
# define DEBUG
# endif
#endif
#ifdef DEBUG
# ifndef USE_STANDARD_MALLOC
# ifndef MALLOCDEBUG
# ifndef MALLOCDEBUG0
# define MALLOCDEBUG0
# endif
# endif
# endif
#endif
/*****************************************************************************\
* option compatibility check *
\*****************************************************************************/
#ifdef USE_STANDARD_MALLOC
#ifdef MALLOCDEBUG
error=USE_STANDARD_MALLOC_and_MALLOCDEBUG_are_incompatible_options;
#endif
#ifdef MALLOCDEBUG0
error=USE_STANDARD_MALLOC_and_MALLOCDEBUG0_are_incompatible_options;
#endif
#ifdef MLEAK
error=USE_STANDARD_MALLOC_and_MLEAK_are_incompatible_options;
#endif
#ifdef DO_NOT_REDEFINE_MALLOC
error=USE_STANDARD_MALLOC_and_DO_NOT_REDEFINE_MALLOC_are_incompatible_options;
#endif
#endif /* USE_STANDARD_MALLOC */
#ifdef SYSV
#define NO_MALLOC_DECLARE /* since already done in stdlib.h */
#endif
#ifndef va_start
# if __STDC__
# include <stdarg.h>
# else
# include <varargs.h>
# endif
#endif
/*****************************************************************************\
* ANSI C K&R compatibilty layer *
\*****************************************************************************/
#undef _ANSI_ARGS_
#undef CONST
#if defined(__STDC__) || defined(__cplusplus)
# define _USING_PROTOTYPES_ 1
# define _ANSI_ARGS_(x) x
# define CONST const
# ifdef __cplusplus
# define VARARGS (...)
# else
# define VARARGS ()
# endif
#else /* K&R C */
# define _ANSI_ARGS_(x) ()
# define CONST
#endif /* K&R C */
#ifdef __cplusplus
# define EXTERN extern "C"
#else
# define EXTERN extern
#endif
/*****************************************************************************\
* misc parameters *
\*****************************************************************************/
/*
* Maximum size for:
* length of name of CACHED objets (fonts, etc...)
* output lines of KlPrintf (not KlPuts)
* file names (path look-up)
* X properties (only "machine name" for now)
*
* Should alway be >= 256, 1024 is fine.
* Used only for speed concerns to allocate temp strings in the stack
*/
#define KlMAX_TEMP_STRING_SIZE 1024 /* pathname expansion */
EXT int KLMAX_KEYWORDS INIT(31); /* max number of keywords for a Subr
should be 2^n - 1 */
/* generic numerical type */
#ifdef PTR_TYPE
typedef PTR_TYPE Int;
typedef unsigned PTR_TYPE UInt;
#else /* PTR_TYPE */
typedef long Int;
typedef unsigned long UInt;
#endif
#ifdef CARD32
typedef CARD32 Card32;
#else /* CARD32 */
typedef unsigned int Card32;
#endif /* CARD32 */
#ifdef INT32
typedef INT32 Int32;
#else /* CARD32 */
typedef int Int32;
#endif /* CARD32 */
/* END OF INSTALLATION PARAMETERS */
/*****************************************************************************\
* main loop *
\*****************************************************************************/
/* path */
EXT char *KlPath INIT(0); /* default current directory "." */
EXT char *KlUserProfileName INIT(0); /* default: none loaded */
EXT char *KlTextExtension INIT(0); /* default: none "" */
/* shell variables */
/* application_name */
EXT char *KlApplicationName INIT(0); /* default: "" */
EXT char *KlMachineName; /* default: unix */
/* klone_pool */
EXT char *KlPoolBuffer INIT(NULL);
EXT int KlPoolBufferSize INIT(252);
/* yacc+lex */
extern int Klyylinenoget();
/*****************************************************************************\
* misc useful macros *
\*****************************************************************************/
/* first include standards file if missing */
#ifndef NULL
#define NULL 0
#endif /* NULL */
#ifndef Max
#define Max(x,y) (((x)<(y))?(y):(x))
#define Min(x,y) (((x)<(y))?(x):(y))
#define KlAbs(x) (((x)>0)?(x):-(x))
#define FlagOn(mask,flag) ((mask)&(flag))
#endif
/*****************************************************************************\
* types *
\*****************************************************************************/
/* the KlO type:
* Each object handled by KLONE is a pointer to a structure including at least:
* - a pointer to a list of methods, common to all objects of this type.
* - a reference count, integer telling how many objects points to this
* one. The object should be freed as soon as this counter goes down to
* zero. (first bit is to see if it is not in the KlZrt, rest is for count)
* hack: first slots in the list of methods are reserved for some type info
* such as name of type, inheritance, etc... this hack is for efficiency...
*/
#ifndef DEBUG
#define KlKLONE_HEADER \
struct _KlO *(**type)(); \
unsigned int reference_count
#else /* DEBUG */
#define KlKLONE_HEADER \
struct _KlO *(**type)(); \
int reference_count
#endif /* DEBUG */
#define KlKLONE_HEADER_PLIST \
KlKLONE_HEADER; \
KlO plist
typedef struct _KlO {
KlKLONE_HEADER;
} *KlO;
#define KLSO sizeof(KlO)
typedef KlO(*KlMethod) ();
typedef void (*KlVoidFunc)();
typedef KlMethod *KlType;
#define KlOZero(o, s) bzero(((char *) (o)) + KLSO, (s) - KLSO)
/************************************************************* the type type */
EXT KlType KlAnyType;
EXT KlType KlTypeType;
#define KlIsAType(o) (((KlO) o)->type == KlTypeType)
#define KlMustBeType(o, n) KlArgumentMustBe(((KlO) o), n, KlTypeType)
#define KlDeclareMethod1(type, selector, method) type[selector] = method
#define KlDeclareMethodUndefined(type, selector) \
KlDeclareMethod(type, selector, KlSelectorUndefmethod(selector))
#define KlUndefinedMethod(selector) KlSelectorUndefmethod(selector)
#define KlIsUndefinedMethod(obj, selector) \
((obj)->type[selector] == KlSelectorUndefmethod(selector))
#define KlClassMethod(type, selector) type[selector]
/* definition of first "methods": first fields in a klone type are:
* type KlTypeType
* refcount integer
* name klone atom
* next linked list pointer to next type. KlTypes = llist of all types
* traits class of types to which this type belongs
* trait is this type defining a trait, and which one?
* father allows to have a simple hierarchy
* ID (0..N) ordering number of the type for tables such as coerce
* TypeMethods used to store Klone methods dispatched by generic functions
* mhooks 0 or pointer to a backup of the whole type itself, allowing
* the system to replace a method by a hook-caller
* mcalls 0 or pointer to an array of Klone functions to be applied
* by the hook caller
* plist offset of plist slot in object, if present (0 otherwise)
* --- to add?
* bucket optimization: bucket number to malloc with
*/
#define KlTypeSlotGet(type, n) ((int) type[n])
#define KlTypeSlotSet(type, n, val) type[n] = ((KlMethod) (val))
#define KlTypeTypeGet(type) ((KlType) type[0]) /* type */
#define KlTypeTypeSet(type,name) type[0] = (KlMethod)(name)
#define KlTypeRefGet(type) ((UInt) type[1]) /* refcount */
#define KlTypeRefSet(type,name) type[1] = (KlMethod)(name)
#define KlTypeNameGet(type) ((KlAtom) type[2]) /* name as an KlAtom */
#define KlTypeNameSet(type,name) type[2] = (KlMethod)(name)
#define KlTypeNextGet(type) ((KlType) type[3]) /* linked list of types */
#define KlTypeNextSet(type,name) type[3] = (KlMethod)(name)
#define KlTypeTraitsGet(type) ((Card32) type[4]) /* traits */
#define KlTypeTraitsReset(type) type[4] = 0
#define KlTypeTraitsSet(type, v) type[4] = (KlMethod)(v)
#define KlTypeTraitGet(type) ((Card32) type[5]) /* trait this type defines */
#define KlTypeTraitReset(type) type[5] = 0
#define KlTypeTraitSet(type, v) type[5] = (KlMethod)(v)
#define KlTypeFatherGet(type) ((KlType) type[6]) /* supertype */
#define KlTypeFatherSet(type, f) type[6] = (KlMethod)(f)
#define KlTypeNumGet(type) ((int) type[7]) /* type number, for coerces */
#define KlTypeNumSet(type, ht) type[7] = (KlMethod)(ht)
#define KlTypeMHooksGet(type) ((KlType) ((type)[8])) /* for *:mhook */
#define KlTypeMHooksSet(type, h) (type)[8] = (KlMethod)(h)
#define KlTypeMCallsGet(type) ((KlType) ((type)[9])) /* for *:mhook */
#define KlTypeMCallsSet(type, h) (type)[9] = (KlMethod)(h)
#define KlTypeSizeGet(type) ((KlType) ((type)[10])) /* for KlOMake */
#define KlTypeSizeSet(type, h) (type)[10] = (KlMethod)(h)
#define KlTypePlistGet(type) ((KlType) ((type)[11])) /* for object-plist */
#define KlTypePlistSet(type, l) (type)[11] = (KlMethod)(l) /* for object-plist */
#define KlTypeNumOpGet(type) ((UInt) ((type)[12])) /* for arithmetics */
#define KlTypeNumOpSet(type, n) (type)[12] = (KlMethod)(n)
/* number of non-method slots. Must be last slot index + 2 */
#define KlTypeStaticReservedSlots 14
EXT int KlSelEval INIT(KlTypeStaticReservedSlots-1); /* must be here */
EXT int KlTypeReservedSlots INIT(KlTypeStaticReservedSlots);
#define KlTypeCName(type) ((KlAtom) (type)[2])->p_name /* name as an KlAtom */
EXT KlType KlTypes INIT(0);
EXT int KlTypeNumCurrent INIT(0);
EXT KlMethod **KlCoerceTable;
EXT int *KlCoerceTableSizes;
/* some backcompats */
#define KlTypeRef(type) KlTypeRefGet(type)
#define KlTypeName(type) KlTypeNameGet(type)
#define KlTypeNext(type) KlTypeNextGet(type)
#define KlTypeTraits(type) KlTypeTraitsGet(type)
#define KlTypeTrait(type) KlTypeTraitGet(type)
#define KlDeclareType(typep, name, size) \
KlDeclareSubType(typep, name, 0, size)
#define KlDeclarePseudoType(typep, name) KlDeclareType(typep, name, 0)
#define KlDeclarePlistSlot(type, Ctype, field) \
KlTypePlistSet(type, KlOffset(Ctype, field))
KlO KlOMake();
KlO KlOMakeZero();
KlO KlOMakeOfSize();
KlO KlOMakeOfSizeZero();
/***************************************************************** SELECTORS */
/* Properties of each individual selector */
EXT struct _KlSelector {
char *name; /* external printable name */
int arity; /* actual arity, 0 = NARY */
} *KlSelectors INIT(0);
EXT int KlSelectorsSize INIT(KlTypeStaticReservedSlots);
/* Properties per selector arity 0=NARY */
EXT struct _KlSelectorProps {
KlMethod undefmethod; /* default method */
KlMethod hooker; /* calls the Klone hook */
KlMethod bypass_once; /* used to bypass the hooker once */
} *KlSelectorsProps INIT(0);
EXT int KlSelectorsPropsSize;
#define KlSelectorArity(sel) KlSelectors[sel].arity
#define KlSelectorName(sel) KlSelectors[sel].name
#define KlSelectorUndefmethod(sel) \
KlSelectorsProps[KlSelectors[sel].arity].undefmethod
#define KlSelectorHooker(sel) \
KlSelectorsProps[KlSelectors[sel].arity].hooker
#define KlCurrentHookerCall(obj) \
((KlO) KlTypeSlotGet(KlTypeMCallsGet((obj)->type), KlCurrentMessage))
#define KlCurrentHookerBackup(obj) \
((KlMethod) KlTypeSlotGet(KlTypeMHooksGet((obj)->type), KlCurrentMessage))
#define KlUnHookedMethod(type, sel) \
((KlMethod) (KlTypeMHooksGet(type) \
? KlTypeSlotGet(KlTypeMHooksGet(type), sel) \
: KlTypeSlotGet(type, sel)))
/* predefined selectors. KlSelEval is defined before */
/* NOTE: if you add a built-in selector foo, you must
- add a symbol KlSelFoo here
- add a macro KlSend_foo underneath
- in klone.c: in KlInitPredefinedSelectors, add definition
*/
EXT int KlSelPrint;
EXT int KlSelFree;
EXT int KlSelExecute;
EXT int KlSelApply;
EXT int KlSelEqual;
EXT int KlSelCopy;
EXT int KlSelSetq;
EXT int KlSelMake;
EXT int KlSelAdd;
EXT int KlSelGet;
EXT int KlSelPut;
EXT int KlSelDelete;
EXT int KlSelInsert;
EXT int KlSelNth;
EXT int KlSelLength;
EXT int KlSelHash;
EXT int KlSelDolist;
EXT int KlSelDohash;
EXT int KlSelCompare;
/*****************************************************************************\
* SENDS *
\*****************************************************************************/
/* the send define:
* called by KlSend(KLONE_MethodName,
* object,
* (object, parm1, parm2, ... )); NEED parenthesises !!!
*/
/* WARNING: DO NOT CALL A SEND INTO ANOTHER SEND!!!
* use temporary variable to hold the result
* See KlSend_setq_protect convenient macro for exemple
*/
#ifndef DEBUG
# ifndef TRY
# define KlSend(message,object,parms) \
(*(((object)->type)[KlCurrentMessage = message]))parms
# define KlSendNary(message,argc,argv) \
CFAPPLY((((argv[0])->type)[KlCurrentMessage = message]), (argc, argv))
# define KlSendType(message,t,parms) \
(*((t)[KlCurrentMessage = message]))parms
# endif /* !TRY */
#else /* DEBUG */
# define KlSend(message,object,parms) \
(KlCurSend++,KlSendIsValid(message,object), KlCurrentMessage = message, \
(KlO) (*(((object)->type)[message]))parms)
# define KlSendType(message,t,parms) \
(KlCurSend++,KlCurrentMessage = message, (*((t)[message]))parms)
# define KlSendNary(message,argc,argv) \
(KlCurSend++,KlSendIsValid(message,argv[0]), KlCurrentMessage = message, \
(KlO) CFAPPLY((((argv[0])->type)[message]), (argc, argv)))
#endif /* DEBUG */
/********************************************** some predefined method sends */
#define KlSend_eval(o) KlSend(KlSelEval, o, (o))
#ifdef DEBUG
#define KlSend_print(o, s) ((KlIsInError && !KlObjectIsValid(o)) ? \
(KlO) KlPrintf("{NONKLO: 0x%x}", o) \
: KlSend(KlSelPrint, o, (o, s)))
#else /* !DEBUG */
#define KlSend_print(o, s) KlSend(KlSelPrint, o, (o, s))
#endif /* !DEBUG */
#ifdef DEBUG2
extern void KlSend_free();
#else /* ! DEBUG2 */
#define KlSend_free(o) KlSend(KlSelFree, o, (o))
#endif /* ! DEBUG2 */
#define KlSend_execute(o, l) KlSend(KlSelExecute, o, (o, l))
#define KlSend_apply(o, l) KlSend(KlSelApply, o, (o, l))
#define KlSend_equal(o, p) KlSend(KlSelEqual, o, (o, p))
#define KlSend_copy(o) KlSend(KlSelCopy, o, (o))
#define KlSend_setq(o, v) KlSend(KlSelSetq, o, (o, (v)))
#define KlSend_make(o) KlSend(KlSelMake, o, (o))
#define KlSend_add(o, argc, argv) KlSend(KlSelAdd, o, (o, argc, argv))
#define KlSend_get(o, key, def) KlSend(KlSelGet, o, (o, key, def))
#define KlSend_put(o, key, val) KlSend(KlSelPut, o, (o, key, val))
#define KlSend_delete(o, key) KlSend(KlSelDelete, o, (o, key))
#define KlSend_insert(o, key, val) KlSend(KlSelInsert, o, (o, key, val))
#define KlSend_nth(o, i, val) KlSend(KlSelNth, o, (o, i, val))
#define KlSend_length(o) KlSend(KlSelLength, o, (o))
#define KlSend_hash(o) (KlIsAnAtom(o) ? o :KlSend(KlSelHash, o, (o)))
#define KlSend_dolist(o, v, ac, av) KlSend(KlSelDolist, o, (o, (v), ac, av))
#define KlSend_dohash(o, v, val, ac, av) \
KlSend(KlSelDohash, o, (o, (v), (val), ac, av))
#define KlSend_compare(o, v) ((int) KlSend(KlSelCompare, o, (o, (v))))
#define KlCompare(o1, o2) KlSend_compare(o1, o2)
/* to preserve KlCurrentMessage */
#define KlSend_setq_protectDECL KlO KlSend_setq_protectVAL
#define KlSend_setq_protect(o, v) \
(KlSend_setq_protectVAL = v, \
KlSend(KlSelSetq, o, (o, KlSend_setq_protectVAL)))
/* traits. Do not forget to update the KlDeclareBuiltInTraits func in klone.c*/
EXT char **KlTraitNames;
#define KlTrait_string (1 << 0)
#define KlTrait_symbol (1 << 1)
#define KlTrait_function (1 << 2)
#define KlTrait_number (1 << 3)
#define KlTrait_exo (1 << 4)
#define KlTrait_table (1 << 5)
#define KlTrait_hasheq (1 << 6)
#define KlTrait_list (1 << 7)
#define KlTrait_pseudotype (1 << 8)
#define KlTrait_unreallocable (1 << 9)
EXT int KlLastTrait INIT(10); /* number of traits */
/****************************************************** type-checking macros */
#define KlHasTrait(obj, trait) (KlTypeTraits((obj)->type) & (trait))
#define KlArgumentMustHaveTrait(obj, pos, trait) \
if(!KlHasTrait(obj, trait)) KlBadArgument(obj, pos, KlTraitName(trait))
#ifdef SIMPLE_LHS
#define KlDeclareTrait(type,trait) \
type[4] = (KlMethod) (((Card32) type[4]) | trait)
#define KlDeclareIsTrait(type,trait) \
type[5] = (KlMethod) (((Card32) type[5]) | trait); \
KlDeclareTrait(type,trait)
#else
#define KlDeclareTrait(type,trait) (type[4] = (Card32) type[4] | trait)
#define KlDeclareIsTrait(type,trait) (type[5] = (Card32) type[5] | trait); \
KlDeclareTrait(type,trait)
#endif
#define KlIsOfType(o, t) \
(KlTypeTrait(t) ? KlHasTrait(o, KlTypeTrait(t)) : \
((o)->type == t ? 1 : KlTypeIsSonOf((o)->type, t)))
#define KlArgumentValue(o, n, t) \
((KlTypeTrait(t) ? KlHasTrait(o, KlTypeTrait(t)) : (o)->type == t) \
? o : KlBadArgument(o, n, KlTypeCName(t)), o)
#define KlArgumentMustBe(obj, pos, t) \
(((obj)->type != (t))? KlBadArgument((obj), (pos), KlTypeCName(t)): 0)
#define KlArgumentMustBeOrNil(obj, pos, t) \
(((obj)->type != (t) && KlTrueP(obj))?\
KlBadArgument((obj), (pos), KlTypeCName(t)): 0)
#define KlMustBeOrEval(variable, value, kltype, predicate, error) \
variable = (kltype) value;\
if(!predicate) { \
variable = (kltype) KlSend_eval(variable); \
if (!predicate) { \
error;}}
EXT KlO KlEvalOrNullObj;
#define KlEvalOrNull(o) \
((KlEvalOrNullObj=(o)) ? KlSend_eval(KlEvalOrNullObj) : 0)
EXT KlO KlConvertArgTo_obj;
#define KlConvertArgTo(o, n, t) (KlIsOfType(o, t) ? ((KlO) (o)) : \
((KlConvertArgTo_obj = KlCoerceOrNil(o, t)) ? \
KlConvertArgTo_obj : KlBadArgument(o, n, KlTypeCName(t))))
#define KlBadNumberOfArguments(i) \
KlError1i(KlE_BAD_NUMBER_OF_ARGS, (i))
#define KlNumberOfArgumentsCheck(e, i) \
if (e) {return KlError1i(KlE_BAD_NUMBER_OF_ARGS, (i));}
/* the undefined methods (aborts!), one per arity */
extern KlO KlUndefinedMethodNary();
extern KlO KlUndefinedMethod1();
extern KlO KlUndefinedMethod2();
extern KlO KlUndefinedMethod3();
extern KlO KlUndefinedMethod4();
extern KlO KlUndefinedMethod5();
/* Hookers, one per arity */
extern KlO KlSelectorHookerNary();
extern KlO KlSelectorHooker1();
extern KlO KlSelectorHooker2();
extern KlO KlSelectorHooker3();
extern KlO KlSelectorHooker4();
extern KlO KlSelectorHooker5();
/* Hooker bypassers, one per arity */
extern KlO KlSelectorBypassOnceNary();
extern KlO KlSelectorBypassOnce1();
extern KlO KlSelectorBypassOnce2();
extern KlO KlSelectorBypassOnce3();
extern KlO KlSelectorBypassOnce4();
extern KlO KlSelectorBypassOnce5();
/*****************************************************************************\
* errors *
\*****************************************************************************/
#define KlError0(err) _KlError(1, &(err))
#define KlError(err, obj) KlError1((err), (obj))
extern KlO _KlError();
#if __STDC__
extern KlO KlErrorV(KlO error, int size, ...);
#define KlError1(error, arg1) KlErrorV((KlO) error, 1, arg1)
#define KlError2(error, arg1, arg2) KlErrorV((KlO) error, 2, arg1, arg2)
#define KlError3(error, arg1, arg2, arg3) \
KlErrorV((KlO) error, 3, arg1, arg2, arg3)
#define KlError1i(error, number) KlErrorV((KlO) error, 1, KlNumberMake(number))
#define KlError1s(error, string) KlErrorV((KlO) error, 1, KlStringMake(string))
#define KlError2s(error, o, string) \
KlErrorV((KlO) error, 2, o, KlStringMake(string))
#else /* !__STDC__ */
extern KlO KlErrorV _ANSI_ARGS_(VARARGS);
#define KlError1(error, arg1) KlErrorV(error, 1, arg1)
#define KlError2(error, arg1, arg2) KlErrorV(error, 2, arg1, arg2)
#define KlError3(error, arg1, arg2, arg3) KlErrorV(error, 3, arg1, arg2, arg3)
#define KlError1i(error, number) KlErrorV(error, 1, KlNumberMake(number))
#define KlError1s(error, string) KlErrorV(error, 1, KlStringMake(string))
#define KlError2s(error, o, string) KlErrorV(error, 2, o, KlStringMake(string))
#endif /* !__STDC__ */
EXT int (*KlMallocError)();
EXT KlO KlErrorNumberOutOfRange();
EXT KlMethod KlErrorBadArgumentText;
extern char **KlFatalErrorMessages;
EXT int (*KlFatalError)();
extern int KlFatalErrorDefaultHandler();
#ifdef DEBUG_CFAPPLY
#define CFAPPLY(f, args) (f ? ((*(f)) args) : (CFAPPLY_ERROR(), (*(f)) args))
#else /* !DEBUG_CFAPPLY */
#define CFAPPLY(f, args) ((*(f)) args)
#endif /* !DEBUG_CFAPPLY */
#ifdef DEBUG
#if __STDC__
#define ANSI_STRING_MACRO_EXPANSION
#endif /* __STDC__ */
# ifdef ANSI_STRING_MACRO_EXPANSION
# define ASSERT(p) \
if (!(p)) {fprintf(stderr, "\nAssertion failed: %s\n", #p); \
stop_if_in_dbx("ASSERT FAILED");}
# define KlSTROF(p) #p
# else /* ANSI_STRING_MACRO_EXPANSION */
# define ASSERT(p) \
if (!(p)) {fprintf(stderr, "\nAssertion failed: %s\n", "p"); \
stop_if_in_dbx("ASSERT FAILED");}
# define KlSTROF(p) "p"
# endif /* ANSI_STRING_MACRO_EXPANSION */
#else /* !DEBUG */
# define ASSERT(p)
#endif /* !DEBUG */
/*****************************************************************************\
* memory and allocations *
\*****************************************************************************/
/* for alignement problems, gives next valid pointer */
#define KlAlignPtr(ptr) ((((ptr) >> 2) + 1) << 2)
#ifdef REAL_PADDING
#define Kl_REAL_PADDING Int padding;
#else
#define Kl_REAL_PADDING
#endif
#ifndef DO_NOT_REDEFINE_MALLOC
#define Malloc(bytes) malloc(bytes)
#define Free(bytes) free(bytes)
#define Realloc(ptr, bytes) realloc(ptr, bytes)
#define Calloc(ptr, bytes) calloc(ptr, bytes)
#define KlMalloc(bytes) malloc(bytes)
#define KlFree(bytes) free(bytes)
#define KlRealloc(ptr, bytes) realloc(ptr, bytes)
#define KlCalloc(ptr, bytes) calloc(ptr, bytes)
#else /* DO_NOT_REDEFINE_MALLOC */
#define Malloc(bytes) KlMalloc(bytes)
#define Free(bytes) KlFree(bytes)
#define Realloc(ptr, bytes) KlRealloc(ptr, bytes)
#define Calloc(ptr, bytes) KlCalloc(ptr, bytes)
#endif /* DO_NOT_REDEFINE_MALLOC */
#ifdef USE_STANDARD_MALLOC
/* standard realloc might not like null pointers */
#ifndef REALLOC_ACCEPTS_NULL
#undef Realloc
#undef KlRealloc
#define Realloc(ptr, bytes) ((ptr) ? realloc(ptr, bytes) : malloc(bytes))
#define KlRealloc(ptr, bytes) ((ptr) ? realloc(ptr, bytes) : malloc(bytes))
#endif /* !REALLOC_ACCEPTS_NULL */
#define KlMallocBucketOfSize(s) s
#define KlMallocSizeOfBucket(s) s
#define KlMallocBucket(bytes) malloc((size_t) (bytes))
#else /* !USE_STANDARD_MALLOC */
/* magic markers */
#define KlMAGIC 0xef /* = 239 magic # on accounting info */
#define KlRMAGIC 0x5555 /* = 21845 magic # on range info */
#define KlFREED_MAGIC 0x77 /* block has been freed */
#define KlUNINIT_MAGIC 0x88 /* malloced uninitialized block */
#ifdef DEBUG
EXT void * KlFREED_MAGIC_PTR; /* word filled with KlFREED_MAGIC */
EXT void * KlUNINIT_MAGIC_PTR; /* word filled with KlUNINIT_MAGIC */
#endif /* DEBUG */
#endif /* !USE_STANDARD_MALLOC */
#ifndef NO_MALLOC_DECLARE
# ifdef VOID_MALLOC
extern void *malloc(), *realloc(), *calloc();
# ifdef VOID_FREE
extern void free();
# else /* !VOID_FREE */
extern free();
# endif /* !VOID_FREE */
# else /* !VOID_MALLOC */
# ifdef DO_NOT_REDEFINE_MALLOC
extern char *KlMalloc(), *KlRealloc(), *KlCalloc();
# else /* !DO_NOT_REDEFINE_MALLOC */
extern char *malloc(), *realloc(), *calloc();
# endif /* !DO_NOT_REDEFINE_MALLOC */
# endif /* !VOID_MALLOC */
#endif /* NO_MALLOC_DECLARE */
#if !defined(IINLINE)
# if defined(__NUTC__)
#include <nutc/bzero.h>
#define IINLINE __inline
# else /* !NUTC */
#define IINLINE inline
# endif /* !NUTC */
#endif /* IINLINE */
/*****************************************************************************\
* GC *
\*****************************************************************************/
/* to access easily any object's reference count */
#define KlRef(obj) (((KlO) (obj))->reference_count)
#define KlResetRef(obj) if (KlRef(obj) & 1) KlRef(obj)=0; else KlZrtPut(obj)
#ifndef DEBUGREF
#define KlIncRef(obj) KlRef(obj) += 2
#define KlIncRefOrNull(obj) {if (obj) KlRef(obj) += 2;}
#define KlDecRef(obj) {if(obj && (KlRef(obj)-=2)==1)KlZrtPut(obj);}
#define KlDecRefNonNull(obj) {if((KlRef(obj)-=2)==1)KlZrtPut(obj);}
#endif /* DEBUG2 */
#define KlAppendToArray(array, i, obj) \
array = (KlO *) Realloc(array, (i+2) * sizeof(KlO)); \
KlIncRef(array[i++] = (KlO) obj); \
array[i] = 0
/*********************************************************************** ZRT */
/* ZRT= Zero Reference Table, objects that will be scanned for deletion */
EXT KlO *KlZrt; /* start of Garbaged objects stack */
EXT KlO *KlZrtLast; /* current end (+ 1) */
EXT KlO *KlZrtFrom; /* current start during current GC */
EXT KlO *KlZrtLimit; /* malloced space */
EXT Int KlZrtSizeLimit; /* same for efficiency */
#define KlDftGc() /* obsolete, for backwards compat */
#define KlGCMark() Int KlZrtLocalMarker = KlZrtLast - KlZrt
#define KlGCDecls Int KlZrtLocalMarker
#define KlGCSet() KlZrtLocalMarker = KlZrtLast - KlZrt
#define KlGC() KlZrtGc(KlZrtLocalMarker)
#define KlGCFull() KlZrtGc(0);
#define KlGCMark2() Int KlZrtLocalMarker2 = KlZrtLast - KlZrt
#define KlGC2() KlZrtGc(KlZrtLocalMarker2)
#define KlZrtSize (KlZrtLast - KlZrt) /* for backwards compat */
/*****************************************************************************\
* exported functions *
\*****************************************************************************/
extern KlO _KlError();
extern KlO KlPrint();
extern KlO KlPrintNary();
extern KlO Kl_subr_make();
extern KlO KlEval();
extern int KlPool();
extern KlO NIL_FUNC();
extern KlO KlTypeOrEvaluate();
extern KlO KlBadArgument();
extern KlO KlProgn();
extern KlO KlQuote();
extern KlO KlBackquote();
extern KlO KlApplyUnary();
extern KlO KlDeclareSubr();
extern KlO KlDeclareFSubr();
extern KlO KlNumber2KlO();
extern KlType KlFindType();
extern KlO KlDefaultPrint();
extern KlO KlCoerceError();
extern KlO KlErrorCannotSet();
extern KlO KlExecuteString();
extern KlO KlParseString();
extern char *stpcpy();
extern void KlSetField();
extern KlO KlCoerce();
extern KlO KlCoerceOrNil();
extern KlO KlExecuteGetDefault();
extern KlSignalHandler KlSignal();
extern char * KlExpandTildeForFilesC();
extern KlO KlSetq();
extern int KlPoolToplevel();
extern KlO KlLoad();
extern KlO KlLoadSilent();
extern KlO KlLoadKl();
extern char *KlTraitName _ANSI_ARGS_((unsigned int trait));
extern KlO KlExecuteHook();
extern char *KlIsReadingFile();
int KlExecuteKloneNoReturn();
KlO KlExecuteKlone();
/********************************************************** exported objects */
EXT KlO KlReadExpr INIT(NULL);
EXT KlO KlReadExprBin INIT(0);
EXT KlO KlReadString;
#define KlRead() (!(Klyyparse()) && KlReadExpr)
#define KlToplevelPrint(obj) KlPrintNary(1, &(obj))
EXT KlO KlDoReadAndEval();
EXT void (*KlMainPreSelect)() INIT(0); /* to be called before select at top */
EXT void (*KlChildDeathHook)() INIT(0);
EXT KlO KlTempObj;
EXT KlO NIL; /* NIL is just a predefined nil list */
EXT KlO TRU; /* t is just a predefined atom */
EXT KlO QUOTE; /* Function needed for parsing */
EXT KlO KlUndef INIT(0); /* undefined value of atoms */
#ifndef NULL
#define NULL 0
#endif /* NULL */
#define NARY -1
EXT int KlCurrentMessage;
#ifdef DEBUG
EXT int KlCurSend INIT(0); /* send counter for debug */
#else /* DEBUG */
#define stop_if_in_dbx(why)
#endif /* DEBUG */
#define KlUndefinedPos -1
/* the user-level debugging functions */
EXT int KlTracingOn INIT(0);
EXT KlO KlTracingOnEXPR INIT(0);
EXT int KlStillTracing INIT(0);
#if defined(__HIGHC__)
pragma
on(POINTERS_COMPATIBLE);
#endif
/* logical values */
#define KlFalseP(o) (!((KlList)(o))->size && KlIsAList((o)))
#define KlTrueP(o) (((KlList)(o))->size || (!KlIsAList((o))))
#define KlIntBE32Read(p) \
((*(p) << 24) + (*(p+1) << 16) + (*(p+2) << 8) + *(p+3))
#define KlIntBE24Read(p) ((*(p) << 16) + (*(p+1) << 8) + *(p+2))
#define KlIntBE16Read(p) ((*(p) << 8) + *(p+1))
#define KlIntBE8Read(p) (*(p))
/******************************************************** exported variables */
EXT int KlInitState INIT(0); /* were are we in the init process? */
EXT int KlErrorStatus INIT(0); /* set to 1 by a KlError */
EXT int KlContinueReadingOnError INIT(0); /* in files */
EXT int KlErrorInProfile INIT(0); /* do we abort? */
EXT unsigned int KlMaxPrintLevel INIT(9); /* max list imbrication */
EXT int KlPrintReadably INIT(0); /* do we print for re-reading? */
EXT int KlQuoteNewlines INIT(0); /* quote newlines as \n in strings? */
EXT int KlPrintBinary INIT(0); /* do we print for fast re-reading? */
EXT int KlPrintAsRawStrings INIT(0); /* do we print for fast re-reading? */
EXT int KlPrintFormatOldBehavior /* reproduce old bug for compat */
INIT(0);
EXT int KlPrintLevel INIT(-1); /* current value */
EXT char *KlShellName INIT(0); /* var name of forked shell */
EXT KlO KlHostName INIT(0); /* host name running klone */
EXT int KlRealPrecision INIT(-1); /* number of printed digits */
EXT int KlIsInError INIT(0); /* to not recurse in error */
EXT char *KlErrorMessagePrefix INIT("Error: "); /* text before error message */
EXT int KlLastSignal INIT(0); /* last handled signal type */
EXT int KlChildDeathReported INIT(0); /* shall we look for dead children? */
EXT int KlQuoteInlines INIT(0); /* do not eval inline expressions */
EXT int KlSIGHUPOnExit INIT(1); /* send SIGHUP to children on exit */
EXT int KlInfixAssigns INIT(1); /* do we parse x = y as (setq x y) ? */
#ifdef MONITOR
EXT int KlMonControlled INIT(0); /* is the code traced? */
#endif
EXT char *KlVersionNumber; /* "2.4c" */
extern char *KlRCSVersionNumber; /* "$Version: 2.4c$" */
/* Should be incremented at each change, see KlHashKl in klone.c */
EXT Int KlHashVersionNumber;
EXT int KlSigPipeHandler_notcalled INIT(0); /* trap SIGPIPE */
/*****************************************************************************\
* debugging-only traces *
\*****************************************************************************/
#define KLTRACE printf
#ifdef DEBUG
EXT char *KlTraceFlags INIT("");
#define KlTrace(flag, args) if(strchr(KlTraceFlags, flag)) printf args
#else /* DEBUG */
#define KlTrace(flag, args)
#endif /* DEBUG */
/* obsolete calls emulated */
#define KlPuts(s) KlSPuts(s, KlStdout)
#define KlNewline() KlSPutc('\n', KlStdout)
#define KlPrintf(s, a) KlSPrintf(KlStdout, s, a)
#define KlPutchar(c) KlSPutc(c, KlStdout)
#define KlSPrint(o, s) KlSend_print(o, s)
#define KlPrint(o) KlSPrint(o, KlStdout)
/*****************************************************************************\
* properties *
\*****************************************************************************/
#ifdef KlHOOK_NUMBER
EXT int KlSelHookMask;
#define KlHookNumber KlHOOK_NUMBER
EXT KlO klHookHashTableArray[KlHOOK_NUMBER];
EXT KlO KlH_plists;
extern void KlFreeHooks(); /* (obj) */
#endif /* KlHOOK_NUMBER */
/*****************************************************************************\
* C-klone interface *
\*****************************************************************************/
extern KlParseKeywords();
extern KlO KlCheckKeywordValue();
/******************************************** Macros to ease initializations */
#define KlDefaultTo(var, value) if (!var) var=(value)
/* macro to define and initialize klone atoms in the code:
* type is KlAtom or KlO
* C_name is the name in the C code (i.e NIL)
* KlValue is the string which will represent the atom
* value is an object taken as the c_val
*/
#define KlDeclareSymbol(type, C_name, KlName, value) \
C_name = (type) KlIntern(KlName); \
KlSend_setq(C_name, value)
#define KlDeclareAtom(name, value) \
(KlTmpAtom = KlIntern(name), KlSend_setq(KlTmpAtom, value), KlTmpAtom)
#define KlAtomWithNumericValueMake(name, value) \
(KlTmpAtom = KlIntern(name), KlSend_setq(KlTmpAtom, KlNumberMake(value)))
/* get from context */
#define KlGetValFromContext(field, atom) \
KlIncRef((KlO) (field = (void*) KlSend_eval(atom)))
/********************************************************** Extension system */
typedef struct _KlExtension {
char *name; /* name of extension */
int (*selectors)(); /* init of selectors */
int (*types)(); /* init of types */
int (*profile)(); /* klone level inits */
} *KlExtension;
EXT KlExtension KlExtensions INIT(0); /* list of asked for extensions */
EXT int KlExtensionsSize INIT(0);
/**************************************************** PtrInt mixed variables */
/* KlPI allows to handle small integers or pointers in a same Int location
*/
#define KlPI_CUT ((UInt) 0x10000)
#define KlPI_INVALID_VALUE (((UInt) -1))
#define KlPI_PTR(p) ((((UInt) (p)) > KlPI_CUT) && \
(((UInt) (p)) != KlPI_INVALID_VALUE))
#define KlPI_INT(p) (((UInt) (p)) <= KlPI_CUT)
#define KlPI_INVALID(p) (((UInt) (p)) == KlPI_INVALID_VALUE)
/********************************************************* Klone C functions */
#define KlListDeleteC(l, n) KlListDelete(l, KlNumberMake(n))
/*****************************************************************************\
* Backwars compatibility *
\*****************************************************************************/
/* catched --> caught
*/
#define KlSetNonCatchedErrorPoint KlSetNonCaughtErrorPoint
#define KlNonCatchedErrorHandlerDefault KlNonCaughtErrorHandlerDefault
#define KlNonCatchedErrorFrame KlNonCaughtErrorFrame
#define KlNonCatchedErrorVerbose KlNonCaughtErrorVerbose
#define KlNonCatchedErrorJumpPoint KlNonCaughtErrorJumpPoint
#define KlLastCatchedTag KlLastCaughtTag
#define KlNonCatchedErrorHandler KlNonCaughtErrorHandler
#define KlUnsetNonCatchedErrorPoint KlUnsetNonCaughtErrorPoint
#endif /* INCLUDE_KLONE_H */
syntax highlighted by Code2HTML, v. 0.9.1