globle int EnvArgRangeCheck(
void *theEnv,
char *functionName,
int min,
int max)
{
int numberOfArguments;
numberOfArguments = EnvRtnArgCount(theEnv);
if ((numberOfArguments < min) || (numberOfArguments > max))
{
PrintErrorID(theEnv,"ARGACCES",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function ");
EnvPrintRouter(theEnv,WERROR,functionName);
EnvPrintRouter(theEnv,WERROR," expected at least ");
PrintLongInteger(theEnv,WERROR,(long) min);
EnvPrintRouter(theEnv,WERROR," and no more than ");
PrintLongInteger(theEnv,WERROR,(long) max);
EnvPrintRouter(theEnv,WERROR," arguments.\n");
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(-1);
}
return(numberOfArguments);
}
/************************************************************************************
NAME : MessageHandlerExistPCommand
DESCRIPTION : Determines if a message-handler is present in a class
INPUTS : None
RETURNS : TRUE if the message header is present, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (message-handler-existp <class> <hnd> [<type>])
************************************************************************************/
globle int MessageHandlerExistPCommand(
void *theEnv)
{
DEFCLASS *cls;
SYMBOL_HN *mname;
DATA_OBJECT temp;
unsigned mtype = MPRIMARY;
if (EnvArgTypeCheck(theEnv,"message-handler-existp",1,SYMBOL,&temp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (cls == NULL)
{
ClassExistError(theEnv,"message-handler-existp",DOToString(temp));
return(FALSE);
}
if (EnvArgTypeCheck(theEnv,"message-handler-existp",2,SYMBOL,&temp) == FALSE)
return(FALSE);
mname = (SYMBOL_HN *) GetValue(temp);
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"message-handler-existp",3,SYMBOL,&temp) == FALSE)
return(FALSE);
mtype = HandlerType(theEnv,"message-handler-existp",DOToString(temp));
if (mtype == MERROR)
{
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
}
if (FindHandlerByAddress(cls,mname,mtype) != NULL)
return(TRUE);
return(FALSE);
}
/****************************************************************
NAME : BrowseClassesCommand
DESCRIPTION : Displays a "graph" of the class hierarchy
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : Syntax : (browse-classes [<class>])
****************************************************************/
globle void BrowseClassesCommand(
void *theEnv)
{
register DEFCLASS *cls;
if (EnvRtnArgCount(theEnv) == 0)
/* ================================================
Find the OBJECT root class (has no superclasses)
================================================ */
cls = LookupDefclassByMdlOrScope(theEnv,OBJECT_TYPE_NAME);
else
{
DATA_OBJECT tmp;
if (EnvArgTypeCheck(theEnv,"browse-classes",1,SYMBOL,&tmp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if (cls == NULL)
{
ClassExistError(theEnv,"browse-classes",DOToString(tmp));
return;
}
}
EnvBrowseClasses(theEnv,WDISPLAY,(void *) cls);
}
/*********************************************************************
NAME : SlotExistPCommand
DESCRIPTION : Determines if a slot is present in a class
INPUTS : None
RETURNS : TRUE if the slot exists, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (slot-existp <class> <slot> [inherit])
*********************************************************************/
globle int SlotExistPCommand(
void *theEnv)
{
DEFCLASS *cls;
SLOT_DESC *sd;
int inheritFlag = FALSE;
DATA_OBJECT dobj;
sd = CheckSlotExists(theEnv,"slot-existp",&cls,FALSE,TRUE);
if (sd == NULL)
return(FALSE);
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"slot-existp",3,SYMBOL,&dobj) == FALSE)
return(FALSE);
if (strcmp(DOToString(dobj),"inherit") != 0)
{
ExpectedTypeError1(theEnv,"slot-existp",3,"keyword \"inherit\"");
SetEvaluationError(theEnv,TRUE);
return(FALSE);
}
inheritFlag = TRUE;
}
return((sd->cls == cls) ? TRUE : inheritFlag);
}
globle intBool EqFunction(
void *theEnv,
EXEC_STATUS)
{
DATA_OBJECT item, nextItem;
int numArgs, i;
struct expr *theExpression;
/*====================================*/
/* Determine the number of arguments. */
/*====================================*/
numArgs = EnvRtnArgCount(theEnv,execStatus);
if (numArgs == 0) return(FALSE);
/*==============================================*/
/* Get the value of the first argument against */
/* which subsequent arguments will be compared. */
/*==============================================*/
theExpression = GetFirstArgument();
EvaluateExpression(theEnv,execStatus,theExpression,&item);
/*=====================================*/
/* Compare all arguments to the first. */
/* If any are the same, return FALSE. */
/*=====================================*/
theExpression = GetNextArgument(theExpression);
for (i = 2 ; i <= numArgs ; i++)
{
EvaluateExpression(theEnv,execStatus,theExpression,&nextItem);
if (GetType(nextItem) != GetType(item))
{ return(FALSE); }
if (GetType(nextItem) == MULTIFIELD)
{
if (MultifieldDOsEqual(&nextItem,&item) == FALSE)
{ return(FALSE); }
}
else if (nextItem.value != item.value)
{ return(FALSE); }
theExpression = GetNextArgument(theExpression);
}
/*=====================================*/
/* All of the arguments were different */
/* from the first. Return TRUE. */
/*=====================================*/
return(TRUE);
}
globle void ReturnFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
if (EnvRtnArgCount(theEnv) == 0)
{
result->type = RVOID;
result->value = EnvFalseSymbol(theEnv);
}
else
EnvRtnUnknown(theEnv,1,result);
ProcedureFunctionData(theEnv)->ReturnFlag = TRUE;
}
/***********************************************************
NAME : ClassInfoFnxArgs
DESCRIPTION : Examines arguments for:
class-slots, get-defmessage-handler-list,
class-superclasses and class-subclasses
INPUTS : 1) Name of function
2) A buffer to hold a flag indicating if
the inherit keyword was specified
RETURNS : Pointer to the class on success,
NULL on errors
SIDE EFFECTS : inhp flag set
error flag set
NOTES : None
***********************************************************/
globle void *ClassInfoFnxArgs(
void *theEnv,
const char *fnx,
int *inhp)
{
void *clsptr;
DATA_OBJECT tmp;
*inhp = 0;
if (EnvRtnArgCount(theEnv) == 0)
{
ExpectedCountError(theEnv,fnx,AT_LEAST,1);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
if (EnvArgTypeCheck(theEnv,fnx,1,SYMBOL,&tmp) == FALSE)
return(NULL);
clsptr = (void *) LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if (clsptr == NULL)
{
ClassExistError(theEnv,fnx,ValueToString(tmp.value));
return(NULL);
}
if (EnvRtnArgCount(theEnv) == 2)
{
if (EnvArgTypeCheck(theEnv,fnx,2,SYMBOL,&tmp) == FALSE)
return(NULL);
if (strcmp(ValueToString(tmp.value),"inherit") == 0)
*inhp = 1;
else
{
SyntaxErrorMessage(theEnv,fnx);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
}
return(clsptr);
}
globle intBool NeqFunction(
void *theEnv)
{
DATA_OBJECT item, nextItem;
int numArgs, i;
struct expr *theExpression;
/*====================================*/
/* Determine the number of arguments. */
/*====================================*/
numArgs = EnvRtnArgCount(theEnv);
if (numArgs == 0) return(FALSE);
/*==============================================*/
/* Get the value of the first argument against */
/* which subsequent arguments will be compared. */
/*==============================================*/
theExpression = GetFirstArgument();
EvaluateExpression(theEnv,theExpression,&item);
/*=====================================*/
/* Compare all arguments to the first. */
/* If any are different, return FALSE. */
/*=====================================*/
for (i = 2, theExpression = GetNextArgument(theExpression);
i <= numArgs;
i++, theExpression = GetNextArgument(theExpression))
{
EvaluateExpression(theEnv,theExpression,&nextItem);
if (GetType(nextItem) != GetType(item))
{ continue; }
else if (nextItem.type == MULTIFIELD)
{
if (MultifieldDOsEqual(&nextItem,&item) == TRUE)
{ return(FALSE); }
}
else if (nextItem.value == item.value)
{ return(FALSE); }
}
/*=====================================*/
/* All of the arguments were identical */
/* to the first. Return TRUE. */
/*=====================================*/
return(TRUE);
}
/*******************************************************************************
NAME : PPDefmessageHandlerCommand
DESCRIPTION : Displays the pretty-print form (if any) for a handler
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : H/L Syntax: (ppdefmessage-handler <class> <message> [<type>])
*******************************************************************************/
globle void PPDefmessageHandlerCommand(
void *theEnv)
{
DATA_OBJECT temp;
SYMBOL_HN *csym,*msym;
const char *tname;
DEFCLASS *cls = NULL;
unsigned mtype;
HANDLER *hnd;
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",1,SYMBOL,&temp) == FALSE)
return;
csym = FindSymbolHN(theEnv,DOToString(temp));
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",2,SYMBOL,&temp) == FALSE)
return;
msym = FindSymbolHN(theEnv,DOToString(temp));
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"ppdefmessage-handler",3,SYMBOL,&temp) == FALSE)
return;
tname = DOToString(temp);
}
else
tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
mtype = HandlerType(theEnv,"ppdefmessage-handler",tname);
if (mtype == MERROR)
{
EnvSetEvaluationError(theEnv,TRUE);
return;
}
if (csym != NULL)
cls = LookupDefclassByMdlOrScope(theEnv,ValueToString(csym));
if (((cls == NULL) || (msym == NULL)) ? TRUE :
((hnd = FindHandlerByAddress(cls,msym,(unsigned) mtype)) == NULL))
{
PrintErrorID(theEnv,"MSGCOM",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to find message-handler ");
EnvPrintRouter(theEnv,WERROR,ValueToString(msym));
EnvPrintRouter(theEnv,WERROR," ");
EnvPrintRouter(theEnv,WERROR,tname);
EnvPrintRouter(theEnv,WERROR," for class ");
EnvPrintRouter(theEnv,WERROR,ValueToString(csym));
EnvPrintRouter(theEnv,WERROR," in function ppdefmessage-handler.\n");
EnvSetEvaluationError(theEnv,TRUE);
return;
}
if (hnd->ppForm != NULL)
PrintInChunks(theEnv,WDISPLAY,hnd->ppForm);
}
/*****************************************************************************
NAME : ListDefmessageHandlersCommand
DESCRIPTION : Depending on arguments, does lists handlers which
match restrictions
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : None
NOTES : H/L Syntax: (list-defmessage-handlers [<class> [inherit]]))
*****************************************************************************/
globle void ListDefmessageHandlersCommand(
void *theEnv)
{
int inhp;
void *clsptr;
if (EnvRtnArgCount(theEnv) == 0)
EnvListDefmessageHandlers(theEnv,WDISPLAY,NULL,0);
else
{
clsptr = ClassInfoFnxArgs(theEnv,"list-defmessage-handlers",&inhp);
if (clsptr == NULL)
return;
EnvListDefmessageHandlers(theEnv,WDISPLAY,clsptr,inhp);
}
}
globle long RandomFunction(
void *theEnv)
{
int argCount;
long rv;
DATA_OBJECT theValue;
long begin, end;
/*====================================*/
/* The random function accepts either */
/* zero or two arguments. */
/*====================================*/
argCount = EnvRtnArgCount(theEnv);
if ((argCount != 0) && (argCount != 2))
{
PrintErrorID(theEnv,"MISCFUN",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function random expected either 0 or 2 arguments\n");
}
/*========================================*/
/* Return the randomly generated integer. */
/*========================================*/
rv = genrand();
if (argCount == 2)
{
if (EnvArgTypeCheck(theEnv,"random",1,INTEGER,&theValue) == FALSE) return(rv);
begin = DOToLong(theValue);
if (EnvArgTypeCheck(theEnv,"random",2,INTEGER,&theValue) == FALSE) return(rv);
end = DOToLong(theValue);
if (end < begin)
{
PrintErrorID(theEnv,"MISCFUN",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function random expected argument #1 to be less than argument #2\n");
return(rv);
}
rv = begin + (rv % ((end - begin) + 1));
}
return(rv);
}
/******************************************************************************
NAME : UndefmessageHandlerCommand
DESCRIPTION : Deletes a handler from a class
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Handler deleted if possible
NOTES : H/L Syntax: (undefmessage-handler <class> <handler> [<type>])
******************************************************************************/
globle void UndefmessageHandlerCommand(
void *theEnv)
{
#if RUN_TIME || BLOAD_ONLY
PrintErrorID(theEnv,"MSGCOM",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n");
#else
SYMBOL_HN *mname;
const char *tname;
DATA_OBJECT tmp;
DEFCLASS *cls;
#if BLOAD || BLOAD_AND_BSAVE
if (Bloaded(theEnv))
{
PrintErrorID(theEnv,"MSGCOM",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Unable to delete message-handlers.\n");
return;
}
#endif
if (EnvArgTypeCheck(theEnv,"undefmessage-handler",1,SYMBOL,&tmp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(tmp));
if ((cls == NULL) ? (strcmp(DOToString(tmp),"*") != 0) : FALSE)
{
ClassExistError(theEnv,"undefmessage-handler",DOToString(tmp));
return;
}
if (EnvArgTypeCheck(theEnv,"undefmessage-handler",2,SYMBOL,&tmp) == FALSE)
return;
mname = (SYMBOL_HN *) tmp.value;
if (EnvRtnArgCount(theEnv) == 3)
{
if (EnvArgTypeCheck(theEnv,"undefmessage-handler",3,SYMBOL,&tmp) == FALSE)
return;
tname = DOToString(tmp);
if (strcmp(tname,"*") == 0)
tname = NULL;
}
else
tname = MessageHandlerData(theEnv)->hndquals[MPRIMARY];
WildDeleteHandler(theEnv,cls,mname,tname);
#endif
}
static void NewCAddress(
void *theEnv,
DATA_OBJECT *rv)
{
int numberOfArguments;
numberOfArguments = EnvRtnArgCount(theEnv);
if (numberOfArguments != 1)
{
PrintErrorID(theEnv,"NEW",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function new expected no additional arguments for the C external language type.\n");
SetEvaluationError(theEnv,TRUE);
return;
}
SetpType(rv,EXTERNAL_ADDRESS);
SetpValue(rv,EnvAddExternalAddress(theEnv,NULL,0));
}
/***********************************************************************
NAME : GetDefmessageHandlersListCmd
DESCRIPTION : Groups message-handlers for a class into a multifield
value for dynamic perusal
INPUTS : Data object buffer to hold the handlers of the class
RETURNS : Nothing useful
SIDE EFFECTS : Creates a multifield storing the names of
the message-handlers of the class
NOTES : Syntax: (get-defmessage-handler-list <class> [inherit])
***********************************************************************/
globle void GetDefmessageHandlersListCmd(
void *theEnv,
DATA_OBJECT *result)
{
int inhp;
void *clsptr;
if (EnvRtnArgCount(theEnv) == 0)
EnvGetDefmessageHandlerList(theEnv,NULL,result,0);
else
{
clsptr = ClassInfoFnxArgs(theEnv,"get-defmessage-handler-list",&inhp);
if (clsptr == NULL)
{
EnvSetMultifieldErrorValue(theEnv,result);
return;
}
EnvGetDefmessageHandlerList(theEnv,clsptr,result,inhp);
}
}
globle double TimerFunction(
void *theEnv)
{
int numa, i;
double startTime;
DATA_OBJECT returnValue;
startTime = gentime();
numa = EnvRtnArgCount(theEnv);
i = 1;
while ((i <= numa) && (GetHaltExecution(theEnv) != TRUE))
{
EnvRtnUnknown(theEnv,i,&returnValue);
i++;
}
return(gentime() - startTime);
}
globle int EnvArgCountCheck(
void *theEnv,
char *functionName,
int countRelation,
int expectedNumber)
{
int numberOfArguments;
/*==============================================*/
/* Get the number of arguments for the function */
/* currently being evaluated. */
/*==============================================*/
numberOfArguments = EnvRtnArgCount(theEnv);
/*=========================================================*/
/* If the function satisfies expected number of arguments, */
/* constraint, then return the number of arguments found. */
/*=========================================================*/
if (countRelation == EXACTLY)
{ if (numberOfArguments == expectedNumber) return(numberOfArguments); }
else if (countRelation == AT_LEAST)
{ if (numberOfArguments >= expectedNumber) return(numberOfArguments); }
else if (countRelation == NO_MORE_THAN)
{ if (numberOfArguments <= expectedNumber) return(numberOfArguments); }
/*================================================*/
/* The correct number of arguments was not found. */
/* Generate an error message and return -1. */
/*================================================*/
ExpectedCountError(theEnv,functionName,countRelation,expectedNumber);
SetHaltExecution(theEnv,TRUE);
SetEvaluationError(theEnv,TRUE);
return(-1);
}
globle char *GetConstructName(
void *theEnv,
char *functionName,
char *constructType)
{
DATA_OBJECT result;
if (EnvRtnArgCount(theEnv) != 1)
{
ExpectedCountError(theEnv,functionName,EXACTLY,1);
return(NULL);
}
EnvRtnUnknown(theEnv,1,&result);
if (GetType(result) != SYMBOL)
{
ExpectedTypeError1(theEnv,functionName,1,constructType);
return(NULL);
}
return(DOToString(result));
}
static void StrOrSymCatFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue,
unsigned short returnType)
{
DATA_OBJECT theArg;
int numArgs, i, total, j;
char *theString;
SYMBOL_HN **arrayOfStrings;
SYMBOL_HN *hashPtr;
char *functionName;
/*============================================*/
/* Determine the calling function name. */
/* Store the null string or the symbol nil as */
/* the return value in the event of an error. */
/*============================================*/
SetpType(returnValue,returnType);
if (returnType == STRING)
{
functionName = "str-cat";
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
}
else
{
functionName = "sym-cat";
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,"nil"));
}
/*===============================================*/
/* Determine the number of arguments as create a */
/* string array which is large enough to store */
/* the string representation of each argument. */
/*===============================================*/
numArgs = EnvRtnArgCount(theEnv);
arrayOfStrings = (SYMBOL_HN **) gm1(theEnv,(int) sizeof(SYMBOL_HN *) * numArgs);
for (i = 0; i < numArgs; i++)
{ arrayOfStrings[i] = NULL; }
/*=============================================*/
/* Evaluate each argument and store its string */
/* representation in the string array. */
/*=============================================*/
total = 1;
for (i = 1 ; i <= numArgs ; i++)
{
EnvRtnUnknown(theEnv,i,&theArg);
switch(GetType(theArg))
{
case STRING:
#if OBJECT_SYSTEM
case INSTANCE_NAME:
#endif
case SYMBOL:
hashPtr = (SYMBOL_HN *) GetValue(theArg);
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case FLOAT:
hashPtr = (SYMBOL_HN *) EnvAddSymbol(theEnv,FloatToString(theEnv,ValueToDouble(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
case INTEGER:
hashPtr = (SYMBOL_HN *) EnvAddSymbol(theEnv,LongIntegerToString(theEnv,ValueToLong(GetValue(theArg))));
arrayOfStrings[i-1] = hashPtr;
IncrementSymbolCount(hashPtr);
break;
default:
ExpectedTypeError1(theEnv,functionName,i,"string, instance name, symbol, float, or integer");
SetEvaluationError(theEnv,TRUE);
break;
}
if (EvaluationData(theEnv)->EvaluationError)
{
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(theEnv,arrayOfStrings[i]); }
}
rm(theEnv,arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
return;
}
total += (int) strlen(ValueToString(arrayOfStrings[i - 1]));
}
/*=========================================================*/
/* Allocate the memory to store the concatenated string or */
/* symbol, then copy the values in the string array to the */
/* memory just allocated. */
/*=========================================================*/
theString = (char *) gm2(theEnv,(sizeof(char) * total));
j = 0;
for (i = 0 ; i < numArgs ; i++)
{
sprintf(&theString[j],"%s",ValueToString(arrayOfStrings[i]));
j += (int) strlen(ValueToString(arrayOfStrings[i]));
}
/*=========================================*/
/* Return the concatenated value and clean */
/* up the temporary memory used. */
/*=========================================*/
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,theString));
rm(theEnv,theString,sizeof(char) * total);
for (i = 0; i < numArgs; i++)
{
if (arrayOfStrings[i] != NULL)
{ DecrementSymbolCount(theEnv,arrayOfStrings[i]); }
}
rm(theEnv,arrayOfStrings,sizeof(SYMBOL_HN *) * numArgs);
}