/***************************************************
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 struct expr *ConvertValueToExpression(
DATA_OBJECT *theValue)
{
long i;
struct expr *head = NULL, *last = NULL, *newItem;
if (GetpType(theValue) != MULTIFIELD)
{ return(GenConstant(GetpType(theValue),GetpValue(theValue))); }
for (i = GetpDOBegin(theValue); i <= GetpDOEnd(theValue); i++)
{
newItem = GenConstant(GetMFType(GetpValue(theValue),i),
GetMFValue(GetpValue(theValue),i));
if (last == NULL) head = newItem;
else last->nextArg = newItem;
last = newItem;
}
if (head == NULL)
return(GenConstant(FCALL,(void *) FindFunction("create$")));
return(head);
}
/*************************************************************
NAME : FormChain
DESCRIPTION : Builds a list of classes to be used in
fact queries - uses parse form.
INPUTS : 1) Name of calling function for error msgs
2) Data object - must be a symbol or a
multifield value containing all symbols
The symbols must be names of existing templates
RETURNS : The query chain, or NULL on errors
SIDE EFFECTS : Memory allocated for chain
Busy count incremented for all templates
NOTES : None
*************************************************************/
static QUERY_TEMPLATE *FormChain(
void *theEnv,
char *func,
DATA_OBJECT *val)
{
struct deftemplate *templatePtr;
QUERY_TEMPLATE *head,*bot,*tmp;
register long i,end; /* 6.04 Bug Fix */
char *templateName;
int count;
if (val->type == DEFTEMPLATE_PTR)
{
IncrementDeftemplateBusyCount(theEnv,(void *) val->value);
head = get_struct(theEnv,query_template);
head->templatePtr = (struct deftemplate *) val->value;
head->chain = NULL;
head->nxt = NULL;
return(head);
}
if (val->type == SYMBOL)
{
/* ===============================================
Allow instance-set query restrictions to have a
module specifier as part of the class name,
but search imported defclasses too if a
module specifier is not given
=============================================== */
templatePtr = (struct deftemplate *)
FindImportedConstruct(theEnv,"deftemplate",NULL,DOPToString(val),
&count,TRUE,NULL);
if (templatePtr == NULL)
{
CantFindItemInFunctionErrorMessage(theEnv,"deftemplate",DOPToString(val),func);
return(NULL);
}
IncrementDeftemplateBusyCount(theEnv,(void *) templatePtr);
head = get_struct(theEnv,query_template);
head->templatePtr = templatePtr;
head->chain = NULL;
head->nxt = NULL;
return(head);
}
if (val->type == MULTIFIELD)
{
head = bot = NULL;
end = GetpDOEnd(val);
for (i = GetpDOBegin(val) ; i <= end ; i++)
{
if (GetMFType(val->value,i) == SYMBOL)
{
templateName = ValueToString(GetMFValue(val->value,i));
templatePtr = (struct deftemplate *)
FindImportedConstruct(theEnv,"deftemplate",NULL,templateName,
&count,TRUE,NULL);
if (templatePtr == NULL)
{
CantFindItemInFunctionErrorMessage(theEnv,"deftemplate",templateName,func);
DeleteQueryTemplates(theEnv,head);
return(NULL);
}
}
else
{
DeleteQueryTemplates(theEnv,head);
return(NULL);
}
IncrementDeftemplateBusyCount(theEnv,(void *) templatePtr);
tmp = get_struct(theEnv,query_template);
tmp->templatePtr = templatePtr;
tmp->chain = NULL;
tmp->nxt = NULL;
if (head == NULL)
head = tmp;
else
bot->chain = tmp;
bot = tmp;
}
return(head);
}
return(NULL);
}
globle void *ImplodeMultifield(
void *theEnv,
DATA_OBJECT *value)
{
size_t strsize = 0;
long i, j;
const char *tmp_str;
char *ret_str;
void *rv;
struct multifield *theMultifield;
DATA_OBJECT tempDO;
/*===================================================*/
/* Determine the size of the string to be allocated. */
/*===================================================*/
theMultifield = (struct multifield *) GetpValue(value);
for (i = GetpDOBegin(value) ; i <= GetpDOEnd(value) ; i++)
{
if (GetMFType(theMultifield,i) == FLOAT)
{
tmp_str = FloatToString(theEnv,ValueToDouble(GetMFValue(theMultifield,i)));
strsize += strlen(tmp_str) + 1;
}
else if (GetMFType(theMultifield,i) == INTEGER)
{
tmp_str = LongIntegerToString(theEnv,ValueToLong(GetMFValue(theMultifield,i)));
strsize += strlen(tmp_str) + 1;
}
else if (GetMFType(theMultifield,i) == STRING)
{
strsize += strlen(ValueToString(GetMFValue(theMultifield,i))) + 3;
tmp_str = ValueToString(GetMFValue(theMultifield,i));
while(*tmp_str)
{
if (*tmp_str == '"')
{ strsize++; }
else if (*tmp_str == '\\') /* GDR 111599 #835 */
{ strsize++; } /* GDR 111599 #835 */
tmp_str++;
}
}
#if OBJECT_SYSTEM
else if (GetMFType(theMultifield,i) == INSTANCE_NAME)
{ strsize += strlen(ValueToString(GetMFValue(theMultifield,i))) + 3; }
else if (GetMFType(theMultifield,i) == INSTANCE_ADDRESS)
{ strsize += strlen(ValueToString(((INSTANCE_TYPE *)
GetMFValue(theMultifield,i))->name)) + 3; }
#endif
else
{
SetType(tempDO,GetMFType(theMultifield,i));
SetValue(tempDO,GetMFValue(theMultifield,i));
strsize += strlen(DataObjectToString(theEnv,&tempDO)) + 1;
}
}
/*=============================================*/
/* Allocate the string and copy all components */
/* of the MULTIFIELD variable to it. */
/*=============================================*/
if (strsize == 0) return(EnvAddSymbol(theEnv,""));
ret_str = (char *) gm2(theEnv,strsize);
for(j=0, i=GetpDOBegin(value); i <= GetpDOEnd(value) ; i++)
{
/*============================*/
/* Convert numbers to strings */
/*============================*/
if (GetMFType(theMultifield,i) == FLOAT)
{
tmp_str = FloatToString(theEnv,ValueToDouble(GetMFValue(theMultifield,i)));
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
}
else if (GetMFType(theMultifield,i) == INTEGER)
{
tmp_str = LongIntegerToString(theEnv,ValueToLong(GetMFValue(theMultifield,i)));
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
}
/*=======================================*/
/* Enclose strings in quotes and preceed */
/* imbedded quotes with a backslash */
/*=======================================*/
else if (GetMFType(theMultifield,i) == STRING)
{
tmp_str = ValueToString(GetMFValue(theMultifield,i));
*(ret_str+j) = '"';
j++;
while(*tmp_str)
{
if (*tmp_str == '"')
{
*(ret_str+j) = '\\';
j++;
}
else if (*tmp_str == '\\') /* GDR 111599 #835 */
{ /* GDR 111599 #835 */
*(ret_str+j) = '\\'; /* GDR 111599 #835 */
j++; /* GDR 111599 #835 */
} /* GDR 111599 #835 */
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
*(ret_str+j) = '"';
j++;
}
#if OBJECT_SYSTEM
else if (GetMFType(theMultifield,i) == INSTANCE_NAME)
{
tmp_str = ValueToString(GetMFValue(theMultifield,i));
*(ret_str + j++) = '[';
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
*(ret_str + j++) = ']';
}
else if (GetMFType(theMultifield,i) == INSTANCE_ADDRESS)
{
tmp_str = ValueToString(((INSTANCE_TYPE *) GetMFValue(theMultifield,i))->name);
*(ret_str + j++) = '[';
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
*(ret_str + j++) = ']';
}
#endif
else
{
SetType(tempDO,GetMFType(theMultifield,i));
SetValue(tempDO,GetMFValue(theMultifield,i));
tmp_str = DataObjectToString(theEnv,&tempDO);
while(*tmp_str)
{
*(ret_str+j) = *tmp_str;
j++, tmp_str++;
}
}
*(ret_str+j) = ' ';
j++;
}
*(ret_str+j-1) = '\0';
/*====================*/
/* Return the string. */
/*====================*/
rv = EnvAddSymbol(theEnv,ret_str);
rm(theEnv,ret_str,strsize);
return(rv);
}
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;
}
}
/***********************************************************************
NAME : ExpandFuncMultifield
DESCRIPTION : Recursively examines an expression and replaces
PROC_EXPAND_MULTIFIELD expressions with the expanded
evaluation expression of its argument
INPUTS : 1) A data object result buffer
2) The expression to modify
3) The address of the expression, in case it is
deleted entirely
4) The address of the H/L function expand$
RETURNS : Nothing useful
SIDE EFFECTS : Expressions allocated/deallocated as necessary
Evaluations performed
On errors, argument expression set to call a function
which causes an evaluation error when evaluated
a second time by actual caller.
NOTES : THIS ROUTINE MODIFIES EXPRESSIONS AT RUNTIME!! MAKE
SURE THAT THE EXPRESSION PASSED IS SAFE TO CHANGE!!
**********************************************************************/
static void ExpandFuncMultifield(
void *theEnv,
DATA_OBJECT *result,
EXPRESSION *theExp,
EXPRESSION **sto,
void *expmult)
{
EXPRESSION *newexp,*top,*bot;
register long i; /* 6.04 Bug Fix */
while (theExp != NULL)
{
if (theExp->value == expmult)
{
EvaluateExpression(theEnv,theExp->argList,result);
ReturnExpression(theEnv,theExp->argList);
if ((EvaluationData(theEnv)->EvaluationError) || (result->type != MULTIFIELD))
{
theExp->argList = NULL;
if ((EvaluationData(theEnv)->EvaluationError == FALSE) && (result->type != MULTIFIELD))
ExpectedTypeError2(theEnv,"expand$",1);
theExp->value = (void *) FindFunction(theEnv,"(set-evaluation-error)");
EvaluationData(theEnv)->EvaluationError = FALSE;
EvaluationData(theEnv)->HaltExecution = FALSE;
return;
}
top = bot = NULL;
for (i = GetpDOBegin(result) ; i <= GetpDOEnd(result) ; i++)
{
newexp = get_struct(theEnv,expr);
newexp->type = GetMFType(result->value,i);
newexp->value = GetMFValue(result->value,i);
newexp->argList = NULL;
newexp->nextArg = NULL;
if (top == NULL)
top = newexp;
else
bot->nextArg = newexp;
bot = newexp;
}
if (top == NULL)
{
*sto = theExp->nextArg;
rtn_struct(theEnv,expr,theExp);
theExp = *sto;
}
else
{
bot->nextArg = theExp->nextArg;
*sto = top;
rtn_struct(theEnv,expr,theExp);
sto = &bot->nextArg;
theExp = bot->nextArg;
}
}
else
{
if (theExp->argList != NULL)
ExpandFuncMultifield(theEnv,result,theExp->argList,&theExp->argList,expmult);
sto = &theExp->nextArg;
theExp = theExp->nextArg;
}
}
}
/*************************************************************
NAME : FormChain
DESCRIPTION : Builds a list of classes to be used in
instance queries - uses parse form.
INPUTS : 1) Name of calling function for error msgs
2) Data object - must be a symbol or a
multifield value containing all symbols
The symbols must be names of existing classes
RETURNS : The query chain, or NULL on errors
SIDE EFFECTS : Memory allocated for chain
Busy count incremented for all classes
NOTES : None
*************************************************************/
static QUERY_CLASS *FormChain(
void *theEnv,
EXEC_STATUS,
char *func,
DATA_OBJECT *val)
{
DEFCLASS *cls;
QUERY_CLASS *head,*bot,*tmp;
register long i,end; /* 6.04 Bug Fix */
char *className;
struct defmodule *currentModule;
currentModule = ((struct defmodule *) EnvGetCurrentModule(theEnv,execStatus));
if (val->type == DEFCLASS_PTR)
{
IncrementDefclassBusyCount(theEnv,execStatus,(void *) val->value);
head = get_struct(theEnv,execStatus,query_class);
head->cls = (DEFCLASS *) val->value;
if (DefclassInScope(theEnv,execStatus,head->cls,currentModule))
head->theModule = currentModule;
else
head->theModule = head->cls->header.whichModule->theModule;
head->chain = NULL;
head->nxt = NULL;
return(head);
}
if (val->type == SYMBOL)
{
/* ===============================================
Allow instance-set query restrictions to have a
module specifier as part of the class name,
but search imported defclasses too if a
module specifier is not given
=============================================== */
cls = LookupDefclassByMdlOrScope(theEnv,execStatus,DOPToString(val));
if (cls == NULL)
{
ClassExistError(theEnv,execStatus,func,DOPToString(val));
return(NULL);
}
IncrementDefclassBusyCount(theEnv,execStatus,(void *) cls);
head = get_struct(theEnv,execStatus,query_class);
head->cls = cls;
if (DefclassInScope(theEnv,execStatus,head->cls,currentModule))
head->theModule = currentModule;
else
head->theModule = head->cls->header.whichModule->theModule;
head->chain = NULL;
head->nxt = NULL;
return(head);
}
if (val->type == MULTIFIELD)
{
head = bot = NULL;
end = GetpDOEnd(val);
for (i = GetpDOBegin(val) ; i <= end ; i++)
{
if (GetMFType(val->value,i) == SYMBOL)
{
className = ValueToString(GetMFValue(val->value,i));
cls = LookupDefclassByMdlOrScope(theEnv,execStatus,className);
if (cls == NULL)
{
ClassExistError(theEnv,execStatus,func,className);
DeleteQueryClasses(theEnv,execStatus,head);
return(NULL);
}
}
else
{
DeleteQueryClasses(theEnv,execStatus,head);
return(NULL);
}
IncrementDefclassBusyCount(theEnv,execStatus,(void *) cls);
tmp = get_struct(theEnv,execStatus,query_class);
tmp->cls = cls;
if (DefclassInScope(theEnv,execStatus,tmp->cls,currentModule))
tmp->theModule = currentModule;
else
tmp->theModule = tmp->cls->header.whichModule->theModule;
tmp->chain = NULL;
tmp->nxt = NULL;
if (head == NULL)
head = tmp;
else
bot->chain = tmp;
bot = tmp;
}
return(head);
}
return(NULL);
}