/*******************************************************
NAME : CheckDeffunctionCall
DESCRIPTION : Checks the number of arguments
passed to a deffunction
INPUTS : 1) Deffunction pointer
2) The number of arguments
RETURNS : TRUE if OK, FALSE otherwise
SIDE EFFECTS : Message printed on errors
NOTES : None
*******************************************************/
globle int CheckDeffunctionCall(
void *theEnv,
void *vdptr,
int args)
{
DEFFUNCTION *dptr;
if (vdptr == NULL)
return(FALSE);
dptr = (DEFFUNCTION *) vdptr;
if (args < dptr->minNumberOfParameters)
{
if (dptr->maxNumberOfParameters == -1)
ExpectedCountError(theEnv,EnvGetDeffunctionName(theEnv,(void *) dptr),
AT_LEAST,dptr->minNumberOfParameters);
else
ExpectedCountError(theEnv,EnvGetDeffunctionName(theEnv,(void *) dptr),
EXACTLY,dptr->minNumberOfParameters);
return(FALSE);
}
else if ((args > dptr->minNumberOfParameters) &&
(dptr->maxNumberOfParameters != -1))
{
ExpectedCountError(theEnv,EnvGetDeffunctionName(theEnv,(void *) dptr),
EXACTLY,dptr->minNumberOfParameters);
return(FALSE);
}
return(TRUE);
}
/***************************************************
NAME : RemoveAllDeffunctions
DESCRIPTION : Removes all deffunctions
INPUTS : None
RETURNS : TRUE if all deffunctions
removed, FALSE otherwise
SIDE EFFECTS : Deffunctions removed
NOTES : None
***************************************************/
static intBool RemoveAllDeffunctions(
void *theEnv,
EXEC_STATUS)
{
DEFFUNCTION *dptr,*dtmp;
unsigned oldbusy;
intBool success = TRUE;
#if BLOAD || BLOAD_AND_BSAVE
if (Bloaded(theEnv,execStatus) == TRUE)
return(FALSE);
#endif
dptr = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,execStatus,NULL);
while (dptr != NULL)
{
if (dptr->executing > 0)
{
DeffunctionDeleteError(theEnv,execStatus,EnvGetDeffunctionName(theEnv,execStatus,(void *) dptr));
success = FALSE;
}
else
{
oldbusy = dptr->busy;
ExpressionDeinstall(theEnv,execStatus,dptr->code);
dptr->busy = oldbusy;
ReturnPackedExpression(theEnv,execStatus,dptr->code);
dptr->code = NULL;
}
dptr = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,execStatus,(void *) dptr);
}
dptr = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,execStatus,NULL);
while (dptr != NULL)
{
dtmp = dptr;
dptr = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,execStatus,(void *) dptr);
if (dtmp->executing == 0)
{
if (dtmp->busy > 0)
{
PrintWarningID(theEnv,execStatus,"DFFNXFUN",1,FALSE);
EnvPrintRouter(theEnv,execStatus,WWARNING,"Deffunction ");
EnvPrintRouter(theEnv,execStatus,WWARNING,EnvGetDeffunctionName(theEnv,execStatus,(void *) dtmp));
EnvPrintRouter(theEnv,execStatus,WWARNING," only partially deleted due to usage by other constructs.\n");
SetDeffunctionPPForm((void *) dtmp,NULL);
success = FALSE;
}
else
{
RemoveConstructFromModule(theEnv,execStatus,(struct constructHeader *) dtmp);
RemoveDeffunction(theEnv,execStatus,dtmp);
}
}
}
return(success);
}
std::string Function::name( )
{
if ( m_cobj )
return EnvGetDeffunctionName( m_environment.cobj(), m_cobj );
else
return std::string();
}
/***************************************************
NAME : SaveDeffunctionHeader
DESCRIPTION : Writes a deffunction forward
declaration to the save file
INPUTS : 1) The deffunction
2) The logical name of the output
RETURNS : Nothing useful
SIDE EFFECTS : Defffunction header written
NOTES : None
***************************************************/
static void SaveDeffunctionHeader(
void *theEnv,
struct constructHeader *theDeffunction,
void *userBuffer)
{
DEFFUNCTION *dfnxPtr = (DEFFUNCTION *) theDeffunction;
char *logicalName = (char *) userBuffer;
register int i;
if (EnvGetDeffunctionPPForm(theEnv,(void *) dfnxPtr) != NULL)
{
EnvPrintRouter(theEnv,logicalName,(char*)"(deffunction ");
EnvPrintRouter(theEnv,logicalName,EnvDeffunctionModule(theEnv,(void *) dfnxPtr));
EnvPrintRouter(theEnv,logicalName,(char*)"::");
EnvPrintRouter(theEnv,logicalName,EnvGetDeffunctionName(theEnv,(void *) dfnxPtr));
EnvPrintRouter(theEnv,logicalName,(char*)" (");
for (i = 0 ; i < dfnxPtr->minNumberOfParameters ; i++)
{
EnvPrintRouter(theEnv,logicalName,(char*)"?p");
PrintLongInteger(theEnv,logicalName,(long long) i);
if (i != dfnxPtr->minNumberOfParameters-1)
EnvPrintRouter(theEnv,logicalName,(char*)" ");
}
if (dfnxPtr->maxNumberOfParameters == -1)
{
if (dfnxPtr->minNumberOfParameters != 0)
EnvPrintRouter(theEnv,logicalName,(char*)" ");
EnvPrintRouter(theEnv,logicalName,(char*)"$?wildargs))\n\n");
}
else
EnvPrintRouter(theEnv,logicalName,(char*)"))\n\n");
}
}
/*******************************************************
NAME : UnboundDeffunctionErr
DESCRIPTION : Print out a synopis of the currently
executing deffunction for unbound
variable errors
INPUTS : None
RETURNS : Nothing useful
SIDE EFFECTS : Error synopsis printed to WERROR
NOTES : None
*******************************************************/
static void UnboundDeffunctionErr(
void *theEnv)
{
EnvPrintRouter(theEnv,WERROR,"deffunction ");
EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,(void *) DeffunctionData(theEnv)->ExecutingDeffunction));
EnvPrintRouter(theEnv,WERROR,".\n");
}
/***************************************************
NAME : PrintDeffunctionCall
DESCRIPTION : PrintExpression() support function
for deffunction calls
INPUTS : 1) The output logical name
2) The deffunction
RETURNS : Nothing useful
SIDE EFFECTS : Call expression printed
NOTES : None
***************************************************/
static void PrintDeffunctionCall(
void *theEnv,
char *logName,
void *value)
{
#if DEVELOPER
EnvPrintRouter(theEnv,logName,(char*)"(");
EnvPrintRouter(theEnv,logName,EnvGetDeffunctionName(theEnv,value));
if (GetFirstArgument() != NULL)
{
EnvPrintRouter(theEnv,logName,(char*)" ");
PrintExpression(theEnv,logName,GetFirstArgument());
}
EnvPrintRouter(theEnv,logName,(char*)")");
#else
#endif
}
static void PrintDeffunctionCall(
void *theEnv,
EXEC_STATUS,
char *logName,
void *value)
{
#if DEVELOPER
EnvPrintRouter(theEnv,execStatus,logName,"(");
EnvPrintRouter(theEnv,execStatus,logName,EnvGetDeffunctionName(theEnv,execStatus,value));
if (GetFirstArgument() != NULL)
{
EnvPrintRouter(theEnv,execStatus,logName," ");
PrintExpression(theEnv,execStatus,logName,GetFirstArgument());
}
EnvPrintRouter(theEnv,execStatus,logName,")");
#else
#if MAC_MCW || WIN_MCW || MAC_XCD
#pragma unused(theEnv,execStatus)
#pragma unused(logName)
#pragma unused(value)
#endif
#endif
}
EXPORT void* STDCALL EnvGetDeffunctionName2(void* env, void* ptr)
{
return EnvGetDeffunctionName(env, ptr);
}
static void OutputConstructsCodeInfo(
void *theEnv)
{
#if (! DEFFUNCTION_CONSTRUCT) && (! DEFGENERIC_CONSTRUCT) && (! OBJECT_SYSTEM) && (! DEFRULE_CONSTRUCT)
#pragma unused(theEnv)
#endif
#if DEFFUNCTION_CONSTRUCT
DEFFUNCTION *theDeffunction;
#endif
#if DEFRULE_CONSTRUCT
struct defrule *theDefrule;
#endif
#if DEFGENERIC_CONSTRUCT
DEFGENERIC *theDefgeneric;
DEFMETHOD *theMethod;
unsigned methodIndex;
char methodBuffer[512];
#endif
#if OBJECT_SYSTEM
DEFCLASS *theDefclass;
HANDLER *theHandler;
unsigned handlerIndex;
#endif
#if DEFGENERIC_CONSTRUCT || OBJECT_SYSTEM
char *prefix, *prefixBefore, *prefixAfter;
#endif
char *banner;
banner = "\n*** Deffunctions ***\n\n";
#if DEFFUNCTION_CONSTRUCT
for (theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,NULL);
theDeffunction != NULL;
theDeffunction = (DEFFUNCTION *) EnvGetNextDeffunction(theEnv,theDeffunction))
{
OutputProfileInfo(theEnv,EnvGetDeffunctionName(theEnv,theDeffunction),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDeffunction->header.usrData),
NULL,NULL,NULL,&banner);
}
#endif
banner = "\n*** Defgenerics ***\n";
#if DEFGENERIC_CONSTRUCT
for (theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,NULL);
theDefgeneric != NULL;
theDefgeneric = (DEFGENERIC *) EnvGetNextDefgeneric(theEnv,theDefgeneric))
{
prefixBefore = "\n";
prefix = EnvGetDefgenericName(theEnv,theDefgeneric);
prefixAfter = "\n";
for (methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,0);
methodIndex != 0;
methodIndex = EnvGetNextDefmethod(theEnv,theDefgeneric,methodIndex))
{
theMethod = GetDefmethodPointer(theDefgeneric,methodIndex);
EnvGetDefmethodDescription(theEnv,methodBuffer,510,theDefgeneric,methodIndex);
if (OutputProfileInfo(theEnv,methodBuffer,
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theMethod->usrData),
prefixBefore,prefix,prefixAfter,&banner))
{
prefixBefore = NULL;
prefix = NULL;
prefixAfter = NULL;
}
}
}
#endif
banner = "\n*** Defclasses ***\n";
#if OBJECT_SYSTEM
for (theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,NULL);
theDefclass != NULL;
theDefclass = (DEFCLASS *) EnvGetNextDefclass(theEnv,theDefclass))
{
prefixAfter = "\n";
prefix = EnvGetDefclassName(theEnv,theDefclass);
prefixBefore = "\n";
for (handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,0);
handlerIndex != 0;
handlerIndex = EnvGetNextDefmessageHandler(theEnv,theDefclass,handlerIndex))
{
theHandler = GetDefmessageHandlerPointer(theDefclass,handlerIndex);
if (OutputProfileInfo(theEnv,EnvGetDefmessageHandlerName(theEnv,theDefclass,handlerIndex),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,
theHandler->usrData),
prefixBefore,prefix,prefixAfter,&banner))
{
prefixBefore = NULL;
prefix = NULL;
prefixAfter = NULL;
}
}
}
#endif
banner = "\n*** Defrules ***\n\n";
#if DEFRULE_CONSTRUCT
for (theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,NULL);
theDefrule != NULL;
theDefrule = (struct defrule *) EnvGetNextDefrule(theEnv,theDefrule))
{
OutputProfileInfo(theEnv,EnvGetDefruleName(theEnv,theDefrule),
(struct constructProfileInfo *)
TestUserData(ProfileFunctionData(theEnv)->ProfileDataID,theDefrule->header.usrData),
NULL,NULL,NULL,&banner);
}
#endif
}
/************************************************************
NAME : ValidDeffunctionName
DESCRIPTION : Determines if a new deffunction of the given
name can be defined in the current module
INPUTS : The new deffunction name
RETURNS : TRUE if OK, FALSE otherwise
SIDE EFFECTS : Error message printed if not OK
NOTES : GetConstructNameAndComment() (called before
this function) ensures that the deffunction
name does not conflict with one from
another module
************************************************************/
static BOOLEAN ValidDeffunctionName(
void *theEnv,
char *theDeffunctionName)
{
struct constructHeader *theDeffunction;
#if DEFGENERIC_CONSTRUCT
struct defmodule *theModule;
struct constructHeader *theDefgeneric;
#endif
/* ============================================
A deffunction cannot be named the same as a
construct type, e.g, defclass, defrule, etc.
============================================ */
if (FindConstruct(theEnv,theDeffunctionName) != NULL)
{
PrintErrorID(theEnv,"DFFNXPSR",1,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunctions are not allowed to replace constructs.\n");
return(FALSE);
}
/* ============================================
A deffunction cannot be named the same as a
pre-defined system function, e.g, watch,
list-defrules, etc.
============================================ */
if (FindFunction(theEnv,theDeffunctionName) != NULL)
{
PrintErrorID(theEnv,"DFFNXPSR",2,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunctions are not allowed to replace external functions.\n");
return(FALSE);
}
#if DEFGENERIC_CONSTRUCT
/* ============================================
A deffunction cannot be named the same as a
generic function (either in this module or
imported from another)
============================================ */
theDefgeneric =
(struct constructHeader *) LookupDefgenericInScope(theEnv,theDeffunctionName);
if (theDefgeneric != NULL)
{
theModule = GetConstructModuleItem(theDefgeneric)->theModule;
if (theModule != ((struct defmodule *) EnvGetCurrentModule(theEnv)))
{
PrintErrorID(theEnv,"DFFNXPSR",5,FALSE);
EnvPrintRouter(theEnv,WERROR,"Defgeneric ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefgenericName(theEnv,(void *) theDefgeneric));
EnvPrintRouter(theEnv,WERROR," imported from module ");
EnvPrintRouter(theEnv,WERROR,EnvGetDefmoduleName(theEnv,(void *) theModule));
EnvPrintRouter(theEnv,WERROR," conflicts with this deffunction.\n");
return(FALSE);
}
else
{
PrintErrorID(theEnv,"DFFNXPSR",3,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunctions are not allowed to replace generic functions.\n");
}
return(FALSE);
}
#endif
theDeffunction = (struct constructHeader *) EnvFindDeffunction(theEnv,theDeffunctionName);
if (theDeffunction != NULL)
{
/* ===========================================
And a deffunction in the current module can
only be redefined if it is not executing.
=========================================== */
if (((DEFFUNCTION *) theDeffunction)->executing)
{
PrintErrorID(theEnv,"DFNXPSR",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Deffunction ");
EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,(void *) theDeffunction));
EnvPrintRouter(theEnv,WERROR," may not be redefined while it is executing.\n");
return(FALSE);
}
}
return(TRUE);
}
globle void FuncallFunction(
void *theEnv,
DATA_OBJECT *returnValue)
{
int argCount, i, j;
DATA_OBJECT theValue;
FUNCTION_REFERENCE theReference;
char *name;
struct multifield *theMultifield;
struct expr *lastAdd = NULL, *nextAdd, *multiAdd;
/*==================================*/
/* Set up the default return value. */
/*==================================*/
SetpType(returnValue,SYMBOL);
SetpValue(returnValue,EnvFalseSymbol(theEnv));
/*=================================================*/
/* The funcall function has at least one argument: */
/* the name of the function being called. */
/*=================================================*/
if ((argCount = EnvArgCountCheck(theEnv,"funcall",AT_LEAST,1)) == -1) return;
/*============================================*/
/* Get the name of the function to be called. */
/*============================================*/
if (EnvArgTypeCheck(theEnv,"funcall",1,SYMBOL_OR_STRING,&theValue) == FALSE)
{
return;
}
/*====================*/
/* Find the function. */
/*====================*/
name = DOToString(theValue);
if (! GetFunctionReference(theEnv,name,&theReference))
{
ExpectedTypeError1(theEnv,"funcall",1,"function, deffunction, or generic function name");
return;
}
ExpressionInstall(theEnv,&theReference);
/*======================================*/
/* Add the arguments to the expression. */
/*======================================*/
for (i = 2; i <= argCount; i++)
{
EnvRtnUnknown(theEnv,i,&theValue);
if (GetEvaluationError(theEnv))
{
ExpressionDeinstall(theEnv,&theReference);
return;
}
switch(GetType(theValue))
{
case MULTIFIELD:
nextAdd = GenConstant(theEnv,FCALL,(void *) FindFunction(theEnv,"create$"));
if (lastAdd == NULL)
{
theReference.argList = nextAdd;
}
else
{
lastAdd->nextArg = nextAdd;
}
lastAdd = nextAdd;
multiAdd = NULL;
theMultifield = (struct multifield *) GetValue(theValue);
for (j = GetDOBegin(theValue); j <= GetDOEnd(theValue); j++)
{
nextAdd = GenConstant(theEnv,GetMFType(theMultifield,j),GetMFValue(theMultifield,j));
if (multiAdd == NULL)
{
lastAdd->argList = nextAdd;
}
else
{
multiAdd->nextArg = nextAdd;
}
multiAdd = nextAdd;
}
ExpressionInstall(theEnv,lastAdd);
break;
default:
nextAdd = GenConstant(theEnv,GetType(theValue),GetValue(theValue));
if (lastAdd == NULL)
{
theReference.argList = nextAdd;
}
else
{
lastAdd->nextArg = nextAdd;
}
lastAdd = nextAdd;
ExpressionInstall(theEnv,lastAdd);
break;
}
}
/*===========================================================*/
/* Verify a deffunction has the correct number of arguments. */
/*===========================================================*/
#if DEFFUNCTION_CONSTRUCT
if (theReference.type == PCALL)
{
if (CheckDeffunctionCall(theEnv,theReference.value,CountArguments(theReference.argList)) == FALSE)
{
PrintErrorID(theEnv,"MISCFUN",4,FALSE);
EnvPrintRouter(theEnv,WERROR,"Function funcall called with the wrong number of arguments for deffunction ");
EnvPrintRouter(theEnv,WERROR,EnvGetDeffunctionName(theEnv,theReference.value));
EnvPrintRouter(theEnv,WERROR,"\n");
ExpressionDeinstall(theEnv,&theReference);
ReturnExpression(theEnv,theReference.argList);
return;
}
}
#endif
/*======================*/
/* Call the expression. */
/*======================*/
EvaluateExpression(theEnv,&theReference,returnValue);
/*========================================*/
/* Return the expression data structures. */
/*========================================*/
ExpressionDeinstall(theEnv,&theReference);
ReturnExpression(theEnv,theReference.argList);
}
globle const char *GetDeffunctionName(
void *theDeffunction)
{
return EnvGetDeffunctionName(GetCurrentEnvironment(),theDeffunction);
}
/****************************************************
NAME : CallDeffunction
DESCRIPTION : Executes the body of a deffunction
INPUTS : 1) The deffunction
2) Argument expressions
3) Data object buffer to hold result
RETURNS : Nothing useful
SIDE EFFECTS : Deffunction executed and result
stored in data object buffer
NOTES : Used in EvaluateExpression(theEnv,)
****************************************************/
globle void CallDeffunction(
void *theEnv,
DEFFUNCTION *dptr,
EXPRESSION *args,
DATA_OBJECT *result)
{
int oldce;
DEFFUNCTION *previouslyExecutingDeffunction;
struct garbageFrame newGarbageFrame;
struct garbageFrame *oldGarbageFrame;
#if PROFILING_FUNCTIONS
struct profileFrameInfo profileFrame;
#endif
result->type = SYMBOL;
result->value = EnvFalseSymbol(theEnv);
EvaluationData(theEnv)->EvaluationError = FALSE;
if (EvaluationData(theEnv)->HaltExecution)
return;
oldGarbageFrame = UtilityData(theEnv)->CurrentGarbageFrame;
memset(&newGarbageFrame,0,sizeof(struct garbageFrame));
newGarbageFrame.priorFrame = oldGarbageFrame;
UtilityData(theEnv)->CurrentGarbageFrame = &newGarbageFrame;
oldce = ExecutingConstruct(theEnv);
SetExecutingConstruct(theEnv,TRUE);
previouslyExecutingDeffunction = DeffunctionData(theEnv)->ExecutingDeffunction;
DeffunctionData(theEnv)->ExecutingDeffunction = dptr;
EvaluationData(theEnv)->CurrentEvaluationDepth++;
dptr->executing++;
PushProcParameters(theEnv,args,CountArguments(args),EnvGetDeffunctionName(theEnv,(void *) dptr),
"deffunction",UnboundDeffunctionErr);
if (EvaluationData(theEnv)->EvaluationError)
{
dptr->executing--;
DeffunctionData(theEnv)->ExecutingDeffunction = previouslyExecutingDeffunction;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
return;
}
#if DEBUGGING_FUNCTIONS
if (dptr->trace)
WatchDeffunction(theEnv,BEGIN_TRACE);
#endif
#if PROFILING_FUNCTIONS
StartProfile(theEnv,&profileFrame,
&dptr->header.usrData,
ProfileFunctionData(theEnv)->ProfileConstructs);
#endif
EvaluateProcActions(theEnv,dptr->header.whichModule->theModule,
dptr->code,dptr->numberOfLocalVars,
result,UnboundDeffunctionErr);
#if PROFILING_FUNCTIONS
EndProfile(theEnv,&profileFrame);
#endif
#if DEBUGGING_FUNCTIONS
if (dptr->trace)
WatchDeffunction(theEnv,END_TRACE);
#endif
ProcedureFunctionData(theEnv)->ReturnFlag = FALSE;
dptr->executing--;
PopProcParameters(theEnv);
DeffunctionData(theEnv)->ExecutingDeffunction = previouslyExecutingDeffunction;
EvaluationData(theEnv)->CurrentEvaluationDepth--;
RestorePriorGarbageFrame(theEnv,&newGarbageFrame,oldGarbageFrame,result);
CallPeriodicTasks(theEnv);
SetExecutingConstruct(theEnv,oldce);
}