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 BOOLEAN GetFactSlot(
void *vTheFact,
char *slotName,
DATA_OBJECT *theValue)
{
struct fact *theFact = (struct fact *) vTheFact;
struct deftemplate *theDeftemplate;
int whichSlot;
/*===============================================*/
/* Get the deftemplate associated with the fact. */
/*===============================================*/
theDeftemplate = theFact->whichDeftemplate;
/*==============================================*/
/* Handle retrieving the slot value from a fact */
/* having an implied deftemplate. An implied */
/* facts has a single multifield slot. */
/*==============================================*/
if (theDeftemplate->implied)
{
if (slotName != NULL) return(FALSE);
theValue->type = theFact->theProposition.theFields[0].type;
theValue->value = theFact->theProposition.theFields[0].value;
SetpDOBegin(theValue,1);
SetpDOEnd(theValue,((struct multifield *) theValue->value)->multifieldLength);
return(TRUE);
}
/*===================================*/
/* Make sure the slot name requested */
/* corresponds to a valid slot name. */
/*===================================*/
if (FindSlot(theDeftemplate,(SYMBOL_HN *) AddSymbol(slotName),&whichSlot) == NULL)
{ return(FALSE); }
/*======================================================*/
/* Return the slot value. If the slot value wasn't set, */
/* then return FALSE to indicate that an appropriate */
/* slot value wasn't available. */
/*======================================================*/
theValue->type = theFact->theProposition.theFields[whichSlot-1].type;
theValue->value = theFact->theProposition.theFields[whichSlot-1].value;
if (theValue->type == MULTIFIELD)
{
SetpDOBegin(theValue,1);
SetpDOEnd(theValue,((struct multifield *) theValue->value)->multifieldLength);
}
if (theValue->type == RVOID) return(FALSE);
return(TRUE);
}
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);
}
}
/***************************************************
NAME : EnvGetNextInstanceInClassAndSubclasses
DESCRIPTION : Finds next instance of class
(or first instance of class) and
all of its subclasses
INPUTS : 1) Class address (DIRECT POINTER!)
2) Instance address
(NULL to get first instance)
RETURNS : The next or first class instance
SIDE EFFECTS : None
NOTES : None
***************************************************/
globle void *EnvGetNextInstanceInClassAndSubclasses_PY(
void *theEnv,
void *cptr, /* this has changed */
void *iptr,
DATA_OBJECT *iterationInfo)
{
INSTANCE_TYPE *nextInstance;
DEFCLASS *theClass;
theClass = (DEFCLASS *)cptr;
if (iptr == NULL)
{
ClassSubclassAddresses(theEnv,theClass,iterationInfo,TRUE);
nextInstance = theClass->instanceList;
}
else if (((INSTANCE_TYPE *) iptr)->garbage == 1)
{ nextInstance = NULL; }
else
{ nextInstance = ((INSTANCE_TYPE *) iptr)->nxtClass; }
while ((nextInstance == NULL) &&
(GetpDOBegin(iterationInfo) <= GetpDOEnd(iterationInfo)))
{
theClass = (struct defclass *) GetMFValue(DOPToPointer(iterationInfo),
GetpDOBegin(iterationInfo));
SetpDOBegin(iterationInfo,GetpDOBegin(iterationInfo) + 1);
nextInstance = theClass->instanceList;
}
return(nextInstance);
}
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);
}
}
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);
}
/********************************************************************
NAME : EnvClassSlots
DESCRIPTION : Groups slot info for a class into a multifield value
for dynamic perusal
INPUTS : 1) Generic pointer to class
2) Data object buffer to hold the slots of the class
3) Include (1) or exclude (0) inherited slots
RETURNS : Nothing useful
SIDE EFFECTS : Creates a multifield storing the names of
the slots of the class
NOTES : None
********************************************************************/
globle void EnvClassSlots(
void *theEnv,
void *clsptr,
DATA_OBJECT *result,
int inhp)
{
long size;
register DEFCLASS *cls;
long i;
cls = (DEFCLASS *) clsptr;
size = inhp ? cls->instanceSlotCount : cls->slotCount;
result->type = MULTIFIELD;
SetpDOBegin(result,1);
SetpDOEnd(result,size);
result->value = (void *) EnvCreateMultifield(theEnv,size);
if (size == 0)
return;
if (inhp)
{
for (i = 0 ; i < cls->instanceSlotCount ; i++)
{
SetMFType(result->value,i+1,SYMBOL);
SetMFValue(result->value,i+1,cls->instanceTemplate[i]->slotName->name);
}
}
else
{
for (i = 0 ; i < cls->slotCount ; i++)
{
SetMFType(result->value,i+1,SYMBOL);
SetMFValue(result->value,i+1,cls->slots[i].slotName->name);
}
}
}
/***********************************************************
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);
}
/***************************************************************************
NAME : GetQueryFactSlot
DESCRIPTION : Internal function for referring to slots of fact in
fact array on fact-queries
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set appropriately
NOTES : H/L Syntax : ((query-fact-slot) <index> <slot-name>)
**************************************************************************/
globle void GetQueryFactSlot(
void *theEnv,
DATA_OBJECT *result)
{
struct fact *theFact;
DATA_OBJECT temp;
QUERY_CORE *core;
short position;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
core = FindQueryCore(theEnv,ValueToInteger(GetpValue(GetFirstArgument())));
theFact = core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))];
EvaluateExpression(theEnv,GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,"get",1,"symbol");
SetEvaluationError(theEnv,TRUE);
return;
}
/*==================================================*/
/* Make sure the slot exists (the symbol implied is */
/* used for the implied slot of an ordered fact). */
/*==================================================*/
if (theFact->whichDeftemplate->implied)
{
if (strcmp(ValueToString(temp.value),"implied") != 0)
{
SlotExistError(theEnv,ValueToString(temp.value),"fact-set query");
return;
}
position = 1;
}
else if (FindSlot((struct deftemplate *) theFact->whichDeftemplate,
(struct symbolHashNode *) temp.value,&position) == NULL)
{
SlotExistError(theEnv,ValueToString(temp.value),"fact-set query");
return;
}
result->type = theFact->theProposition.theFields[position-1].type;
result->value = theFact->theProposition.theFields[position-1].value;
if (result->type == MULTIFIELD)
{
SetpDOBegin(result,1);
SetpDOEnd(result,((struct multifield *) result->value)->multifieldLength);
}
}
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)));
}
}
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)));
}
}
globle void StoreInMultifield(
void *theEnv,
DATA_OBJECT *returnValue,
EXPRESSION *expptr,
int garbageSegment)
{
DATA_OBJECT val_ptr;
DATA_OBJECT *val_arr;
struct multifield *theMultifield;
struct multifield *orig_ptr;
long start, end, i,j, k, argCount;
unsigned long seg_size;
argCount = CountArguments(expptr);
/*=========================================*/
/* If no arguments are given return a NULL */
/* multifield of length zero. */
/*=========================================*/
if (argCount == 0)
{
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,0);
if (garbageSegment) theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,0L);
else theMultifield = (struct multifield *) CreateMultifield2(theEnv,0L);
SetpValue(returnValue,(void *) theMultifield);
return;
}
else
{
/*========================================*/
/* Get a new segment with length equal to */
/* the total length of all the arguments. */
/*========================================*/
val_arr = (DATA_OBJECT *) gm3(theEnv,(long) sizeof(DATA_OBJECT) * argCount);
seg_size = 0;
for (i = 1; i <= argCount; i++, expptr = expptr->nextArg)
{
EvaluateExpression(theEnv,expptr,&val_ptr);
if (EvaluationData(theEnv)->EvaluationError)
{
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,0);
if (garbageSegment)
{ theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,0L); }
else theMultifield = (struct multifield *) CreateMultifield2(theEnv,0L);
SetpValue(returnValue,(void *) theMultifield);
rm3(theEnv,val_arr,(long) sizeof(DATA_OBJECT) * argCount);
return;
}
SetpType(val_arr+i-1,GetType(val_ptr));
if (GetType(val_ptr) == MULTIFIELD)
{
SetpValue(val_arr+i-1,GetpValue(&val_ptr));
start = GetDOBegin(val_ptr);
end = GetDOEnd(val_ptr);
}
else if (GetType(val_ptr) == RVOID)
{
SetpValue(val_arr+i-1,GetValue(val_ptr));
start = 1;
end = 0;
}
else
{
SetpValue(val_arr+i-1,GetValue(val_ptr));
start = end = -1;
}
seg_size += (unsigned long) (end - start + 1);
SetpDOBegin(val_arr+i-1,start);
SetpDOEnd(val_arr+i-1,end);
}
if (garbageSegment)
{ theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,seg_size); }
else theMultifield = (struct multifield *) CreateMultifield2(theEnv,seg_size);
/*========================================*/
/* Copy each argument into new segment. */
/*========================================*/
for (k = 0, j = 1; k < argCount; k++)
{
if (GetpType(val_arr+k) == MULTIFIELD)
{
start = GetpDOBegin(val_arr+k);
end = GetpDOEnd(val_arr+k);
orig_ptr = (struct multifield *) GetpValue(val_arr+k);
for (i = start; i < end + 1; i++, j++)
{
SetMFType(theMultifield,j,(GetMFType(orig_ptr,i)));
SetMFValue(theMultifield,j,(GetMFValue(orig_ptr,i)));
}
}
else if (GetpType(val_arr+k) != RVOID)
{
SetMFType(theMultifield,j,(short) (GetpType(val_arr+k)));
SetMFValue(theMultifield,j,(GetpValue(val_arr+k)));
j++;
}
}
/*=========================*/
/* Return the new segment. */
/*=========================*/
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,(long) seg_size);
SetpValue(returnValue,(void *) theMultifield);
rm3(theEnv,val_arr,(long) sizeof(DATA_OBJECT) * argCount);
return;
}
}
globle intBool FactPNGetVar1(
void *theEnv,
void *theValue,
DATA_OBJECT_PTR returnValue)
{
unsigned short theField, theSlot;
struct fact *factPtr;
struct field *fieldPtr;
struct multifieldMarker *marks;
struct multifield *segmentPtr;
long extent;
struct factGetVarPN1Call *hack;
/*==========================================*/
/* Retrieve the arguments for the function. */
/*==========================================*/
hack = (struct factGetVarPN1Call *) ValueToBitMap(theValue);
/*=====================================================*/
/* Get the pointer to the fact from the partial match. */
/*=====================================================*/
factPtr = FactData(theEnv)->CurrentPatternFact;
marks = FactData(theEnv)->CurrentPatternMarks;
/*==========================================================*/
/* Determine if we want to retrieve the fact address of the */
/* fact, rather than retrieving a field from the fact. */
/*==========================================================*/
if (hack->factAddress)
{
returnValue->type = FACT_ADDRESS;
returnValue->value = (void *) factPtr;
return(TRUE);
}
/*=========================================================*/
/* Determine if we want to retrieve the entire slot value. */
/*=========================================================*/
if (hack->allFields)
{
theSlot = hack->whichSlot;
fieldPtr = &factPtr->theProposition.theFields[theSlot];
returnValue->type = fieldPtr->type;
returnValue->value = fieldPtr->value;
if (returnValue->type == MULTIFIELD)
{
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,((struct multifield *) fieldPtr->value)->multifieldLength);
}
return(TRUE);
}
/*====================================================*/
/* If the slot being accessed is a single field slot, */
/* then just return the single value found in that */
/* slot. The multifieldMarker data structures do not */
/* have to be considered since access to a single */
/* field slot is not affected by variable bindings */
/* from multifield slots. */
/*====================================================*/
theField = hack->whichField;
theSlot = hack->whichSlot;
fieldPtr = &factPtr->theProposition.theFields[theSlot];
/*==========================================================*/
/* Retrieve a value from a multifield slot. First determine */
/* the range of fields for the variable being retrieved. */
/*==========================================================*/
extent = -1;
theField = AdjustFieldPosition(theEnv,marks,theField,theSlot,&extent);
/*=============================================================*/
/* If a range of values are being retrieved (i.e. a multifield */
/* variable), then return the values as a multifield. */
/*=============================================================*/
if (extent != -1)
{
returnValue->type = MULTIFIELD;
returnValue->value = (void *) fieldPtr->value;
returnValue->begin = theField;
returnValue->end = theField + extent - 1;
return(TRUE);
}
/*========================================================*/
/* Otherwise a single field value is being retrieved from */
/* a multifield slot. Just return the type and value. */
/*========================================================*/
segmentPtr = (struct multifield *) fieldPtr->value;
fieldPtr = &segmentPtr->theFields[theField];
returnValue->type = fieldPtr->type;
returnValue->value = fieldPtr->value;
return(TRUE);
}
void C_leer_ficha(void *environment, DATA_OBJECT_PTR returnValuePtr)
{
SDL_Event evento;
int x, y, pos, head=1;
void *retorno;
char fin=0, fin2=0;
if (n == 0) {
x=-1;
y=-1;
fin = 1;
}
leyendo=1;
while (!fin) {
while (SDL_PollEvent(&evento)) {
switch (evento.type) {
case SDL_QUIT:
SDL_Quit();
fin = 1;
break;
case SDL_MOUSEBUTTONDOWN:
if (evento.button.button == SDL_BUTTON_RIGHT) {
x=-1; y=-1;
fin = 1;
break;
}
if (evento.button.y >= FICHAS_Y &&
evento.button.y <= FICHAS_Y + fichaH) {
for (pos=0; pos<n; ++pos) {
if (evento.button.y >= FICHAS_Y &&
evento.button.y <= FICHAS_Y + fichaH) {
if (evento.button.x >= (30 + pos*(fichaW + 10)) &&
evento.button.x <= (30 + pos*(fichaW + 10) + fichaW)) {
if (evento.button.y > FICHAS_Y + fichaH/2) {
x = fichas[jugador[pos]].y;
y = fichas[jugador[pos]].x;
}
else {
x = fichas[jugador[pos]].x;
y = fichas[jugador[pos]].y;
}
fin2=0;
while (!fin2) {
SDL_PollEvent(&evento);
switch (evento.type) {
case SDL_MOUSEBUTTONDOWN:
if (evento.button.button == SDL_BUTTON_RIGHT) fin2=1;
else {
if (is_head (evento.button.x, evento.button.y))
fin=1, fin2=1;
else if (is_tail (evento.button.x, evento.button.y)) {
fin = x;
x = y;
y = fin;
fin = 1;
head = 0;
fin2=1;
}
}
break;
}
}
}
}
}
}
break;
}
}
C_flip(environment);
}
retorno = EnvCreateMultifield(environment,3);
SetMFType(retorno, 1, INTEGER);
SetMFValue(retorno, 1, EnvAddLong(environment,x));
SetMFType(retorno, 2, INTEGER);
SetMFValue(retorno, 2, EnvAddLong(environment,y));
SetMFType(retorno, 3, INTEGER);
SetMFValue(retorno, 3, EnvAddLong(environment,head));
SetpType(returnValuePtr, MULTIFIELD);
SetpValue(returnValuePtr, retorno);
SetpDOBegin(returnValuePtr, 1);
SetpDOEnd(returnValuePtr, 3);
n=0;
while (SDL_PollEvent(&evento));
}
globle intBool FactJNGetVar1(
void *theEnv,
EXEC_STATUS,
void *theValue,
DATA_OBJECT_PTR returnValue)
{
unsigned short theField, theSlot;
struct fact *factPtr;
struct field *fieldPtr;
struct multifieldMarker *marks;
struct multifield *segmentPtr;
int extent;
struct factGetVarJN1Call *hack;
/*==========================================*/
/* Retrieve the arguments for the function. */
/*==========================================*/
hack = (struct factGetVarJN1Call *) ValueToBitMap(theValue);
/*=====================================================*/
/* Get the pointer to the fact from the partial match. */
/*=====================================================*/
if (hack->lhs)
{
factPtr = (struct fact *) get_nth_pm_match(LocalEngineData(theEnv,execStatus).LHSBinds,hack->whichPattern)->matchingItem;
marks = get_nth_pm_match(LocalEngineData(theEnv,execStatus).LHSBinds,hack->whichPattern)->markers;
}
else if (hack->rhs)
{
factPtr = (struct fact *) get_nth_pm_match(LocalEngineData(theEnv,execStatus).RHSBinds,hack->whichPattern)->matchingItem;
marks = get_nth_pm_match(LocalEngineData(theEnv,execStatus).RHSBinds,hack->whichPattern)->markers;
}
else if (LocalEngineData(theEnv,execStatus).RHSBinds == NULL)
{
factPtr = (struct fact *) get_nth_pm_match(LocalEngineData(theEnv,execStatus).LHSBinds,hack->whichPattern)->matchingItem;
marks = get_nth_pm_match(LocalEngineData(theEnv,execStatus).LHSBinds,hack->whichPattern)->markers;
}
else if ((((unsigned short) (EngineData(theEnv,execStatus)->GlobalJoin->depth - 1))) == hack->whichPattern)
{
factPtr = (struct fact *) get_nth_pm_match(LocalEngineData(theEnv,execStatus).RHSBinds,0)->matchingItem;
marks = get_nth_pm_match(LocalEngineData(theEnv,execStatus).RHSBinds,0)->markers;
}
else
{
factPtr = (struct fact *) get_nth_pm_match(LocalEngineData(theEnv,execStatus).LHSBinds,hack->whichPattern)->matchingItem;
marks = get_nth_pm_match(LocalEngineData(theEnv,execStatus).LHSBinds,hack->whichPattern)->markers;
}
/*==========================================================*/
/* Determine if we want to retrieve the fact address of the */
/* fact, rather than retrieving a field from the fact. */
/*==========================================================*/
if (hack->factAddress)
{
returnValue->type = FACT_ADDRESS;
returnValue->value = (void *) factPtr;
return(TRUE);
}
/*=========================================================*/
/* Determine if we want to retrieve the entire slot value. */
/*=========================================================*/
if (hack->allFields)
{
theSlot = hack->whichSlot;
fieldPtr = &factPtr->theProposition.theFields[theSlot];
returnValue->type = fieldPtr->type;
returnValue->value = fieldPtr->value;
if (returnValue->type == MULTIFIELD)
{
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,((struct multifield *) fieldPtr->value)->multifieldLength);
}
return(TRUE);
}
/*====================================================*/
/* If the slot being accessed is a single field slot, */
/* then just return the single value found in that */
/* slot. The multifieldMarker data structures do not */
/* have to be considered since access to a single */
/* field slot is not affected by variable bindings */
/* from multifield slots. */
/*====================================================*/
theField = hack->whichField;
theSlot = hack->whichSlot;
fieldPtr = &factPtr->theProposition.theFields[theSlot];
if (fieldPtr->type != MULTIFIELD)
{
returnValue->type = fieldPtr->type;
returnValue->value = fieldPtr->value;
return(TRUE);
}
/*==========================================================*/
/* Retrieve a value from a multifield slot. First determine */
/* the range of fields for the variable being retrieved. */
/*==========================================================*/
extent = -1;
theField = AdjustFieldPosition(theEnv,execStatus,marks,theField,theSlot,&extent);
/*=============================================================*/
/* If a range of values are being retrieved (i.e. a multifield */
/* variable), then return the values as a multifield. */
/*=============================================================*/
if (extent != -1)
{
returnValue->type = MULTIFIELD;
returnValue->value = (void *) fieldPtr->value;
returnValue->begin = theField;
returnValue->end = theField + extent - 1;
return(TRUE);
}
/*========================================================*/
/* Otherwise a single field value is being retrieved from */
/* a multifield slot. Just return the type and value. */
/*========================================================*/
segmentPtr = (struct multifield *) factPtr->theProposition.theFields[theSlot].value;
fieldPtr = &segmentPtr->theFields[theField];
returnValue->type = fieldPtr->type;
returnValue->value = fieldPtr->value;
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);
}
globle void SortFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
long argumentCount, i, j, k = 0;
DATA_OBJECT *theArguments, *theArguments2;
DATA_OBJECT theArg;
struct multifield *theMultifield, *tempMultifield;
char *functionName;
struct expr *functionReference;
int argumentSize = 0;
struct FunctionDefinition *fptr;
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *dptr;
#endif
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
/*=============================================*/
/* The function expects at least one argument. */
/*=============================================*/
if ((argumentCount = EnvArgCountCheck(theEnv,"sort",AT_LEAST,1)) == -1)
{ return; }
/*=============================================*/
/* Verify that the comparison function exists. */
/*=============================================*/
if (EnvArgTypeCheck(theEnv,"sort",1,SYMBOL,&theArg) == FALSE)
{ return; }
functionName = DOToString(theArg);
functionReference = FunctionReferenceExpression(theEnv,functionName);
if (functionReference == NULL)
{
ExpectedTypeError1(theEnv,"sort",1,"function name, deffunction name, or defgeneric name");
return;
}
/*======================================*/
/* For an external function, verify the */
/* correct number of arguments. */
/*======================================*/
if (functionReference->type == FCALL)
{
fptr = (struct FunctionDefinition *) functionReference->value;
if ((GetMinimumArgs(fptr) > 2) ||
(GetMaximumArgs(fptr) == 0) ||
(GetMaximumArgs(fptr) == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"function name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
/*=======================================*/
/* For a deffunction, verify the correct */
/* number of arguments. */
/*=======================================*/
#if DEFFUNCTION_CONSTRUCT
if (functionReference->type == PCALL)
{
dptr = (DEFFUNCTION *) functionReference->value;
if ((dptr->minNumberOfParameters > 2) ||
(dptr->maxNumberOfParameters == 0) ||
(dptr->maxNumberOfParameters == 1))
{
ExpectedTypeError1(theEnv,"sort",1,"deffunction name expecting two arguments");
ReturnExpression(theEnv,functionReference);
return;
}
}
#endif
/*=====================================*/
/* If there are no items to be sorted, */
/* then return an empty multifield. */
/*=====================================*/
if (argumentCount == 1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*=====================================*/
/* Retrieve the arguments to be sorted */
/* and determine how many there are. */
/*=====================================*/
theArguments = (DATA_OBJECT *) genalloc(theEnv,(argumentCount - 1) * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
EnvRtnUnknown(theEnv,i,&theArguments[i-2]);
if (GetType(theArguments[i-2]) == MULTIFIELD)
{ argumentSize += GetpDOLength(&theArguments[i-2]); }
else
{ argumentSize++; }
}
if (argumentSize == 0)
{
genfree(theEnv,theArguments,(argumentCount - 1) * sizeof(DATA_OBJECT)); /* Bug Fix */
EnvSetMultifieldErrorValue(theEnv,returnValue);
ReturnExpression(theEnv,functionReference);
return;
}
/*====================================*/
/* Pack all of the items to be sorted */
/* into a data object array. */
/*====================================*/
theArguments2 = (DATA_OBJECT *) genalloc(theEnv,argumentSize * sizeof(DATA_OBJECT));
for (i = 2; i <= argumentCount; i++)
{
if (GetType(theArguments[i-2]) == MULTIFIELD)
{
tempMultifield = (struct multifield *) GetValue(theArguments[i-2]);
for (j = GetDOBegin(theArguments[i-2]); j <= GetDOEnd(theArguments[i-2]); j++, k++)
{
SetType(theArguments2[k],GetMFType(tempMultifield,j));
SetValue(theArguments2[k],GetMFValue(tempMultifield,j));
}
}
else
{
SetType(theArguments2[k],GetType(theArguments[i-2]));
SetValue(theArguments2[k],GetValue(theArguments[i-2]));
k++;
}
}
genfree(theEnv,theArguments,(argumentCount - 1) * sizeof(DATA_OBJECT));
functionReference->nextArg = SortFunctionData(theEnv)->SortComparisonFunction;
SortFunctionData(theEnv)->SortComparisonFunction = functionReference;
for (i = 0; i < argumentSize; i++)
{ ValueInstall(theEnv,&theArguments2[i]); }
MergeSort(theEnv,(unsigned long) argumentSize,theArguments2,DefaultCompareSwapFunction);
for (i = 0; i < argumentSize; i++)
{ ValueDeinstall(theEnv,&theArguments2[i]); }
SortFunctionData(theEnv)->SortComparisonFunction = SortFunctionData(theEnv)->SortComparisonFunction->nextArg;
functionReference->nextArg = NULL;
ReturnExpression(theEnv,functionReference);
theMultifield = (struct multifield *) EnvCreateMultifield(theEnv,(unsigned long) argumentSize);
for (i = 0; i < argumentSize; i++)
{
SetMFType(theMultifield,i+1,GetType(theArguments2[i]));
SetMFValue(theMultifield,i+1,GetValue(theArguments2[i]));
}
genfree(theEnv,theArguments2,argumentSize * sizeof(DATA_OBJECT));
SetpType(returnValue,MULTIFIELD);
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,argumentSize);
SetpValue(returnValue,(void *) theMultifield);
}
static void DuplicateModifyCommand(
void *theEnv,
int retractIt,
DATA_OBJECT_PTR returnValue)
{
long int factNum;
struct fact *oldFact, *newFact, *theFact;
struct expr *testPtr;
DATA_OBJECT computeResult;
struct deftemplate *templatePtr;
struct templateSlot *slotPtr;
int i, position, found;
/*===================================================*/
/* Set the default return value to the symbol FALSE. */
/*===================================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,SymbolData(theEnv)->FalseSymbol);
/*==================================================*/
/* Evaluate the first argument which is used to get */
/* a pointer to the fact to be modified/duplicated. */
/*==================================================*/
testPtr = GetFirstArgument();
EvaluateExpression(theEnv,testPtr,&computeResult);
/*==============================================================*/
/* If an integer is supplied, then treat it as a fact-index and */
/* search the fact-list for the fact with that fact-index. */
/*==============================================================*/
if (computeResult.type == INTEGER)
{
factNum = ValueToLong(computeResult.value);
if (factNum < 0)
{
if (retractIt) ExpectedTypeError2(theEnv,"modify",1);
else ExpectedTypeError2(theEnv,"duplicate",1);
SetEvaluationError(theEnv,TRUE);
return;
}
oldFact = (struct fact *) EnvGetNextFact(theEnv,NULL);
while (oldFact != NULL)
{
if (oldFact->factIndex == factNum)
{ break; }
else
{ oldFact = oldFact->nextFact; }
}
if (oldFact == NULL)
{
char tempBuffer[20];
sprintf(tempBuffer,"f-%ld",factNum);
CantFindItemErrorMessage(theEnv,"fact",tempBuffer);
return;
}
}
/*==========================================*/
/* Otherwise, if a pointer is supplied then */
/* no lookup is required. */
/*==========================================*/
else if (computeResult.type == FACT_ADDRESS)
{ oldFact = (struct fact *) computeResult.value; }
/*===========================================*/
/* Otherwise, the first argument is invalid. */
/*===========================================*/
else
{
if (retractIt) ExpectedTypeError2(theEnv,"modify",1);
else ExpectedTypeError2(theEnv,"duplicate",1);
SetEvaluationError(theEnv,TRUE);
return;
}
/*==================================*/
/* See if it is a deftemplate fact. */
/*==================================*/
templatePtr = oldFact->whichDeftemplate;
if (templatePtr->implied) return;
/*================================================================*/
/* Duplicate the values from the old fact (skipping multifields). */
/*================================================================*/
newFact = (struct fact *) CreateFactBySize(theEnv,oldFact->theProposition.multifieldLength);
newFact->whichDeftemplate = templatePtr;
for (i = 0; i < (int) oldFact->theProposition.multifieldLength; i++)
{
newFact->theProposition.theFields[i].type = oldFact->theProposition.theFields[i].type;
if (newFact->theProposition.theFields[i].type != MULTIFIELD)
{ newFact->theProposition.theFields[i].value = oldFact->theProposition.theFields[i].value; }
else
{ newFact->theProposition.theFields[i].value = NULL; }
}
/*========================*/
/* Start replacing slots. */
/*========================*/
testPtr = testPtr->nextArg;
while (testPtr != NULL)
{
/*============================================================*/
/* If the slot identifier is an integer, then the slot was */
/* previously identified and its position within the template */
/* was stored. Otherwise, the position of the slot within the */
/* deftemplate has to be determined by comparing the name of */
/* the slot against the list of slots for the deftemplate. */
/*============================================================*/
if (testPtr->type == INTEGER)
{ position = (int) ValueToLong(testPtr->value); }
else
{
found = FALSE;
position = 0;
slotPtr = templatePtr->slotList;
while (slotPtr != NULL)
{
if (slotPtr->slotName == (SYMBOL_HN *) testPtr->value)
{
found = TRUE;
slotPtr = NULL;
}
else
{
slotPtr = slotPtr->next;
position++;
}
}
if (! found)
{
InvalidDeftemplateSlotMessage(theEnv,ValueToString(testPtr->value),
ValueToString(templatePtr->header.name));
SetEvaluationError(theEnv,TRUE);
ReturnFact(theEnv,newFact);
return;
}
}
/*===================================================*/
/* If a single field slot is being replaced, then... */
/*===================================================*/
if (newFact->theProposition.theFields[position].type != MULTIFIELD)
{
/*======================================================*/
/* If the list of values to store in the slot is empty */
/* or contains more than one member than an error has */
/* occured because a single field slot can only contain */
/* a single value. */
/*======================================================*/
if ((testPtr->argList == NULL) ? TRUE : (testPtr->argList->nextArg != NULL))
{
MultiIntoSingleFieldSlotError(theEnv,GetNthSlot(templatePtr,position),templatePtr);
ReturnFact(theEnv,newFact);
return;
}
/*===================================================*/
/* Evaluate the expression to be stored in the slot. */
/*===================================================*/
EvaluateExpression(theEnv,testPtr->argList,&computeResult);
SetEvaluationError(theEnv,FALSE);
/*====================================================*/
/* If the expression evaluated to a multifield value, */
/* then an error occured since a multifield value can */
/* not be stored in a single field slot. */
/*====================================================*/
if (computeResult.type == MULTIFIELD)
{
ReturnFact(theEnv,newFact);
MultiIntoSingleFieldSlotError(theEnv,GetNthSlot(templatePtr,position),templatePtr);
return;
}
/*=============================*/
/* Store the value in the slot */
/*=============================*/
newFact->theProposition.theFields[position].type =
computeResult.type;
newFact->theProposition.theFields[position].value =
computeResult.value;
}
/*=================================*/
/* Else replace a multifield slot. */
/*=================================*/
else
{
/*======================================*/
/* Determine the new value of the slot. */
/*======================================*/
StoreInMultifield(theEnv,&computeResult,testPtr->argList,FALSE);
SetEvaluationError(theEnv,FALSE);
/*=============================*/
/* Store the value in the slot */
/*=============================*/
newFact->theProposition.theFields[position].type =
computeResult.type;
newFact->theProposition.theFields[position].value =
computeResult.value;
}
testPtr = testPtr->nextArg;
}
/*=====================================*/
/* Copy the multifield values from the */
/* old fact that were not replaced. */
/*=====================================*/
for (i = 0; i < (int) oldFact->theProposition.multifieldLength; i++)
{
if ((newFact->theProposition.theFields[i].type == MULTIFIELD) &&
(newFact->theProposition.theFields[i].value == NULL))
{
newFact->theProposition.theFields[i].value =
CopyMultifield(theEnv,(struct multifield *) oldFact->theProposition.theFields[i].value);
}
}
/*======================================*/
/* Perform the duplicate/modify action. */
/*======================================*/
if (retractIt) EnvRetract(theEnv,oldFact);
theFact = (struct fact *) EnvAssert(theEnv,newFact);
/*========================================*/
/* The asserted fact is the return value. */
/*========================================*/
if (theFact != NULL)
{
SetpDOBegin(returnValue,1);
SetpDOEnd(returnValue,theFact->theProposition.multifieldLength);
SetpType(returnValue,FACT_ADDRESS);
SetpValue(returnValue,(void *) theFact);
}
return;
}
/*might be dangerous, maybe trasfer to from mf instead*/
VOID tpn_mf_mirror(DATA_OBJECT_PTR rp)
{
int *pi,i,num,offset=0,stride=1;
float *pf;
double *pd;
char tstr[9],type,t1[2];
VOID *mfp;
t1[1]='\0';
/*get the type*/
sprintf(tstr,"%s",(char *)RtnLexeme(1));
type = tolower(tstr[0]);
if(type!='i' && type!='f' && type!='d' && type!='b')
{
printf("[1st arg=type:i or f or d]");
return;
}
/*get number (& offset & stride) to put to a m.f.*/
if(RtnArgCount() > 2) num=(int)RtnLong(3);
if(RtnArgCount() > 3) offset=(int)RtnLong(4);
if(RtnArgCount() > 4) stride=(int)RtnLong(5);
/*could use SetMultifieldErrorValue(rp); return;*/
mfp = CreateMultifield(num);
/*get the ptr, and set the MF*/
switch(type)
{
case 'i' : pi = (int *)get_ptr(2);
for(i=0; i<num; i++)
{
printf(",%d ",
SetMFType(mfp,i,INTEGER));
/*SetMFValue(mfp,i,AddLong(pi[offset+i]));
set the Data_Object ptr to the address*/
}
break;
case 'f' : pf = (float *)get_ptr(2);
for(i=0; i<num; i++)
{
printf("%f to mf,",pf[offset+i]);
fflush(stdout);
printf(",%d ",
SetMFType(mfp,i,FLOAT));
fflush(stdout);
/*SetMFValue(mfp,i,AddDouble((double)pf[offset+i]));
set the Data_Object ptr to the address*/
}
break;
case 'd' : pd = (double *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,FLOAT);
/*SetMFValue(mfp,i,AddDouble(pd[offset+i]));
set the Data_Object ptr to the address*/
}
break;
}
SetpType(rp,MULTIFIELD);
SetpValue(rp,mfp);
SetpDOBegin(rp,1);
SetpDOEnd(rp,num);
return;
}
/*-deref or pk_tpn can fill malloced space, then can use this to get to a m.f.*/
VOID tpn_to_mf(DATA_OBJECT_PTR rp)
{
int num=1,stride=1,*pi,offset=0,i;
float *pf;
double *pd;
char tstr[9],type,*pc,t1[2];
VOID *mfp;
t1[1]='\0';
/*get the type*/
sprintf(tstr,"%s",(char *)RtnLexeme(1));
type = tolower(tstr[0]);
if(type!='i' && type!='f' && type!='d' && type!='b')
{
printf("[1st arg=type:i or f or d]");
return;
}
/*get number (& offset & stride) to put to a m.f.*/
if(RtnArgCount() > 2) num=(int)RtnLong(3);
if(RtnArgCount() > 3) offset=(int)RtnLong(4);
if(RtnArgCount() > 4) stride=(int)RtnLong(5);
/*could use SetMultifieldErrorValue(rp); return;*/
mfp = CreateMultifield(num);
/*get the ptr, and set the MF*/
switch(type)
{
case 'i' : pi = (int *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,INTEGER);
SetMFValue(mfp,i,AddLong(pi[offset+i]));
}
break;
case 'f' : pf = (float *)get_ptr(2);
for(i=0; i<num; i++)
{
printf("%f to mf,",pf[offset+i]); fflush(stdout);
SetMFType(mfp,i,FLOAT);
SetMFValue(mfp,i,AddDouble((double)pf[offset+i]));
}
break;
case 'd' : pd = (double *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,FLOAT);
SetMFValue(mfp,i,AddDouble(pd[offset+i]));
}
break;
/*this one could go per char or by stride or by space breaks*/
/*go by char for now*/
case 'b' : pc = (char *)get_ptr(2);
for(i=0; i<num; i++)
{
SetMFType(mfp,i,SYMBOL);
t1[0]=pc[offset+i];
SetMFValue(mfp,i,AddSymbol(t1));
}
break;
} /*gets past this and dies when printing out the result-
-looks liked capped ok though*/
SetpType(rp,MULTIFIELD);
SetpValue(rp,mfp);
SetpDOBegin(rp,1);
SetpDOEnd(rp,num);
return;
}
/************************************************************************
NAME : EnvGetDefmessageHandlerList
DESCRIPTION : Groups handler info for a class into a multifield value
for dynamic perusal
INPUTS : 1) Generic pointer to class (NULL to get handlers for
all classes)
2) Data object buffer to hold the handlers of the class
3) Include (1) or exclude (0) inherited handlers
RETURNS : Nothing useful
SIDE EFFECTS : Creates a multifield storing the names and types of
the message-handlers of the class
NOTES : None
************************************************************************/
globle void EnvGetDefmessageHandlerList(
void *theEnv,
void *clsptr,
DATA_OBJECT *result,
int inhp)
{
DEFCLASS *cls,*svcls,*svnxt,*supcls;
long j;
register int classi,classiLimit;
unsigned long i, sublen, len;
if (clsptr == NULL)
{
inhp = 0;
cls = (DEFCLASS *) EnvGetNextDefclass(theEnv,NULL);
svnxt = (DEFCLASS *) EnvGetNextDefclass(theEnv,(void *) cls);
}
else
{
cls = (DEFCLASS *) clsptr;
svnxt = (DEFCLASS *) EnvGetNextDefclass(theEnv,(void *) cls);
SetNextDefclass((void *) cls,NULL);
}
for (svcls = cls , i = 0 ;
cls != NULL ;
cls = (DEFCLASS *) EnvGetNextDefclass(theEnv,(void *) cls))
{
classiLimit = inhp ? cls->allSuperclasses.classCount : 1;
for (classi = 0 ; classi < classiLimit ; classi++)
i += cls->allSuperclasses.classArray[classi]->handlerCount;
}
len = i * 3;
result->type = MULTIFIELD;
SetpDOBegin(result,1);
SetpDOEnd(result,len);
result->value = (void *) EnvCreateMultifield(theEnv,len);
for (cls = svcls , sublen = 0 ;
cls != NULL ;
cls = (DEFCLASS *) EnvGetNextDefclass(theEnv,(void *) cls))
{
classiLimit = inhp ? cls->allSuperclasses.classCount : 1;
for (classi = 0 ; classi < classiLimit ; classi++)
{
supcls = cls->allSuperclasses.classArray[classi];
if (inhp == 0)
i = sublen + 1;
else
i = len - (supcls->handlerCount * 3) - sublen + 1;
for (j = 0 ; j < supcls->handlerCount ; j++)
{
SetMFType(result->value,i,SYMBOL);
SetMFValue(result->value,i++,GetDefclassNamePointer((void *) supcls));
SetMFType(result->value,i,SYMBOL);
SetMFValue(result->value,i++,supcls->handlers[j].name);
SetMFType(result->value,i,SYMBOL);
SetMFValue(result->value,i++,EnvAddSymbol(theEnv,MessageHandlerData(theEnv)->hndquals[supcls->handlers[j].type]));
}
sublen += supcls->handlerCount * 3;
}
}
if (svcls != NULL)
SetNextDefclass((void *) svcls,(void *) svnxt);
}
globle void DeriveDefaultFromConstraints(
void *theEnv,
CONSTRAINT_RECORD *constraints,
DATA_OBJECT *theDefault,
int multifield,
int garbageMultifield)
{
unsigned short theType;
unsigned long minFields;
void *theValue;
/*=============================================================*/
/* If no constraints are specified, then use the symbol nil as */
/* a default for single field slots and a multifield of length */
/* 0 as a default for multifield slots. */
/*=============================================================*/
if (constraints == NULL)
{
if (multifield)
{
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,0);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,0L));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,0L));
}
else
{
theDefault->type = SYMBOL;
theDefault->value = EnvAddSymbol(theEnv,(char*)"nil");
}
return;
}
/*=========================================*/
/* Determine the default's type and value. */
/*=========================================*/
if (constraints->anyAllowed || constraints->symbolsAllowed)
{
theType = SYMBOL;
theValue = FindDefaultValue(theEnv,SYMBOL,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->stringsAllowed)
{
theType = STRING;
theValue = FindDefaultValue(theEnv,STRING,constraints,EnvAddSymbol(theEnv,(char*)""));
}
else if (constraints->integersAllowed)
{
theType = INTEGER;
theValue = FindDefaultValue(theEnv,INTEGER,constraints,EnvAddLong(theEnv,0LL));
}
else if (constraints->floatsAllowed)
{
theType = FLOAT;
theValue = FindDefaultValue(theEnv,FLOAT,constraints,EnvAddDouble(theEnv,0.0));
}
#if OBJECT_SYSTEM
else if (constraints->instanceNamesAllowed)
{
theType = INSTANCE_NAME;
theValue = FindDefaultValue(theEnv,INSTANCE_NAME,constraints,EnvAddSymbol(theEnv,(char*)"nil"));
}
else if (constraints->instanceAddressesAllowed)
{
theType = INSTANCE_ADDRESS;
theValue = (void *) &InstanceData(theEnv)->DummyInstance;
}
#endif
#if DEFTEMPLATE_CONSTRUCT
else if (constraints->factAddressesAllowed)
{
theType = FACT_ADDRESS;
theValue = (void *) &FactData(theEnv)->DummyFact;
}
#endif
else if (constraints->externalAddressesAllowed)
{
theType = EXTERNAL_ADDRESS;
theValue = EnvAddExternalAddress(theEnv,NULL,0);
}
else
{
theType = SYMBOL;
theValue = EnvAddSymbol(theEnv,(char*)"nil");
}
/*=========================================================*/
/* If the default is for a multifield slot, then create a */
/* multifield default value that satisfies the cardinality */
/* constraints for the slot. The default value for a */
/* multifield slot is a multifield of length 0. */
/*=========================================================*/
if (multifield)
{
if (constraints->minFields == NULL) minFields = 0;
else if (constraints->minFields->value == SymbolData(theEnv)->NegativeInfinity) minFields = 0;
else minFields = (unsigned long) ValueToLong(constraints->minFields->value);
SetpType(theDefault,MULTIFIELD);
SetpDOBegin(theDefault,1);
SetpDOEnd(theDefault,(long) minFields);
if (garbageMultifield) SetpValue(theDefault,(void *) EnvCreateMultifield(theEnv,minFields));
else SetpValue(theDefault,(void *) CreateMultifield2(theEnv,minFields));
for (; minFields > 0; minFields--)
{
SetMFType(GetpValue(theDefault),minFields,theType);
SetMFValue(GetpValue(theDefault),minFields,theValue);
}
}
else
{
theDefault->type = theType;
theDefault->value = theValue;
}
}
