/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */ /*****************************************************************************\ * * * KLONE.c: * * main body of interpreter * * * * Here are defined Klone-only functions. * * To add a function: * * - declare it (coded in or extern) * * - add it to the declaration of predefined functions * * in the KlInit function, or in the Init function of a * * module * * * \*****************************************************************************/ #include #include #include #include #include #ifdef SYSV #include #endif /* IBM_RT && SYSV */ #include "INTERN.h" #include "klone.h" #include "EXTERN.h" #ifdef SYSV_STRINGS #include #else #include #endif #include #include "kl_atom.h" #include "kl_coll.h" #include "kl_list.h" #include "kl_func.h" #include "kl_number.h" #include "kl_string.h" #include "kl_hash.h" #include "kl_stream.h" #include "kl_struct.h" extern KlO KlSmartLoader(); #ifdef STATS extern KlO zrtstats(); extern KlO KlCfstats(); #endif /* STATS */ #ifdef MALLOCDEBUG0 #define MALLOCDEBUG #endif #ifdef MALLOCDEBUG extern KlO KlMDCheckKl(); #endif extern KlO KlPrintNary(); extern KlO KlWith(), KlWithEval(); extern int KlErrorInProfile; extern char *Klyytext; extern KlO KlKloneActiveMake(); extern KlSymbolSlot KlSymbolSlotMake(); extern KlO KlPoolKl(); DECLARE_strchr; DECLARE_strrchr; /* forward declarations */ KlO KlEq(); KlO KlAdd(); extern KlO KlDefConstant(); extern KlO KlDefVar(); extern KlO KlRedefConstant(); extern KlO KlInternKl(); extern KlO KlDoAllSymbols(); KlO KlTypeExecute(); KlO KlTypeApply(); #ifdef DEBUG extern KlO KlCBreak(); KlList KlListOfBuiltInTypes; #endif #ifdef DEBUG2 extern KlO KlGetTrace(); extern KlO KlSetTrace(); #endif /* VARS */ char *KlHomeDir; KlList KlExtensionList; /************************************************************** traits names */ int KlDeclareNewTrait(name) char *name; { KlTraitNames = (char **) Realloc(KlTraitNames, (KlLastTrait + 1) * sizeof(char *)); KlTraitNames[KlLastTrait] = name; return 1 << (KlLastTrait++); } KlDeclareBuiltInTraits() { char **sp = KlTraitNames = (char **) Malloc(KlLastTrait * sizeof(char *)); *sp++ = "string"; *sp++ = "symbol"; *sp++ = "function"; *sp++ = "number"; *sp++ = "object"; *sp++ = "table"; *sp++ = "hasheq"; *sp++ = "list"; *sp++ = "pseudo_type"; *sp++ = "unreallocable"; } /*****************************************************************************\ * internal object layer * \*****************************************************************************/ /* a type is an array of methods. first methods are in fact class variables * which are: * klone header: type and refcount * - the name of type (atom) * - a pointer to next type. This maintains a list of all known types * pointed to by KlTypes * - the traits: inheritance flags (32 1-bit flags in a 32 bit word) telling * which "trait" this type has * - the trait this type may define * - then methods, first one must be "coerce" * pseudo-types stop here, normal types go on with the rest of the methods * array */ KlMethod *KlTypeTemplate = 0; /* KlDeclareTypeSlot * Declares an application-dependent type slot before the methods array * name is stored in the method array */ int KlDeclareTypeSlot(initial_value, name) KlO initial_value; char *name; { int position = KlDeclareSelector(0, name); KlTypeTemplate[position] = (KlMethod) initial_value; KlTypeReservedSlots = KlSelectorsSize; return position; } /* KlDeclareSelector * declare a new selector * returns allocated position. * name must not freed afterwards, pointed to by structure * the arity (0 <= arity < KlSelectorsPropsSize(6 by default)) can be given * arity is 0 for n-ary methods (argc, argv), but NARY (-1) is accepted too */ int KlDeclareSelector(arity, name) int arity; char *name; { int position; if (arity == NARY) arity = 0; if (arity < 0 || arity >= KlSelectorsPropsSize) (*KlFatalError)(3, name); KlMustBeAtInitState(32, 47); position = KlSelectorsSize++; KlSelectors = (struct _KlSelector *) Realloc(KlSelectors, sizeof(struct _KlSelector) * KlSelectorsSize); KlSelectors[position].arity = arity; KlSelectors[position].name = name; KlTypeTemplate = (KlMethod *) Realloc(KlTypeTemplate, sizeof(KlMethod) * KlSelectorsSize); KlTypeTemplate[position] = KlSelectorUndefmethod(position); return position; } /* KlDeclareSelectorArity * Declares an Undefined Method and other things for a given selector arity * number of params may grow in the future * last param MUST be 0 in order to check for version mismatches */ KlDeclareSelectorArity(arity, undefmethod, hooker, bypass_once, zero) int arity; KlMethod undefmethod; KlMethod hooker; KlMethod bypass_once; int zero; { if (zero) (*KlFatalError)(13, "obsolete form of calling"); if (arity != KlSelectorsPropsSize) { /* leave no holes! */ char tmp[80]; sprintf(tmp, "declared %d, expected %d!", arity, KlSelectorsPropsSize); (*KlFatalError)(13, tmp); } KlSelectorsPropsSize++; KlSelectorsProps = (struct _KlSelectorProps *) Realloc(KlSelectorsProps, KlSelectorsPropsSize * sizeof (struct _KlSelectorProps)); KlSelectorsProps[arity].undefmethod = undefmethod; KlSelectorsProps[arity].hooker = hooker; KlSelectorsProps[arity].bypass_once = bypass_once; } /* KlGetSelectorByName * searches a selector by its name, returns its position or 0 if not found */ int KlGetSelectorByName(name) char *name; { int i; for (i = KlTypeReservedSlots; i < KlSelectorsSize; i++) { if (!strcmp(name, KlSelectors[i].name)) { return i; } } return 0; } /* KlInitPredefinedSelectors * used to pre-declare built-in selectors */ KlInitPredefinedSelectors() { /* fill private selector slots with 0 */ KlSelectors = (struct _KlSelector *) Calloc(sizeof(struct _KlSelector), (size_t) KlSelectorsSize); KlSelectorsPropsSize = 6; KlSelectorsProps = (struct _KlSelectorProps *) Malloc(KlSelectorsPropsSize * sizeof(struct _KlSelectorProps)); KlSelectorsProps[0].undefmethod = KlUndefinedMethodNary; KlSelectorsProps[0].hooker = KlSelectorHookerNary; KlSelectorsProps[0].bypass_once = KlSelectorBypassOnceNary; KlSelectorsProps[1].undefmethod = KlUndefinedMethod1; KlSelectorsProps[1].hooker = KlSelectorHooker1; KlSelectorsProps[1].bypass_once = KlSelectorBypassOnce1; KlSelectorsProps[2].undefmethod = KlUndefinedMethod2; KlSelectorsProps[2].hooker = KlSelectorHooker2; KlSelectorsProps[2].bypass_once = KlSelectorBypassOnce2; KlSelectorsProps[3].undefmethod = KlUndefinedMethod3; KlSelectorsProps[3].hooker = KlSelectorHooker3; KlSelectorsProps[3].bypass_once = KlSelectorBypassOnce3; KlSelectorsProps[4].undefmethod = KlUndefinedMethod4; KlSelectorsProps[4].hooker = KlSelectorHooker4; KlSelectorsProps[4].bypass_once = KlSelectorBypassOnce4; KlSelectorsProps[5].undefmethod = KlUndefinedMethod5; KlSelectorsProps[5].hooker = KlSelectorHooker5; KlSelectorsProps[5].bypass_once = KlSelectorBypassOnce5; KlTypeTemplate = (KlMethod *) Calloc(sizeof(KlMethod), (size_t) KlTypeReservedSlots); KlSelPrint = KlDeclareSelector(2, "print"); KlSelFree = KlDeclareSelector(1, "free"); KlSelExecute = KlDeclareSelector(2, "execute"); KlSelEqual = KlDeclareSelector(2, "="); KlSelCopy = KlDeclareSelector(1, "copy"); KlSelSetq = KlDeclareSelector(2, "setq"); KlSelMake = KlDeclareSelector(1, "init"); KlSelAdd = KlDeclareSelector(0, "+"); KlSelGet = KlDeclareSelector(3, "get"); KlSelPut = KlDeclareSelector(3, "put"); KlSelInsert = KlDeclareSelector(3, "insert"); KlSelDelete = KlDeclareSelector(2, "delete"); KlSelNth = KlDeclareSelector(3, "nth"); KlSelHash = KlDeclareSelector(1, "hash"); KlSelLength = KlDeclareSelector(1, "length"); KlSelApply = KlDeclareSelector(2, "apply"); KlSelDolist = KlDeclareSelector(4, "dolist"); KlSelDohash = KlDeclareSelector(5, "dohash"); KlSelCompare = KlDeclareSelector(2, "compare"); #ifdef KlHOOK_NUMBER /* info put into this array, sort of "class variables" */ KlSelHookMask = KlDeclareSelector(0, "hookMask"); KlTypeTemplate[KlSelHookMask] = 0; #endif /* default methods */ KlTypeTemplate[KlSelPrint] = KlDefaultPrint; /* prints pointer */ KlTypeTemplate[KlSelEqual] = KlEq; /* equal is eq */ KlTypeTemplate[KlSelHash] = KlQuote; /* hash is pointer (eq) */ KlTypeTemplate[KlSelFree] = KlNumberFree; /* free chunk itself */ KlTypeTemplate[KlSelEval] = KlQuote; /* eval returns object */ /* eval bootstrap */ KlSelectors[KlSelEval].name = "eval"; KlSelectors[KlSelEval].arity = 1; } /* KlDeclareMethod * declares an internal method, and propagates to the subtypes */ void KlDeclareMethod(type, selector, method) KlType type; int selector; KlMethod method; { KlType t; KlMethod oldmethod = type[selector]; if (selector < KlTypeStaticReservedSlots || selector >= KlSelectorsSize) { (*KlFatalError)(15, selector); } KlDeclareMethod1(type, selector, method); if (type == KlTypes) /* last type defined ==> no children */ return; /* propagate */ for (t = KlTypes; t; t = KlTypeNextGet(t)) { /* finds all direct sons of type with same old method */ if (KlTypeFatherGet(t) == type && t[selector] == oldmethod) { KlDeclareMethod(t, selector, method); /* recurse */ } } } CFAPPLY_ERROR() { fprintf(stderr, "\nINTERNAL ERROR: applying a NULL C Function!\n"); stop_if_in_dbx("NULL C FUNCTION POINTER"); } /************************************************** instance initialisations */ KlO KlOMake(KlType kltype) { KlO KlOMakeTemp; KlOMakeTemp = (KlO) KlMallocBucket(KlTypeSizeGet(kltype)); KlZrtPut(KlOMakeTemp); KlOMakeTemp->type = kltype; return KlOMakeTemp; } KlO KlOMakeZero(KlType kltype) { KlO KlOMakeTemp; KlOMakeTemp = (KlO) KlMallocBucket(KlTypeSizeGet(kltype)); bzero(((char *) KlOMakeTemp) + sizeof(struct _KlO), (size_t) KlMallocSizeOfBucket(KlTypeSizeGet(kltype)) - sizeof(struct _KlO)); KlZrtPut(KlOMakeTemp); KlOMakeTemp->type = kltype; return KlOMakeTemp; } KlO KlOMakeOfSize(KlType kltype, int size) { KlO KlOMakeTemp; KlOMakeTemp = (KlO) Malloc(size); KlZrtPut(KlOMakeTemp); KlOMakeTemp->type = kltype; return KlOMakeTemp; } KlO KlOMakeOfSizeZero(KlType kltype, int size) { KlO KlOMakeTemp; KlOMakeTemp = (KlO) Calloc((size_t) size, (size_t) 1); KlZrtPut(KlOMakeTemp); KlOMakeTemp->type = kltype; return KlOMakeTemp; } /*****************************************************************************\ * type functions * \*****************************************************************************/ KlO KlTypePrint(obj, stream) KlType obj; KlStream stream; { if (KlPrintReadably) { KlSPrintf(stream,"{coerce \"%s\" Type}", KlTypeCName(obj)); } else { KlSPuts(KlTypeCName(obj), stream); } return (KlO) obj; } /* KlTypesInit * bootstrap: builds the Type Type (first type) * its name field will have to be filled by KlAtomInit */ KlTypesInit() { KlAnyType = (KlType) Malloc(sizeof(KlMethod) * KlSelectorsSize); KlTypeType = (KlType) Malloc(sizeof(KlMethod) * KlSelectorsSize); KlTypeTypeSet(KlTypeTemplate, KlTypeType); bcopy((char *) KlTypeTemplate, (char *) KlAnyType, (size_t) (sizeof(KlMethod) * KlSelectorsSize)); bcopy((char *) KlTypeTemplate, (char *) KlTypeType, (size_t) (sizeof(KlMethod) * KlSelectorsSize)); if (KlTypes) { (*KlFatalError)(9, KlTypeCName(KlTypes)); } KlTypes = KlTypeType; KlTypeNextSet(KlTypeType, KlAnyType); KlTypeFatherSet(KlTypeType, KlAnyType); /* type methods */ KlDeclareMethod1(KlTypeType, KlSelPrint, KlTypePrint); KlDeclareMethod1(KlTypeType, KlSelExecute, KlTypeExecute); KlDeclareMethod1(KlTypeType, KlSelApply, KlTypeApply); /* no free method! */ KlTypeNumCurrent += 1; KlCoerceTable = (KlMethod **) Calloc(KlTypeNumCurrent, (size_t) sizeof(KlMethod *)); KlCoerceTableSizes = (int *) Malloc(sizeof(int *) * 15); KlCoerceTableSizes[0] = 0; KlCoerceTableIncr(KlAnyType); } /* KlDeclareSubType * to declare a type inheriting traits and methods from another * to be called after defining all the public methods of main type * copies all traits and methods of parent type * size is the size in bytes or 0 if variable-type size * * KlDeclareType is now a macro calling KlDeclareSubType with parent = 0 */ KlAtom KlDeclareSubType(typep, name, parent, size) KlType *typep; char *name; KlType parent; int size; { KlAtom typename; KlType type = *typep = (KlType) Malloc(sizeof(KlMethod) * KlSelectorsSize); if (parent) { bcopy((char *) parent, (char *) type, (size_t) (sizeof(KlMethod) * KlSelectorsSize)); KlTypeTraitReset(type); KlTypeFatherSet(type, parent); } else { bcopy((char *) KlTypeTemplate, (char *) type, (size_t) (sizeof(KlMethod) * KlSelectorsSize)); KlTypeFatherSet(type, KlAnyType); } KlTypeSizeSet(type, KlMallocBucketOfSize(size)); typename = (KlAtom) KlConstantMake(name, type); KlTypeNameSet(type, typename); KlTypeNextSet(type, KlTypes); KlTypes = type; KlCoerceTableIncr(type); return typename; } /* KlTraitName * get symbolic name of trait from trait */ char * KlTraitName(trait) unsigned int trait; { unsigned int i; for (i = 0; i < 32; i++) { if ((1 << i) == trait) { return KlTraitNames[i]; } } return ""; } /* KlFindType * finds a klone type by its name (atom) */ KlType KlFindType(name) KlAtom name; { if (KlIsAType(name)) { return (KlType) name; } else if (KlIsASymbol(name) && name->c_val != KlUndef && KlIsAType(name->c_val)) { return (KlType) name->c_val; } else { KlMustBeType(name, 0); /*NOTREACHED*/ return 0; } } /* klone-callable (simple!) function */ KlO KlTypeOf(obj) KlO obj; { return (KlO) obj->type; } KlO KlTypeNameKl(kltype) KlType kltype; { KlMustBeType(kltype, 0); return (KlO) KlTypeName(kltype); } /* KlTypeCoerce is basically KlFindType */ KlO KlTypeCoerce(totype, obj) KlType totype; KlString obj; { KlMustBeString(obj, 0); return (KlO) KlFindType(KlIsASymbol(obj) ? obj : (KlString) KlIntern(obj->string)); } /* KlTypeExecute is a Coerce * (type-name foo) ==> (coerce foo type-name) */ KlO KlTypeApply(obj, list) KlType obj; KlList list; { KlNumberOfArgumentsCheck(list->size != 2, list->size); return KlCoerce(list->list[1], obj); } KlO KlTypeExecute(obj, list) KlType obj; KlList list; { KlNumberOfArgumentsCheck(list->size != 2, list->size); return KlCoerce(KlSend_eval(list->list[1]), obj); } /* types-list * returns the list of all types in the system */ KlO KlTypesList() { KlList list = KlListNMake(0); KlType t; for (t = KlTypes; t; t = KlTypeNext(t)) { KlListAppend(list, t); } return (KlO) list; } /*********************** selector hooker, one for each number of parameters. */ /*ARGSUSED*/ KlO KlSelectorHookerNary(argc, argv) int argc; KlO argv[]; { if (KlIsInFrameHook) { /* in hook code, bypass */ return CFAPPLY((KlCurrentHookerBackup(argv[0])), (argc, argv)); } else { /* apply Klone hook code */ KlO result; KlStackFramePushSetHook(); result = KlApplyN(KlCurrentHookerCall(argv[0]), argc, argv); KlStackFramePopHook(); return result; } } KlO KlSelectorHooker1(object) KlO object; { if (KlIsInFrameHook) { /* in hook code, bypass */ return CFAPPLY((KlCurrentHookerBackup(object)), (object)); } else { /* apply Klone hook code */ KlO result; KlStackFramePushSetHook(); result = KlApply1(KlCurrentHookerCall(object), object); KlStackFramePopHook(); return result; } } /*ARGSUSED*/ KlO KlSelectorHooker2(object, param1) KlO object; KlO param1; { if (KlIsInFrameHook) { /* in hook code, bypass */ return CFAPPLY((KlCurrentHookerBackup(object)), (object, param1)); } else { /* apply Klone hook code */ KlO result; KlStackFramePushSetHook(); result = KlApply2(KlCurrentHookerCall(object), object, param1); KlStackFramePopHook(); return result; } } /*ARGSUSED*/ KlO KlSelectorHooker3(object, param1, param2) KlO object; KlO param1; KlO param2; { if (KlIsInFrameHook) { /* in hook code, bypass */ return CFAPPLY((KlCurrentHookerBackup(object)), (object, param1, param2)); } else { /* apply Klone hook code */ KlO result; KlStackFramePushSetHook(); result = KlApply3(KlCurrentHookerCall(object), object, param1, param2); KlStackFramePopHook(); return result; } } /*ARGSUSED*/ KlO KlSelectorHooker4(object, param1, param2, param3) KlO object; KlO param1; KlO param2; KlO param3; { if (KlIsInFrameHook) { /* in hook code, bypass */ return CFAPPLY((KlCurrentHookerBackup(object)), (object, param1, param2, param3)); } else { /* apply Klone hook code */ KlO result; KlStackFramePushSetHook(); result = KlApply4(KlCurrentHookerCall(object), object, param1, param2, param3); KlStackFramePopHook(); return result; } } /*ARGSUSED*/ KlO KlSelectorHooker5(object, param1, param2, param3, param4) KlO object; KlO param1; KlO param2; KlO param3; KlO param4; { if (KlIsInFrameHook) { /* in hook code, bypass */ return CFAPPLY((KlCurrentHookerBackup(object)), (object, param1, param2, param3, param4)); } else { /* apply Klone hook code */ KlO result; KlStackFramePushSetHook(); result = KlApply5(KlCurrentHookerCall(object), object, param1, param2, param3, param4); KlStackFramePopHook(); return result; } } /********** selector hooker bypassers, one for each number of parameters. */ /*ARGSUSED*/ KlO KlSelectorBypassOnceNary(method, argc, argv) KlMethod method; int argc; KlO *argv; { return CFAPPLY(method, (argc, argv)); } KlO KlSelectorBypassOnce1(method, argc, argv) KlMethod method; int argc; KlO *argv; { return CFAPPLY(method, (*argv)); } /*ARGSUSED*/ KlO KlSelectorBypassOnce2(method, argc, argv) KlMethod method; int argc; KlO *argv; { return CFAPPLY(method, (*argv, argv[1])); } /*ARGSUSED*/ KlO KlSelectorBypassOnce3(method, argc, argv) KlMethod method; int argc; KlO *argv; { return CFAPPLY(method, (*argv, argv[1], argv[2])); } /*ARGSUSED*/ KlO KlSelectorBypassOnce4(method, argc, argv) KlMethod method; int argc; KlO *argv; { return CFAPPLY(method, (*argv, argv[1], argv[2], argv[3])); } /*ARGSUSED*/ KlO KlSelectorBypassOnce5(method, argc, argv) KlMethod method; int argc; KlO *argv; { return CFAPPLY(method, (*argv, argv[1], argv[2], argv[3], argv[4])); } /********************** undefined method, one for each number of parameters. */ /*ARGSUSED*/ KlO KlUndefinedMethodNary(argc, argv) int argc; KlO argv[]; { return KlError2s(KlE_UNDEFINED_METHOD, argv[0], KlSelectors[KlCurrentMessage].name); } KlO KlUndefinedMethod1(object) KlO object; { return KlError2s(KlE_UNDEFINED_METHOD, object, KlSelectors[KlCurrentMessage].name); } /*ARGSUSED*/ KlO KlUndefinedMethod2(object, param1) KlO object; KlO param1; { return KlError2s(KlE_UNDEFINED_METHOD, object, KlSelectors[KlCurrentMessage].name); } /*ARGSUSED*/ KlO KlUndefinedMethod3(object, param1, param2) KlO object; KlO param1; KlO param2; { return KlError2s(KlE_UNDEFINED_METHOD, object, KlSelectors[KlCurrentMessage].name); } /*ARGSUSED*/ KlO KlUndefinedMethod4(object, param1, param2, param3) KlO object; KlO param1; KlO param2; KlO param3; { return KlError2s(KlE_UNDEFINED_METHOD, object, KlSelectors[KlCurrentMessage].name); } /*ARGSUSED*/ KlO KlUndefinedMethod5(object, param1, param2, param3, param4) KlO object; KlO param1; KlO param2; KlO param3; KlO param4; { return KlError2s(KlE_UNDEFINED_METHOD, object, KlSelectors[KlCurrentMessage].name); } /********************************************************************* types */ /* KlTypep * the typep primitive */ KlO KlTypep(obj, typename) KlO obj; KlAtom typename; { if (typename == (KlAtom) NIL) { return (KlO) obj->type; } else { KlType type = KlFindType(typename); return (KlIsOfType(obj, type) ? (KlO) (obj->type) : NIL); } } /* KlSubtypep * the subtypep primitive */ KlO KlSubtypep(obj, typename) KlO obj; KlAtom typename; { if (typename == (KlAtom) NIL) { return (KlO) obj; } else { KlType type = KlFindType(typename); if (KlIsAType(obj) && (type == (KlType) obj || KlTypeIsSonOf(obj, type))) { return (KlO) typename; } else { return NIL; } } } /* KlTypeIsSonOf * walks up the primitive type hierarchy * Note: does not checks if type is == to type */ int KlTypeIsSonOf(son, father) KlType son; KlType father; { while (KlTypeFatherGet(son)) { if ((son = KlTypeFatherGet(son)) == father) { return 1; } } return 0; } KlO KlTypeFatherKl(kltype) KlType kltype; { KlType type = KlFindType(kltype); return KlTypeFatherGet(type) ? (KlO) KlTypeFatherGet(type) : NIL; } /* physically changes type of an object * very dangerous, needless to say! */ KlO KlTypeReplace(obj, newtype) KlO obj; KlO newtype; { if (newtype != NIL) { KlMustBeType(newtype, 1); obj->type = (KlType) newtype; } return obj; } /*****************************************************************************\ * klone-C interface * \*****************************************************************************/ /* parses a list for keywords * sets up things to calls to KlKeyVal * should be done at the start of function, (but not mandatory) * All the KlKeyVal MUST be done after it without ANY intervening calls to * eval!!! * KlCount can NEVER be 0 or 1 */ KlParseKeywords(argc, argv, pos) int argc; /* the argc, argv */ KlKeyword *argv; int pos; /* position at which keywords start */ { KlKeyword *last = argv + argc; KlKeyword *argvorig = argv; if ((pos > argc) || ((argc - pos) % 2)) { KlBadNumberOfArguments(argc); pos = argc; /* dont parse */ } argv += pos; if (++KlKCount == 0) { KlKCount += 2; /* TO_DO: reset all keyw counts to 1 */ } while (argv < last) { if ((*argv)->type == KlKeywordType) { (*argv)->k_count = KlKCount; (*argv)->k_val = (KlO) * (argv + 1); argv++; } else { KlArgumentMustBe((*argv), argv - argvorig, KlKeywordType); } argv++; } KlValidKeywordsPtr = KlValidKeywords; /* reset list of allowed keywords */ *KlValidKeywordsPtr = 0; } /* KlKeyVal * is defined as a macro * usage: (KlO) variable = KlKeyVal(keyword, default-value) * must immediately follow KlParseKeywords call */ /* KlCheckUnvalidKeywords * after a KlParseKeywords calls, immediately followed by one call to * KlKeyVal for each valid keyword, you can check for invalid (not awaited * for, i.e. not parsed by a KlKeyVal call) by it. */ KlCheckUnvalidKeywords(argc, argv, pos) int argc; /* the argc, argv */ KlKeyword *argv; int pos; /* position at which keywords start */ { KlKeyword *last = argv + argc; argv += pos; while (argv < last) { if ((*argv)->type != KlKeywordType || (*argv)->k_count == KlKCount) { KlError2(KlE_INVALID_KEYWORD, *argv, KlListNullTerminated(KlValidKeywords)); } argv += 2; } } /* KlCheckKeywordValue * returns the value, in case it is corrected by an error corrector * USAGE: * value = * KlCheckKeywordValue(keyword, value, null-terminated-list-of-possible-vals); */ KlO KlCheckKeywordValue(keyword, value, valid_values_start) KlO keyword; KlO value; KlO *valid_values_start; { KlO *valid_values = valid_values_start; while (*valid_values) { if (value == *valid_values) return value; valid_values++; } /* not found, error */ return KlError3(KlE_INVALID_KEYWORD_VALUE, value, keyword, KlListNullTerminated(valid_values_start)); } /* bad argument call */ KlO KlBadArgument(argument, position, expecting) KlO argument; int position; char *expecting; { return KlError3(KlE_BAD_ARG_TYPE, argument, KlNumberMake(position), KlStringMake(expecting)); } /* executes an expression, returns if error (do not jump to toplevel) * return eval if no error occurred, NULL otherwise */ KlO KlEvalAndCatchErrors(Kl_expr) KlO Kl_expr; { KlO result; int normal; KlCatch(KlA_ERROR, KlSend_eval(Kl_expr), result, normal); return (normal ? result : 0); } #ifndef USE_STANDARD_MALLOC extern char *KlMallocZoneBegin, *KlMallocZoneEnd; #endif /* * KlEval: * evals an expression given as argument; * returns the result of the evaluation * if you want to keep the result, increase its reference count! * In case of eval error, calls KlError which returns NIL * NOTE: for efficiency in C code, use the macro KlSend_eval instead! */ KlO KlEval(expr) KlO expr; { return KlSend_eval(expr); } /* * KlSafeEval: * evals an expression given as argument; * returns 1 if OK, and 0 if exited because the evaluated Klone code attempted * THROKl outside the scope of the expression (by a throw or an error) * if you want to keep the result, increase its reference count! * second argument is a pointer to an KlO which is set to the result * if this pointer is NULL, resulkt is discarded and a GC is called */ int KlSafeEval(expr, resultp) KlO expr; KlO *resultp; { KlO result; int normal; KlGCMark(); KlCatch(KlA_ALL, KlSend_eval(expr), result, normal); if (resultp) { *resultp = result; } else { KlGC(); } return normal; } /* * KlFlushGC: * evals an expression given as argument; * returns () and does a full, discarding GC afterwards * Should be used in toplevel-like situations, inside stable, non redefined * code * This is a temporary solution till the GC system is enhanced to get rid * of the current conservative delayed GC system */ KlO KlFlushGC(read_expr) KlO read_expr; { KlGCMark(); KlSend_eval(read_expr); KlGC(); return NIL; } /***************************************************************************\ * * * KLONE USER routines: * * here are the definition of the standard routines binded to klone atoms by * * KlInit * * * \***************************************************************************/ /* * The NULL function is there only as a placeholder */ /*ARGSUSED*/ KlO NIL_FUNC(argc, argv) int argc; KlAtom *argv; { return NIL; } /* copy an object (useful for lists) */ KlO KlCopy(obj) KlO obj; { return KlSend_copy(obj); } /*****************************************************************************\ * generic functions: * \*****************************************************************************/ /* sugar around method calls */ /* KlGet * access a set with optional default * the default value is to be evaluated */ KlO KlGet(argc, argv) int argc; KlO *argv; { KlO obj = argv[0]; KlO key = argv[1]; switch (argc) { case 2: return KlSend_get(obj, key, KlE_NO_ELEMENT); break; case 3: return KlSend_get(obj, key, argv[2]); break; default: return KlBadNumberOfArguments((char *) argc); } } /* KlExecuteGetDefault * triggers the error: element not found * if def == KlE_NO_ELEMENT, then standard error message, else execute def * and returns its value */ KlO KlExecuteGetDefault(obj, key, def) KlO obj; KlO key; KlAtom def; { if (def == KlE_NO_ELEMENT) { return KlError2(KlE_NO_ELEMENT, key, obj); } else if (def) { return KlSend_eval(def); } else { return 0; /* called from C only, of course! */ } } /* KlGetN * faster version without opt. default, returns always NIL */ KlO KlGetN(obj, key) KlO obj; KlO key; { return KlSend_get(obj, key, NIL); } /* KlPut * stores an element in a set */ KlO KlPut(obj, key, value) KlO obj, key, value; { return KlSend_put(obj, key, value); } /* KlDelete * removes an element from a set */ KlO KlDelete(obj, key) KlO obj, key; { return KlSend_delete(obj, key); } /* KlInsert * inserts an element into a set */ KlO KlInsert(obj, key, value) KlO obj, key, value; { return KlSend_insert(obj, key, value); } /* KlAdd * generic addition (union, concat...) */ KlO KlAdd(argc, argv) int argc; KlO argv[]; { if (argc) { return KlSendNary(KlSelAdd, argc, argv); } else { /* (+) is an error, how to choose between 0, "", and () ? */ return KlBadNumberOfArguments(argc); } } /* length: of a string or list */ KlNumber KlLength(obj) KlList obj; { return (KlNumber) KlSend_length(obj); } /*****************************************************************************\ * Coercion * \*****************************************************************************/ /* KlCoerceTable: list of KlTypeNumCurrent arrays of types, * each individual array length is stored in KlCoerceTableSizes * each list is for a destination type the list of all its sources * from can be 0 = all existing types */ KlDeclareCoerce(from, to, func) KlType from; KlType to; KlMethod func; { int tnum = KlTypeNumGet(to); int fnum = KlTypeNumGet(from); int i; if (from) { if (KlCoerceTableSizes[tnum] <= fnum) { KlCoerceTableActualizeRow(tnum); } KlCoerceTable[tnum][fnum] = func; } else { /* for all types */ if (KlCoerceTableSizes[tnum] < KlTypeNumCurrent) { KlCoerceTableActualizeRow(tnum); } for (i = 0; i < KlTypeNumCurrent; i++) { if (!KlCoerceTable[tnum][i]) KlCoerceTable[tnum][i] = func; } } } /* KlCoerce * converts objects from one type in another * method send is on the destination type, unlike the klone func */ #define KlCoerceMethod(fnum, tnum) \ (KlCoerceTableSizes[tnum] > fnum && KlCoerceTable[tnum][fnum]) KlO KlCoerceOrNil(from, to) KlO from; /* object */ KlO to; /* type (atom) */ { KlType totype; KlO result; int tnum, fnum; KlType fromtype; if (KlIsAType(to)) { totype = (KlType) to; } else if (KlIsASymbol(to)) { totype = (KlType) ((KlAtom) to)->c_val; if (totype == (KlType) KlUndef || !KlIsAType((KlO) totype)) { KlMustBeType(to, 1); } } else if (to == NIL) { return from; } else { return 0; /* ERR: dest is not a type */ } tnum = KlTypeNumGet(totype); fromtype = from->type; while (fromtype) { if (totype == fromtype) return from; /* coerce into a father type = same */ fnum = KlTypeNumGet(fromtype); if (KlCoerceMethod(fnum, tnum)) { if (result = CFAPPLY((KlCoerceTable[tnum][fnum]), (totype, from))) return result; /* otherwise, look into father */ } fromtype = KlTypeFatherGet(fromtype); } /* ERR: no coerce method suceeded */ return 0; } KlO KlCoerce(from, to) KlO from; /* object */ KlO to; /* type (atom) */ { KlO res = KlCoerceOrNil(from, to); return res ? res : KlCoerceError(from, to); } KlO KlCoerceError(obj, totype) KlO obj; /* object */ KlType totype; /* type (atom) */ { return KlError2(KlE_NO_COERCION, obj, totype); } KlCoerceTableIncr(type) KlType type; { KlTypeNumSet(type, KlTypeNumCurrent++); KlCoerceTable = (KlMethod **) Realloc(KlCoerceTable, KlTypeNumCurrent*sizeof(KlMethod *)); KlCoerceTableSizes = (int *) Realloc(KlCoerceTableSizes, KlTypeNumCurrent*sizeof(int *)); KlCoerceTableSizes[KlTypeNumCurrent - 1] = 0; } KlCoerceTableActualizeRow(tnum) int tnum; { if (KlCoerceTableSizes[tnum]) { KlCoerceTable[tnum] = (KlMethod *) Realloc(KlCoerceTable[tnum], (size_t) (KlTypeNumCurrent * sizeof(KlMethod *))); bzero((char *) (KlCoerceTable[tnum] + KlCoerceTableSizes[tnum]), (size_t) ((KlTypeNumCurrent - KlCoerceTableSizes[tnum]) * sizeof(KlMethod *))); } else { KlCoerceTable[tnum] = (KlMethod *) Calloc((size_t) KlTypeNumCurrent, (size_t) sizeof(KlMethod *)); } KlCoerceTableSizes[tnum] = KlTypeNumCurrent; } /* An Identity coercion. useful to fill table */ /*ARGSUSED*/ KlO KlCoerceIdentity(totype, obj) KlType totype; KlO obj; { return obj; } /* initialisations * (done here so that at this time all types are defined) */ KlCoerceInit() { KlDeclareCoerce(KlStringType, KlAtomType, KlAtomCoerce); KlDeclareCoerce(KlStringType, KlKeywordType, KlKeywordCoerce); KlDeclareCoerce(KlListType, KlHashType, KlHashCoerceListToHash); KlDeclareCoerce(KlStringType, KlListType, KlListCoerce); KlDeclareCoerce(KlHashType, KlListType, KlListCoerce); KlDeclareCoerce(KlExprType, KlListType, KlListCoerce); KlDeclareCoerce(KlFExprType, KlListType, KlListCoerce); KlDeclareCoerce(KlMExprType, KlListType, KlListCoerce); KlDeclareCoerce(KlVectorType, KlListType, KlListCoerce); KlDeclareCoerce(KlStringType, KlVectorType, KlListCoerce); KlDeclareCoerce(KlHashType, KlVectorType, KlListCoerce); KlDeclareCoerce(KlExprType, KlVectorType, KlListCoerce); KlDeclareCoerce(KlFExprType, KlVectorType, KlListCoerce); KlDeclareCoerce(KlMExprType, KlVectorType, KlListCoerce); KlDeclareCoerce(KlListType, KlVectorType, KlListCoerce); KlDeclareCoerce(KlListType, KlQuotedExprType, KlQuotedExprCoerce); KlDeclareCoerce(KlStringType, KlNumberType, KlNumberCoerce); KlDeclareCoerce(KlRealType, KlNumberType, KlNumberCoerce); KlDeclareCoerce(KlStringType, KlRealType, KlRealCoerce); KlDeclareCoerce(KlNumberType, KlRealType, KlRealCoerce); KlDeclareCoerce(KlAtomType, KlStringType, KlStringCoerce); KlDeclareCoerce(KlNumberType, KlStringType, KlStringCoerce); KlDeclareCoerce(KlRealType, KlStringType, KlStringCoerce); KlDeclareCoerce(KlListType, KlStringType, KlStringCoerce); KlDeclareCoerce(KlStringType, KlNumbersType, KlNumbersCoerce); KlDeclareCoerce(KlNumberType, KlNumbersType, KlCoerceIdentity); KlDeclareCoerce(KlRealType, KlNumbersType, KlCoerceIdentity); KlDeclareCoerce(KlStringType, KlTypeType, KlTypeCoerce); KlDeclareCoerce(KlTypeType, KlStringType, KlStringCoerce); KlDeclareCoerce(KlStringType, KlSymbolSlotType, KlSymbolSlotCoerce); } /*****************************************************************************\ * comparisons * \*****************************************************************************/ /* equality * and not-equality */ KlO KlEqual(o1, o2) KlO o1, o2; { return KlSend_equal(o1, o2); } /* useful in conjunction with equal: hash */ /* WARNING: KlHashVersionNumber should be incremented each time Hash is * changed! */ Int KlHashVersionNumber = 1; KlO KlHashKl(obj) KlO obj; { Int32 val32bits = (Int32) KlSend_hash(obj); Int val = val32bits; return (KlO) KlNumberMake(val); } KlO KlNotEqual(o1, o2) KlO o1, o2; { return (KlSend_equal(o1, o2) == NIL ? TRU : NIL); } KlO KlEq(o1, o2) KlO o1, o2; { if (o1 == o2) return TRU; else return NIL; } /* inequalities = comparisons */ /* KlCompare returns -diff, 0, diff if <, =, > respectively */ KlO KlCompareKl(o1, o2) KlNumber o1, o2; { return (KlO) KlNumberMake((Int) KlSend_compare(o1, o2)); } KlO KlGreaterThan(o1, o2) KlO o1, o2; { if (KlCompare(o1, o2) > 0) return TRU; else return NIL; } KlO KlGreaterOrEqualThan(o1, o2) KlO o1, o2; { if (KlCompare(o1, o2) >= 0) return TRU; else return NIL; } KlO KlLesserOrEqualThan(o1, o2) KlO o1, o2; { if (KlCompare(o1, o2) <= 0) return TRU; else return NIL; } KlO KlLesserThan(o1, o2) KlO o1, o2; { if (KlCompare(o1, o2) < 0) return TRU; else return NIL; } /* min and max */ KlO KlMin(argc, argv) int argc; KlO *argv; { if (!argc) { return KlBadNumberOfArguments(argc); } else { KlO result = argv[0]; KlO *obj = argv + 1; while (--argc) { if (KlCompare(result, *obj) > 0) { result = *obj; } obj++; } return result; } } KlO KlMax(argc, argv) int argc; KlO *argv; { if (!argc) { return KlBadNumberOfArguments(argc); } else { KlO result = argv[0]; KlO *obj = argv + 1; while (--argc) { if (KlCompare(result, *obj) < 0) { result = *obj; } obj++; } return result; } } /* member of a list, or substring of a string: * returns position in list or string or NIL if not found */ KlO KlSeekKl(argc, argv) int argc; KlString *argv; { int offset; switch (argc) { case 2: offset = 0; break; case 3: KlMustBeNumber(argv[2], 2); offset = ((KlNumber)argv[2])->number; if (offset < 0) offset = 0; break; default: return KlBadNumberOfArguments(argc); } if (KlIsAList(argv[0])) { /* list */ KlList list = (KlList) argv[0]; KlO obj = (KlO) argv[1]; KlO *p = list->list + offset; KlO *last = list->list + list->size; while (p < last) { if (KlSend_equal(obj, *p) != NIL) return (KlO) KlNumberMake(p - list->list); p++; } return NIL; } else { /* substring of a string */ KlString string = argv[0]; KlString obj = argv[1]; char *p, *last; int length; KlMustBeString(string, 0); p = string->string + offset; last = string->string + KlStringLength(string); if (KlIsANumber(obj)) { char c = ((KlNumber)obj)->number; while (p < last) { if (*p++ == c) return (KlO) KlNumberMake(p - string->string - 1); } return NIL; } else { char c, *q, *lastq; int lengthq; KlMustBeString(obj, 1); if (!(lengthq = KlStringLength(obj))) return (KlO) KlNumberMake(0); q = obj->string + 1; c = *(obj->string); lastq = obj->string + lengthq; while (p < last) { if (c == *p++) { char *p2 = p; char *q2 = q; while (q2 < lastq) { if (*q2++ != *p2++) { goto not_substring; } } return (KlO) KlNumberMake(p - string->string - 1); } not_substring: ; } return NIL; } } } /* fast internal version */ int KlPosition(argc, argv, obj) int argc; KlO *argv; KlO obj; { int i = 0; while (i < argc) { if (argv[i] == obj) { return i; } i++; } return -1; } /* logical operations */ KlO KlNot(obj) KlO obj; { if (KlFalseP(obj)) return TRU; else return NIL; } KlO KlAnd(argc, argv) int argc; KlO argv[]; { int i; KlO evalobj = TRU; for (i = 0; i < argc; i++) { evalobj = KlSend_eval(argv[i]); if (KlFalseP(evalobj)) return NIL; } return evalobj; } KlO KlOr(argc, argv) int argc; KlO argv[]; { int i; KlO tmp; for (i = 0; i < argc; i++) { tmp = KlSend_eval(argv[i]); if (KlTrueP(tmp)) return tmp; } return NIL; } /*****************************************************************************\ * bitwise-operators * \*****************************************************************************/ KlO KlBitwiseOr(argc, argv) int argc; KlNumber argv[]; { int num = 0; while (argc--) num |= argv[argc]->number; return (KlO) KlNumberMake(num); } KlO KlBitwiseAnd(argc, argv) int argc; KlNumber argv[]; { int num = (argc ? argv[0]->number : -1); /* CL spec: (logand) ==> -1 */ while (argc--) num &= argv[argc]->number; return (KlO) KlNumberMake(num); } KlO KlBitwiseXor(argc, argv) int argc; KlNumber argv[]; { int num = 0; while (argc--) num ^= argv[argc]->number; return (KlO) KlNumberMake(num); } KlO KlBitwiseNot(klnum) KlNumber klnum; { return (KlO) KlNumberMake(~(klnum->number)); } KlO KlBitwiseShift(klnum, klshift) KlNumber klnum; KlNumber klshift; { return (KlO) KlNumberMake( klshift->number > 0 ? (klnum->number << klshift->number) : (klnum->number >> (- klshift->number))); } /* * Setq, the most important function * implemented as a method */ KlO KlSetq(atom, value) KlAtom atom; KlO value; { KlSend_setq_protectDECL; #ifdef NO_SETQ_ON_UNDEFS if (KlIsAnAtom(atom) && atom->c_val == KlUndef) { return KlError(KlE_UNDEFINED_VARIABLE, atom); } #endif return KlSend_setq_protect(atom, KlSend_eval(value)); } KlO KlSet(atom, value) KlAtom atom; KlO value; { return KlSend_setq(atom, value); } /* a user-friendly message if we cannot set an object (better than the * "no method" message */ /*ARGSUSED*/ KlO KlErrorCannotSet(obj, value) KlO obj; KlO value; { return KlError(KlE_CANNOT_SET, obj); } /* * boundp: tests if atom has already be defined */ KlO KlBoundp(obj) KlAtom obj; { KlMustBeSymbol(obj, 0); if (obj->c_val != KlUndef) return (KlO) obj; else return NIL; } /* * (progn inst1 ... instn) * evals the n instructions then return the last one's result */ KlO KlProgn(argc, argv) int argc; KlO *argv; { KlGCMark(); while (--argc > 0) { KlSend_eval(*argv); KlGC(); argv++; } if (argc) return NIL; /* argc wasn't > 0 at entry */ else return KlSend_eval(*argv); } /* * if "a la emacs" * if [test thenclause]* [elseclause] * nearly a COND, in fact */ KlO KlIf(argc, argv) int argc; KlO *argv; { KlO evalobj; while (argc > 1) { evalobj = KlSend_eval(*argv); if (KlTrueP(evalobj)) { return KlSend_eval(*(argv + 1)); } argc -= 2; argv += 2; } if (argc == 1) { return KlSend_eval(*argv); } else { return NIL; } } /* cond */ KlO KlCond(argc, argv) int argc; KlList *argv; { KlList *op = argv, *last = argv + argc; KlO result; KlO cond; while (op < last) { KlMustBeList((*op), op - argv); if ((*op)->size > 1) { cond = KlSend_eval(*((*op)->list)); if (KlTrueP(cond)) { return KlProgn((*op)->size - 1, (*op)->list + 1); } } else if ((*op)->size) { result = KlSend_eval(*((*op)->list)); if (KlTrueP(result)) return result; } op++; } return NIL; } /*****************************************************************************\ * loops * \*****************************************************************************/ /* * while cond inst1 ... instn * classical while */ KlO KlWhile(argc, argv) int argc; KlO *argv; { KlO cond; KlO *expr; KlO *last_expr = argv + argc; KlGCMark(); if (*argv != TRU) { while (cond = KlSend_eval(*argv), KlTrueP(cond)) { expr = argv+1; while (expr < last_expr) { KlSend_eval(*expr); KlGC(); expr++; } } } else { /* special optimisation for (while t */ for (;;) { expr = argv+1; while (expr < last_expr) { KlSend_eval(*expr); KlGC(); expr++; } } } return NIL; } /* * dolist: * (dolist (var list-of-values [result...]) instructions...) * WARNING: do not physically modify the list! */ KlO KlDolist(argc, argv) int argc; KlList *argv; { KlList list, varlist; KlO var, result; int i; int stackptr = KlStackPtr; KlDebugStackDecls; if (argc < 1) return KlBadNumberOfArguments((char *) argc); varlist = argv[0]; KlMustBeList(varlist, 0); if (varlist->size < 2) { return KlError0(KlE_BAD_DO_SYNTAX); /* "dolist" */ } var = varlist->list[0]; list = (KlList) KlSend_eval(varlist->list[1]); KlStackFramePush(1, &var, NIL,list); /* prevent list freeing */ KlDebugStackPush(KlSFID_normal, NIL); KlSend_dolist(list, var, argc-1, argv+1); if (varlist->size > 2) { result = KlProgn(varlist->size - 2, varlist->list + 2); } else { result = NIL; } KlDebugStackPop(); KlStackFramePopNormal(stackptr); return result; } /* dohash: * (dohash (key-var key-value hashtable) instructions...) * WARNING: do not physically modify the hashtable! */ KlO KlDohash(argc, argv) int argc; KlList *argv; { KlList table, varlist; KlO keyvar, valuevar; int i; int stackptr = KlStackPtr; KlO vart[2]; KlDebugStackDecls; if (argc < 1) return KlBadNumberOfArguments((char *) argc); varlist = argv[0]; KlMustBeList(varlist, 0); if (varlist->size != 3) { return KlError0(KlE_BAD_DO_SYNTAX); /* "dohash" */ } keyvar = varlist->list[0]; valuevar = varlist->list[1]; table = (KlList) KlSend_eval(varlist->list[2]); vart[0] = keyvar; vart[1] = valuevar; KlStackFramePush(2, vart, NIL, table); /* dont free table */ KlDebugStackPush(KlSFID_normal, NIL); KlSend_dohash(table, keyvar, valuevar, argc-1, argv+1); KlDebugStackPop(); KlStackFramePopNormal(stackptr); return NIL; } /* do: general loop constructs * (do ((var [init-value [step]])...) * (end-test results...) * instructions...) * WARNING: do not physically modify the list! */ KlO KlDo(argc, argv) int argc; KlList *argv; { KlList varlists; KlO *vars, *steps, *inits; KlO end_test; KlO endtestres; int v, varsize; int stackptr = KlStackPtr, stackptr2; KlO result; KlO *newvalues; KlStackSpace space; KlGCDecls; KlDebugStackDecls; if (argc < 2) return KlBadNumberOfArguments((char *) argc); varlists = argv[0]; KlMustBeList(varlists, 0); KlMustBeList(argv[1], 1); if (!(((KlList) argv[1])->size)) return KlError0(KlE_BAD_DO_SYNTAX); /* end-test */ end_test = ((KlList) argv[1])->list[0]; varsize = varlists->size; KlStackFramePush(0, 0, NIL, NIL); space = (KlStackSpace) KlAlloca(KlStackSpaceSizeof(varsize)); for (inits = space->list, steps = inits + varsize; inits <= steps; inits++) *inits = 0; /* fill space with 0 */ inits = space->list; space->type = 0; space->obj = (KlO) NIL; KlStack[KlStackPtr - KlSFO_ref] = (KlO) space; steps = KlAlloca(varsize); vars = KlAlloca(varsize); for (v = 0; v < varsize; v++) { /* init */ KlList varlist = (KlList) varlists->list[v]; KlMustBeList(varlist, v); switch (varlist->size) { case 1: KlIncRef(inits[v] = NIL); steps[v] = NIL; break; case 2: KlIncRef(inits[v] = KlSend_eval(varlist->list[1])); steps[v] = (KlO) KlQuotedExprMake(inits[v]); break; case 3: KlIncRef(inits[v] = KlSend_eval(varlist->list[1])); steps[v] = varlist->list[2]; break; default: return KlError0(KlE_BAD_DO_SYNTAX); /* do local variable */ } vars[v] = varlist->list[0]; } stackptr2 = KlStackPtr; KlStackFramePush(varsize, vars, NIL, NIL); KlDebugStackPush(KlSFID_normal, NIL); newvalues = KlAlloca(varsize); for (v = 0; v < varsize; v++) { KlSend_setq(vars[v], inits[v]); } KlGCSet(); while (endtestres = KlSend_eval(end_test), KlFalseP(endtestres)) { /* end-test */ KlProgn(argc - 2, argv + 2); /* forms */ for (v = 0; v < varsize; v++) { /* steps */ newvalues[v] = KlSend_eval(steps[v]); } for (v = 0; v < varsize; v++) { /* steps */ KlSend_setq(vars[v], newvalues[v]); } KlGC(); } result = KlProgn(((KlList) argv[1])->size - 1, ((KlList) argv[1])->list + 1); KlDebugStackPop(); KlStackFramePopNormal(stackptr2); KlStack[KlStackPtr - KlSFO_ref] = (KlO) NIL; for (inits = space->list;*inits;inits++) { KlDecRefNonNull(*inits); } KlStackFramePopNormal(stackptr); return result; } /* do* * KlDoSeq */ KlO KlDoSeq(argc, argv) int argc; KlList *argv; { KlList varlists; KlO *vars, *steps, *inits; KlO end_test; KlO endtestres; int v, varsize; int stackptr = KlStackPtr; KlO result; KlGCDecls; KlDebugStackDecls; if (argc < 2) return KlBadNumberOfArguments((char *) argc); varlists = argv[0]; KlMustBeList(varlists, 0); KlMustBeList(argv[1], 1); if (!(((KlList) argv[1])->size)) return KlError0(KlE_BAD_DO_SYNTAX); /* "do end-test" */ end_test = ((KlList) argv[1])->list[0]; vars = (KlO *) Malloc(sizeof(KlO) * 3 * varlists->size); steps = vars + varlists->size; inits = steps + varlists->size; varsize = varlists->size; for (v = 0; v < varsize; v++) { /* init */ KlList varlist = (KlList) varlists->list[v]; KlMustBeList(varlist, v); switch (varlist->size) { case 1: inits[v] = NIL; steps[v] = NIL; break; case 2: inits[v] = varlist->list[1]; steps[v] = (KlO) KlQuotedExprMake(inits[v]); break; case 3: inits[v] = varlist->list[1]; steps[v] = varlist->list[2]; break; default: Free(vars); return KlError0(KlE_BAD_DO_SYNTAX); /* "do local variable" */ } vars[v] = varlist->list[0]; } KlStackFramePush(varsize, vars, NIL, NIL); KlDebugStackPush(KlSFID_normal, NIL); for (v = 0; v < varsize; v++) { KlSend_setq_protectDECL; KlSend_setq_protect(vars[v], KlSend_eval(inits[v])); } KlGCSet(); while (endtestres = KlSend_eval(end_test), KlFalseP(endtestres)) { /* end-test */ KlProgn(argc - 2, argv + 2); /* forms */ for (v = 0; v < varsize; v++) { /* steps */ KlO temp = KlSend_eval(steps[v]); KlSend_setq(vars[v], temp); } KlGC(); } result = KlProgn(((KlList) argv[1])->size - 1, ((KlList) argv[1])->list + 1); KlDebugStackPop(); KlStackFramePopNormal(stackptr); Free(vars); return result; } /* dotimes: * (dotimes (var up-to [result...]) instructions...) */ KlO KlDoTimes(argc, argv) int argc; KlList *argv; { KlList varlist; KlO var, result; KlNumber klupper_bound; int i, upper_bound; int stackptr = KlStackPtr; KlGCDecls; KlDebugStackDecls; if (argc < 1) return KlBadNumberOfArguments((char *) argc); varlist = argv[0]; if (!KlIsAList(varlist)) { KlNumber num; if (KlIsANumber(varlist)) { num = (KlNumber) varlist; } else { num = (KlNumber) KlSend_eval(varlist); if (!KlIsANumber(num)) KlMustBeList(varlist, 0); } KlGCSet(); upper_bound = num->number; for (i = 0; i < upper_bound; i++) { KlProgn(argc - 1, argv + 1); } KlGC(); return NIL; } if (varlist->size < 2) { return KlError0(KlE_BAD_DO_SYNTAX); /* "dotimes" */ } var = varlist->list[0]; klupper_bound = (KlNumber) KlSend_eval(varlist->list[1]); KlMustBeNumber(klupper_bound, 1); upper_bound = (klupper_bound->number >= 0) ? klupper_bound->number : 0; KlStackFramePush(1, &var, NIL, NIL); KlDebugStackPush(KlSFID_normal, NIL); KlGCSet(); for (i = 0; i < upper_bound; i++) { KlSend_setq(var, KlNumberMake(i)); KlProgn(argc - 1, argv + 1); KlGC(); } if (varlist->size > 2) { result = KlProgn(varlist->size - 2, varlist->list + 2); } else { result = NIL; } KlDebugStackPop(); KlStackFramePopNormal(stackptr); return result; } /*****************************************************************************\ * file * \*****************************************************************************/ KlO KlDoLoadFile() { KlGCMark(); KlDoReadAndEval(); KlGC(); return NIL; } KlO KlDoDoLoadFile(continue_reading_on_error) int continue_reading_on_error; { KlO result; int normal; do { KlCatch(KlA_ERROR, KlDoLoadFile(), result, normal); } while (continue_reading_on_error && (!normal)); if (normal) return result; else return (KlO) KlA_ERROR; } /* KlLoadfile * loads a files (parses it) */ #ifdef ISM_CHECK #define MaxNumberOfOpenedFiles 10 #define MaxNumberOfReadedCharacters 30000 static int NumberOfOpenedFiles = 0; static int NumberOfReadedCharacters = 0; extern int ResetSession(); #endif /* ISM_CHECK */ int KlLoadfile(filename, fp) char *filename; FILE *fp; { if (fp) { KlStream stream, oldstream; int stackptr = KlStackPtr; #ifdef ISM_CHECK struct stat buf; #endif /* ISM_CHECK */ #ifdef CHECK_FILE_TYPE_ON_LOAD { int c = getc(fp); if (c == ';' || c == '(' || c == EOF) { /* valid */ fseek(fp, 0L, 0); /* rewind */ } else { /* invalid, error */ fclose(fp); return KlError1s(KlE_INVALID_LOAD_FILE, filename); } } #endif stream = KlStreamMake(fp, 1, filename); stream->parse_bufferized = 1; #ifdef ISM_CHECK NumberOfOpenedFiles++; fstat(KlFp2Fd(fp), &buf); NumberOfReadedCharacters += buf.st_size; #endif /* ISM_CHECK */ oldstream = KlStdyyRedirect(stream); KlStackFramePush(1, &KlA_star_package, NIL, NIL); KlUnwindProtectStatement(KlDoDoLoadFile(KlContinueReadingOnError), KlApplyUnary, KlStdyyRedirect, oldstream); KlStackFramePopNormal(stackptr); #ifdef ISM_CHECK if (KlIsReadingCrypted) { NumberOfOpenedFiles--; NumberOfReadedCharacters -= buf.st_size; } if (ResetSession (67) != 1 && ResetSession (93) != 1 ) /* MI TOOLKIT = 67 || 93 */ if (ResetSession (0) != 1) /* MI MAGIC */ if ((NumberOfOpenedFiles >= MaxNumberOfOpenedFiles) || (NumberOfReadedCharacters >= MaxNumberOfReadedCharacters)) { fprintf (stderr, "You are using a RUNTIME license of ISM.\nNumber of Sml files not crypted and/or not preparsed is limited.\nExiting ..."); putc ('\n', stderr); fflush (stderr); exit (10); } #endif /* ISM_CHECK */ return 1; } else { return 0; } } /* loadinfo * returns () or a list (pathname-of-file-being-loaded, line-number) */ KlO KlLoadfileInfo() { char *s; if (s = KlIsReadingFile()) { KlList list = KlListPairMake(KlStringMake(s), KlNumberMake(Klyylinenoget())); return (KlO) list; } else { return NIL; } } /*****************************************************************************\ * Calling Klone from C * \*****************************************************************************/ /* executes a given string, returns value * Do not do any GC, it is up to you to do it afterwards * traps all errors but returns 0 on error; */ KlO KlExecuteString(string) char *string; { KlO result; int normal; KlCatch(KlA_ALL, KlParseString(strlen(string), string, 1), result, normal); return normal ? result : 0; } /* same doing GCs, do not return any Klone value, only 1 (OK) or 0 (error); */ int KlExecuteStringNoReturn(string) char *string; { KlGCMark(); /* after redirect!!! */ KlO result = KlExecuteString(string); KlGC(); return result ? 1 : 0; } KlO KlProtectedLoadInput(oldstream) KlStream oldstream; { KlUnwindProtectStatement(KlDoDoLoadFile(KlContinueReadingOnError), KlApplyUnary, KlStdyyRedirect, oldstream); return 0; } /* executes a stream * recommended high-level routine: catches all tags */ int KlExecuteStream(stream) KlStream stream; { KlStream oldstream = KlStdyyRedirect(stream); KlO result; int normal; KlCatch(KlA_ALL, KlProtectedLoadInput(oldstream), result, normal); return normal; } /* same callable from klone */ KlO KlExecuteStringKl(string) KlString string; { KlO result; KlMustBeString(string, 0); return (result = KlExecuteString(string->string)) ? result : NIL; } /***************************************************************** callbacks */ /* KlExecuteKloneNoReturn * executes a call back (array of the callbacks and its arguments) * returns 0 if OK or 1 if an error occured */ int KlExecuteKloneNoReturn(argc, argv) int argc; KlO *argv; { int normal = 1; KlO result; if (argc) { KlGCMark(); KlCatch(KlA_ALL, KlSend_apply(argv[0], KlListKl(argc, argv)), result, normal); KlGC(); } return !normal; } /* KlExecuteKlone * executes a call back (array of the callbacks and its arguments) * returns the result which is kept in static storage and will be overwritten * at next call of KlExecuteKlone * returns 0 in case of error */ KlO KlExecuteKlone(argc, argv) int argc; KlO *argv; { int normal = 0; static KlO KlExecuteKloneResult; KlGCMark(); KlDecRef(KlExecuteKloneResult); if (argc) { KlCatch(KlA_ALL, KlSend_apply(argv[0], KlListKl(argc, argv)), KlExecuteKloneResult, normal); } if (!normal) KlExecuteKloneResult = NIL; KlIncRef(KlExecuteKloneResult); KlGC(); return (normal ? KlExecuteKloneResult : 0); } /****************************************************************** file ops */ /* * tests if file exists and is readable and a regular file (not directory) */ int KlFileExists(name) char *name; { /* Should detect if the file is a regular file, not a directory */ struct stat sbuf; return ((stat(name, &sbuf)) >= 0 /* exists */ && (sbuf.st_mode & S_IFMT) == S_IFREG); /* andregular file */ } #define KlEXT_NORMAL 1 #define KlEXT_ALL 1 /* tests if filename ends with an extension */ int KlFileEndsWith(filename, filelen, extname, extlen) char *filename; int filelen; char *extname; int extlen; { if ((filelen > extlen) && (!strncmp(filename + filelen - extlen, extname, extlen))) { return KlEXT_NORMAL; } return 0; } int KlFileIsHere(klfilename_kl, fpp, what) KlString klfilename_kl; FILE **fpp; int what; { if (what & KlEXT_NORMAL) { /* check if file is there and not a dir */ if (KlFileExists(klfilename_kl->string) && (*fpp = fopen(klfilename_kl->string, "r"))) { return 1; } } return 0; } /* * KlFileWithOptionalExtension: * see if file exists with extension * returns a KlString of actual name, or NULL */ KlString KlFileWithOptionalExtension(filename, fpp) char *filename; FILE **fpp; { KlString klfilename_kl = KlStringNMake(KlMAX_TEMP_STRING_SIZE); char *filename_kl = klfilename_kl->string; char *p; KlList list = (KlList) KlSend_eval(KlA_load_ext); int i, l; KlCurVariable = KlA_load_ext; KlMustBeList(list, -1); strcpy(filename_kl, filename); l = strlen(filename_kl); klfilename_kl->size = l; p = filename_kl + l; if (!l) return 0; for (i = 0; i < list->size; i++) { /* iterate on file extensions */ KlString ext = (KlString) list->list[i]; KlCurVariable = KlA_load_ext; KlMustBeString(ext, -1); if (ext->string[0]) { /* non-void extension */ /* check if extension is not already here */ int le = KlStringLength(ext); switch (KlFileEndsWith(filename_kl, l, ext->string, le)) { case 1: /* ends with extension */ if (KlFileIsHere(klfilename_kl, fpp, KlEXT_ALL)) return klfilename_kl; default: /* dont end with extension, add */ strcpy(p, ext->string); klfilename_kl->size = l + le; if (KlFileIsHere(klfilename_kl, fpp, KlEXT_ALL)) return klfilename_kl; } } else { /* void extension */ if (KlFileIsHere(klfilename_kl, fpp, KlEXT_NORMAL)) return klfilename_kl; } klfilename_kl->size = l; *p = '\0'; } return 0; } /* * KlFileInPath: * find file with using path, extensions, etc... * complete_filename is a pointer to temporary space * extensions are appended even on absolute pathnames */ KlString KlFileInPath(filename, complete_filename, fpp) char *filename, *complete_filename; FILE **fpp; { KlString klname; int i; KlList list = (KlList) KlSend_eval(KlA_load_path); KlCurVariable = KlA_load_path; KlMustBeList(list, -1); if (filename[0] == '/') { /* absolute pathname */ return KlFileWithOptionalExtension(filename, fpp); } else if (filename[0] == '~') { /* home-relative absolute path */ KlString klfilename_kl = KlExpandTildeForFiles(filename); return KlFileWithOptionalExtension(klfilename_kl->string, fpp); } else { /* relative pathname */ for (i = 0; i < list->size; i++) { /* iterate on directories */ KlString s = (KlString) list->list[i]; char *p; KlCurVariable = KlA_load_path; KlMustBeString(s, -1); if (s->string[0] == '~') { KlDecRef(s); s = KlExpandTildeForFiles(s->string); KlIncRef(list->list[i] = (KlO) s); } p = stpcpy(complete_filename, s->string); if (p > complete_filename && p[-1] != '/') p = stpcpy(p, "/"); p = stpcpy(p, filename); if (klname = KlFileWithOptionalExtension(complete_filename, fpp)) return klname; } return 0; } } /* KlExpandTildeForFiles * returns the expanded filename into a newly allocated KlString */ KlString KlExpandTildeForFiles(filename) char *filename; { char username[20]; char *p; KlString klfilename_kl = KlStringNMake(KlMAX_TEMP_STRING_SIZE); char *filename_kl = klfilename_kl->string; struct passwd *user; if (filename[1] == '/') { strcpy(stpcpy(stpcpy(filename_kl, KlHomeDir), "/"), filename + 2); } else if (filename[1]) { strncpy(username, filename + 1, 20); if (p = strchr(username, '/')) *p = '\0'; else username[19] = '\0'; user = getpwnam(username); if (user) { strcpy(filename_kl, user->pw_dir); if (p = strchr(filename, '/')) { strcat(filename_kl, p); } } else { strcpy(filename_kl, filename); } } else { return KlStringMake(KlHomeDir); } KlStringFixLength(klfilename_kl); return klfilename_kl; } /* klone interface to KlExpandTildeForFiles */ KlO KlExpandTildeForFilesKl(filename) KlString filename; { KlMustBeString(filename, 0); if (filename->string[0] == '~') { return (KlO) KlExpandTildeForFiles(filename->string); } else { return (KlO) filename; } } /* C interface to KlExpandTildeForFiles * returns a C string that will be garbaged at next GC call, or the string * if it did not began by ~ */ char * KlExpandTildeForFilesC(filename) char *filename; { if (*filename == '~') { return KlExpandTildeForFiles(filename)->string; } else { return filename; } } /* klone interface to KlFileInPath */ KlO KlFileInPathKl(string) KlString string; { char temp_filename[KlMAX_TEMP_STRING_SIZE]; KlString actual_pathname; FILE *fp = 0; KlMustBeString(string, 0); actual_pathname = KlFileInPath(string->string, temp_filename, &fp); if (fp) fclose(fp); if (actual_pathname) { return (KlO) actual_pathname; } else { return NIL; } } /*****************************************************************************\ * "load" * \*****************************************************************************/ /* loading a file (callable from klone) * (load filename [:if-does-not-exist action]) * Loads and executes the file given in the filename string argument, * searching through the path specified by *load-pathname*. * The default value of the variable *load-pathname* is specified by the * shell variable named KLONEPATH. * Returns the actual file loaded as a string if it was found, otherwise it * depends of the keyword :if-does-not-exist: * - If the keyword is not provided or its the value is * :error -> signals an error. * - otherwise its value is evaluated and returned * Searches first for the filename.suffix then filename in each directory * in the path. If the filename includes a / character, the file is not * searched through the path. If any error occurs while the file is being read. * Klone displays the error message and aborts the reading of the file. */ KlO KlLoadKl(argc, argv) int argc; KlO *argv; { char temp_filename[KlMAX_TEMP_STRING_SIZE]; KlString string; KlString actual_pathname; FILE *fp = 0; KlO if_does_not_exist; if (!argc) KlBadNumberOfArguments(argc); string = (KlString) argv[0]; KlMustBeString(string, 0); actual_pathname = KlFileInPath(string->string, temp_filename, &fp); KlParseKeywords(argc, argv, 1); if_does_not_exist = KlKeyVal(KlK_if_does_not_exist, (KlO) KlK_error); KlCheckUnvalidKeywords(argc, argv, 1); /* note: we dont need to close fp since KlLoadfile makes a Stream out of * it, that will be closed by the stream GC */ if (actual_pathname && KlLoadfile(actual_pathname->string, fp)) { return (KlO) actual_pathname; } else { /* error */ if (if_does_not_exist == (KlO) KlK_error) return KlError(KlE_CANNOT_LOAD_FILE, string); else return KlSend_eval(if_does_not_exist); } } /* old back-compat function */ KlO KlLoad(string) KlString string; { return KlLoadKl(1, &string); } KlO KlLoadSilent(string) KlString string; { KlO args[3]; args[0] = (KlO) string; args[1] = (KlO) KlK_if_does_not_exist; args[2] = NIL; return KlLoadKl(3, args); } /*****************************************************************************\ * hack * \*****************************************************************************/ /* KlNumber2KlO: * used to read back "unprintable" objects from their memory location * converts second argument (number) to a klone object * first argument is ignored */ KlO KlNumber2KlO(argc, argv) int argc; KlNumber *argv; { if (argc < 2) return KlBadNumberOfArguments((char *) argc); KlMustBeInteger(argv[1], 1); return (KlO) argv[1]->number; } /* companion function: * how to print objects in a generic readable-back form: */ KlO KlDefaultPrint(obj, stream) KlO obj; KlStream stream; { KlSPrintf(stream,"{^ %s ", KlTypeCName(obj->type)); KlSPrintf(stream,"0x%x}", obj); return (KlO) obj; } /* * if object is from type, ok. * if not, evaluates it and call KlError if result is still not * YOU MUST check reference on result when no longer needed! * NOTE: NIL is accepted as valid and returned as-is */ KlO KlTypeOrEvaluate(object, type) KlO object; KlType type; { if (KlFalseP(object) || (object->type == type)) return object; if (((object = KlSend_eval(object))->type == type) || KlFalseP(object)) return object; return KlBadArgument(object, 0, KlTypeCName(type)); } KlUserEnd(argc, argv) int argc; KlNumber *argv; { KlExit(argc ? (*argv)->number : 0); } /* KlExit: clean way to exit process */ KlExit(n) int n; { #ifdef MONITOR KlMonControlled = 0; moncontrol(0); /* do not trace ending code */ #endif /* MONITOR */ #ifdef KLPROFILER KlProfilerDumpNames(); #endif #ifdef KLSES KlSesEnd(); #endif KlFlush(0); /* flush output before ending */ KlExecuteHook(KlA_exithook, 0, 0); /* execute user hoooks */ KlKillChildren(); KlEnd(n); /* perform application-defined stuff */ exit(n); } /* KlApplyUnary * useful for calling KlUnwindProtect on single-arg functions * this is NOT a general purpose function! will only work on subrs, non Exprs! */ KlO KlApplyUnary(method, arg) KlMethod method; KlO arg; { return CFAPPLY(method, (arg)); } /* KlObjectIsValid * tests if object is a valid klone object,i.e if we can do a send on it */ int KlObjectIsValid(obj) KlO obj; { KlType t; if (obj #ifdef DO_NOT_REDEFINE_MALLOC # ifndef USE_STANDARD_MALLOC && KlOIsInMallocSpace(obj) # endif /* !USE_STANDARD_MALLOC */ #else /* !DO_NOT_REDEFINE_MALLOC */ # ifndef USE_STANDARD_MALLOC && ((char *) obj) >= KlMallocZoneBegin && ((char *) obj) < KlMallocZoneEnd # endif /* !USE_STANDARD_MALLOC */ #endif /* DO_NOT_REDEFINE_MALLOC */ #ifndef USE_STANDARD_MALLOC && *((int *) obj) != KlFREED_MAGIC && *((int *) obj) != KlUNINIT_MAGIC #endif /* !USE_STANDARD_MALLOC */ && (t = obj->type) #ifdef DO_NOT_REDEFINE_MALLOC # ifndef USE_STANDARD_MALLOC && KlOIsInMallocSpace(t) # endif /* !USE_STANDARD_MALLOC */ #else /* !DO_NOT_REDEFINE_MALLOC */ # ifndef USE_STANDARD_MALLOC && ((char *) t) >= KlMallocZoneBegin && ((char *) t) < KlMallocZoneEnd # endif /* !USE_STANDARD_MALLOC */ #endif /* DO_NOT_REDEFINE_MALLOC */ #ifndef USE_STANDARD_MALLOC && *((int *) t) != KlFREED_MAGIC && *((int *) t) != KlUNINIT_MAGIC #endif /* !USE_STANDARD_MALLOC */ && KlTypeTypeGet(t) == KlTypeType ) return 1; else return 0; } #ifndef USE_STANDARD_MALLOC #ifdef DO_NOT_REDEFINE_MALLOC int KlOIsInMallocSpace(p) char *p; { if (p < KlMallocZoneBegin) { /* horrible guesswork */ if (!KlMallocZoneBegin) { return 1; /* dont check yet */ } else { return 0; } } if (p >= KlMallocZoneEnd) { #ifndef DO_NOT_USE_SBRK KlMallocZoneEnd = (char *) sbrk(0); /* adjust end */ #endif if (p >= KlMallocZoneEnd) { return 0; } } return 1; } #endif /* DO_NOT_REDEFINE_MALLOC */ #endif /* USE_STANDARD_MALLOC */ /*****************************************************************************\ * hooks * \*****************************************************************************/ /* emacs-like hooks triggerable from C code * * hooks are variables that can contain: * - undefined or () : nothing is done * - a lambda : is applied to arguments * - a vector : each element is applied to hook args (if a lambda) or * evaluated to hook arguments, thus comments are * allowed as strings * * Anything else is just evaluated. * KlExecuteHook traps all exits. returns () if Ok, or t if a jump attempted * or error triggered in an hook */ KlO KlExecuteHook(hookvar, argc, argv) KlAtom hookvar; /* the hook variable itself */ int argc; /* number of arguments */ KlO *argv; /* arguments supplied to lambdas via KlApplyN*/ { KlO result = NIL; if (hookvar->c_val != NIL && hookvar->c_val != KlUndef) { /* unset */ if (KlIsAVector(hookvar->c_val)) { /* vector of hooks */ int i = 0; for (; i < ((KlVector)(hookvar->c_val))->size; i++) { if (!KlExecuteHookValue(((KlVector)(hookvar->c_val))->list[i], argc, argv)) result = TRU; } } else { /* one hook */ if (!KlExecuteHookValue(hookvar->c_val, argc, argv)) result = TRU; } } return result; } int KlExecuteHookValue(hook, argc, argv) KlO hook; int argc; /* for KlApplyN */ char *argv; { int normal; KlO result; KlGCMark(); KlCatch(KlA_ALL, ((KlIsAnAtom(hook) ? hook = KlSend_eval(hook) : NIL), /* atom: eval once */ (KlIsAFunction(hook) ? KlApplyN(hook, argc, argv) /* apply functions */ : KlSend_eval(hook) /* eval rest */ )) , result, normal); KlGC(); return normal; } /*****************************************************************************\ * object p-lists * \*****************************************************************************/ #ifdef KlHOOK_NUMBER void KlHookInit() { int i; for (i = 0; i < KlHookNumber; i++) { KlIncRef(klHookHashTableArray[i] = (KlO) KlHashMake(NIL)); /* implicitly: ref_counted = 1; */ } /* KlH_plists= klHookHashTableArray[0]; *//* object plists */ } void KlFreeHooks(obj) KlO obj; { int hookMasks = (int) KlClassMethod(obj->type, KlSelHookMask); int i, j; if (hookMasks) { for (i = 0, j = 1; i < KlHookNumber; i++, j = j << 1) { if (j & hookMasks) KlHashDelete(klHookHashTableArray[i], obj); } } } void KlHookSet(hookNumber, obj, hookValue) int hookNumber; KlO obj; KlO hookValue; { int hookMask = (int) KlClassMethod(obj->type, KlSelHookMask); hookMask |= (1 << hookNumber); KlDeclareMethod1(obj->type, KlSelHookMask, (KlMethod) hookMask); KlHashPut(klHookHashTableArray[hookNumber], obj, hookValue); } KlO KlHookGet(hookNumber, obj, defaultValue) int hookNumber; KlO obj; KlO defaultValue; { return KlHashGet(klHookHashTableArray[hookNumber], obj, defaultValue); } #endif /* KlHOOK_NUMBER */ /* (object-plist object [plist]) * get (set to plist if plist given) the property list of an object * for this to work, the plist field of the C structure of the object must * be declared after type declaration by a call to: * KlDeclarePlistSlot(type_object, C_type, name_of_the_field); * e.g., for atoms: * KlDeclarePlistSlot(KlAtomType, KlAtom, p_list); * dont forget in your C code to: * [1] initialize the field in instances to 0 * [2] perform a KlDecRef on the field in the Free method */ KlO KlObjectPListKl(argc, argv) int argc; KlO *argv; { UInt offset; if (offset = (UInt) KlTypePlistGet(argv[0]->type)) { KlO *slot = (KlO *) (((UInt) argv[0]) + offset); switch (argc) { case 1: /* get */ if (! *slot) { KlIncRef( *slot = (KlO) KlListNMake(0)); } return *slot; case 2: /* set */ KlDecRef(*slot); KlIncRef(*slot = argv[1]); return *slot; } return KlBadNumberOfArguments(argc); } else { /* this type dont have a plist */ return KlError2(KlE_NO_ELEMENT, KlIntern("plist"), argv[0]); } } /* KlDocumentation * get or set documentation string of a symbol. * begin to look for doc string of symbol, and if not found to doc string of * value of symbol */ KlO KlDocumentationSet(obj, string) KlAtom obj; KlString string; { KlO plist = obj->p_list; if (!plist) { KlIncRef(plist = obj->p_list = (KlO) KlListNMake(0)); } KlSend_put(plist, KlA_documentation, string); return (KlO) string; } KlO KlDocumentationClear(obj) KlAtom obj; { KlO plist = obj->p_list; if (plist) { KlListDelete(plist, KlA_documentation); } return NIL; } KlO KlDocumentationGet(obj) KlAtom obj; { KlO plist = obj->p_list; if (plist) { return KlSend_get(plist, KlA_documentation, NIL); } else { return NIL; } } KlO KlDocumentation(argc, argv) int argc; KlAtom *argv; { if (argc) KlMustBeSymbol(argv[0], 0); switch (argc) { case 1: return KlDocumentationGet(argv[0]); case 2: KlDocumentationSet(argv[0], argv[1]); return (KlO) argv[1]; } return KlBadNumberOfArguments(argc); } /*****************************************************************************\ * Profiling * \*****************************************************************************/ #ifdef MONITOR /* (moncontrol t) turns on recording of profiling, * (moncontrol ()) turns it off */ KlO KlMonControl(flag) KlO flag; { if (KlFalseP(flag)) { KlMonControlled = 0; moncontrol(0); } else { KlMonControlled = 1; moncontrol(1); } return flag; } #endif /* MONITOR */ /**************************************************************************\ * Extensions * \**************************************************************************/ int KlExtensionIsDeclared(name) char *name; { int i; for (i = 0; i < KlExtensionsSize; i++) { if (!strcmp(KlExtensions[i].name, name)) { return i+1; } } return 0; } KlDeclareExtension(name, selectors_initfunc, types_initfunc, profile_initfunc) char *name; /* name of extension */ int (*selectors_initfunc)(); /* init of selectors */ int (*types_initfunc)(); /* init of types */ int (*profile_initfunc)(); /* klone level inits */ { int i = KlExtensionIsDeclared(name); if (i) { i--; } else { i = KlExtensionsSize; if (KlExtensionsSize) { KlExtensionsSize++; KlExtensions = (KlExtension) Realloc(KlExtensions, KlExtensionsSize * sizeof(struct _KlExtension)); } else { KlExtensionsSize++; KlExtensions = (KlExtension) Malloc(sizeof(struct _KlExtension)); } } KlExtensions[i].name = name; KlExtensions[i].selectors = selectors_initfunc; KlExtensions[i].types = types_initfunc; KlExtensions[i].profile = profile_initfunc; } /*****************************************************************************\ * * * INITIALISATION: * * to be called before everything else * * * \*****************************************************************************/ /* checks that the initialization process is at the correct state */ KlMustBeAtInitState(min, max) int min; int max; { if (KlInitState < min && KlInitState > max) (*KlFatalError)(7, KlInitState); } /* KlInitState: * 0 = nothing * 16 after KlMalloc * 32 first part of KlInit (selector declarations) * 48 2nd part of KlInit (type declarations) * 64 3rd part of KlInit (function declarations) * 80 4th part of KlInit (profile reading) * 96 end of KlInit */ /* KlDeclareCommandLineArguments * used to set the *arguments* klone list of arguments passed to commands. * should be part of appl_inits parameter of KlInit if to be used from the * user profile, or can be called after KlInit is called if to be set after * user profile */ KlDeclareCommandLineArguments(argc, argv) int argc; char **argv; { int i; KlList arglist = KlListNMake(argc); KlListStoreDReset(arglist); for (i = 0; i< argc; i++) { KlListStoreAdd(KlStringMake(argv[i])); } KlDeclareAtom("*arguments*", arglist); } /* KlParsePath * takes a unix-style path as a C string and returns a list. * separator is the char code separating paths, e.g.: ':' */ KlList KlParsePath(path, separator) char *path; int separator; { int i = 1; char *p = path, *q; KlList pathl; while (p = strchr(p, separator)) i++, p++; pathl = (KlList) KlListNMake(i); p = (char *) Malloc(strlen(path) + 1); strcpy(p, path); while (q = strrchr(p, separator)) { KlListStore(pathl, --i, KlExpandTildeForFilesKl(KlStringMake(q + 1))); *q = '\0'; } KlListStore(pathl, 0, KlExpandTildeForFilesKl(KlStringMake(p))); Free(p); return pathl; } /* * KlInit returns 0 if all is ok * It calls its parameter function if not NULL, just before reading user * profile. Used by GWM for setting default keywords */ int KlInit() { int i; KlAtom load_atom; KlMustBeAtInitState(16, 31); KlInitState = 32; { /* Version number */ char *p = strchr(KlRCSVersionNumber, ':') + 2; int l = strlen(p); KlVersionNumber = (char *) Malloc((size_t) (l - 1)); strncpy(KlVersionNumber, p, (size_t) (l - 2)); KlVersionNumber[l - 2] = '\0'; } /* initialize tables */ KlFatalError = KlFatalErrorDefaultHandler; KlDeclareBuiltInTraits(); KlInitPredefinedSelectors(); /* built-ins */ for (i = 0; i < KlExtensionsSize; i++) /* extensions */ if (KlExtensions[i].selectors) CFAPPLY((KlExtensions[i].selectors), ()); KlInitState = 48; KlZrtInit(); /* initialize types */ KlTypesInit(); KlAtomInit(); /* built-ins. atoms must come first */ KlInitState = 56; KlFuncInit(); KlListInit(); KlNumberInit(); KlStringInit(); KlStreamInit(); KlNetInit(); KlHashInit(); KlErrorInit(); KlCollectionInit(); #ifdef KlHOOK_NUMBER KlHookInit(); #endif KlLinkInit(); KlKoInit(); KlStructInit(); KlGenericInit(); /* init sequence funcs */ KlCoerceInit(); /* init all coercions */ KlOSInit(); KlMathInit(); #ifdef KLDLOAD KlDlInit(); /* Dynamic Loading (optional) */ #endif #ifdef KLSES KlSesInit(); #endif /* KLSES */ #ifdef KLPROFILER KlProfilerInit(); #endif #ifdef DEBUG KlIncRef(KlListOfBuiltInTypes = (KlList) KlTypesList()); #endif for (i = 0; i < KlExtensionsSize; i++) /* extensions */ if (KlExtensions[i].types) CFAPPLY((KlExtensions[i].types), ()); KlInitState = 64; KlSignalsInit(); /* intitialise predefined functions (Subrs) */ KlA_get = (KlAtom) KlDeclareSubr(KlGet, "get", NARY); KlDeclareSubr(KlGetN, "getn", 2); KlA_put = (KlAtom) KlDeclareSubr(KlPut, "put", 3); KlA_delete = (KlAtom) KlDeclareSubr(KlDelete, "delete", 2); KlA_insert = (KlAtom) KlDeclareSubr(KlInsert, "insert", 3); KlA_add = (KlAtom) KlDeclareSubr(KlAdd, "+", NARY); KlDeclareSubr(KlCoerce, "coerce", 2); KlA_documentation = (KlAtom) KlDeclareSubr(KlDocumentation, "documentation", NARY); KlDeclareSubr(KlObjectPListKl, "object-plist", NARY); KlDeclareSubr(KlUserEnd, "exit", NARY); KlA_progn = (KlAtom) KlDeclareFSubr(KlProgn, "progn", NARY); KlDeclareSubr(KlTypep, "typep", 2); KlDeclareSubr(KlSubtypep, "subtypep", 2); KlDeclareSubr(KlExecuteStringKl, "execute-string", 1); KlDeclareFSubr(KlDefConstant, "defconstant", NARY); KlDeclareFSubr(KlDefVar, "defvar", NARY); KlDeclareFSubr(KlRedefConstant, "redefconstant", 2); KlDeclareFSubr(KlKloneActiveMake, "defactive", 4); KlDeclareSubr(KlSymbolSlotMake, "*:symbol-slot", 1); KlDeclareSubr(KlPrintNary, "?", NARY); KlA_setq = (KlAtom) KlDeclareFSubr(KlSetq, "setq", 2); KlAtomSetq(KlA_assign, KlA_setq->c_val); /* := synonym of setq */ KlDeclareSubr(KlSet, "set", 2); KlDeclareSubr(KlAtomUnbind, "makunbound", 1); KlDeclareSubr(KlTypeOf, "type-of", 1); KlDeclareSubr(KlTypeNameKl, "type-name", 1); KlDeclareSubr(KlInternKl, "intern", 1); KlDeclareSubr(KlAtomOf, "atom-of", 1); KlDeclareSubr(KlEq, "eq", 2); KlA_equal = (KlAtom) KlDeclareSubr(KlEqual, "=", 2); KlDeclareSubr(KlNotEqual, "/=", 2); KlDeclareSubr(KlGreaterThan, ">", 2); KlDeclareSubr(KlGreaterOrEqualThan, ">=", 2); KlDeclareSubr(KlLesserThan, "<", 2); KlDeclareSubr(KlLesserOrEqualThan, "<=", 2); KlDeclareSubr(KlCompareKl, "compare", 2); KlDeclareSubr(KlNot, "not", 1); KlDeclareFSubr(KlAnd, "and", NARY); KlDeclareFSubr(KlOr, "or", NARY); KlA_eval = (KlAtom) KlDeclareSubr(KlEval, "eval", 1); KlDeclareFSubr(KlFlushGC, "flush-gc", 1); KlDeclareSubr(KlBoundp, "boundp", 1); KlA_copy = (KlAtom) KlDeclareSubr(KlCopy, "copy", 1); KlDeclareSubr(KlSeekKl, "seek", NARY); KlDeclareFSubr(KlIf, "if", NARY); KlDeclareSubr(KlBitwiseAnd, "logand", NARY); KlDeclareSubr(KlBitwiseOr, "logior", NARY); KlDeclareSubr(KlBitwiseXor, "logxor", NARY); KlDeclareSubr(KlBitwiseNot, "lognot", 1); KlDeclareSubr(KlBitwiseShift, "logshift", 2); KlDeclareSubr(KlMin, "min", NARY); KlDeclareSubr(KlMax, "max", NARY); KlDeclareFSubr(KlWith, "with", NARY); KlDeclareFSubr(KlWithEval, "with-eval", NARY); KlDeclareFSubr(KlWhile, "while", NARY); KlDeclareFSubr(KlDolist, "dolist", NARY); KlDeclareFSubr(KlDohash, "dohash", NARY); KlDeclareFSubr(KlDo, "do", NARY); KlDeclareFSubr(KlDoSeq, "do*", NARY); KlDeclareFSubr(KlCond, "cond", NARY); KlDeclareFSubr(KlDoTimes, "dotimes", NARY); KlDeclareFSubr(KlQuote, "quote", 1); KlDeclareSubr(KlQuote, "identity", 1); KlDeclareFSubr(KlBackquote, "`", 1); KlDeclareSubr(KlFileInPathKl, "find-file", 1); KlDeclareSubr(KlExpandTildeForFilesKl, "expand-filename", 1); load_atom = (KlAtom) KlDeclareSubr(KlLoadKl, "load", NARY); KlDeclareFSubr(KlLoadfileInfo, "loadinfo", 0); KlDeclareFSubr(KlDoAllSymbols, "do-all-symbols", NARY); KlDeclareSubr(KlTypeReplace, "type-replace", 2); KlDeclareSubr(KlTypeFatherKl, "type-father", 1); KlA_lambda = (KlAtom) KlDeclareFSubr(KlLambda, "lambda", NARY); KlA_lambdaq = (KlAtom) KlDeclareFSubr(KlLambdaq, "lambdaq", NARY); KlA_lambdam = (KlAtom) KlDeclareFSubr(KlLambdam, "lambdam", NARY); KlDeclareFSubr(KlTypesList, "types-list", 0); KlA_length = (KlAtom) KlDeclareSubr(KlLength, "length", 1); KlDeclareSubr(KlHashKl, "*:hash", 1); KlDeclareSubr(KlPoolKl, "read-lines-pooled", NARY); /*----*/ /* type constructors */ KlDeclareFSubr(KlNumber2KlO, "^", NARY); /************************************************** OLD FUNCTIONS BEGIN HERE */ { /* KLONE-specific features */ /* := hack to be an atom not a keyword */ KlAtom assign = KlInternBytes(2, ":="); KlAtomInternalsFree(assign); assign->type = KlConstantType; assign->unbound = 0; KlIncRef(assign->c_val = KlA_setq->c_val); } KlDeclareFSubr(KlMallocStats, "*:memory", 0); #ifdef STATS KlDeclareFSubr(zrtstats, "gcinfo", 0); KlDeclareFSubr(KlCfstats, "klcfinfo", 0); KlDeclareFSubr(KlHashstats, "hashinfo", 0); #endif /* STATS */ #ifdef DEBUG KlDeclareFSubr(KlCBreak, "cbreak", NARY); #else /* DEBUG */ KlDeclareFSubr(NIL_FUNC, "cbreak", NARY); #endif /* DEBUG */ #ifdef DEBUG2 KlActiveMake("trace-all-c", KlGetTrace, KlSetTrace, 0); #endif #ifdef MONITOR KlDeclareSubr(KlMonControl, "moncontrol", 1); #endif /* MONITOR */ KlA_print_readably = (KlAtom) KlActivePointerToBooleanMake("*print-readably*", &KlPrintReadably); KlActivePointerToBooleanMake("*print-format-old-behavior*", &KlPrintFormatOldBehavior); KlActivePointerToBooleanMake("*print-binary*", &KlPrintBinary); KlActivePointerToBooleanMake("*print-readably-as-raw-strings*", &KlPrintAsRawStrings); KlActivePointerToBooleanMake("*quote-newlines*", &KlQuoteNewlines); KlActivePointerToBooleanMake("*SIGHUP-on-exit*", &KlSIGHUPOnExit); KlActivePointerToIntMake("*print-level*", &KlMaxPrintLevel); KlActivePointerToObjMake("*last-caught-tag*", &KlLastCaughtTag); KlActivePointerToIntMake("*continue-reading-on-error*", &KlContinueReadingOnError); KlActivePointerToIntMake("*real-precision*", &KlRealPrecision); KlActivePointerToIntMake("*quote-inlines*", &KlQuoteInlines); KlActivePointerToBooleanMake("*infix-assigns*", &KlInfixAssigns); KlA_KlVersionNumber = (KlAtom) KlConstantMake("*version*", KlStringMake(KlVersionNumber)); KlA_KlApplicationName = (KlAtom) KlConstantMake("*application-name*", KlStringMake(KlApplicationName)); KlConstantMake("*:hash-version", KlNumberMake(KlHashVersionNumber)); KlMachineName = MACHINE_TYPE; KlA_KlMachineName = (KlAtom) KlConstantMake("*machine*", KlIntern(KlMachineName)); KlConstantMake("*:load", load_atom->c_val); /* backup */ #ifdef MLEAK { extern KlO MLEAK_printKl(); extern int MLEAK_on, MLEAK_num, MLEAK_count; KlActivePointerToIntMake("mleak", &MLEAK_on); KlActivePointerToIntMake("mleak-num", &MLEAK_num); KlActivePointerToIntMake("mleak-count", &MLEAK_count); KlDeclareFSubr(MLEAK_printKl, "mleak-print", 0); } #endif #ifdef MALLOCDEBUG KlDeclareSubr(KlMDCheckKl, "mcheck", NARY); #endif #ifdef NO_SETQ_ON_UNDEFS KlSend_setq(KlA_star_package, NIL); #endif /* paths... */ if (!(KlHomeDir = (char *) getenv("HOME"))) { KlHomeDir = "."; } if (!KlPath) { KlPath = ".:kl:/usr/local/lib/klone"; } /* computes *load-pathname* */ #ifdef WIN32 KlAtomSetq(KlA_load_path, KlParsePath(KlPath, ';')); #else /* !WIN32 */ KlAtomSetq(KlA_load_path, KlParsePath(KlPath, ':')); #endif /* !WIN32 */ if (!KlTextExtension) { KlTextExtension = ".kl"; } { KlList ext = (KlList) KlListPairMake(KlStringMake(KlTextExtension), KlStringMake(0)); KlSend_setq(KlA_load_ext, ext); } /* misc initialisations */ KlStdyyInit(); /* init parse stream to stdin */ /* here do client inits before the profile is read */ KlDeclareAtom("*extensions*", KlExtensionList = KlListNMake(0))->type = KlConstantType; for (i = 0; i < KlExtensionsSize; i++) {/* extensions */ KlListAppend(KlExtensionList, KlIntern(KlExtensions[i].name)); if (KlExtensions[i].profile) CFAPPLY((KlExtensions[i].profile), ()); } if (KlExtensionsSize) Free(KlExtensions); KlInitState = 80; /* first time, load the user file */ KlErrorStatus = 0; KlZrtGc(0); if (KlUserProfileName) { KlO result; int normal; KlCatch(KlA_ERROR, KlLoadSilent(KlStringMake(KlUserProfileName)), result, normal); if (KlFalseP(result)) { KlZrtGc(0); return 1; } } /* KlCfFlush(); *//* not necessary */ KlErrorInProfile = KlErrorStatus; KlZrtGc(0); KlInitState = 96; return 0; } #ifndef DEBUG #ifdef DEBUGGABLE #undef stop_if_in_dbx stop_if_in_dbx(why) char *why; {} /* used in dbx */ KlCBreakPoint(tag, value) char *tag; KlO value; {} #ifndef __INSIGHT__ _Insight_trap_error() {} #endif #endif /* DEBUGGABLE */ #endif /* !DEBUG */