/***************************************************************************
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);
}
}
/***************************************************************************
NAME : GetQueryInstanceSlot
DESCRIPTION : Internal function for referring to slots of instances in
instance array on instance-queries
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set appropriately
NOTES : H/L Syntax : ((query-instance-slot) <index> <slot-name>)
**************************************************************************/
globle void GetQueryInstanceSlot(
DATA_OBJECT *result)
{
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
DATA_OBJECT temp;
QUERY_CORE *core;
result->type = SYMBOL;
result->value = FalseSymbol;
core = FindQueryCore(DOPToInteger(GetFirstArgument()));
ins = core->solns[DOPToInteger(GetFirstArgument()->nextArg)];
EvaluateExpression(GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1("get",1,"symbol");
SetEvaluationError(TRUE);
return;
}
sp = FindInstanceSlot(ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(ValueToString(temp.value),"instance-set query");
return;
}
result->type = sp->type;
result->value = sp->value;
if (sp->type == MULTIFIELD)
{
result->begin = 0;
result->end = GetInstanceSlotLength(sp) - 1;
}
}
/*********************************************************
NAME : SlotInfoSlot
DESCRIPTION : Runtime support routine for slot-sources,
slot-facets, et. al. which looks up
a slot
INPUTS : 1) Data object buffer
2) Class pointer
3) Name-string of slot to find
4) The name of the calling function
RETURNS : Nothing useful
SIDE EFFECTS : Support function called and data object
buffer initialized
NOTES : None
*********************************************************/
static SLOT_DESC *SlotInfoSlot(
void *theEnv,
DATA_OBJECT *result,
DEFCLASS *cls,
const char *sname,
const char *fnxname)
{
SYMBOL_HN *ssym;
int i;
if ((ssym = FindSymbolHN(theEnv,sname)) == NULL)
{
SetEvaluationError(theEnv,TRUE);
EnvSetMultifieldErrorValue(theEnv,result);
return(NULL);
}
i = FindInstanceTemplateSlot(theEnv,cls,ssym);
if (i == -1)
{
SlotExistError(theEnv,sname,fnxname);
SetEvaluationError(theEnv,TRUE);
EnvSetMultifieldErrorValue(theEnv,result);
return(NULL);
}
result->type = MULTIFIELD;
result->begin = 0;
return(cls->instanceTemplate[i]);
}
/***************************************************************************
NAME : GetQueryInstanceSlot
DESCRIPTION : Internal function for referring to slots of instances in
instance array on instance-queries
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set appropriately
NOTES : H/L Syntax : ((query-instance-slot) <index> <slot-name>)
**************************************************************************/
globle void GetQueryInstanceSlot(
void *theEnv,
DATA_OBJECT *result)
{
INSTANCE_TYPE *ins;
INSTANCE_SLOT *sp;
DATA_OBJECT temp;
QUERY_CORE *core;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
core = FindQueryCore(theEnv,ValueToInteger(GetpValue(GetFirstArgument())));
ins = core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))];
EvaluateExpression(theEnv,GetFirstArgument()->nextArg->nextArg,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,"get",1,"symbol");
EnvSetEvaluationError(theEnv,TRUE);
return;
}
sp = FindInstanceSlot(theEnv,ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(theEnv,ValueToString(temp.value),"instance-set query");
return;
}
result->type = (unsigned short) sp->type;
result->value = sp->value;
if (sp->type == MULTIFIELD)
{
result->begin = 0;
SetpDOEnd(result,GetInstanceSlotLength(sp));
}
}
/***********************************************************
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);
}
/***************************************************
NAME : CheckSlotExists
DESCRIPTION : Checks first two arguments of
a function for a valid class
and (inherited) slot
INPUTS : 1) The name of the function
2) A buffer to hold the found class
3) A flag indicating whether the
non-existence of the slot should
be an error
4) A flag indicating if the slot
can be inherited or not
RETURNS : NULL if slot not found, slot
descriptor otherwise
SIDE EFFECTS : Class buffer set if no errors,
NULL on errors
NOTES : None
***************************************************/
static SlotDescriptor *CheckSlotExists(
UDFContext *context,
const char *func,
Defclass **classBuffer,
bool existsErrorFlag,
bool inheritFlag)
{
CLIPSLexeme *ssym;
int slotIndex;
SlotDescriptor *sd;
Environment *theEnv = context->environment;
ssym = CheckClassAndSlot(context,func,classBuffer);
if (ssym == NULL)
return NULL;
slotIndex = FindInstanceTemplateSlot(theEnv,*classBuffer,ssym);
if (slotIndex == -1)
{
if (existsErrorFlag)
{
SlotExistError(theEnv,ssym->contents,func);
SetEvaluationError(theEnv,true);
}
return NULL;
}
sd = (*classBuffer)->instanceTemplate[slotIndex];
if ((sd->cls == *classBuffer) || inheritFlag)
{ return sd; }
PrintErrorID(theEnv,"CLASSEXM",1,false);
WriteString(theEnv,STDERR,"Inherited slot '");
WriteString(theEnv,STDERR,ssym->contents);
WriteString(theEnv,STDERR,"' from class ");
PrintClassName(theEnv,STDERR,sd->cls,true,false);
WriteString(theEnv,STDERR," is not valid for function '");
WriteString(theEnv,STDERR,func);
WriteString(theEnv,STDERR,"'.\n");
SetEvaluationError(theEnv,true);
return NULL;
}
/*****************************************************
NAME : DynamicHandlerGetSlot
DESCRIPTION : Directly references a slot's value
(uses dynamic binding to lookup slot)
INPUTS : The caller's result buffer
RETURNS : Nothing useful
SIDE EFFECTS : Caller's result buffer set
NOTES : H/L Syntax: (get <slot>)
*****************************************************/
globle void DynamicHandlerGetSlot(
DATA_OBJECT *result)
{
INSTANCE_SLOT *sp;
INSTANCE_TYPE *ins;
DATA_OBJECT temp;
result->type = SYMBOL;
result->value = FalseSymbol;
if (CheckCurrentMessage("dynamic-get",TRUE) == FALSE)
return;
EvaluateExpression(GetFirstArgument(),&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1("dynamic-get",1,"symbol");
SetEvaluationError(TRUE);
return;
}
ins = GetActiveInstance();
sp = FindInstanceSlot(ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(ValueToString(temp.value),"dynamic-get");
return;
}
if ((sp->desc->publicVisibility == 0) &&
(CurrentCore->hnd->cls != sp->desc->cls))
{
SlotVisibilityViolationError(sp->desc,CurrentCore->hnd->cls);
SetEvaluationError(TRUE);
return;
}
result->type = sp->type;
result->value = sp->value;
if (sp->type == MULTIFIELD)
{
result->begin = 0;
result->end = GetInstanceSlotLength(sp) - 1;
}
}
/***************************************************
NAME : CheckSlotExists
DESCRIPTION : Checks first two arguments of
a function for a valid class
and (inherited) slot
INPUTS : 1) The name of the function
2) A buffer to hold the found class
3) A flag indicating whether the
non-existence of the slot should
be an error
4) A flag indicating if the slot
can be inherited or not
RETURNS : NULL if slot not found, slot
descriptor otherwise
SIDE EFFECTS : Class buffer set if no errors,
NULL on errors
NOTES : None
***************************************************/
static SLOT_DESC *CheckSlotExists(
void *theEnv,
char *func,
DEFCLASS **classBuffer,
intBool existsErrorFlag,
intBool inheritFlag)
{
SYMBOL_HN *ssym;
int slotIndex;
SLOT_DESC *sd;
ssym = CheckClassAndSlot(theEnv,func,classBuffer);
if (ssym == NULL)
return(NULL);
slotIndex = FindInstanceTemplateSlot(theEnv,*classBuffer,ssym);
if (slotIndex == -1)
{
if (existsErrorFlag)
{
SlotExistError(theEnv,ValueToString(ssym),func);
SetEvaluationError(theEnv,TRUE);
}
return(NULL);
}
sd = (*classBuffer)->instanceTemplate[slotIndex];
if ((sd->cls == *classBuffer) || inheritFlag)
return(sd);
PrintErrorID(theEnv,"CLASSEXM",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Inherited slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ssym));
EnvPrintRouter(theEnv,WERROR," from class ");
PrintClassName(theEnv,WERROR,sd->cls,FALSE);
EnvPrintRouter(theEnv,WERROR," is not valid for function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR,"\n");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
/*********************************************************************
NAME : CheckMultifieldSlotModify
DESCRIPTION : For the functions slot-replace$, insert, & delete
as well as direct-slot-replace$, insert, & delete
this function gets the slot, index, and optional
field-value for these functions
INPUTS : 1) A code indicating the type of operation
INSERT (0) : Requires one index
REPLACE (1) : Requires two indices
DELETE_OP (2) : Requires two indices
2) Function name-string
3) Instance address
4) Argument expression chain
5) Caller's buffer for index (or beginning of range)
6) Caller's buffer for end of range
(can be NULL for INSERT)
7) Caller's new-field value buffer
(can be NULL for DELETE_OP)
RETURNS : The address of the instance-slot,
NULL on errors
SIDE EFFECTS : Caller's index buffer set
Caller's new-field value buffer set (if not NULL)
Will allocate an ephemeral segment to store more
than 1 new field value
EvaluationError set on errors
NOTES : Assume the argument chain is at least 2
expressions deep - slot, index, and optional values
*********************************************************************/
static INSTANCE_SLOT *CheckMultifieldSlotModify(
void *theEnv,
int code,
char *func,
INSTANCE_TYPE *ins,
EXPRESSION *args,
int *rb,
int *re,
DATA_OBJECT *newval)
{
DATA_OBJECT temp;
INSTANCE_SLOT *sp;
int start;
start = (args == GetFirstArgument()) ? 1 : 2;
EvaluationData(theEnv)->EvaluationError = FALSE;
EvaluateExpression(theEnv,args,&temp);
if (temp.type != SYMBOL)
{
ExpectedTypeError1(theEnv,func,start,"symbol");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
sp = FindInstanceSlot(theEnv,ins,(SYMBOL_HN *) temp.value);
if (sp == NULL)
{
SlotExistError(theEnv,ValueToString(temp.value),func);
return(NULL);
}
if (sp->desc->multiple == 0)
{
PrintErrorID(theEnv,"INSMULT",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function ");
EnvPrintRouter(theEnv,WERROR,func);
EnvPrintRouter(theEnv,WERROR," cannot be used on single-field slot ");
EnvPrintRouter(theEnv,WERROR,ValueToString(sp->desc->slotName->name));
EnvPrintRouter(theEnv,WERROR," in instance ");
EnvPrintRouter(theEnv,WERROR,ValueToString(ins->name));
EnvPrintRouter(theEnv,WERROR,".\n");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
EvaluateExpression(theEnv,args->nextArg,&temp);
if (temp.type != INTEGER)
{
ExpectedTypeError1(theEnv,func,start+1,"integer");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
args = args->nextArg->nextArg;
*rb = ValueToInteger(temp.value);
if ((code == REPLACE) || (code == DELETE_OP))
{
EvaluateExpression(theEnv,args,&temp);
if (temp.type != INTEGER)
{
ExpectedTypeError1(theEnv,func,start+2,"integer");
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
*re = ValueToInteger(temp.value);
args = args->nextArg;
}
if ((code == INSERT) || (code == REPLACE))
{
if (EvaluateAndStoreInDataObject(theEnv,1,args,newval) == FALSE)
return(NULL);
}
return(sp);
}
