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)));
}
}
