globle void StringToFieldFunction( void *theEnv, DATA_OBJECT *returnValue) { DATA_OBJECT theArg; /*========================================================*/ /* Function string-to-field expects exactly one argument. */ /*========================================================*/ if (EnvArgCountCheck(theEnv,"string-to-field",EXACTLY,1) == -1) { returnValue->type = STRING; returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***"); return; } /*==================================================*/ /* The argument should be of type symbol or string. */ /*==================================================*/ if (EnvArgTypeCheck(theEnv,"string-to-field",1,SYMBOL_OR_STRING,&theArg) == FALSE) { returnValue->type = STRING; returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***"); return; } /*================================*/ /* Convert the string to an atom. */ /*================================*/ StringToField(theEnv,DOToString(theArg),returnValue); }
globle char *GetLogicalName( void *theEnv, int whichArgument, char *defaultLogicalName) { char *logicalName; DATA_OBJECT result; EnvRtnUnknown(theEnv,whichArgument,&result); if ((GetType(result) == SYMBOL) || (GetType(result) == STRING) || (GetType(result) == INSTANCE_NAME)) { logicalName = ValueToString(result.value); if ((strcmp(logicalName,"t") == 0) || (strcmp(logicalName,"T") == 0)) { logicalName = defaultLogicalName; } } else if (GetType(result) == FLOAT) { logicalName = ValueToString(EnvAddSymbol(theEnv,FloatToString(theEnv,DOToDouble(result)))); } else if (GetType(result) == INTEGER) { logicalName = ValueToString(EnvAddSymbol(theEnv,LongIntegerToString(theEnv,DOToLong(result)))); } else { logicalName = NULL; } return(logicalName); }
void* GetMouseAction(void* theEnv) { unsigned state; AdventureEngine::AdventureEngineEngine* engine = PullOutEngine(theEnv); Common::EventManager* _eventMan = engine->getEventManager(); Common::Point pos = _eventMan->getMousePos(); state = _eventMan->getButtonState(); if(state == engine->previousMouseCommand()) { state = 0; } else { engine->setPreviousMouseCommand(state); } switch(state) { case 0: return EnvAddSymbol(theEnv, (char*)"no-click"); case 1: return EnvAddSymbol(theEnv, (char*)"mouse1"); case 2: return EnvAddSymbol(theEnv, (char*)"mouse2"); case 3: return EnvAddSymbol(theEnv, (char*)"mouse3"); default: return EnvAddSymbol(theEnv, (char*)"unknown"); } }
static void SetErrorCaptureValues( void *theEnv, DATA_OBJECT_PTR returnValue) { struct multifield *theMultifield; theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,2L); if (ParseFunctionData(theEnv)->ErrorString != NULL) { SetMFType(theMultifield,1,STRING); SetMFValue(theMultifield,1,EnvAddSymbol(theEnv,ParseFunctionData(theEnv)->ErrorString)); } else { SetMFType(theMultifield,1,SYMBOL); SetMFValue(theMultifield,1,EnvFalseSymbol(theEnv)); } if (ParseFunctionData(theEnv)->WarningString != NULL) { SetMFType(theMultifield,2,STRING); SetMFValue(theMultifield,2,EnvAddSymbol(theEnv,ParseFunctionData(theEnv)->WarningString)); } else { SetMFType(theMultifield,2,SYMBOL); SetMFValue(theMultifield,2,EnvFalseSymbol(theEnv)); } SetpType(returnValue,MULTIFIELD); SetpDOBegin(returnValue,1); SetpDOEnd(returnValue,2); SetpValue(returnValue,(void *) theMultifield); }
globle const char *FloatToString( void *theEnv, double number) { char floatString[40]; int i; char x; void *thePtr; gensprintf(floatString,"%.15g",number); for (i = 0; (x = floatString[i]) != '\0'; i++) { if ((x == '.') || (x == 'e')) { thePtr = EnvAddSymbol(theEnv,floatString); return(ValueToString(thePtr)); } } genstrcat(floatString,".0"); thePtr = EnvAddSymbol(theEnv,floatString); return(ValueToString(thePtr)); }
globle void *SetSalienceEvaluationCommand( void *theEnv) { DATA_OBJECT argPtr; char *argument, *oldValue; /*==================================================*/ /* Get the current setting for salience evaluation. */ /*==================================================*/ oldValue = SalienceEvaluationName(EnvGetSalienceEvaluation(theEnv)); /*=========================================*/ /* This function expects a single argument */ /* which must be a symbol. */ /*=========================================*/ if (EnvArgCountCheck(theEnv,(char*)"set-salience-evaluation",EXACTLY,1) == -1) { return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue)); } if (EnvArgTypeCheck(theEnv,(char*)"set-salience-evaluation",1,SYMBOL,&argPtr) == FALSE) { return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue)); } /*=============================================================*/ /* The allowed symbols to pass as an argument to this function */ /* are when-defined, when-activated, and every-cycle. */ /*=============================================================*/ argument = DOToString(argPtr); if (strcmp(argument,(char*)"when-defined") == 0) { EnvSetSalienceEvaluation(theEnv,WHEN_DEFINED); } else if (strcmp(argument,(char*)"when-activated") == 0) { EnvSetSalienceEvaluation(theEnv,WHEN_ACTIVATED); } else if (strcmp(argument,(char*)"every-cycle") == 0) { EnvSetSalienceEvaluation(theEnv,EVERY_CYCLE); } else { ExpectedTypeError1(theEnv,(char*)"set-salience-evaluation",1, (char*)"symbol with value when-defined, when-activated, or every-cycle"); return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue)); } /*=================================================*/ /* Return the old setting for salience evaluation. */ /*=================================================*/ return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue)); }
globle void LowcaseFunction( void *theEnv, DATA_OBJECT_PTR returnValue) { DATA_OBJECT theArg; unsigned i; size_t slen; char *osptr, *nsptr; /*================================================*/ /* Function lowcase expects exactly one argument. */ /*================================================*/ if (EnvArgCountCheck(theEnv,"lowcase",EXACTLY,1) == -1) { SetpType(returnValue,STRING); SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,"")); return; } /*==================================================*/ /* The argument should be of type symbol or string. */ /*==================================================*/ if (EnvArgTypeCheck(theEnv,"lowcase",1,SYMBOL_OR_STRING,&theArg) == FALSE) { SetpType(returnValue,STRING); SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,"")); return; } /*======================================================*/ /* Allocate temporary memory and then copy the original */ /* string or symbol to that memory, while lowercasing */ /* upper case alphabetic characters. */ /*======================================================*/ osptr = DOToString(theArg); slen = strlen(osptr) + 1; nsptr = (char *) gm2(theEnv,slen); for (i = 0 ; i < slen ; i++) { if (isupper(osptr[i])) { nsptr[i] = (char) tolower(osptr[i]); } else { nsptr[i] = osptr[i]; } } /*========================================*/ /* Return the lowercased string and clean */ /* up the temporary memory used. */ /*========================================*/ SetpType(returnValue,GetType(theArg)); SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,nsptr)); rm(theEnv,nsptr,slen); }
globle void *SetStrategyCommand( void *theEnv) { DATA_OBJECT argPtr; char *argument; int oldStrategy; oldStrategy = AgendaData(theEnv)->Strategy; /*=====================================================*/ /* Check for the correct number and type of arguments. */ /*=====================================================*/ if (EnvArgCountCheck(theEnv,"set-strategy",EXACTLY,1) == -1) { return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); } if (EnvArgTypeCheck(theEnv,"set-strategy",1,SYMBOL,&argPtr) == FALSE) { return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); } argument = DOToString(argPtr); /*=============================================*/ /* Set the strategy to the specified strategy. */ /*=============================================*/ if (strcmp(argument,"depth") == 0) { EnvSetStrategy(theEnv,DEPTH_STRATEGY); } else if (strcmp(argument,"breadth") == 0) { EnvSetStrategy(theEnv,BREADTH_STRATEGY); } else if (strcmp(argument,"lex") == 0) { EnvSetStrategy(theEnv,LEX_STRATEGY); } else if (strcmp(argument,"mea") == 0) { EnvSetStrategy(theEnv,MEA_STRATEGY); } else if (strcmp(argument,"complexity") == 0) { EnvSetStrategy(theEnv,COMPLEXITY_STRATEGY); } else if (strcmp(argument,"simplicity") == 0) { EnvSetStrategy(theEnv,SIMPLICITY_STRATEGY); } else if (strcmp(argument,"random") == 0) { EnvSetStrategy(theEnv,RANDOM_STRATEGY); } else { ExpectedTypeError1(theEnv,"set-strategy",1, "symbol with value depth, breadth, lex, mea, complexity, simplicity, or random"); return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); } /*=======================================*/ /* Return the old value of the strategy. */ /*=======================================*/ return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(oldStrategy))); }
/********************************************************** NAME : SetupObjectSystem DESCRIPTION : Initializes all COOL constructs, functions, and data structures INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : COOL initialized NOTES : Order of setup calls is important **********************************************************/ globle void SetupObjectSystem( void *theEnv) { ENTITY_RECORD defclassEntityRecord = { (char*)"DEFCLASS_PTR", DEFCLASS_PTR,1,0,0, NULL,NULL,NULL,NULL,NULL, DecrementDefclassBusyCount, IncrementDefclassBusyCount, NULL,NULL,NULL,NULL,NULL }; AllocateEnvironmentData(theEnv,DEFCLASS_DATA,sizeof(struct defclassData),NULL); AddEnvironmentCleanupFunction(theEnv,(char*)"defclasses",DeallocateDefclassData,-500); memcpy(&DefclassData(theEnv)->DefclassEntityRecord,&defclassEntityRecord,sizeof(struct entityRecord)); #if ! RUN_TIME DefclassData(theEnv)->ClassDefaultsMode = CONVENIENCE_MODE; DefclassData(theEnv)->ISA_SYMBOL = (SYMBOL_HN *) EnvAddSymbol(theEnv,SUPERCLASS_RLN); IncrementSymbolCount(DefclassData(theEnv)->ISA_SYMBOL); DefclassData(theEnv)->NAME_SYMBOL = (SYMBOL_HN *) EnvAddSymbol(theEnv,NAME_RLN); IncrementSymbolCount(DefclassData(theEnv)->NAME_SYMBOL); #if DEFRULE_CONSTRUCT DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL = (SYMBOL_HN *) EnvAddSymbol(theEnv,INITIAL_OBJECT_NAME); IncrementSymbolCount(DefclassData(theEnv)->INITIAL_OBJECT_SYMBOL); #endif #endif SetupDefclasses(theEnv); SetupInstances(theEnv); SetupMessageHandlers(theEnv); #if DEFINSTANCES_CONSTRUCT SetupDefinstances(theEnv); #endif #if INSTANCE_SET_QUERIES SetupQuery(theEnv); #endif #if BLOAD_AND_BSAVE || BLOAD || BLOAD_ONLY SetupObjectsBload(theEnv); #endif #if CONSTRUCT_COMPILER && (! RUN_TIME) SetupObjectsCompiler(theEnv); #endif #if DEFRULE_CONSTRUCT SetupObjectPatternStuff(theEnv); #endif }
/************************************************************ NAME : WildDeleteHandler DESCRIPTION : Deletes a handler from a class INPUTS : 1) Class address (Can be NULL) 2) Message Handler Name (Can be NULL) 3) Type name ("primary", etc.) RETURNS : 1 if successful, 0 otherwise SIDE EFFECTS : Handler deleted if possible NOTES : None ************************************************************/ static int WildDeleteHandler( void *theEnv, DEFCLASS *cls, SYMBOL_HN *msym, const char *tname) { int mtype; if (msym == NULL) msym = (SYMBOL_HN *) EnvAddSymbol(theEnv,"*"); if (tname != NULL) { mtype = (int) HandlerType(theEnv,"undefmessage-handler",tname); if (mtype == MERROR) return(0); } else mtype = -1; if (cls == NULL) { int success = 1; for (cls = (DEFCLASS *) EnvGetNextDefclass(theEnv,NULL) ; cls != NULL ; cls = (DEFCLASS *) EnvGetNextDefclass(theEnv,(void *) cls)) if (DeleteHandler(theEnv,cls,msym,mtype,FALSE) == 0) success = 0; return(success); } return(DeleteHandler(theEnv,cls,msym,mtype,TRUE)); }
globle void *GetClassDefaultsModeCommand( void *theEnv) { EnvArgCountCheck(theEnv,"get-class-defaults-mode",EXACTLY,0); return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv)))); }
globle char *StringPrintForm( void *theEnv, char *str) { int i = 0, pos = 0; unsigned max = 0; char *theString = NULL; void *thePtr; theString = ExpandStringWithChar(theEnv,'"',theString,&pos,&max,max+80); while (str[i] != EOS) { if ((str[i] == '"') || (str[i] == '\\')) { theString = ExpandStringWithChar(theEnv,'\\',theString,&pos,&max,max+80); theString = ExpandStringWithChar(theEnv,str[i],theString,&pos,&max,max+80); } else { theString = ExpandStringWithChar(theEnv,str[i],theString,&pos,&max,max+80); } i++; } theString = ExpandStringWithChar(theEnv,'"',theString,&pos,&max,max+80); thePtr = EnvAddSymbol(theEnv,theString); rm(theEnv,theString,max); return(ValueToString(thePtr)); }
globle void *GensymStar( void *theEnv) { char genstring[15]; /*=======================================================*/ /* Create a symbol using the current gensym index as the */ /* postfix. If the symbol is already present in the */ /* symbol table, then continue generating symbols until */ /* a unique symbol is found. */ /*=======================================================*/ do { sprintf(genstring,"gen%ld",MiscFunctionData(theEnv)->GensymNumber); MiscFunctionData(theEnv)->GensymNumber++; } while (FindSymbolHN(theEnv,genstring) != NULL); /*====================*/ /* Return the symbol. */ /*====================*/ return(EnvAddSymbol(theEnv,genstring)); }
globle void *GensymFunction( void *theEnv) { char genstring[15]; /*===========================================*/ /* The gensym function accepts no arguments. */ /*===========================================*/ EnvArgCountCheck(theEnv,"gensym",EXACTLY,0); /*================================================*/ /* Create a symbol using the current gensym index */ /* as the postfix. */ /*================================================*/ sprintf(genstring,"gen%ld",MiscFunctionData(theEnv)->GensymNumber); MiscFunctionData(theEnv)->GensymNumber++; /*====================*/ /* Return the symbol. */ /*====================*/ return(EnvAddSymbol(theEnv,genstring)); }
/********************************************************* NAME : SlotDefaultValue DESCRIPTION : Determines the default value for the specified slot of the specified class INPUTS : 1) The class 2) The slot name RETURNS : TRUE if slot default value is set, FALSE otherwise SIDE EFFECTS : Slot default value evaluated - dynamic defaults will cause any side effects NOTES : None *********************************************************/ globle intBool EnvSlotDefaultValue( void *theEnv, void *theDefclass, char *slotName, DATA_OBJECT_PTR theValue) { SLOT_DESC *sd; SetpType(theValue,SYMBOL); SetpValue(theValue,EnvFalseSymbol(theEnv)); if ((sd = LookupSlot(theEnv,(DEFCLASS *) theDefclass,slotName,TRUE)) == NULL) return(FALSE); if (sd->noDefault) { SetpType(theValue,SYMBOL); SetpValue(theValue,EnvAddSymbol(theEnv,"?NONE")); return(TRUE); } if (sd->dynamicDefault) return(EvaluateAndStoreInDataObject(theEnv,(int) sd->multiple, (EXPRESSION *) sd->defaultValue, theValue,TRUE)); GenCopyMemory(DATA_OBJECT,1,theValue,sd->defaultValue); return(TRUE); }
dataObject * value_to_data_object( const Environment& env, const Value & value ) { void *p; dataObject* clipsdo = new dataObject; SetpType(clipsdo, value.type() ); switch ( value.type() ) { case TYPE_SYMBOL: case TYPE_STRING: case TYPE_INSTANCE_NAME: p = EnvAddSymbol( env.cobj(), const_cast<char*>( value.as_string().c_str()) ); SetpValue(clipsdo, p); return clipsdo; case TYPE_INTEGER: p = EnvAddLong( env.cobj(), value.as_integer() ); SetpValue(clipsdo, p); return clipsdo; case TYPE_FLOAT: p = EnvAddDouble( env.cobj(), value.as_float() ); SetpValue(clipsdo, p); return clipsdo; case TYPE_EXTERNAL_ADDRESS: p = EnvAddExternalAddress( env.cobj(), value.as_address(), EXTERNAL_ADDRESS ); SetpValue(clipsdo, p); return clipsdo; default: throw std::logic_error( "clipsmm::value_to_data_object: Unhandled data object type" ); } return NULL; }
globle void *GetSalienceEvaluationCommand( void *theEnv) { EnvArgCountCheck(theEnv,(char*)"get-salience-evaluation",EXACTLY,0); return((SYMBOL_HN *) EnvAddSymbol(theEnv,SalienceEvaluationName(EnvGetSalienceEvaluation(theEnv)))); }
/********************************************************************** NAME : SlotDefaultValueCommand DESCRIPTION : Determines the default avlue for the specified slot of the specified class INPUTS : None RETURNS : Nothing useful SIDE EFFECTS : None NOTES : H/L Syntax : (slot-default-value <class> <slot>) **********************************************************************/ globle void SlotDefaultValueCommand( void *theEnv, DATA_OBJECT_PTR theValue) { DEFCLASS *theDefclass; SLOT_DESC *sd; SetpType(theValue,SYMBOL); SetpValue(theValue,EnvFalseSymbol(theEnv)); sd = CheckSlotExists(theEnv,"slot-default-value",&theDefclass,TRUE,TRUE); if (sd == NULL) return; if (sd->noDefault) { SetpType(theValue,SYMBOL); SetpValue(theValue,EnvAddSymbol(theEnv,"?NONE")); return; } if (sd->dynamicDefault) EvaluateAndStoreInDataObject(theEnv,(int) sd->multiple, (EXPRESSION *) sd->defaultValue, theValue,TRUE); else GenCopyMemory(DATA_OBJECT,1,theValue,sd->defaultValue); }
globle void *GetStrategyCommand( void *theEnv) { EnvArgCountCheck(theEnv,"get-strategy",EXACTLY,0); return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); }
globle void EnvFactSlotNames( void *theEnv, void *vTheFact, DATA_OBJECT *returnValue) { struct fact *theFact = (struct fact *) vTheFact; struct multifield *theList; struct templateSlot *theSlot; unsigned long count; /*===============================================*/ /* If we're dealing with an implied deftemplate, */ /* then the only slot names is "implied." */ /*===============================================*/ if (theFact->whichDeftemplate->implied) { SetpType(returnValue,MULTIFIELD); SetpDOBegin(returnValue,1); SetpDOEnd(returnValue,1); theList = (struct multifield *) EnvCreateMultifield(theEnv,(int) 1); SetMFType(theList,1,SYMBOL); SetMFValue(theList,1,EnvAddSymbol(theEnv,"implied")); SetpValue(returnValue,(void *) theList); return; } /*=================================*/ /* Count the number of slot names. */ /*=================================*/ for (count = 0, theSlot = theFact->whichDeftemplate->slotList; theSlot != NULL; count++, theSlot = theSlot->next) { /* Do Nothing */ } /*=============================================================*/ /* Create a multifield value in which to store the slot names. */ /*=============================================================*/ SetpType(returnValue,MULTIFIELD); SetpDOBegin(returnValue,1); SetpDOEnd(returnValue,(long) count); theList = (struct multifield *) EnvCreateMultifield(theEnv,count); SetpValue(returnValue,(void *) theList); /*===============================================*/ /* Store the slot names in the multifield value. */ /*===============================================*/ for (count = 1, theSlot = theFact->whichDeftemplate->slotList; theSlot != NULL; count++, theSlot = theSlot->next) { SetMFType(theList,count,SYMBOL); SetMFValue(theList,count,theSlot->slotName); } }
globle struct lhsParseNode *CreateInitialFactPattern( void *theEnv) { struct lhsParseNode *topNode; struct deftemplate *theDeftemplate; int count; /*==================================*/ /* If the initial-fact deftemplate */ /* doesn't exist, then create it. */ /*==================================*/ theDeftemplate = (struct deftemplate *) FindImportedConstruct(theEnv,"deftemplate",NULL,"initial-fact", &count,TRUE,NULL); if (theDeftemplate == NULL) { PrintWarningID(theEnv,"FACTLHS",1,FALSE); EnvPrintRouter(theEnv,WWARNING,"Creating implied initial-fact deftemplate in module "); EnvPrintRouter(theEnv,WWARNING,EnvGetDefmoduleName(theEnv,EnvGetCurrentModule(theEnv))); EnvPrintRouter(theEnv,WWARNING,".\n"); EnvPrintRouter(theEnv,WWARNING," You probably want to import this deftemplate from the MAIN module.\n"); CreateImpliedDeftemplate(theEnv,(SYMBOL_HN *) EnvAddSymbol(theEnv,"initial-fact"),FALSE); } /*====================================*/ /* Create the (initial-fact) pattern. */ /*====================================*/ topNode = GetLHSParseNode(theEnv); topNode->type = SF_WILDCARD; topNode->index = 0; topNode->slotNumber = 1; topNode->bottom = GetLHSParseNode(theEnv); topNode->bottom->type = SYMBOL; topNode->bottom->value = (void *) EnvAddSymbol(theEnv,"initial-fact"); /*=====================*/ /* Return the pattern. */ /*=====================*/ return(topNode); }
globle void *SetClassDefaultsModeCommand( void *theEnv, EXEC_STATUS) { DATA_OBJECT argPtr; char *argument; unsigned short oldMode; oldMode = DefclassData(theEnv,execStatus)->ClassDefaultsMode; /*=====================================================*/ /* Check for the correct number and type of arguments. */ /*=====================================================*/ if (EnvArgCountCheck(theEnv,execStatus,"set-class-defaults-mode",EXACTLY,1) == -1) { return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv,execStatus)))); } if (EnvArgTypeCheck(theEnv,execStatus,"set-class-defaults-mode",1,SYMBOL,&argPtr) == FALSE) { return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv,execStatus)))); } argument = DOToString(argPtr); /*=============================================*/ /* Set the strategy to the specified strategy. */ /*=============================================*/ if (strcmp(argument,"conservation") == 0) { EnvSetClassDefaultsMode(theEnv,execStatus,CONSERVATION_MODE); } else if (strcmp(argument,"convenience") == 0) { EnvSetClassDefaultsMode(theEnv,execStatus,CONVENIENCE_MODE); } else { ExpectedTypeError1(theEnv,execStatus,"set-class-defaults-mode",1, "symbol with value conservation or convenience"); return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(EnvGetClassDefaultsMode(theEnv,execStatus)))); } /*===================================*/ /* Return the old value of the mode. */ /*===================================*/ return((SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,GetClassDefaultsModeName(oldMode))); }
globle void StringToField( void *theEnv, char *theString, DATA_OBJECT *returnValue) { struct token theToken; /*====================================*/ /* Open the string as an input source */ /* and retrieve the first value. */ /*====================================*/ OpenStringSource(theEnv,"string-to-field-str",theString,0); GetToken(theEnv,"string-to-field-str",&theToken); CloseStringSource(theEnv,"string-to-field-str"); /*====================================================*/ /* Copy the token to the return value data structure. */ /*====================================================*/ returnValue->type = theToken.type; if ((theToken.type == FLOAT) || (theToken.type == STRING) || #if OBJECT_SYSTEM (theToken.type == INSTANCE_NAME) || #endif (theToken.type == SYMBOL) || (theToken.type == INTEGER)) { returnValue->value = theToken.value; } else if (theToken.type == STOP) { returnValue->type = SYMBOL; returnValue->value = (void *) EnvAddSymbol(theEnv,"EOF"); } else if (theToken.type == UNKNOWN_VALUE) { returnValue->type = STRING; returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***"); } else { returnValue->type = STRING; returnValue->value = (void *) EnvAddSymbol(theEnv,theToken.printForm); } }
/******************************************************************** NAME : GetFunctionRestrictions DESCRIPTION : Gets DefineFunction2() restriction list for function INPUTS : None RETURNS : A string containing the function restriction codes SIDE EFFECTS : EvaluationError set on errors NOTES : None ********************************************************************/ globle void *GetFunctionRestrictions( void *theEnv) { DATA_OBJECT temp; struct FunctionDefinition *fptr; if (EnvArgTypeCheck(theEnv,"get-function-restrictions",1,SYMBOL,&temp) == FALSE) return((SYMBOL_HN *) EnvAddSymbol(theEnv,"")); fptr = FindFunction(theEnv,DOToString(temp)); if (fptr == NULL) { CantFindItemErrorMessage(theEnv,"function",DOToString(temp)); SetEvaluationError(theEnv,TRUE); return((SYMBOL_HN *) EnvAddSymbol(theEnv,"")); } if (fptr->restrictions == NULL) return((SYMBOL_HN *) EnvAddSymbol(theEnv,"0**")); return((SYMBOL_HN *) EnvAddSymbol(theEnv,fptr->restrictions)); }
globle SYMBOL_HN *ExtractModuleName( void *theEnv, EXEC_STATUS, unsigned thePosition, char *theString) { char *newString; SYMBOL_HN *returnValue; /*=============================================*/ /* Return NULL if the :: is in a position such */ /* that a module name can't be extracted. */ /*=============================================*/ if (thePosition <= 1) return(NULL); /*==========================================*/ /* Allocate storage for a temporary string. */ /*==========================================*/ newString = (char *) gm2(theEnv,execStatus,thePosition); /*======================================================*/ /* Copy the entire module/construct name to the string. */ /*======================================================*/ genstrncpy(newString,theString, (STD_SIZE) thePosition - 1); /*========================================================*/ /* Place an end of string marker where the :: is located. */ /*========================================================*/ newString[thePosition-1] = EOS; /*=====================================================*/ /* Add the module name (the truncated module/construct */ /* name) to the symbol table. */ /*=====================================================*/ returnValue = (SYMBOL_HN *) EnvAddSymbol(theEnv,execStatus,newString); /*=============================================*/ /* Return the storage of the temporary string. */ /*=============================================*/ rm(theEnv,execStatus,newString,thePosition); /*=============================================*/ /* Return a pointer to the module name symbol. */ /*=============================================*/ return(returnValue); }
static void ClearBload( void *theEnv) { size_t space; int i; /*=============================================*/ /* Decrement in use counters for atomic values */ /* contained in the construct headers. */ /*=============================================*/ for (i = 0; i < DeftemplateBinaryData(theEnv)->NumberOfDeftemplates; i++) { UnmarkConstructHeader(theEnv,&DeftemplateBinaryData(theEnv)->DeftemplateArray[i].header); } /*=======================================*/ /* Decrement in use counters for symbols */ /* used as slot names. */ /*=======================================*/ for (i = 0; i < DeftemplateBinaryData(theEnv)->NumberOfTemplateSlots; i++) { DecrementSymbolCount(theEnv,DeftemplateBinaryData(theEnv)->SlotArray[i].slotName); } /*======================================================================*/ /* Deallocate the space used for the deftemplateModule data structures. */ /*======================================================================*/ space = DeftemplateBinaryData(theEnv)->NumberOfTemplateModules * sizeof(struct deftemplateModule); if (space != 0) genfree(theEnv,(void *) DeftemplateBinaryData(theEnv)->ModuleArray,space); DeftemplateBinaryData(theEnv)->NumberOfTemplateModules = 0; /*================================================================*/ /* Deallocate the space used for the deftemplate data structures. */ /*================================================================*/ space = DeftemplateBinaryData(theEnv)->NumberOfDeftemplates * sizeof(struct deftemplate); if (space != 0) genfree(theEnv,(void *) DeftemplateBinaryData(theEnv)->DeftemplateArray,space); DeftemplateBinaryData(theEnv)->NumberOfDeftemplates = 0; /*=================================================================*/ /* Deallocate the space used for the templateSlot data structures. */ /*=================================================================*/ space = DeftemplateBinaryData(theEnv)->NumberOfTemplateSlots * sizeof(struct templateSlot); if (space != 0) genfree(theEnv,(void *) DeftemplateBinaryData(theEnv)->SlotArray,space); DeftemplateBinaryData(theEnv)->NumberOfTemplateSlots = 0; /*======================================*/ /* Create the initial-fact deftemplate. */ /*======================================*/ #if (! BLOAD_ONLY) CreateImpliedDeftemplate(theEnv,(SYMBOL_HN *) EnvAddSymbol(theEnv,"initial-fact"),FALSE); #endif }
static void ClearDeftemplates( void *theEnv) { #if (! RUN_TIME) && (! BLOAD_ONLY) CreateImpliedDeftemplate(theEnv,(SYMBOL_HN *) EnvAddSymbol(theEnv,(char*)"initial-fact"),FALSE); #else #if MAC_MCW || WIN_MCW || MAC_XCD #pragma unused(theEnv) #endif #endif }
globle const char *LongIntegerToString( void *theEnv, long long number) { char buffer[50]; void *thePtr; gensprintf(buffer,"%lld",number); thePtr = EnvAddSymbol(theEnv,buffer); return(ValueToString(thePtr)); }
globle void *GetCurrentModuleCommand( void *theEnv) { struct defmodule *theModule; EnvArgCountCheck(theEnv,"get-current-module",EXACTLY,0); theModule = (struct defmodule *) EnvGetCurrentModule(theEnv); if (theModule == NULL) return((SYMBOL_HN *) EnvFalseSymbol(theEnv)); return((SYMBOL_HN *) EnvAddSymbol(theEnv,ValueToString(theModule->name))); }
globle void OldGetConstructList( void *theEnv, EXEC_STATUS, DATA_OBJECT_PTR returnValue, void *(*nextFunction)(void *,EXEC_STATUS,void *), char *(*nameFunction)(void *,EXEC_STATUS,void *)) { void *theConstruct; unsigned long count = 0; struct multifield *theList; /*====================================*/ /* Determine the number of constructs */ /* of the specified type. */ /*====================================*/ for (theConstruct = (*nextFunction)(theEnv,execStatus,NULL); theConstruct != NULL; theConstruct = (*nextFunction)(theEnv,execStatus,theConstruct)) { count++; } /*===========================*/ /* Create a multifield large */ /* enough to store the list. */ /*===========================*/ SetpType(returnValue,MULTIFIELD); SetpDOBegin(returnValue,1); SetpDOEnd(returnValue,(long) count); theList = (struct multifield *) EnvCreateMultifield(theEnv,execStatus,count); SetpValue(returnValue,(void *) theList); /*====================================*/ /* Store the names in the multifield. */ /*====================================*/ for (theConstruct = (*nextFunction)(theEnv,execStatus,NULL), count = 1; theConstruct != NULL; theConstruct = (*nextFunction)(theEnv,execStatus,theConstruct), count++) { if (execStatus->HaltExecution == TRUE) { EnvSetMultifieldErrorValue(theEnv,execStatus,returnValue); return; } SetMFType(theList,count,SYMBOL); SetMFValue(theList,count,EnvAddSymbol(theEnv,execStatus,(*nameFunction)(theEnv,execStatus,theConstruct))); } }