/******************************************************
NAME : CheckTwoClasses
DESCRIPTION : Checks for exactly two class arguments
for a H/L function
INPUTS : 1) The function name
2) Caller's buffer for first class
3) Caller's buffer for second class
RETURNS : TRUE if both found, FALSE otherwise
SIDE EFFECTS : Caller's buffers set
NOTES : Assumes exactly 2 arguments
******************************************************/
static int CheckTwoClasses(
void *theEnv,
char *func,
DEFCLASS **c1,
DEFCLASS **c2)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,func,1,SYMBOL,&temp) == FALSE)
return(FALSE);
*c1 = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (*c1 == NULL)
{
ClassExistError(theEnv,func,ValueToString(temp.value));
return(FALSE);
}
if (EnvArgTypeCheck(theEnv,func,2,SYMBOL,&temp) == FALSE)
return(FALSE);
*c2 = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (*c2 == NULL)
{
ClassExistError(theEnv,func,ValueToString(temp.value));
return(FALSE);
}
return(TRUE);
}
/************************************************************************************
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);
}
globle void ModFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT item1, item2;
double fnum1, fnum2;
long long lnum1, lnum2;
if (EnvArgCountCheck(theEnv,"mod",EXACTLY,2) == -1)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (EnvArgTypeCheck(theEnv,"mod",1,INTEGER_OR_FLOAT,&item1) == FALSE)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (EnvArgTypeCheck(theEnv,"mod",2,INTEGER_OR_FLOAT,&item2) == FALSE)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if (((item2.type == INTEGER) ? (ValueToLong(item2.value) == 0L) : FALSE) ||
((item2.type == FLOAT) ? ValueToDouble(item2.value) == 0.0 : FALSE))
{
DivideByZeroErrorMessage(theEnv,"mod");
SetEvaluationError(theEnv,TRUE);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,0L);
return;
}
if ((item1.type == FLOAT) || (item2.type == FLOAT))
{
fnum1 = CoerceToDouble(item1.type,item1.value);
fnum2 = CoerceToDouble(item2.type,item2.value);
result->type = FLOAT;
result->value = (void *) EnvAddDouble(theEnv,fnum1 - (dtrunc(fnum1 / fnum2) * fnum2));
}
else
{
lnum1 = DOToLong(item1);
lnum2 = DOToLong(item2);
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,lnum1 - (lnum1 / lnum2) * lnum2);
}
}
globle void StrIndexFunction(
void *theEnv,
DATA_OBJECT_PTR result)
{
DATA_OBJECT theArgument1, theArgument2;
char *strg1, *strg2;
int i, j;
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
/*===================================*/
/* Check and retrieve the arguments. */
/*===================================*/
if (EnvArgCountCheck(theEnv,"str-index",EXACTLY,2) == -1) return;
if (EnvArgTypeCheck(theEnv,"str-index",1,SYMBOL_OR_STRING,&theArgument1) == FALSE) return;
if (EnvArgTypeCheck(theEnv,"str-index",2,SYMBOL_OR_STRING,&theArgument2) == FALSE) return;
strg1 = DOToString(theArgument1);
strg2 = DOToString(theArgument2);
/*=================================*/
/* Find the position in string2 of */
/* string1 (counting from 1). */
/*=================================*/
if (strlen(strg1) == 0)
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,(long) strlen(strg2) + 1L);
return;
}
for (i=1; *strg2; i++, strg2++)
{
for (j=0; *(strg1+j) && *(strg1+j) == *(strg2+j); j++)
{ /* Do Nothing */ }
if (*(strg1+j) == '\0')
{
result->type = INTEGER;
result->value = (void *) EnvAddLong(theEnv,(long) i);
return;
}
}
return;
}
globle long int StrCompareFunction(
void *theEnv)
{
int numArgs, length;
DATA_OBJECT arg1, arg2, arg3;
long returnValue;
/*=======================================================*/
/* Function str-compare expects either 2 or 3 arguments. */
/*=======================================================*/
if ((numArgs = EnvArgRangeCheck(theEnv,"str-compare",2,3)) == -1) return(0L);
/*=============================================================*/
/* The first two arguments should be of type symbol or string. */
/*=============================================================*/
if (EnvArgTypeCheck(theEnv,"str-compare",1,SYMBOL_OR_STRING,&arg1) == FALSE)
{ return(0L); }
if (EnvArgTypeCheck(theEnv,"str-compare",2,SYMBOL_OR_STRING,&arg2) == FALSE)
{ return(0L); }
/*===================================================*/
/* Compare the strings. Use the 3rd argument for the */
/* maximum length of comparison, if it is provided. */
/*===================================================*/
if (numArgs == 3)
{
if (EnvArgTypeCheck(theEnv,"str-compare",3,INTEGER,&arg3) == FALSE)
{ return(0L); }
length = CoerceToInteger(GetType(arg3),GetValue(arg3));
returnValue = strncmp(DOToString(arg1),DOToString(arg2),
(STD_SIZE) length);
}
else
{ returnValue = strcmp(DOToString(arg1),DOToString(arg2)); }
/*========================================================*/
/* Return Values are as follows: */
/* -1 is returned if <string-1> is less than <string-2>. */
/* 1 is return if <string-1> is greater than <string-2>. */
/* 0 is returned if <string-1> is equal to <string-2>. */
/*========================================================*/
if (returnValue < 0) returnValue = -1;
else if (returnValue > 0) returnValue = 1;
return(returnValue);
}
/*******************************************************************************
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);
}
globle long int SetgenFunction(
void *theEnv)
{
long theLong;
DATA_OBJECT theValue;
/*==========================================================*/
/* Check to see that a single integer argument is provided. */
/*==========================================================*/
if (EnvArgCountCheck(theEnv,"setgen",EXACTLY,1) == -1) return(MiscFunctionData(theEnv)->GensymNumber);
if (EnvArgTypeCheck(theEnv,"setgen",1,INTEGER,&theValue) == FALSE) return(MiscFunctionData(theEnv)->GensymNumber);
/*========================================*/
/* The integer must be greater than zero. */
/*========================================*/
theLong = ValueToLong(theValue.value);
if (theLong < 1L)
{
ExpectedTypeError1(theEnv,"setgen",1,"number (greater than or equal to 1)");
return(MiscFunctionData(theEnv)->GensymNumber);
}
/*====================================*/
/* Set the gensym index to the number */
/* provided and return this value. */
/*====================================*/
MiscFunctionData(theEnv)->GensymNumber = theLong;
return(theLong);
}
globle double FloatFunction(
void *theEnv)
{
DATA_OBJECT valstruct;
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"float",EXACTLY,1) == -1) return(0.0);
/*================================================================*/
/* Check for the correct type of argument. Note that ArgTypeCheck */
/* will convert integers to floats when a float is requested */
/* (which is the purpose of the float function). */
/*================================================================*/
if (EnvArgTypeCheck(theEnv,"float",1,FLOAT,&valstruct) == FALSE) return(0.0);
/*================================================*/
/* Return the numeric value converted to a float. */
/*================================================*/
return(ValueToDouble(valstruct.value));
}
globle long int IntegerFunction(
void *theEnv)
{
DATA_OBJECT valstruct;
/*============================================*/
/* Check for the correct number of arguments. */
/*============================================*/
if (EnvArgCountCheck(theEnv,"integer",EXACTLY,1) == -1) return(0L);
/*================================================================*/
/* Check for the correct type of argument. Note that ArgTypeCheck */
/* will convert floats to integers when an integer is requested */
/* (which is the purpose of the integer function). */
/*================================================================*/
if (EnvArgTypeCheck(theEnv,"integer",1,INTEGER,&valstruct) == FALSE) return(0L);
/*===================================================*/
/* Return the numeric value converted to an integer. */
/*===================================================*/
return(ValueToLong(valstruct.value));
}
/****************************************************************
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);
}
globle void EvalFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT theArg;
/*=============================================*/
/* Function eval expects exactly one argument. */
/*=============================================*/
if (EnvArgCountCheck(theEnv,"eval",EXACTLY,1) == -1)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return;
}
/*==================================================*/
/* The argument should be of type SYMBOL or STRING. */
/*==================================================*/
if (EnvArgTypeCheck(theEnv,"eval",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
return;
}
/*======================*/
/* Evaluate the string. */
/*======================*/
EnvEval(theEnv,DOToString(theArg),returnValue);
}
globle void StringToFieldFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
DATA_OBJECT theArg;
/*========================================================*/
/* Function string-to-field expects exactly one argument. */
/*========================================================*/
if (EnvArgCountCheck(theEnv,"string-to-field",EXACTLY,1) == -1)
{
returnValue->type = STRING;
returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***");
return;
}
/*==================================================*/
/* The argument should be of type symbol or string. */
/*==================================================*/
if (EnvArgTypeCheck(theEnv,"string-to-field",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{
returnValue->type = STRING;
returnValue->value = (void *) EnvAddSymbol(theEnv,"*** ERROR ***");
return;
}
/*================================*/
/* Convert the string to an atom. */
/*================================*/
StringToField(theEnv,DOToString(theArg),returnValue);
}
globle long int StrLengthFunction(
void *theEnv)
{
DATA_OBJECT theArg;
/*===================================================*/
/* Function str-length expects exactly one argument. */
/*===================================================*/
if (EnvArgCountCheck(theEnv,"str-length",EXACTLY,1) == -1)
{ return(-1L); }
/*==================================================*/
/* The argument should be of type symbol or string. */
/*==================================================*/
if (EnvArgTypeCheck(theEnv,"str-length",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{ return(-1L); }
/*============================================*/
/* Return the length of the string or symbol. */
/*============================================*/
return( (long) strlen(DOToString(theArg)));
}
globle void RemoveBreakCommand(
void *theEnv)
{
DATA_OBJECT argPtr;
char *argument;
int nargs;
void *defrulePtr;
if ((nargs = EnvArgCountCheck(theEnv,"remove-break",NO_MORE_THAN,1)) == -1)
{ return; }
if (nargs == 0)
{
RemoveAllBreakpoints(theEnv);
return;
}
if (EnvArgTypeCheck(theEnv,"remove-break",1,SYMBOL,&argPtr) == FALSE) return;
argument = DOToString(argPtr);
if ((defrulePtr = EnvFindDefrule(theEnv,argument)) == NULL)
{
CantFindItemErrorMessage(theEnv,"defrule",argument);
return;
}
if (EnvRemoveBreak(theEnv,defrulePtr) == FALSE)
{
EnvPrintRouter(theEnv,WERROR,"Rule ");
EnvPrintRouter(theEnv,WERROR,argument);
EnvPrintRouter(theEnv,WERROR," does not have a breakpoint set.\n");
}
}
globle void AproposCommand(
void *theEnv)
{
char *argument;
DATA_OBJECT argPtr;
struct symbolHashNode *hashPtr = NULL;
size_t theLength;
/*=======================================================*/
/* The apropos command expects a single symbol argument. */
/*=======================================================*/
if (EnvArgCountCheck(theEnv,"apropos",EXACTLY,1) == -1) return;
if (EnvArgTypeCheck(theEnv,"apropos",1,SYMBOL,&argPtr) == FALSE) return;
/*=======================================*/
/* Determine the length of the argument. */
/*=======================================*/
argument = DOToString(argPtr);
theLength = strlen(argument);
/*====================================================================*/
/* Print each entry in the symbol table that contains the argument as */
/* a substring. When using a non-ANSI compiler, only those strings */
/* that contain the substring starting at the beginning of the string */
/* are printed. */
/*====================================================================*/
while ((hashPtr = GetNextSymbolMatch(theEnv,argument,theLength,hashPtr,TRUE,NULL)) != NULL)
{
EnvPrintRouter(theEnv,WDISPLAY,ValueToString(hashPtr));
EnvPrintRouter(theEnv,WDISPLAY,"\n");
}
}
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;
}
}
}
/**********************************************************************
NAME : CheckMultifieldSlotInstance
DESCRIPTION : Gets the instance for the functions slot-replace$,
insert and delete
INPUTS : The function name
RETURNS : The instance address, NULL on errors
SIDE EFFECTS : None
NOTES : None
**********************************************************************/
static INSTANCE_TYPE *CheckMultifieldSlotInstance(
void *theEnv,
char *func)
{
INSTANCE_TYPE *ins;
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,func,1,INSTANCE_OR_INSTANCE_NAME,&temp) == FALSE)
{
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
if (temp.type == INSTANCE_ADDRESS)
{
ins = (INSTANCE_TYPE *) temp.value;
if (ins->garbage == 1)
{
StaleInstanceAddress(theEnv,func,0);
SetEvaluationError(theEnv,TRUE);
return(NULL);
}
}
else
{
ins = FindInstanceBySymbol(theEnv,(SYMBOL_HN *) temp.value);
if (ins == NULL)
NoInstanceError(theEnv,ValueToString(temp.value),func);
}
return(ins);
}
globle double SetProfilePercentThresholdCommand(
void *theEnv)
{
DATA_OBJECT theValue;
double newThreshold;
if (EnvArgCountCheck(theEnv,"set-profile-percent-threshold",EXACTLY,1) == -1)
{ return(ProfileFunctionData(theEnv)->PercentThreshold); }
if (EnvArgTypeCheck(theEnv,"set-profile-percent-threshold",1,INTEGER_OR_FLOAT,&theValue) == FALSE)
{ return(ProfileFunctionData(theEnv)->PercentThreshold); }
if (GetType(theValue) == INTEGER)
{ newThreshold = (double) DOToLong(theValue); }
else
{ newThreshold = (double) DOToDouble(theValue); }
if ((newThreshold < 0.0) || (newThreshold > 100.0))
{
ExpectedTypeError1(theEnv,"set-profile-percent-threshold",1,
"number in the range 0 to 100");
return(-1.0);
}
return(SetProfilePercentThreshold(theEnv,newThreshold));
}
/*********************************************************************
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 void CheckSyntaxFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
DATA_OBJECT theArg;
/*===============================*/
/* Set up a default return value */
/* (TRUE for problems found). */
/*===============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvTrueSymbol(theEnv));
/*=====================================================*/
/* Function check-syntax expects exactly one argument. */
/*=====================================================*/
if (EnvArgCountCheck(theEnv,"check-syntax",EXACTLY,1) == -1) return;
/*========================================*/
/* The argument should be of type STRING. */
/*========================================*/
if (EnvArgTypeCheck(theEnv,"check-syntax",1,STRING,&theArg) == FALSE)
{ return; }
/*===================*/
/* Check the syntax. */
/*===================*/
CheckSyntax(theEnv,DOToString(theArg),returnValue);
}
globle void *SetSalienceEvaluationCommand(
void *theEnv)
{
DATA_OBJECT argPtr;
char *argument, *oldValue;
/*==================================================*/
/* Get the current setting for salience evaluation. */
/*==================================================*/
oldValue = SalienceEvaluationName(EnvGetSalienceEvaluation(theEnv));
/*=========================================*/
/* This function expects a single argument */
/* which must be a symbol. */
/*=========================================*/
if (EnvArgCountCheck(theEnv,(char*)"set-salience-evaluation",EXACTLY,1) == -1)
{
return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
}
if (EnvArgTypeCheck(theEnv,(char*)"set-salience-evaluation",1,SYMBOL,&argPtr) == FALSE)
{
return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
}
/*=============================================================*/
/* The allowed symbols to pass as an argument to this function */
/* are when-defined, when-activated, and every-cycle. */
/*=============================================================*/
argument = DOToString(argPtr);
if (strcmp(argument,(char*)"when-defined") == 0)
{
EnvSetSalienceEvaluation(theEnv,WHEN_DEFINED);
}
else if (strcmp(argument,(char*)"when-activated") == 0)
{
EnvSetSalienceEvaluation(theEnv,WHEN_ACTIVATED);
}
else if (strcmp(argument,(char*)"every-cycle") == 0)
{
EnvSetSalienceEvaluation(theEnv,EVERY_CYCLE);
}
else
{
ExpectedTypeError1(theEnv,(char*)"set-salience-evaluation",1,
(char*)"symbol with value when-defined, when-activated, or every-cycle");
return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
}
/*=================================================*/
/* Return the old setting for salience evaluation. */
/*=================================================*/
return((SYMBOL_HN *) EnvAddSymbol(theEnv,oldValue));
}
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);
}
globle void LowcaseFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
DATA_OBJECT theArg;
unsigned i;
size_t slen;
char *osptr, *nsptr;
/*================================================*/
/* Function lowcase expects exactly one argument. */
/*================================================*/
if (EnvArgCountCheck(theEnv,"lowcase",EXACTLY,1) == -1)
{
SetpType(returnValue,STRING);
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
return;
}
/*==================================================*/
/* The argument should be of type symbol or string. */
/*==================================================*/
if (EnvArgTypeCheck(theEnv,"lowcase",1,SYMBOL_OR_STRING,&theArg) == FALSE)
{
SetpType(returnValue,STRING);
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,""));
return;
}
/*======================================================*/
/* Allocate temporary memory and then copy the original */
/* string or symbol to that memory, while lowercasing */
/* upper case alphabetic characters. */
/*======================================================*/
osptr = DOToString(theArg);
slen = strlen(osptr) + 1;
nsptr = (char *) gm2(theEnv,slen);
for (i = 0 ; i < slen ; i++)
{
if (isupper(osptr[i]))
{ nsptr[i] = (char) tolower(osptr[i]); }
else
{ nsptr[i] = osptr[i]; }
}
/*========================================*/
/* Return the lowercased string and clean */
/* up the temporary memory used. */
/*========================================*/
SetpType(returnValue,GetType(theArg));
SetpValue(returnValue,(void *) EnvAddSymbol(theEnv,nsptr));
rm(theEnv,nsptr,slen);
}
/********************************************************
NAME : ClassExistPCommand
DESCRIPTION : Determines if a class exists
INPUTS : None
RETURNS : TRUE if class exists, FALSE otherwise
SIDE EFFECTS : None
NOTES : H/L Syntax : (class-existp <arg>)
********************************************************/
globle intBool ClassExistPCommand(
void *theEnv)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,"class-existp",1,SYMBOL,&temp) == FALSE)
return(FALSE);
return((LookupDefclassByMdlOrScope(theEnv,DOToString(temp)) != NULL) ? TRUE : FALSE);
}
/******************************************************************************
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
}
/*********************************************************
NAME : GetClassNameArgument
DESCRIPTION : Gets a class name-string
INPUTS : Calling function name
RETURNS : Class name (NULL on errors)
SIDE EFFECTS : None
NOTES : Assumes only 1 argument
*********************************************************/
static char *GetClassNameArgument(
void *theEnv,
char *fname)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,fname,1,SYMBOL,&temp) == FALSE)
return(NULL);
return(DOToString(temp));
}
/********************************************************************
NAME : CheckClassAndSlot
DESCRIPTION : Checks class and slot argument for various functions
INPUTS : 1) Name of the calling function
2) Buffer for class address
RETURNS : Slot symbol, NULL on errors
SIDE EFFECTS : None
NOTES : None
********************************************************************/
globle SYMBOL_HN *CheckClassAndSlot(
void *theEnv,
const char *func,
DEFCLASS **cls)
{
DATA_OBJECT temp;
if (EnvArgTypeCheck(theEnv,func,1,SYMBOL,&temp) == FALSE)
return(NULL);
*cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (*cls == NULL)
{
ClassExistError(theEnv,func,DOToString(temp));
return(NULL);
}
if (EnvArgTypeCheck(theEnv,func,2,SYMBOL,&temp) == FALSE)
return(NULL);
return((SYMBOL_HN *) GetValue(temp));
}
globle void *SetStrategyCommand(
void *theEnv)
{
DATA_OBJECT argPtr;
char *argument;
int oldStrategy;
oldStrategy = AgendaData(theEnv)->Strategy;
/*=====================================================*/
/* Check for the correct number and type of arguments. */
/*=====================================================*/
if (EnvArgCountCheck(theEnv,"set-strategy",EXACTLY,1) == -1)
{ return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); }
if (EnvArgTypeCheck(theEnv,"set-strategy",1,SYMBOL,&argPtr) == FALSE)
{ return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv)))); }
argument = DOToString(argPtr);
/*=============================================*/
/* Set the strategy to the specified strategy. */
/*=============================================*/
if (strcmp(argument,"depth") == 0)
{ EnvSetStrategy(theEnv,DEPTH_STRATEGY); }
else if (strcmp(argument,"breadth") == 0)
{ EnvSetStrategy(theEnv,BREADTH_STRATEGY); }
else if (strcmp(argument,"lex") == 0)
{ EnvSetStrategy(theEnv,LEX_STRATEGY); }
else if (strcmp(argument,"mea") == 0)
{ EnvSetStrategy(theEnv,MEA_STRATEGY); }
else if (strcmp(argument,"complexity") == 0)
{ EnvSetStrategy(theEnv,COMPLEXITY_STRATEGY); }
else if (strcmp(argument,"simplicity") == 0)
{ EnvSetStrategy(theEnv,SIMPLICITY_STRATEGY); }
else if (strcmp(argument,"random") == 0)
{ EnvSetStrategy(theEnv,RANDOM_STRATEGY); }
else
{
ExpectedTypeError1(theEnv,"set-strategy",1,
"symbol with value depth, breadth, lex, mea, complexity, simplicity, or random");
return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(EnvGetStrategy(theEnv))));
}
/*=======================================*/
/* Return the old value of the strategy. */
/*=======================================*/
return((SYMBOL_HN *) EnvAddSymbol(theEnv,GetStrategyName(oldStrategy)));
}
/********************************************************************
NAME : PreviewSendCommand
DESCRIPTION : Displays a list of the core for a message describing
shadows,etc.
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Temporary core created and destroyed
NOTES : H/L Syntax: (preview-send <class> <msg>)
********************************************************************/
globle void PreviewSendCommand(
void *theEnv)
{
DEFCLASS *cls;
DATA_OBJECT temp;
/* =============================
Get the class for the message
============================= */
if (EnvArgTypeCheck(theEnv,"preview-send",1,SYMBOL,&temp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(theEnv,DOToString(temp));
if (cls == NULL)
{
ClassExistError(theEnv,"preview-send",ValueToString(temp.value));
return;
}
if (EnvArgTypeCheck(theEnv,"preview-send",2,SYMBOL,&temp) == FALSE)
return;
EnvPreviewSend(theEnv,WDISPLAY,(void *) cls,DOToString(temp));
}
static int SingleNumberCheck(
void *theEnv,
const char *functionName,
double *theNumber)
{
DATA_OBJECT theValue;
if (EnvArgCountCheck(theEnv,functionName,EXACTLY,1) == -1) return(FALSE);
if (EnvArgTypeCheck(theEnv,functionName,1,FLOAT,&theValue) == FALSE) return(FALSE);
*theNumber = DOToDouble(theValue);
return(TRUE);
}
