/* 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 #ifdef SYSV #include #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 # else # include # 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 #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 */