/***************************************************************************
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 : GetQueryInstance
DESCRIPTION : Internal function for referring to instance
array on instance-queries
INPUTS : None
RETURNS : The name of the specified instance-set member
SIDE EFFECTS : None
NOTES : H/L Syntax : ((query-instance) <index>)
*************************************************************/
globle void *GetQueryInstance(
void *theEnv)
{
register QUERY_CORE *core;
core = FindQueryCore(theEnv,ValueToInteger(GetpValue(GetFirstArgument())));
return(GetFullInstanceName(theEnv,core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))]));
}
/*************************************************************
NAME : GetQueryFact
DESCRIPTION : Internal function for referring to fact
array on fact-queries
INPUTS : None
RETURNS : The name of the specified fact-set member
SIDE EFFECTS : None
NOTES : H/L Syntax : ((query-fact) <index>)
*************************************************************/
globle void GetQueryFact(
void *theEnv,
DATA_OBJECT *result)
{
register QUERY_CORE *core;
core = FindQueryCore(theEnv,ValueToInteger(GetpValue(GetFirstArgument())));
result->type = FACT_ADDRESS;
result->value = core->solns[ValueToInteger(GetpValue(GetFirstArgument()->nextArg))];
}
/***************************************************************************
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);
}
}
void get_argument(void* env, int argposition, Values& values) {
DATA_OBJECT arg;
if (EnvArgTypeCheck(env, (char *)"clipsmm get_argument",
argposition, MULTIFIELD, &arg) == 0) return;
values.clear();
int end = EnvGetDOEnd(env, arg);
void *mfp = EnvGetValue(env, arg);
for (int i = EnvGetDOBegin(env, arg); i <= end; ++i) {
switch (GetMFType(mfp, i)) {
case SYMBOL:
case STRING:
case INSTANCE_NAME:
values.push_back(Value(ValueToString(GetMFValue(mfp, i))));
break;
case FLOAT:
values.push_back(Value(ValueToDouble(GetMFValue(mfp, i))));
break;
case INTEGER:
values.push_back(Value(ValueToInteger(GetMFValue(mfp, i))));
break;
default:
continue;
break;
}
}
}
globle void PrintMethod(
void *theEnv,
EXEC_STATUS,
char *buf,
int buflen,
DEFMETHOD *meth)
{
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv,execStatus)
#endif
long j,k;
register RESTRICTION *rptr;
char numbuf[15];
buf[0] = '\0';
if (meth->system)
genstrncpy(buf,"SYS",(STD_SIZE) buflen);
gensprintf(numbuf,"%-2d ",meth->index);
genstrncat(buf,numbuf,(STD_SIZE) buflen-3);
for (j = 0 ; j < meth->restrictionCount ; j++)
{
rptr = &meth->restrictions[j];
if ((((int) j) == meth->restrictionCount-1) && (meth->maxRestrictions == -1))
{
if ((rptr->tcnt == 0) && (rptr->query == NULL))
{
genstrncat(buf,"$?",buflen-strlen(buf));
break;
}
genstrncat(buf,"($? ",buflen-strlen(buf));
}
else
genstrncat(buf,"(",buflen-strlen(buf));
for (k = 0 ; k < rptr->tcnt ; k++)
{
#if OBJECT_SYSTEM
genstrncat(buf,EnvGetDefclassName(theEnv,execStatus,rptr->types[k]),buflen-strlen(buf));
#else
genstrncat(buf,TypeName(theEnv,execStatus,ValueToInteger(rptr->types[k])),buflen-strlen(buf));
#endif
if (((int) k) < (((int) rptr->tcnt) - 1))
genstrncat(buf," ",buflen-strlen(buf));
}
if (rptr->query != NULL)
{
if (rptr->tcnt != 0)
genstrncat(buf," ",buflen-strlen(buf));
genstrncat(buf,"<qry>",buflen-strlen(buf));
}
genstrncat(buf,")",buflen-strlen(buf));
if (((int) j) != (((int) meth->restrictionCount)-1))
genstrncat(buf," ",buflen-strlen(buf));
}
}
globle long GetLoopCount()
{
int depth;
LOOP_COUNTER_STACK *tmpCounter;
depth = ValueToInteger(GetFirstArgument()->value);
tmpCounter = LoopCounterStack;
while (depth > 0)
{
tmpCounter = tmpCounter->nxt;
depth--;
}
return(tmpCounter->loopCounter);
}
/******************************************************************
NAME : PrintMethod
DESCRIPTION : Lists a brief description of methods for a method
INPUTS : 1) Buffer for method info
2) Size of buffer (not including space for '\0')
3) The method address
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : A terminating newline is NOT included
******************************************************************/
globle void PrintMethod(
char *buf,
int buflen,
DEFMETHOD *meth)
{
register int j,k;
register RESTRICTION *rptr;
char numbuf[15];
buf[0] = '\0';
if (meth->system)
strncpy(buf,"SYS",(STD_SIZE) buflen);
sprintf(numbuf,"%-2d ",meth->index);
strncat(buf,numbuf,(STD_SIZE) buflen-3);
for (j = 0 ; j < meth->restrictionCount ; j++)
{
rptr = &meth->restrictions[j];
if ((j == meth->restrictionCount-1) && (meth->maxRestrictions == -1))
{
if ((rptr->tcnt == 0) && (rptr->query == NULL))
{
strncat(buf,"$?",buflen-strlen(buf));
break;
}
strncat(buf,"($? ",buflen-strlen(buf));
}
else
strncat(buf,"(",buflen-strlen(buf));
for (k = 0 ; k < rptr->tcnt ; k++)
{
#if OBJECT_SYSTEM
strncat(buf,GetDefclassName(rptr->types[k]),buflen-strlen(buf));
#else
strncat(buf,TypeName(ValueToInteger(rptr->types[k])),buflen-strlen(buf));
#endif
if (k < (rptr->tcnt - 1))
strncat(buf," ",buflen-strlen(buf));
}
if (rptr->query != NULL)
{
if (rptr->tcnt != 0)
strncat(buf," ",buflen-strlen(buf));
strncat(buf,"<qry>",buflen-strlen(buf));
}
strncat(buf,")",buflen-strlen(buf));
if (j != (meth->restrictionCount-1))
strncat(buf," ",buflen-strlen(buf));
}
}
globle long long GetLoopCount(
void *theEnv)
{
int depth;
LOOP_COUNTER_STACK *tmpCounter;
depth = ValueToInteger(GetFirstArgument()->value);
tmpCounter = ProcedureFunctionData(theEnv)->LoopCounterStack;
while (depth > 0)
{
tmpCounter = tmpCounter->nxt;
depth--;
}
return(tmpCounter->loopCounter);
}
/***********************************************************************
NAME : IsMethodApplicable
DESCRIPTION : Tests to see if a method satsifies the arguments of a
generic function
A method is applicable if all its restrictions are
satisfied by the corresponding arguments
INPUTS : The method address
RETURNS : true if method is applicable, false otherwise
SIDE EFFECTS : Any query functions are evaluated
NOTES : Uses globals ProcParamArraySize and ProcParamArray
***********************************************************************/
bool IsMethodApplicable(
void *theEnv,
DEFMETHOD *meth)
{
DATA_OBJECT temp;
short i,j,k;
register RESTRICTION *rp;
#if OBJECT_SYSTEM
void *type;
#else
int type;
#endif
if ((ProceduralPrimitiveData(theEnv)->ProcParamArraySize < meth->minRestrictions) ||
((ProceduralPrimitiveData(theEnv)->ProcParamArraySize > meth->minRestrictions) && (meth->maxRestrictions != -1)))
return(false);
for (i = 0 , k = 0 ; i < ProceduralPrimitiveData(theEnv)->ProcParamArraySize ; i++)
{
rp = &meth->restrictions[k];
if (rp->tcnt != 0)
{
#if OBJECT_SYSTEM
type = (void *) DetermineRestrictionClass(theEnv,&ProceduralPrimitiveData(theEnv)->ProcParamArray[i]);
if (type == NULL)
return(false);
for (j = 0 ; j < rp->tcnt ; j++)
{
if (type == rp->types[j])
break;
if (HasSuperclass((DEFCLASS *) type,(DEFCLASS *) rp->types[j]))
break;
if (rp->types[j] == (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_ADDRESS])
{
if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_ADDRESS)
break;
}
else if (rp->types[j] == (void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME])
{
if (ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_NAME)
break;
}
else if (rp->types[j] ==
(void *) DefclassData(theEnv)->PrimitiveClassMap[INSTANCE_NAME]->directSuperclasses.classArray[0])
{
if ((ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_NAME) ||
(ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type == INSTANCE_ADDRESS))
break;
}
}
#else
type = ProceduralPrimitiveData(theEnv)->ProcParamArray[i].type;
for (j = 0 ; j < rp->tcnt ; j++)
{
if (type == ValueToInteger(rp->types[j]))
break;
if (SubsumeType(type,ValueToInteger(rp->types[j])))
break;
}
#endif
if (j == rp->tcnt)
return(false);
}
if (rp->query != NULL)
{
DefgenericData(theEnv)->GenericCurrentArgument = &ProceduralPrimitiveData(theEnv)->ProcParamArray[i];
EvaluateExpression(theEnv,rp->query,&temp);
if ((temp.type != SYMBOL) ? false :
(temp.value == EnvFalseSymbol(theEnv)))
return(false);
}
if (((int) k) != meth->restrictionCount-1)
k++;
}
return(true);
}
/*********************************************************************
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);
}
