/************************************************************************************
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 : 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 : 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 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);
}
globle void GetFactListFunction(
void *theEnv,
DATA_OBJECT_PTR returnValue)
{
struct defmodule *theModule;
DATA_OBJECT result;
int numArgs;
/*===========================================*/
/* Determine if a module name was specified. */
/*===========================================*/
if ((numArgs = EnvArgCountCheck(theEnv,"get-fact-list",NO_MORE_THAN,1)) == -1)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
return;
}
if (numArgs == 1)
{
EnvRtnUnknown(theEnv,1,&result);
if (GetType(result) != SYMBOL)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ExpectedTypeError1(theEnv,"get-fact-list",1,"defmodule name");
return;
}
if ((theModule = (struct defmodule *) EnvFindDefmodule(theEnv,DOToString(result))) == NULL)
{
if (strcmp("*",DOToString(result)) != 0)
{
EnvSetMultifieldErrorValue(theEnv,returnValue);
ExpectedTypeError1(theEnv,"get-fact-list",1,"defmodule name");
return;
}
theModule = NULL;
}
}
else
{ theModule = ((struct defmodule *) EnvGetCurrentModule(theEnv)); }
/*=====================*/
/* Get the constructs. */
/*=====================*/
EnvGetFactList(theEnv,returnValue,theModule);
}
globle struct defmodule *GetModuleName(
void *theEnv,
char *functionName,
int whichArgument,
int *error)
{
DATA_OBJECT result;
struct defmodule *theModule;
*error = FALSE;
/*========================*/
/* Retrieve the argument. */
/*========================*/
EnvRtnUnknown(theEnv,whichArgument,&result);
/*=================================*/
/* A module name must be a symbol. */
/*=================================*/
if (GetType(result) != SYMBOL)
{
ExpectedTypeError1(theEnv,functionName,whichArgument,"defmodule name");
*error = TRUE;
return(NULL);
}
/*=======================================*/
/* Check to see that the symbol actually */
/* corresponds to a defined module. */
/*=======================================*/
if ((theModule = (struct defmodule *) EnvFindDefmodule(theEnv,DOToString(result))) == NULL)
{
if (strcmp("*",DOToString(result)) != 0)
{
ExpectedTypeError1(theEnv,functionName,whichArgument,"defmodule name");
*error = TRUE;
}
return(NULL);
}
/*=================================*/
/* Return a pointer to the module. */
/*=================================*/
return(theModule);
}
/*******************************************************************************
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);
}
std::vector<std::string> data_object_to_strings( dataObject& clipsdo ) {
void* mfptr;
long int end, i;
std::string s;
std::vector<std::string> strings;
switch ( GetType(clipsdo) ) {
case SYMBOL:
case INSTANCE_NAME:
case STRING:
strings.push_back( DOToString( clipsdo ) );
break;
case MULTIFIELD:
end = GetDOEnd( clipsdo );
mfptr = GetValue( clipsdo );
for ( i = GetDOBegin( clipsdo ); i <= end; i++ ) {
switch ( GetMFType( mfptr, i ) ) {
case SYMBOL:
case STRING:
case INSTANCE_NAME:
strings.push_back( ValueToString( GetMFValue( mfptr, i ) ) );
break;
default:
break;
}
}
default:
break;
}
return strings;
}
/*********************************************************************
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 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");
}
}
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 CheckSyntaxFunction(
DATA_OBJECT *returnValue)
{
DATA_OBJECT theArg;
/*===============================*/
/* Set up a default return value */
/* (TRUE for problems found). */
/*===============================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,TrueSymbol);
/*=====================================================*/
/* Function check-syntax expects exactly one argument. */
/*=====================================================*/
if (ArgCountCheck("check-syntax",EXACTLY,1) == -1) return;
/*========================================*/
/* The argument should be of type STRING. */
/*========================================*/
if (ArgTypeCheck("check-syntax",1,STRING,&theArg) == FALSE)
{ return; }
/*===================*/
/* Check the syntax. */
/*===================*/
CheckSyntax(DOToString(theArg),returnValue);
}
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 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 *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));
}
/*************************************************************
NAME : PreviewGeneric
DESCRIPTION : Allows the user to see a printout of all the
applicable methods for a particular generic
function call
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic
function arguments
and evaluating query-functions to determine
the set of applicable methods
NOTES : H/L Syntax: (preview-generic <func> <args>)
*************************************************************/
globle void PreviewGeneric(
void *theEnv,
EXEC_STATUS)
{
DEFGENERIC *gfunc;
DEFGENERIC *previousGeneric;
int oldce;
DATA_OBJECT temp;
execStatus->EvaluationError = FALSE;
if (EnvArgTypeCheck(theEnv,execStatus,"preview-generic",1,SYMBOL,&temp) == FALSE)
return;
gfunc = LookupDefgenericByMdlOrScope(theEnv,execStatus,DOToString(temp));
if (gfunc == NULL)
{
PrintErrorID(theEnv,execStatus,"GENRCFUN",3,FALSE);
EnvPrintRouter(theEnv,execStatus,WERROR,"Unable to find generic function ");
EnvPrintRouter(theEnv,execStatus,WERROR,DOToString(temp));
EnvPrintRouter(theEnv,execStatus,WERROR," in function preview-generic.\n");
return;
}
oldce = ExecutingConstruct(theEnv,execStatus);
SetExecutingConstruct(theEnv,execStatus,TRUE);
previousGeneric = DefgenericData(theEnv,execStatus)->CurrentGeneric;
DefgenericData(theEnv,execStatus)->CurrentGeneric = gfunc;
execStatus->CurrentEvaluationDepth++;
PushProcParameters(theEnv,execStatus,GetFirstArgument()->nextArg,
CountArguments(GetFirstArgument()->nextArg),
EnvGetDefgenericName(theEnv,execStatus,(void *) gfunc),"generic function",
UnboundMethodErr);
if (execStatus->EvaluationError)
{
PopProcParameters(theEnv,execStatus);
DefgenericData(theEnv,execStatus)->CurrentGeneric = previousGeneric;
execStatus->CurrentEvaluationDepth--;
SetExecutingConstruct(theEnv,execStatus,oldce);
return;
}
gfunc->busy++;
DisplayGenericCore(theEnv,execStatus,gfunc);
gfunc->busy--;
PopProcParameters(theEnv,execStatus);
DefgenericData(theEnv,execStatus)->CurrentGeneric = previousGeneric;
execStatus->CurrentEvaluationDepth--;
SetExecutingConstruct(theEnv,execStatus,oldce);
}
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 : PreviewGeneric
DESCRIPTION : Allows the user to see a printout of all the
applicable methods for a particular generic
function call
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Any side-effects of evaluating the generic
function arguments
and evaluating query-functions to determine
the set of applicable methods
NOTES : H/L Syntax: (preview-generic <func> <args>)
*************************************************************/
globle void PreviewGeneric()
{
DEFGENERIC *gfunc;
DEFGENERIC *previousGeneric;
int oldce;
DATA_OBJECT temp;
EvaluationError = FALSE;
if (ArgTypeCheck("preview-generic",1,SYMBOL,&temp) == FALSE)
return;
gfunc = LookupDefgenericByMdlOrScope(DOToString(temp));
if (gfunc == NULL)
{
PrintErrorID("GENRCFUN",3,FALSE);
PrintRouter(WERROR,"Unable to find generic function ");
PrintRouter(WERROR,DOToString(temp));
PrintRouter(WERROR," in function preview-generic.\n");
return;
}
oldce = ExecutingConstruct();
SetExecutingConstruct(TRUE);
previousGeneric = CurrentGeneric;
CurrentGeneric = gfunc;
CurrentEvaluationDepth++;
PushProcParameters(GetFirstArgument()->nextArg,
CountArguments(GetFirstArgument()->nextArg),
GetDefgenericName((void *) gfunc),"generic function",
UnboundMethodErr);
if (EvaluationError)
{
PopProcParameters();
CurrentGeneric = previousGeneric;
CurrentEvaluationDepth--;
SetExecutingConstruct(oldce);
return;
}
gfunc->busy++;
DisplayGenericCore(gfunc);
gfunc->busy--;
PopProcParameters();
CurrentGeneric = previousGeneric;
CurrentEvaluationDepth--;
SetExecutingConstruct(oldce);
}
/******************************************************************************
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 : GetFunctionRestrictions
DESCRIPTION : Gets DefineFunction2() restriction list for function
INPUTS : None
RETURNS : A string containing the function restriction codes
SIDE EFFECTS : EvaluationError set on errors
NOTES : None
********************************************************************/
globle void *GetFunctionRestrictions(
void *theEnv)
{
DATA_OBJECT temp;
struct FunctionDefinition *fptr;
if (EnvArgTypeCheck(theEnv,"get-function-restrictions",1,SYMBOL,&temp) == FALSE)
return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
fptr = FindFunction(theEnv,DOToString(temp));
if (fptr == NULL)
{
CantFindItemErrorMessage(theEnv,"function",DOToString(temp));
SetEvaluationError(theEnv,TRUE);
return((SYMBOL_HN *) EnvAddSymbol(theEnv,""));
}
if (fptr->restrictions == NULL)
return((SYMBOL_HN *) EnvAddSymbol(theEnv,"0**"));
return((SYMBOL_HN *) EnvAddSymbol(theEnv,fptr->restrictions));
}
/*********************************************************
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));
}
/********************************************************************
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()
{
DEFCLASS *cls;
DATA_OBJECT temp;
/* =============================
Get the class for the message
============================= */
if (ArgTypeCheck("preview-send",1,SYMBOL,&temp) == FALSE)
return;
cls = LookupDefclassByMdlOrScope(DOToString(temp));
if (cls == NULL)
{
ClassExistError("preview-send",ValueToString(temp.value));
return;
}
if (ArgTypeCheck("preview-send",2,SYMBOL,&temp) == FALSE)
return;
PreviewSend(WDISPLAY,(void *) cls,DOToString(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)));
}
globle void ConserveMemCommand(
void *theEnv)
{
char *argument;
DATA_OBJECT theValue;
/*===================================*/
/* The conserve-mem function expects */
/* a single symbol argument. */
/*===================================*/
if (EnvArgCountCheck(theEnv,"conserve-mem",EXACTLY,1) == -1) return;
if (EnvArgTypeCheck(theEnv,"conserve-mem",1,SYMBOL,&theValue) == FALSE) return;
argument = DOToString(theValue);
/*====================================================*/
/* If the argument is the symbol "on", then store the */
/* pretty print representation of a construct when it */
/* is defined. */
/*====================================================*/
if (strcmp(argument,"on") == 0)
{
EnvSetConserveMemory(theEnv,TRUE);
}
/*======================================================*/
/* Otherwise, if the argument is the symbol "off", then */
/* don't store the pretty print representation of a */
/* construct when it is defined. */
/*======================================================*/
else if (strcmp(argument,"off") == 0)
{
EnvSetConserveMemory(theEnv,FALSE);
}
/*=====================================================*/
/* Otherwise, generate an error since the only allowed */
/* arguments are "on" or "off." */
/*=====================================================*/
else
{
ExpectedTypeError1(theEnv,"conserve-mem",1,"symbol with value on or off");
return;
}
return;
}
/***************************************************************
NAME : ParseSimpleQualifier
DESCRIPTION : Parses abstract/concrete role and
pattern-matching reactivity for class
INPUTS : 1) The input logical name
2) The name of the qualifier being parsed
3) The qualifier value indicating that the
qualifier should be false
4) The qualifier value indicating that the
qualifier should be TRUE
5) A pointer to a bitmap indicating
if the qualifier has already been parsed
6) A buffer to store the value of the qualifier
RETURNS : TRUE if all OK, FALSE otherwise
SIDE EFFECTS : Bitmap and qualifier buffers set
Messages printed on errors
NOTES : None
***************************************************************/
static intBool ParseSimpleQualifier(
void *theEnv,
char *readSource,
char *classQualifier,
char *clearRelation,
char *setRelation,
intBool *alreadyTestedFlag,
intBool *binaryFlag)
{
if (*alreadyTestedFlag)
{
PrintErrorID(theEnv,"CLASSPSR",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Class ");
EnvPrintRouter(theEnv,WERROR,classQualifier);
EnvPrintRouter(theEnv,WERROR," already declared.\n");
return(FALSE);
}
SavePPBuffer(theEnv," ");
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != SYMBOL)
goto ParseSimpleQualifierError;
if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),setRelation) == 0)
*binaryFlag = TRUE;
else if (strcmp(DOToString(DefclassData(theEnv)->ObjectParseToken),clearRelation) == 0)
*binaryFlag = FALSE;
else
goto ParseSimpleQualifierError;
GetToken(theEnv,readSource,&DefclassData(theEnv)->ObjectParseToken);
if (GetType(DefclassData(theEnv)->ObjectParseToken) != RPAREN)
goto ParseSimpleQualifierError;
*alreadyTestedFlag = TRUE;
return(TRUE);
ParseSimpleQualifierError:
SyntaxErrorMessage(theEnv,"defclass");
return(FALSE);
}
/*********************************************************************
NAME : ClassAbstractPCommand
DESCRIPTION : Determines if direct instances of a class can be made
INPUTS : None
RETURNS : TRUE (1) if class is abstract, FALSE (0) if concrete
SIDE EFFECTS : None
NOTES : Syntax: (class-abstractp <class>)
*********************************************************************/
globle int ClassAbstractPCommand()
{
DATA_OBJECT tmp;
DEFCLASS *cls;
if (ArgTypeCheck("class-abstractp",1,SYMBOL,&tmp) == FALSE)
return(FALSE);
cls = LookupDefclassByMdlOrScope(DOToString(tmp));
if (cls == NULL)
{
ClassExistError("class-abstractp",ValueToString(tmp.value));
return(FALSE);
}
return(ClassAbstractP((void *) cls));
}
