/*********************************************************
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;
}
/**********************************************************************
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 EvalFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT theArg;
/*=============================================*/
/* Function eval expects exactly one argument. */
/*=============================================*/
if (EnvArgCountCheck(theEnv,"eval",EXACTLY,1) == -1)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return;
}
/*==================================================*/
/* The argument should be of type SYMBOL or STRING. */
/*==================================================*/
if (EnvArgTypeCheck(theEnv,"eval",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return;
}
/*======================*/
/* Evaluate the string. */
/*======================*/
EnvEval(theEnv,DOToString(theArg),returnValue);
}
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 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 EnvGetFocusStack(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
struct focus *theFocus;
struct multifield *theList;
unsigned long count = 0;
/*===========================================*/
/* If there is no current focus, then return */
/* a multifield value of length zero. */
/*===========================================*/
if (EngineData(theEnv)->CurrentFocus == NULL)
{
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,0);
SetpValue(returnValue,(void *) EnvCreateMultifield(theEnv,0L));
return;
}
/*=====================================================*/
/* Determine the number of modules on the focus stack. */
/*=====================================================*/
for (theFocus = EngineData(theEnv)->CurrentFocus; theFocus != NULL; theFocus = theFocus->next)
{ count++; }
/*=============================================*/
/* Create a multifield of the appropriate size */
/* in which to store the module names. */
/*=============================================*/
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,(long) count);
theList = (struct multifield *) EnvCreateMultifield(theEnv,count);
SetpValue(returnValue,(void *) theList);
/*=================================================*/
/* Store the module names in the multifield value. */
/*=================================================*/
for (theFocus = EngineData(theEnv)->CurrentFocus, count = 1;
theFocus != NULL;
theFocus = theFocus->next, count++)
{
SetMFType(theList,count,SYMBOL);
SetMFValue(theList,count,theFocus->theModule->name);
}
}
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);
}
static void SetErrorCaptureValues(
DATA_OBJECT_PTR returnValue)
{
struct multifield *theMultifield;
theMultifield = (struct multifield *) CreateMultifield(2L);
if (ErrorString != NULL)
{
SetMFType(theMultifield,1,STRING);
SetMFValue(theMultifield,1,AddSymbol(ErrorString));
}
else
{
SetMFType(theMultifield,1,SYMBOL);
SetMFValue(theMultifield,1,FalseSymbol);
}
if (WarningString != NULL)
{
SetMFType(theMultifield,2,STRING);
SetMFValue(theMultifield,2,AddSymbol(WarningString));
}
else
{
SetMFType(theMultifield,2,SYMBOL);
SetMFValue(theMultifield,2,FalseSymbol);
}
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,2);
SetpValue(returnValue,(void *) theMultifield);
}
globle void GetFunctionListFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
struct FunctionDefinition *theFunction;
struct multifield *theList;
unsigned long functionCount = 0;
if (EnvArgCountCheck(theEnv,"get-function-list",EXACTLY,0) == -1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
return;
}
for (theFunction = GetFunctionList(theEnv);
theFunction != NULL;
theFunction = theFunction->next)
{
functionCount++;
}
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,functionCount);
theList = (struct multifield *) EnvCreateMultifield(theEnv,functionCount);
SetpValue(returnValue,(void *) theList);
for (theFunction = GetFunctionList(theEnv), functionCount = 1;
theFunction != NULL;
theFunction = theFunction->next, functionCount++)
{
SetMFType(theList,functionCount,SYMBOL);
SetMFValue(theList,functionCount,theFunction->callFunctionName);
}
}
globle void CheckSyntaxFunction(
DATA_OBJECT *returnValue)
{
DATA_OBJECT theArg;
/*===============================*/
/* Set up a default return value */
/* (TRUE for problems found). */
/*===============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
/*=====================================================*/
/* Function check-syntax expects exactly one argument. */
/*=====================================================*/
if (ArgCountCheck("check-syntax",EXACTLY,1) == -1) return;
/*========================================*/
/* The argument should be of type STRING. */
/*========================================*/
if (ArgTypeCheck("check-syntax",1,STRING,&theArg) == FALSE)
{ return; }
/*===================*/
/* Check the syntax. */
/*===================*/
CheckSyntax(DOToString(theArg),returnValue);
}
globle void EvalFunction(
DATA_OBJECT_PTR returnValue)
{
PrintErrorID("STRNGFUN",1,FALSE);
PrintRouter(WERROR,"Function eval does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
}
globle void CheckSyntaxFunction(
DATA_OBJECT *returnValue)
{
PrintErrorID("PARSEFUN",1,FALSE);
PrintRouter(WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
}
globle void EvalFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
PrintErrorID(theEnv,"STRNGFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function eval does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
}
globle void CheckSyntaxFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
}
/***********************************************************
NAME : DynamicHandlerPutSlot
DESCRIPTION : Directly puts a slot's value
(uses dynamic binding to lookup slot)
INPUTS : Data obejct buffer for holding slot value
RETURNS : Nothing useful
SIDE EFFECTS : Slot modified - and caller's buffer set
to value (or symbol FALSE on errors)
NOTES : H/L Syntax: (put <slot> <value>*)
***********************************************************/
globle void DynamicHandlerPutSlot(
DATA_OBJECT *theResult)
{
INSTANCE_SLOT *sp;
INSTANCE_TYPE *ins;
DATA_OBJECT temp;
theResult->type = SYMBOL;
theResult->value = FalseSymbol;
if (CheckCurrentMessage("dynamic-put",TRUE) == FALSE)
return;
EvaluateExpression(GetFirstArgument(),&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1("dynamic-put",1,"symbol");
SetEvaluationError(TRUE);
return;
}
ins = GetActiveInstance();
sp = FindInstanceSlot(ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(ValueToString(temp.value),"dynamic-put");
return;
}
if ((sp->desc->noWrite == 0) ? FALSE :
((sp->desc->initializeOnly == 0) || (!ins->initializeInProgress)))
{
SlotAccessViolationError(ValueToString(sp->desc->slotName->name),
TRUE,(void *) ins);
SetEvaluationError(TRUE);
return;
}
if ((sp->desc->publicVisibility == 0) &&
(CurrentCore->hnd->cls != sp->desc->cls))
{
SlotVisibilityViolationError(sp->desc,CurrentCore->hnd->cls);
SetEvaluationError(TRUE);
return;
}
if (GetFirstArgument()->nextArg)
{
if (EvaluateAndStoreInDataObject((int) sp->desc->multiple,
GetFirstArgument()->nextArg,&temp) == FALSE)
return;
}
else
{
SetpDOBegin(&temp,1);
SetpDOEnd(&temp,0);
SetpType(&temp,MULTIFIELD);
SetpValue(&temp,NoParamValue);
}
PutSlotValue(ins,sp,&temp,theResult,NULL);
}
extern "C" void GetCurrentlyPressedKeys(void* theEnv, DATA_OBJECT_PTR returnValue) {
void* multifield;
AdventureEngine::AdventureEngineEngine* engine = PullOutEngine(theEnv);
Common::EventManager* _eventMan = engine->getEventManager();
Common::Event keyEvent;
//this function does generate side effects if we assert facts
//However, if we return a multifield with all the contents then we need to
//parse it....hmmmmmm, doing the multifield is easier
//only check for a single key at this point
while(_eventMan->pollEvent(keyEvent))
{
//let's do a simple test
switch(keyEvent.type) {
case Common::EVENT_KEYDOWN:
switch(keyEvent.kbd.keycode) {
case Common::KEYCODE_ESCAPE:
multifield = EnvCreateMultifield(theEnv, 1);
SetMFType(multifield, 1, SYMBOL);
SetMFValue(multifield, 1, EnvAddSymbol(theEnv, (char*)"escape"));
SetpType(returnValue, MULTIFIELD);
SetpValue(returnValue, multifield);
SetpDOBegin(returnValue, 1);
SetpDOEnd(returnValue, 1);
return;
default:
multifield = EnvCreateMultifield(theEnv, 1);
SetMFType(multifield, 1, INTEGER);
SetMFValue(multifield, 1, EnvAddLong(theEnv, keyEvent.kbd.keycode));
SetpType(returnValue, MULTIFIELD);
SetpValue(returnValue, multifield);
SetpDOBegin(returnValue, 1);
SetpDOEnd(returnValue, 1);
return;
}
default:
NullMultifield(theEnv, returnValue);
return;
}
}
NullMultifield(theEnv, returnValue);
}
globle int CheckSyntax(
void *theEnv,
const char *theString,
DATA_OBJECT_PTR returnValue)
{
PrintErrorID(theEnv,"PARSEFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
return(TRUE);
}
globle void AssertStringFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT argPtr;
struct fact *theFact;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
if (EnvArgCountCheck(theEnv,"assert-string",EXACTLY,1) == -1) return;
if (EnvArgTypeCheck(theEnv,"assert-string",1,STRING,&argPtr) == FALSE)
{
return;
}
/*==========================================*/
/* Call the driver routine for converting a */
/* string to a fact and then assert it. */
/*==========================================*/
theFact = (struct fact *) EnvAssertString(theEnv,DOToString(argPtr));
if (theFact != NULL)
{
SetpType(returnValue,FACT_ADDRESS);
SetpValue(returnValue,(void *) theFact);
}
return;
}
globle int Eval(
char *theString,
DATA_OBJECT_PTR returnValue)
{
#if (MAC_MPW || MAC_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theString)
#endif
PrintErrorID("STRNGFUN",1,FALSE);
PrintRouter(WERROR,"Function eval does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
return(FALSE);
}
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)));
}
}
globle int CheckSyntax(
char *theString,
DATA_OBJECT_PTR returnValue)
{
#if (MAC_MPW || MAC_MCW) && (RUN_TIME || BLOAD_ONLY)
#pragma unused(theString)
#pragma unused(returnValue)
#endif
PrintErrorID("PARSEFUN",1,FALSE);
PrintRouter(WERROR,"Function check-syntax does not work in run time modules.\n");
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
return(TRUE);
}
extern "C" void GetMouseLocation(void* theEnv, DATA_OBJECT_PTR returnValue) {
void* multifield;
AdventureEngine::AdventureEngineEngine* engine = PullOutEngine(theEnv);
multifield = EnvCreateMultifield(theEnv, 2);
Common::EventManager* _eventMan = engine->getEventManager();
Common::Point pos = _eventMan->getMousePos();
SetMFType(multifield, 1, INTEGER);
SetMFValue(multifield, 1, EnvAddLong(theEnv, pos.x));
SetMFType(multifield, 2, INTEGER);
SetMFValue(multifield, 2, EnvAddLong(theEnv, pos.y));
SetpType(returnValue, MULTIFIELD);
SetpValue(returnValue, multifield);
SetpDOBegin(returnValue, 1);
SetpDOEnd(returnValue, 2);
}
dataObject * value_to_data_object( const Environment& env, const Values & values )
{
void *p, *p2;
if (values.size() == 0 )
return NULL;
if ( values.size() == 1 )
return value_to_data_object( env, values[0] );
dataObject* clipsdo = new dataObject;
p = EnvCreateMultifield( env.cobj(), values.size() );
for (unsigned int iter = 0; iter < values.size(); iter++) {
unsigned int mfi = iter + 1; // mfptr indices start at 1
SetMFType(p, mfi, values[iter].type());
switch ( values[iter].type() ) {
case TYPE_SYMBOL:
case TYPE_STRING:
case TYPE_INSTANCE_NAME:
p2 = EnvAddSymbol( env.cobj(),
const_cast<char*>(values[iter].as_string().c_str())
);
SetMFValue(p, mfi, p2);
break;
case TYPE_INTEGER:
p2 = EnvAddLong( env.cobj(), values[iter].as_integer() );
SetMFValue(p, mfi, p2);
break;
case TYPE_FLOAT:
p2 = EnvAddDouble( env.cobj(), values[iter].as_float() );
SetMFValue(p, mfi, p2);
break;
case TYPE_EXTERNAL_ADDRESS:
p2 = EnvAddExternalAddress( env.cobj(), values[iter].as_address(), EXTERNAL_ADDRESS );
SetMFValue(p, mfi, p2);
break;
default:
throw std::logic_error( "clipsmm::value_to_data_object: Unhandled data object type" );
}
}
SetpType(clipsdo, MULTIFIELD);
SetpValue(clipsdo, p);
SetpDOBegin(clipsdo, 1);
SetpDOEnd(clipsdo, values.size());
return clipsdo;
}
void EnvGetDefmoduleList(
void *theEnv,
CLIPSValue *returnValue)
{
void *theConstruct;
unsigned long count = 0;
struct multifield *theList;
/*====================================*/
/* Determine the number of constructs */
/* of the specified type. */
/*====================================*/
for (theConstruct = EnvGetNextDefmodule(theEnv,NULL);
theConstruct != NULL;
theConstruct = EnvGetNextDefmodule(theEnv,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,count);
SetpValue(returnValue,(void *) theList);
/*====================================*/
/* Store the names in the multifield. */
/*====================================*/
for (theConstruct = EnvGetNextDefmodule(theEnv,NULL), count = 1;
theConstruct != NULL;
theConstruct = EnvGetNextDefmodule(theEnv,theConstruct), count++)
{
if (EvaluationData(theEnv)->HaltExecution == true)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
return;
}
SetMFType(theList,count,SYMBOL);
SetMFValue(theList,count,EnvAddSymbol(theEnv,EnvGetDefmoduleName(theEnv,theConstruct)));
}
}
static void NewCAddress(
void *theEnv,
DATA_OBJECT *rv)
{
int numberOfArguments;
numberOfArguments = EnvRtnArgCount(theEnv);
if (numberOfArguments != 1)
{
PrintErrorID(theEnv,"NEW",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function new expected no additional arguments for the C external language type.\n");
SetEvaluationError(theEnv,TRUE);
return;
}
SetpType(rv,EXTERNAL_ADDRESS);
SetpValue(rv,EnvAddExternalAddress(theEnv,NULL,0));
}
globle void AssertCommand(
void *theEnv,
DATA_OBJECT_PTR rv)
{
struct deftemplate *theDeftemplate;
struct field *theField;
DATA_OBJECT theValue;
struct expr *theExpression;
struct templateSlot *slotPtr;
struct fact *newFact;
int error = FALSE;
int i;
struct fact *theFact;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(rv,SYMBOL);
SetpValue(rv,EnvFalseSymbol(theEnv));
/*================================*/
/* Get the deftemplate associated */
/* with the fact being asserted. */
/*================================*/
theExpression = GetFirstArgument();
theDeftemplate = (struct deftemplate *) theExpression->value;
/*=======================================*/
/* Create the fact and store the name of */
/* the deftemplate as the 1st field. */
/*=======================================*/
if (theDeftemplate->implied == FALSE)
{
newFact = CreateFactBySize(theEnv,theDeftemplate->numberOfSlots);
slotPtr = theDeftemplate->slotList;
}
else
{
newFact = CreateFactBySize(theEnv,1);
if (theExpression->nextArg == NULL)
{
newFact->theProposition.theFields[0].type = MULTIFIELD;
newFact->theProposition.theFields[0].value = CreateMultifield2(theEnv,0L);
}
slotPtr = NULL;
}
newFact->whichDeftemplate = theDeftemplate;
/*===================================================*/
/* Evaluate the expression associated with each slot */
/* and store the result in the appropriate slot of */
/* the newly created fact. */
/*===================================================*/
theField = newFact->theProposition.theFields;
for (theExpression = theExpression->nextArg, i = 0;
theExpression != NULL;
theExpression = theExpression->nextArg, i++)
{
/*===================================================*/
/* Evaluate the expression to be stored in the slot. */
/*===================================================*/
EvaluateExpression(theEnv,theExpression,&theValue);
/*============================================================*/
/* A multifield value can't be stored in a single field slot. */
/*============================================================*/
if ((slotPtr != NULL) ?
(slotPtr->multislot == FALSE) && (theValue.type == MULTIFIELD) :
FALSE)
{
MultiIntoSingleFieldSlotError(theEnv,slotPtr,theDeftemplate);
theValue.type = SYMBOL;
theValue.value = EnvFalseSymbol(theEnv);
error = TRUE;
}
/*==============================*/
/* Store the value in the slot. */
/*==============================*/
theField[i].type = theValue.type;
theField[i].value = theValue.value;
/*========================================*/
/* Get the information for the next slot. */
/*========================================*/
if (slotPtr != NULL) slotPtr = slotPtr->next;
}
/*============================================*/
/* If an error occured while generating the */
/* fact's slot values, then abort the assert. */
/*============================================*/
if (error)
{
ReturnFact(theEnv,newFact);
return;
}
/*================================*/
/* Add the fact to the fact-list. */
/*================================*/
theFact = (struct fact *) EnvAssert(theEnv,(void *) newFact);
/*========================================*/
/* The asserted fact is the return value. */
/*========================================*/
if (theFact != NULL)
{
SetpType(rv,FACT_ADDRESS);
SetpValue(rv,(void *) theFact);
}
return;
}
globle int CheckSyntax(
char *theString,
DATA_OBJECT_PTR returnValue)
{
char *name;
struct token theToken;
struct expr *top;
short rv;
/*==============================*/
/* Set the default return value */
/* (TRUE for problems found). */
/*==============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
/*===========================================*/
/* Create a string source router so that the */
/* string can be used as an input source. */
/*===========================================*/
if (OpenStringSource("check-syntax",theString,0) == 0)
{ return(TRUE); }
/*=================================*/
/* Only expressions and constructs */
/* can have their syntax checked. */
/*=================================*/
GetToken("check-syntax",&theToken);
if (theToken.type != LPAREN)
{
CloseStringSource("check-syntax");
SetpValue(returnValue,AddSymbol("MISSING-LEFT-PARENTHESIS"));
return(TRUE);
}
/*========================================*/
/* The next token should be the construct */
/* type or function name. */
/*========================================*/
GetToken("check-syntax",&theToken);
if (theToken.type != SYMBOL)
{
CloseStringSource("check-syntax");
SetpValue(returnValue,AddSymbol("EXPECTED-SYMBOL-AFTER-LEFT-PARENTHESIS"));
return(TRUE);
}
name = ValueToString(theToken.value);
/*==============================================*/
/* Set up a router to capture the error output. */
/*==============================================*/
AddRouter("error-capture",40,
FindErrorCapture, PrintErrorCapture,
NULL, NULL, NULL);
/*================================*/
/* Determine if it's a construct. */
/*================================*/
if (FindConstruct(name))
{
CheckSyntaxMode = TRUE;
rv = (short) ParseConstruct(name,"check-syntax");
GetToken("check-syntax",&theToken);
CheckSyntaxMode = FALSE;
if (rv)
{
PrintRouter(WERROR,"\nERROR:\n");
PrintInChunks(WERROR,GetPPBuffer());
PrintRouter(WERROR,"\n");
}
DestroyPPBuffer();
CloseStringSource("check-syntax");
if ((rv != FALSE) || (WarningString != NULL))
{
SetErrorCaptureValues(returnValue);
DeactivateErrorCapture();
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,AddSymbol("EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture();
return(TRUE);
}
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
DeactivateErrorCapture();
return(FALSE);
}
/*=======================*/
/* Parse the expression. */
/*=======================*/
top = Function2Parse("check-syntax",name);
GetToken("check-syntax",&theToken);
ClearParsedBindNames();
CloseStringSource("check-syntax");
if (top == NULL)
{
SetErrorCaptureValues(returnValue);
DeactivateErrorCapture();
return(TRUE);
}
if (theToken.type != STOP)
{
SetpValue(returnValue,AddSymbol("EXTRANEOUS-INPUT-AFTER-LAST-PARENTHESIS"));
DeactivateErrorCapture();
ReturnExpression(top);
return(TRUE);
}
DeactivateErrorCapture();
ReturnExpression(top);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,FalseSymbol);
return(FALSE);
}
globle int EnvEval(
void *theEnv,
char *theString,
DATA_OBJECT_PTR returnValue)
{
struct expr *top;
int ov;
static int depth = 0;
char logicalNameBuffer[20];
struct BindInfo *oldBinds;
/*======================================================*/
/* Evaluate the string. Create a different logical name */
/* for use each time the eval function is called. */
/*======================================================*/
depth++;
sprintf(logicalNameBuffer,"Eval-%d",depth);
if (OpenStringSource(theEnv,logicalNameBuffer,theString,0) == 0)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
depth--;
return(FALSE);
}
/*================================================*/
/* Save the current parsing state before routines */
/* are called to parse the eval string. */
/*================================================*/
ov = GetPPBufferStatus(theEnv);
SetPPBufferStatus(theEnv,FALSE);
oldBinds = GetParsedBindNames(theEnv);
SetParsedBindNames(theEnv,NULL);
/*========================================================*/
/* Parse the string argument passed to the eval function. */
/*========================================================*/
top = ParseAtomOrExpression(theEnv,logicalNameBuffer,NULL);
/*============================*/
/* Restore the parsing state. */
/*============================*/
SetPPBufferStatus(theEnv,ov);
ClearParsedBindNames(theEnv);
SetParsedBindNames(theEnv,oldBinds);
/*===========================================*/
/* Return if an error occured while parsing. */
/*===========================================*/
if (top == NULL)
{
SetEvaluationError(theEnv,TRUE);
CloseStringSource(theEnv,logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
depth--;
return(FALSE);
}
/*==============================================*/
/* The sequence expansion operator must be used */
/* within the argument list of a function call. */
/*==============================================*/
if ((top->type == MF_GBL_VARIABLE) || (top->type == MF_VARIABLE))
{
PrintErrorID(theEnv,"MISCFUN",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"expand$ must be used in the argument list of a function call.\n");
SetEvaluationError(theEnv,TRUE);
CloseStringSource(theEnv,logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
ReturnExpression(theEnv,top);
depth--;
return(FALSE);
}
/*=======================================*/
/* The expression to be evaluated cannot */
/* contain any local variables. */
/*=======================================*/
if (ExpressionContainsVariables(top,FALSE))
{
PrintErrorID(theEnv,"STRNGFUN",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Some variables could not be accessed by the eval function.\n");
SetEvaluationError(theEnv,TRUE);
CloseStringSource(theEnv,logicalNameBuffer);
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
ReturnExpression(theEnv,top);
depth--;
return(FALSE);
}
/*====================================*/
/* Evaluate the expression and return */
/* the memory used to parse it. */
/*====================================*/
ExpressionInstall(theEnv,top);
EvaluateExpression(theEnv,top,returnValue);
ExpressionDeinstall(theEnv,top);
depth--;
ReturnExpression(theEnv,top);
CloseStringSource(theEnv,logicalNameBuffer);
if (GetEvaluationError(theEnv)) return(FALSE);
return(TRUE);
}
globle void EnvGetFactList(
void *theEnv,
DATA_OBJECT_PTR returnValue,
void *vTheModule)
{
struct fact *theFact;
unsigned long count;
struct multifield *theList;
struct defmodule *theModule = (struct defmodule *) vTheModule;
/*==========================*/
/* Save the current module. */
/*==========================*/
SaveCurrentModule(theEnv);
/*============================================*/
/* Count the number of facts to be retrieved. */
/*============================================*/
if (theModule == NULL)
{
for (theFact = (struct fact *) EnvGetNextFact(theEnv,NULL), count = 0;
theFact != NULL;
theFact = (struct fact *) EnvGetNextFact(theEnv,theFact), count++)
{ /* Do Nothing */ }
}
else
{
EnvSetCurrentModule(theEnv,(void *) theModule);
UpdateDeftemplateScope(theEnv);
for (theFact = (struct fact *) GetNextFactInScope(theEnv,NULL), count = 0;
theFact != NULL;
theFact = (struct fact *) GetNextFactInScope(theEnv,theFact), count++)
{ /* Do Nothing */ }
}
/*===========================================================*/
/* Create the multifield value to store the construct names. */
/*===========================================================*/
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,(long) count);
theList = (struct multifield *) EnvCreateMultifield(theEnv,count);
SetpValue(returnValue,(void *) theList);
/*==================================================*/
/* Store the fact pointers in the multifield value. */
/*==================================================*/
if (theModule == NULL)
{
for (theFact = (struct fact *) EnvGetNextFact(theEnv,NULL), count = 1;
theFact != NULL;
theFact = (struct fact *) EnvGetNextFact(theEnv,theFact), count++)
{
SetMFType(theList,count,FACT_ADDRESS);
SetMFValue(theList,count,(void *) theFact);
}
}
else
{
for (theFact = (struct fact *) GetNextFactInScope(theEnv,NULL), count = 1;
theFact != NULL;
theFact = (struct fact *) GetNextFactInScope(theEnv,theFact), count++)
{
SetMFType(theList,count,FACT_ADDRESS);
SetMFValue(theList,count,(void *) theFact);
}
}
/*=============================*/
/* Restore the current module. */
/*=============================*/
RestoreCurrentModule(theEnv);
UpdateDeftemplateScope(theEnv);
}